diff options
Diffstat (limited to 'printers/print-types.scm')
| -rw-r--r-- | printers/print-types.scm | 201 |
1 files changed, 201 insertions, 0 deletions
diff --git a/printers/print-types.scm b/printers/print-types.scm new file mode 100644 index 0000000..53d3bee --- /dev/null +++ b/printers/print-types.scm @@ -0,0 +1,201 @@ +;;; 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)) + + + |