1 files changed, 125 insertions, 0 deletions
diff --git a/printers/print-modules.scm b/printers/print-modules.scm
new file mode 100644
index 0000000..2372714
--- /dev/null
+++ b/printers/print-modules.scm
@@ -0,0 +1,125 @@
+;;; print-modules.scm -- print routines for module-related AST structures
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  6 Jan 1992
+;;;
+;;;
+;;; This file corresponds to the file ast/modules.scm.
+
+;;; Note: by default, only the module name is printed.  To print the
+;;; full module, the function print-full-module must be called.
+
+(define *print-abbreviated-modules* '#t)
+
+(define-ast-printer module (object xp)
+ (if *print-abbreviated-modules*
+     (begin
+       (write-string "Module " xp)
+       (write-string (symbol->string (module-name object)) xp))
+     (do-print-full-module object xp)))
+
+(define (print-full-module object . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (dynamic-let ((*print-abbreviated-modules* '#f))
+       (pprint object stream))))
+
+(define (do-print-full-module object xp)
+ (dynamic-let ((*print-abbreviated-modules* '#t))
+  (let ((modid    (module-name object))
+	(exports  (module-exports object))
+	(body     (append (module-imports object)
+			  (module-fixities object)
+			  (module-synonyms object)
+			  (module-algdatas object)
+			  (module-classes object)
+			  (module-instances object)
+			  (if (or (not (module-default object))
+				  (eq? (module-default object)
+				       *standard-module-default*))
+			      '()
+			      (list (module-default object)))
+			  (module-decls object))))
+    (write-string "module " xp)
+    (write-modid modid xp)
+    (when (not (null? exports))
+      (write-whitespace xp)
+      (write-commaized-list exports xp))
+    (write-wheredecls body xp))))
+
+(define-ast-printer import-decl (object xp)
+  (let ((modid     (import-decl-module-name object))
+	(mode      (import-decl-mode object))
+	(specs     (import-decl-specs object))
+	(renamings (import-decl-renamings object)))
+    (with-ast-block (xp)
+      (write-string "import " xp)
+      (write-modid modid xp)
+      (if (eq? mode 'all)
+	  (when (not (null? specs))
+	    (write-whitespace xp)
+	    (write-string "hiding " xp)
+	    (write-commaized-list specs xp))
+	  (begin
+	    (write-whitespace xp)
+	    (write-commaized-list specs xp)))
+      (when (not (null? renamings))
+	(write-whitespace xp)
+	(write-string "renaming " xp)
+	(write-commaized-list renamings xp))
+      )))
+
+(define-ast-printer entity-module (object xp)
+  (write-modid (entity-name object) xp)
+  (write-string ".." xp))
+
+(define-ast-printer entity-var (object xp)
+  (write-varid (entity-name object) xp))
+
+(define-ast-printer entity-con (object xp)
+  (write-tyconid (entity-name object) xp))
+
+(define-ast-printer entity-abbreviated (object xp)
+  (write-tyconid (entity-name object) xp)
+  (write-string "(..)" xp))
+
+(define-ast-printer entity-class (object xp)
+  (with-ast-block (xp)
+    (write-tyclsid (entity-name object) xp)
+    (write-whitespace xp)
+    (write-delimited-list (entity-class-methods object) xp
+			  (function write-varid) "," "(" ")")))
+
+(define-ast-printer entity-datatype (object xp)
+  (with-ast-block (xp)
+    (write-tyconid (entity-name object) xp)
+    (write-whitespace xp)
+    (write-delimited-list (entity-datatype-constructors object) xp
+			  (function write-conid) "," "(" ")")))
+
+
+(define-ast-printer renaming (object xp)
+  (with-ast-block (xp)
+    (write-varid-conid (renaming-from object) xp)
+    (write-string " to" xp)
+    (write-whitespace xp)
+    (write-varid-conid (renaming-to object) xp)))
+
+;;; *** Should it omit precedence if it's 9?
+
+(define-ast-printer fixity-decl (object xp)
+  (let* ((fixity         (fixity-decl-fixity object))
+	 (associativity  (fixity-associativity fixity))
+	 (precedence     (fixity-precedence fixity))
+	 (ops            (fixity-decl-names object)))
+    (with-ast-block (xp)
+      (cond ((eq? associativity 'l)
+	     (write-string "infixl " xp))
+	    ((eq? associativity 'r)
+	     (write-string "infixr " xp))
+	    ((eq? associativity 'n)
+	     (write-string "infix " xp)))
+      (write precedence xp)
+      (write-whitespace xp)
+      (write-delimited-list ops xp (function write-varop-conop) "," "" ""))))