init-modules.scm

;;; This initializes the module ast structures.

;;; This requires that the module table be created and updated with new
;;; modules first.  *unit* must also be defined.

;;; Things initialized there:
;;;  all tables in the module structure
;;;  the module slot of all import declarations and entity-modules
;;;  The import Prelude is added when necessary
;;;  Empty export lists are explicated

(define (init-module-structure)
  (when (not (eq? (module-type *module*) 'extension))
    ;; If this is an extension, the incremental compiler has already
    ;; filled in the compilation unit.
    (setf (module-unit *module*) *unit*))
  ;;; This processes the annotations.  Annotations used at the top
  ;;; level of the module:
  ;;;   {-#PRELUDE#-} : this contains definitions in the Haskell prelude
  (setf (module-prelude? *module*) '#f)
  (setf (module-interface-codefile *module*) '())
  (dolist (a (module-annotations *module*))
    (when (annotation-value? a)
      (let ((name (annotation-value-name a)))
	(cond ((eq? name '|Prelude|)
	       (setf (module-prelude? *module*) '#t))))))
  (cond ((eq? (module-type *module*) 'interface)
	 (setf (module-exported-modules *module*) (list *module*))
	 (process-interface-imports *module*))
	((eq? (module-type *module*) 'standard)
	 (init-standard-module))))

(define (init-standard-module)
   (let ((seen-prelude? '#f))
    (dolist (import (module-imports *module*))
      (let* ((name (import-decl-module-name import))
	     (imported-mod (locate-module name)))
	(when (eq? name '|Prelude|)
	   (setf seen-prelude? '#t))
	(if (eq? imported-mod '#f)
	    (signal-undefined-module-import name)
	    (setf (import-decl-module import) imported-mod))
	(when (eq? name *module-name*)
	  (signal-self-import name))))
    (when (null? (module-exports *module*))
	(setf (module-exports *module*)
	      (list (make entity-module (name *module-name*)
			                (module *module*)))))
    (when (not seen-prelude?)
      (let ((prelude (locate-module '|Prelude|)))
	(cond ((eq? prelude '#f)
	       (signal-missing-prelude))
	      ((module-prelude? *module*)
	       (setf (module-uses-standard-prelude? *module*) '#f)
	       (add-imported-module prelude))
	      (else
	       (setf (module-uses-standard-prelude? *module*) '#t)
	       (let ((fix-table (module-fixity-table *module*)))
		 (table-for-each (lambda (k v)
				   (setf (table-entry fix-table k) v))
				 *prelude-fixity-table*))))))
    (let ((prelude-core (locate-module '|PreludeCore|)))
       (if (eq? prelude-core '#f)
	   (signal-missing-prelude-core)
	   (when (module-prelude? *module*)
		 (add-imported-module prelude-core))))
    (setf (module-exports *module*)
	  (filter-complete-module-exports (module-exports *module*))))
    )


(define (add-imported-module module)
  (setf (module-imports *module*)
	(cons (make import-decl
		    (module-name (module-name module))
		    (module module)
		    (mode 'all)
		    (specs '())
		    (renamings '()))
	      (module-imports *module*))))

(define (filter-complete-module-exports exports)
  (if (null? exports)
      '()
      (let ((export (car exports))
	    (others (filter-complete-module-exports (cdr exports))))
	(if (is-type? 'entity-module export)
	    (let* ((name (entity-name export))
		   (exported-mod (locate-module name)))
	      (when (eq? exported-mod '#f)
		(signal-undefined-module-export name))
	      (push exported-mod (module-exported-modules *module*))
	      (when (not (memq name
			   (cons *module-name*
				 (map
				   (lambda (import)
				     (import-decl-module-name import))
				   (module-imports *module*)))))
		(signal-export-not-imported name))
	      others)
	    (cons export others)))))

(define (process-interface-imports module)
  (let ((imports '()))
    (dolist (i (module-imports module))
      (let ((module (import-decl-module-name i))
	    (renamings (import-decl-renamings i)))
	(dolist (s (import-decl-specs i))
          (let* ((n (entity-name s))
		 (n1 (do-interface-rename n renamings)))
	    (when (assq n1 imports)
               (signal-multiple-imports n1))
	    (push (tuple n1 (tuple module n)) imports)
	    (cond ((entity-class? s)
		   (dolist (m (entity-class-methods s))
                     (let ((m1 (do-interface-rename m renamings)))
		       (when (assq m1 imports)
                          (signal-multiple-imports m1))
		       (push (tuple m1 (tuple module m)) imports))))
		  ((entity-datatype? s)
		   (dolist (m (entity-datatype-constructors s))
                     (let ((m1 (do-interface-rename m renamings)))
		       (when (assq m1 imports)
                          (signal-multiple-imports m1))
		       (push (tuple m1 (tuple module m)) imports)))))))))
    (setf (module-interface-imports module) imports)))

(define (signal-multiple-imports name)
  (phase-error 'multuple-interface-import
    "Interface file has more than one definition of ~A~%" name))

(define (do-interface-rename name renamings)
  (if (has-con-prefix? (symbol->string name))
      (let* ((n1 (remove-con-prefix/symbol name))
	     (res (locate-renaming n1 renamings)))
	(if (eq? res '#f)
	    name
	    (add-con-prefix/symbol (renaming-to res))))
      (let ((res (locate-renaming name renamings)))
	(if (eq? res '#f)
	    name
	    (renaming-to res)))))