;;; 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) "," "" ""))))