;;; print-valdefs.scm -- print AST structures for local declarations
;;;
;;; author :  Sandra Loosemore
;;; date   :  14 Jan 1992
;;;
;;; This file corresponds to ast/valdef-structs.scm.
;;;
;;;



(define-ast-printer signdecl (object xp)
  (with-ast-block (xp)
    (write-delimited-list (signdecl-vars object) xp (function write) "," "" "")
    (write-string " ::" xp)
    (write-whitespace xp)
    (write (signdecl-signature object) xp)))


;;; This interacts with the layout rule stuff.  See util.scm.

(define-ast-printer valdef (object xp)
  (let ((lhs         (valdef-lhs object))
	(definitions (valdef-definitions object)))
    (write-definition lhs (car definitions) xp)
    (dolist (d (cdr definitions))
      (if (dynamic *print-pretty*)
	  (pprint-newline 'mandatory xp)
	  (write-string "; " xp))
      (write-definition lhs d xp))))


(define (write-definition lhs d xp)
  (with-ast-block (xp)
    (let ((args        (single-fun-def-args d))
	  (rhs-list    (single-fun-def-rhs-list d))
	  (where-decls (single-fun-def-where-decls d))
	  (infix?      (single-fun-def-infix? d)))
      (write-lhs lhs args infix? xp)
      (write-rhs rhs-list xp)
      (write-wheredecls where-decls xp)
      )))
				
(define (write-lhs lhs args infix? xp)       
  (cond ((null? args)
	 ;; pattern definition
	 (write-apat lhs xp)
	 )
        ;; If there are args, the lhs is always a var-pat pointing to a 
        ;; var-ref. The infix? slot from the single-fun-def must override
	;; the slot on the var-ref, since there can be a mixture of
	;; infix and prefix definitions for the same lhs.
	(infix?
	 ;; operator definition
	 (when (not (null? (cddr args)))
	   (write-char #\( xp))
	 (write-apat (car args) xp)
	 (write-whitespace xp)
	 (write-varop (var-ref-name (var-pat-var lhs)) xp)
	 (write-whitespace xp)
	 (write-apat (cadr args) xp)
	 (when (not (null? (cddr args)))
	   (write-char #\) xp)
	   (write-whitespace xp)
	   (write-delimited-list (cddr args) xp (function write-apat)
				 "" "" "")))
	(else
	 ;; normal prefix function definition
	 (write-varid (var-ref-name (var-pat-var lhs)) xp)
	 (write-whitespace xp)
	 (write-delimited-list args xp (function write-apat) "" "" ""))
	))

(define (write-rhs rhs-list xp)
  (let ((guard   (guarded-rhs-guard (car rhs-list)))
	(rhs     (guarded-rhs-rhs   (car rhs-list))))
    (when (not (is-type? 'omitted-guard guard))
      (write-string " | " xp)
      (write guard xp))
    (write-string " =" xp)
    (write-whitespace xp)
    (write rhs xp)
    (when (not (null? (cdr rhs-list)))
      (write-newline xp)
      (write-rhs (cdr rhs-list) xp))))


;;; Pattern printers


;;; As per jcp suggestion, don't put whitespace after @; line break comes
;;; before, not after (as is the case for other infix-style punctuation).
    
(define-ast-printer as-pat (object xp)
  (with-ast-block (xp)
    (write (as-pat-var object) xp)
    (write-whitespace xp)
    (write-string "@" xp)
    (write-apat (as-pat-pattern object) xp)))

(define (write-apat pat xp)
  (if (or (is-type? 'apat pat)
	  (is-type? 'pp-pat-plus pat)  ; hack per jcp
	  (and (is-type? 'pcon pat)
	       (or (null? (pcon-pats pat))
		   (eq? (pcon-con pat) (core-symbol "UnitConstructor"))
		   (is-tuple-constructor? (pcon-con pat)))))
      (write pat xp)
      (begin
        (write-char #\( xp)
        (write pat xp)
        (write-char #\) xp))))

(define-ast-printer irr-pat (object xp)
  (write-string "~" xp)
  (write-apat (irr-pat-pattern object) xp))

(define-ast-printer var-pat (object xp)
  (write (var-pat-var object) xp))

(define-ast-printer wildcard-pat (object xp)
  (declare (ignore object))
  (write-char #\_ xp))

(define-ast-printer const-pat (object xp)
  (write (const-pat-value object) xp))

(define-ast-printer plus-pat (object xp)
  (write (plus-pat-pattern object) xp)
  (write-string " + " xp)
  (write (plus-pat-k object) xp))



(define-ast-printer pcon (object xp)
  (let ((name    (pcon-name object))
	(pats    (pcon-pats object))
	(infix?  (pcon-infix? object))
	(def     (pcon-con object)))
    (cond ((eq? def (core-symbol "UnitConstructor"))
	   (write-string "()" xp))
	  ((is-tuple-constructor? def)
	   (write-commaized-list pats xp))
          ((null? pats)
	   (if infix?
	       ;; infix pcon with no arguments can happen inside pp-pat-list
	       ;; before precedence parsing happens.
	       (write-conop name xp)
	       (write-conid name xp)))
	  (infix?
	   ;; This could be smarter about dealing with precedence of patterns.
	   (with-ast-block (xp)
	     (write-apat (car pats) xp)
	     (write-whitespace xp)
	     (write-conop name xp)
	     (write-whitespace xp)
	     (write-apat (cadr pats) xp)))
	  (else
	   (with-ast-block (xp)
	     (write-conid name xp)
	     (write-whitespace xp)
	     (write-delimited-list pats xp (function write-apat) "" "" "")))
	  )))

(define-ast-printer list-pat (object xp)
  (write-delimited-list
    (list-pat-pats object) xp (function write) "," "[" "]"))

(define-ast-printer pp-pat-list (object xp)
  (write-delimited-list (pp-pat-list-pats object) xp (function write-apat)
			"" "" ""))

(define-ast-printer pp-pat-plus (object xp)
  (declare (ignore object))
  (write-string "+ " xp))

(define-ast-printer pp-pat-negated (object xp)
  (declare (ignore object))
  (write-string "-" xp))