;;; print-exps.scm -- print expression AST structures
 ;;;
 ;;; author :  Sandra Loosemore
 ;;; date   :  10 Jan 1992
 ;;;
 ;;; This file corresponds to ast/exp-structs.scm.
 ;;;
 
 (define-ast-printer lambda (object xp)
   (with-ast-block (xp)
     (write-string "\\ " xp)
     (write-delimited-list
       (lambda-pats object) xp (function write-apat) "" "" "")
     (write-string " ->" xp)
     (write-whitespace xp)
     (write (lambda-body object) xp)))
 
 (define-ast-printer let (object xp)
   (write-lets-body "let " (let-decls object) (let-body object) xp))
 
 (define (write-lets-body let-name decls body xp)
   (pprint-logical-block (xp '() "" "")  ; no extra indentation
     (write-string let-name xp)
     (write-layout-rule (remove-recursive-grouping decls) xp (function write))
     (write-whitespace xp)
     (write-string "in " xp)
     (write body xp)))
 
 (define-ast-printer if (object xp)
   (with-ast-block (xp)
     (write-string "if " xp)
     (write (if-test-exp object) xp)
     (write-whitespace xp)
     (with-ast-block (xp)
       (write-string "then" xp)
       (write-whitespace xp)
       (write (if-then-exp object) xp))
     (write-whitespace xp)
     (with-ast-block (xp)
       (write-string "else" xp)
       (write-whitespace xp)
       (write (if-else-exp object) xp))))
 
 (define-ast-printer case (object xp)
   (with-ast-block (xp)
     (write-string "case " xp)
     (write (case-exp object) xp)
     (write-string " of" xp)
     (write-whitespace xp)
     (write-layout-rule (case-alts object) xp (function write))))
 
 (define-ast-printer alt (object xp)
   (with-ast-block (xp)
     (write (alt-pat object) xp)
     (dolist (r (alt-rhs-list object))
       (write-whitespace xp)
       (unless (is-type? 'omitted-guard (guarded-rhs-guard r))
 	(write-string "| " xp)
 	(write (guarded-rhs-guard r) xp))
       (write-string " -> " xp)
       (write (guarded-rhs-rhs r) xp))
     (write-wheredecls (alt-where-decls object) xp)))
 
 (define-ast-printer exp-sign (object xp)
   (with-ast-block (xp)
     (write (exp-sign-exp object) xp)
     (write-string " ::" xp)
     (write-whitespace xp)
     (write (exp-sign-signature object) xp)))
 
 ;;; Have to look for application of special-case constructors before
 ;;; doing the normal prefix/infix cases.
 
 (define-ast-printer app (object xp)
   (let* ((fn          (app-fn object))
 	 (arg         (app-arg object)))
     (multiple-value-bind (con args) (extract-constructor fn (list arg))
       (cond ;; ((eq? con (core-symbol "UnitConstructor"))
 	    ;;  *** Does this ever happen?
 	    ;;  (write-string "()" xp))
 	    ((and con (is-tuple-constructor? con))
 	     (write-commaized-list args xp))
 	    (else
 	     (multiple-value-bind (fixity op arg1) (extract-infix-operator fn)
 	       (if fixity
 		   (write-infix-application fixity op arg1 arg xp)
 		   (write-prefix-application fn arg xp))))
 	    ))))
 
 
 (define (write-infix-application fixity op arg1 arg2 xp)
   (let ((precedence      (fixity-precedence fixity))
 	(associativity   (fixity-associativity fixity)))
     (with-ast-block (xp)
       (write-exp-with-precedence
         arg1 (1+ precedence) (if (eq? associativity 'l) 'l '#f) xp)
       (write-whitespace xp)
       (write op xp)
       (write-whitespace xp)
       (write-exp-with-precedence
         arg2 (1+ precedence) (if (eq? associativity 'r) 'r '#f) xp))))
 
 (define (write-prefix-application fn arg xp)      
   (with-ast-block (xp)
     (write-exp-with-precedence fn 10 '#f xp)
     (write-whitespace xp)
     (write-aexp arg xp)))
 
 
 ;;; Write an expression with at least the given precedence.  If the
 ;;; actual precedence is lower, put parens around it.
 
 (define *print-exp-parens* '#f)
 
 (define (write-exp-with-precedence exp precedence associativity xp)
   (if *print-exp-parens*
       (write-aexp exp xp)
       (if (< (precedence-of-exp exp associativity) precedence)
 	  (begin
 	    (write-char #\( xp)
 	    (write exp xp)
 	    (write-char #\) xp))
 	  (write exp xp))))
 
 
 ;;; Similar to the above: write an aexp.
 
 (define *print-original-code* '#t)
 
 (define (write-aexp object xp)
   (if (is-type? 'save-old-exp object)
       (write-aexp (if *print-original-code*
 		      (save-old-exp-old-exp object)
 		      (save-old-exp-new-exp object))
 		  xp)
       (if (or (is-type? 'aexp object)
 	      (pp-exp-list-section? object)
 	      (is-type? 'negate object))
 	  (write object xp)
 	  (begin
 	    (write-char #\( xp)
 	    (write object xp)
 	    (write-char #\) xp)))))
 
 
 ;;; The infix? slot on var-ref and con-ref structs refers to whether
 ;;; the thing appears as an infix operator or not, not whether the name
 ;;; has operator or identifier syntax.
 
 (define-ast-printer var-ref (object xp)
   (let ((name  (var-ref-name object)))
     (if (var-ref-infix? object)
 	(write-varop name xp)
 	(write-varid name xp))))
 
 (define-ast-printer con-ref (object xp)
   (if (eq? (con-ref-con object) (core-symbol "UnitConstructor"))
       (write-string "()" xp)
       (let ((name  (con-ref-name object)))
 	(if (con-ref-infix? object)
 	    (write-conop name xp)
 	    (write-conid name xp)))))
 
 
 (define-ast-printer integer-const (object xp)
   (write (integer-const-value object) xp))
 
 (define-ast-printer float-const (object xp)
   (let* ((numerator   (float-const-numerator object))
 	 (denominator (float-const-denominator object))
 	 (exponent    (float-const-exponent object))
 	 (whole       (quotient numerator denominator))
 	 (fraction    (remainder numerator denominator)))
     (write whole xp)
     (write-char #\. xp)
     (write-precision-integer fraction denominator xp)
     (unless (zero? exponent)
       (write-char #\E xp)
       (write exponent xp))))
 
 (define (write-precision-integer fraction denominator xp)
   (cond ((eqv? denominator 1)
 	 ; no fraction
 	 )
 	((eqv? denominator 10)
 	 (write-digit fraction xp))
 	(else
 	 (write-digit (quotient fraction 10) xp)
 	 (write-precision-integer (remainder fraction 10)
 				  (quotient denominator 10)
 				  xp))
 	))
 
 (define (write-digit n xp)
   (write-char (string-ref "0123456789" n) xp))
 
 
 ;;; Character and string printers need to handle weird escapes.
 ;;; Fortunately we can just choose one canonical style for printing
 ;;; unprintable characters.
 
 (define-ast-printer char-const (object xp)
   (write-char #\' xp)
   (write-char-literal (char-const-value object) xp #\')
   (write-char #\' xp))
 
 (define-ast-printer string-const (object xp)
   (write-char #\" xp)
   (let ((s  (string-const-value object)))
     (dotimes (i (string-length s))
       (write-char-literal (string-ref s i) xp #\")))
   (write-char #\" xp))
 
 (define (write-char-literal c xp special)
   (cond ((eqv? c special)
 	 (write-char #\\ xp)
 	 (write c xp))
 	((eqv? c #\newline)
 	 (write-char #\\ xp)
 	 (write-char #\n xp))
 	(else
 	 (let ((code  (char->integer c)))
 	   (if (and (>= code 32) (< code 128))
 	       ;; printing ascii characters
 	       (write-char c xp)
 	       ;; "control" characters print in \ddd notation
 	       (begin
 		 (write-char #\\ xp)
 		 (write code xp)))))
 	))
 
 (define-ast-printer list-exp (object xp)
   (write-delimited-list
     (list-exp-exps object) xp (function write) "," "[" "]"))
 
 (define-ast-printer sequence (object xp)
   (with-ast-block (xp)
     (write-string "[" xp)
     (write (sequence-from object) xp)
     (write-string "..]" xp)))
 
 (define-ast-printer sequence-to (object xp)
   (with-ast-block (xp)
     (write-string "[" xp)
     (write (sequence-to-from object) xp)
     (write-string " .." xp)
     (write-whitespace xp)
     (write (sequence-to-to object) xp)
     (write-string "]" xp)))
 
 (define-ast-printer sequence-then (object xp)
   (with-ast-block (xp)
     (write-string "[" xp)			
     (write (sequence-then-from object) xp)
     (write-string "," xp)
     (write-whitespace xp)
     (write (sequence-then-then object) xp)
     (write-string "..]" xp)))
 
 (define-ast-printer sequence-then-to (object xp)
   (with-ast-block (xp)
     (write-string "[" xp)
     (write (sequence-then-to-from object) xp)
     (write-string "," xp)
     (write-whitespace xp)
     (write (sequence-then-to-then object) xp)
     (write-string " .." xp)
     (write-whitespace xp)
     (write (sequence-then-to-to object) xp)
     (write-string "]" xp)))
 
 (define-ast-printer list-comp (object xp)
   (with-ast-block (xp)
     (write-string "[" xp)
     (write (list-comp-exp object) xp)
     (write-string " |" xp)
     (write-whitespace xp)
     (write-delimited-list
       (list-comp-quals object) xp (function write) "," "" "")
     (write-string "]" xp)))
 
 
 (define-ast-printer section-l (object xp)
   (let* ((exp           (section-l-exp object))
 	 (op            (section-l-op object))
 	 (fixity        (operator-fixity op))
 	 (precedence    (fixity-precedence fixity)))
     (with-ast-block (xp)
       (write-string "(" xp)
       (write op xp)
       (write-whitespace xp)
       (write-exp-with-precedence exp (1+ precedence) '#f xp)
       (write-string ")" xp))))
 
 (define-ast-printer section-r (object xp)
   (let* ((exp           (section-r-exp object))
 	 (op            (section-r-op object))
 	 (fixity        (operator-fixity op))
 	 (precedence    (fixity-precedence fixity)))
     (with-ast-block (xp)
       (write-string "(" xp)
       (write-exp-with-precedence exp (1+ precedence) '#f xp)
       (write-whitespace xp)
       (write op xp)
       (write-string ")" xp))))
 
 (define-ast-printer qual-generator (object xp)
   (with-ast-block (xp)
     (write (qual-generator-pat object) xp)
     (write-string " <-" xp)
     (write-whitespace xp)
     (write (qual-generator-exp object) xp)))
 
 (define-ast-printer qual-filter (object xp)
   (write (qual-filter-exp object) xp))
 
 
 ;;; A pp-exp-list with an op as the first or last element is really
 ;;; a section.  These always get parens and are treated like aexps.
 ;;; Other pp-exp-lists are treated as exps with precedence 0.
 ;;; Bleah...  Seems like the parser ought to recognize this up front....
 ;;;                                                     Yeah but I'm lazy ...
 
 (define-ast-printer pp-exp-list (object xp)
   (let ((section?  (pp-exp-list-section? object)))
     (if section? (write-char #\( xp))
     (write-delimited-list
       (pp-exp-list-exps object) xp (function write-aexp) "" "" "")
     (if section? (write-char #\) xp))))
 
 (define-ast-printer negate (object xp)
   (declare (ignore object))
   (write-string "-" xp))
 
 (define-ast-printer def (object xp)
   (write-string (symbol->string (def-name object)) xp))
 
 (define-ast-printer con (object xp)
   (write-string (remove-con-prefix (symbol->string (def-name object))) xp))
 
 (define-ast-printer con-number (object xp)
   (with-ast-block (xp)
     (write-string "con-number/" xp)
     (write (con-number-type object) xp)
     (write-whitespace xp)
     (write-aexp (con-number-value object) xp)))
 
 (define-ast-printer sel (object xp)
   (with-ast-block (xp)
     (write-string "sel/" xp)
     (write (sel-constructor object) xp)
     (write-whitespace xp)
     (write (sel-slot object) xp)
     (write-whitespace xp)
     (write-aexp (sel-value object) xp)))
 
 (define-ast-printer is-constructor (object xp)
 (with-ast-block (xp)
     (write-string "is-constructor/" xp)
     (write (is-constructor-constructor object) xp)
     (write-whitespace xp)
     (write-aexp (is-constructor-value object) xp)))
   
 (define-ast-printer void (object xp)
   (declare (ignore object))
   (write-string "Void" xp))
 
 ;;; Special cfn constructs
 
 (define-ast-printer case-block (object xp)
   (with-ast-block (xp)
     (write-string "case-block " xp)
     (write (case-block-block-name object) xp)
     (write-whitespace xp)
     (write-layout-rule (case-block-exps object) xp (function write))))
 
 (define-ast-printer return-from (object xp)
   (with-ast-block (xp)
     (write-string "return-from " xp)
     (write (return-from-block-name object) xp)
     (write-whitespace xp)
     (write (return-from-exp object) xp)))
 
 (define-ast-printer and-exp (object xp)
   (with-ast-block (xp)
     (write-string "and " xp)
     (write-layout-rule (and-exp-exps object) xp (function write))))
 
 ;;; Expression types used by the type checker.
 
 (define-ast-printer dict-placeholder (object xp)
   (cond ((not (eq? (dict-placeholder-exp object) '#f))
 	 (write (dict-placeholder-exp object) xp))
 	(else
 	 (write-string "%" xp)
 	 (write-string (symbol->string
 			(def-name (dict-placeholder-class object))) xp))))
 
 (define-ast-printer recursive-placeholder (object xp)
   (cond ((not (eq? (recursive-placeholder-exp object) '#f))
 	 (write (recursive-placeholder-exp object) xp))
 	(else
 	 (write-varid (def-name (recursive-placeholder-var object)) xp))))
 
 ;;; This should probably have a flag to allow the dictionary converted code
 ;;; to be printed during debugging.
 
 (define-ast-printer save-old-exp (object xp)
   (write (save-old-exp-old-exp object) xp))