;;; print-types.scm -- print type-related AST structures
;;;
;;; author :  Sandra Loosemore
;;; date   :  15 Jan 1991
;;;
;;; This file corresponds to the stuff in ast/type-structs.scm
;;;

(define-ast-printer tyvar (object xp)
  (write-avarid (tyvar-name object) xp))


;;; Various type special cases have a magic cookie in the def field.

(define-ast-printer tycon (object xp)
  (print-general-tycon (tycon-def object) (tycon-args object) object xp))

(define (print-general-tycon def args object xp)
    (cond ((eq? def (core-symbol "Arrow"))
	   (write-arrow-tycon args xp))
	  ((eq? def (core-symbol "UnitType"))
	   (write-unit-tycon xp))
	  ((eq? def (core-symbol "List"))
	   (write-list-tycon args xp))
	  ((is-tuple-tycon? def)
	   (write-tuple-tycon args xp))
	  (else
	   (write-ordinary-tycon def args object xp))))

(define (write-arrow-tycon args xp)
  (with-ast-block (xp)
    (write-btype (car args) xp)
    (write-string " ->" xp)
    (write-whitespace xp)
    (write (cadr args) xp)))

(define (write-unit-tycon xp)
  (write-string "()" xp))

(define (write-list-tycon args xp)
  (with-ast-block (xp)
    (write-char #\[ xp)
    (write (car args) xp)
    (write-char #\] xp)))

(define (write-tuple-tycon args xp)
  (write-commaized-list args xp))

(define (write-ordinary-tycon def args object xp)
  (with-ast-block (xp)
    (if (tycon? object)
	(write-tyconid (tycon-name object) xp)
	(write-tyconid (def-name def) xp))
    (when (not (null? args))
      (write-whitespace xp)
      (write-delimited-list
        args xp (function write-atype) "" "" ""))))


;;; All of the special cases above except "Arrow" are atypes, as is
;;; a tyvar or a tycon with no arguments.

(define (write-atype object xp)
 (let ((object (maybe-prune object)))
  (if (or (tyvar? object)
	  (gtyvar? object)
	  (ntyvar? object)
	  (is-some-tycon? object
	     (lambda (def)
	       (or (eq? def (core-symbol "UnitType"))
		   (eq? def (core-symbol "List"))
		   (is-tuple-tycon? def)))))
      (write object xp)
      (begin
        (write-char #\( xp)
	(write object xp)
	(write-char #\) xp)))))


;;; A btype is any type except the arrow tycon.

(define (write-btype object xp)
 (let ((object (maybe-prune object)))
  (if (or (and (tycon? object)
	       (eq? (tycon-def object) (core-symbol "Arrow")))
	  (and (ntycon? object)
	       (eq? (ntycon-tycon object) (core-symbol "Arrow"))))
      (begin
        (write-char #\( xp)
	(write object xp)
	(write-char #\) xp))
      (write object xp))))
      
(define (maybe-prune object)
  (if (ntyvar? object)
      (prune object)
      object))

(define (is-some-tycon? object fn)
  (let ((object (maybe-prune object)))
    (or (and (tycon? object)
	     (or (null? (tycon-args object))
		 (funcall fn (tycon-def object))))
	(and (ntycon? object)
	     (or (null? (ntycon-args object))
		 (funcall fn (ntycon-tycon object)))))))

(define-ast-printer context (object xp)
  (with-ast-block (xp)
    (write (context-class object) xp)
    (write-whitespace xp)
    (write-avarid (context-tyvar object) xp)))

(define-ast-printer signature (object xp)
  (write-contexts (signature-context object) xp)
  (write (signature-type object) xp))

(define (write-contexts contexts xp)
  (when (not (null? contexts))
    (if (null? (cdr contexts))
	(write (car contexts) xp)
	(write-commaized-list contexts xp))
    (write-string " =>" xp)
    (write-whitespace xp)))

(define-ast-printer synonym-decl (object xp)
  (with-ast-block (xp)
    (write-string "type " xp)
    (write (synonym-decl-simple object) xp)
    (write-string " =" xp)
    (write-whitespace xp)
    (write (synonym-decl-body object) xp)))

(define-ast-printer data-decl (object xp)
  (with-ast-block (xp)
    (write-string "data " xp)
    (write-contexts (data-decl-context object) xp)
    (write (data-decl-simple object) xp)
    (write-whitespace xp)
    (write-char #\= xp)
    (write-whitespace xp)
    (write-delimited-list
      (data-decl-constrs object) xp (function write) " |" "" "")
    (write-whitespace xp)
    (let ((deriving  (data-decl-deriving object)))
      (when (not (null? deriving))
	(write-string "deriving " xp)
	(if (null? (cdr deriving))
	    (write (car deriving) xp)
	    (write-commaized-list deriving xp))))))

(define-ast-printer constr (object xp)
  (if (con-ref-infix? (constr-constructor object))
      (with-ast-block (xp)
        (write-btype (car (constr-types object)) xp)
	(write-whitespace xp)
	(write (constr-constructor object) xp)
	(write-whitespace xp)
	(write-btype (cadr (constr-types object)) xp))
      (with-ast-block (xp)
	(write (constr-constructor object) xp)
	(when (not (null? (constr-types object)))
	  (write-whitespace xp)
	  (write-delimited-list
	   (constr-types object) xp (function write-atype) "" "" "")))))


(define-ast-printer class-decl (object xp)
  (with-ast-block (xp)
    (write-string "class " xp)
    (write-contexts (class-decl-super-classes object) xp)
    (write (class-decl-class object) xp)
    (write-whitespace xp)
    (write-avarid (class-decl-class-var object) xp)
    (write-wheredecls (class-decl-decls object) xp)))

(define-ast-printer instance-decl (object xp)
  (with-ast-block (xp)
    (write-string "instance " xp)
    (write-contexts (instance-decl-context object) xp)
    (write (instance-decl-class object) xp)
    (write-whitespace xp)
    (write-atype (instance-decl-simple object) xp)
    (write-wheredecls (instance-decl-decls object) xp)))


;;; Don't print out default decl if the value is the default.

(define-ast-printer default-decl (object xp)
  (with-ast-block (xp)
    (write-string "default " xp)
    (let ((types  (default-decl-types object)))
      (if (null? (cdr types))
	  (write (car types) xp)
	  (write-commaized-list types xp)))))

(define-ast-printer class-ref (object xp)
  (write-tyclsid (class-ref-name object) xp))