;;; This is the main driver for the import / export routine

(define (import-export modules)
  (walk-modules modules
        (lambda () (add-module-to-symbol-table *module*)))
  (walk-modules modules
      (lambda () (init-module-structure)))
  (import-export/fixpoint modules '#t)
  (walk-modules modules (lambda () (check-missing-names)))
  (when (memq 'import (dynamic *printers*))
    (show-export-tables modules))
 modules)

(define (import-export/interface modules)
  (walk-modules modules
        (lambda () (add-module-to-symbol-table *module*)))
  (walk-modules modules
      (lambda () (init-module-structure)))
  (walk-modules modules
      (lambda () (create-top-definitions)
	         (attach-fixities))))

(define (import-export/fixpoint modules initial-cycle?)
  (setf *new-exports-found?* '#f)
  (walk-modules modules
   (lambda ()
     (setf (module-fresh-exports *module*) '())
     (when initial-cycle?
       (create-top-definitions)
       (attach-fixities)
       (import-non-local))
     (locally-import)
     (locally-export)))
  (when *new-exports-found?*
      (import-export/fixpoint modules '#f)))

;;; This does the non-local importing from previously defined modules

(define (import-non-local)
  (setf (module-imports *module*)
	(process-non-local-imports (module-imports *module*))))

(define (process-non-local-imports imports)
  (if (null? imports)
      '()
      (let* ((import (car imports)))
        (with-slots import-decl (module mode specs renamings) import
	  (cond ((eq? *unit* (module-unit module))
		 (cons import (process-non-local-imports (cdr imports))))
		((eq? mode 'all)
		 (import-all-entities module specs renamings import)
		 (process-non-local-imports (cdr imports)))
		(else
		 (import-named-entities module specs renamings import)
		 (process-non-local-imports (cdr imports))))))))

(define (import-all-entities module hiding renamings import-decl)
  (table-for-each
   (lambda (name group)
     (declare (ignore name))
     (cond ((in-hiding-list? group hiding)
	    (setf hiding (remove-entity group hiding)))
	   (else
	    (import-group (rename-group group renamings) module))))
   (module-export-table module))
  (when (not (null? hiding))
    (remember-context import-decl
      (dolist (h hiding)
	(signal-unused-hiding (entity-name h) (module-name module)))))
  (find-unused-renamings renamings import-decl))

(define (import-named-entities mod specs renamings import-decl)
  (dolist (entity specs)
    (let ((group (locate-entity/export-table entity mod '#t)))
      (when (not (eq? group 'error))
	(setf group (rename-group group renamings))
	(import-group group mod))))
  (find-unused-renamings renamings import-decl))

;;; This takes a module and processes the import declarations, moving as
;;; many entities from the freshly exported components of other modules into
;;; the current module.

(define (locally-import)
  (dolist (import (module-imports *module*))
    (with-slots import-decl (module mode specs renamings) import
      (if (eq? mode 'all)
	  (import-fresh-entities import module specs renamings)
	  (setf (import-decl-specs import)
		(import-entities specs module renamings))))))

(define (import-fresh-entities import module hiding renamings)
  (dolist (group (module-fresh-exports module))
    (cond ((in-hiding-list? group hiding)
	    (setf hiding (remove-entity group hiding)))
	   (else
	    (import-group (rename-group group renamings) module))))
  (setf (import-decl-specs import) hiding))

(define (import-entities entities module renamings)
  (if (null? entities)
      '()
      (let ((group (locate-entity/export-table (car entities) module '#f)))
	(cond ((eq? group 'not-found)
	       (cons (car entities)
		     (import-entities (cdr entities) module renamings)))
	      ((eq? group 'error)
	       (import-entities (cdr entities) module renamings))
	      (else
	       (setf group (rename-group group renamings))
	       (import-group group module)
	       (import-entities (cdr entities) module renamings))))))

;;; This imports a group into *module*.  module is the place the group is
;;; taken from.

(define (import-group group module)
  (when (memq module (module-exported-modules *module*))
    (export-group group))
  (dolist (n-d group)
    (insert-top-definition (tuple-2-1 n-d) (tuple-2-2 n-d))))

;;; This takes as yet unresolved exports and moves them to the export table.

(define (locally-export)
  (setf (module-exports *module*)
	(export-entities (module-exports *module*))))

(define (export-entities entities)
  (if (null? entities)
      '()
      (let* ((entity (car entities))
	     (group (locate-entity entity)))
	(cond ((eq? group 'error)
	       (export-entities (cdr entities)))
	      ((eq? group 'not-found)
	       (cons entity (export-entities (cdr entities))))
	      (else
	       (export-group group)
	       (export-entities (cdr entities)))))))


;;; This moves a group into the export table.  If this export is new,
;;; a flag is set.

(define (export-group group)
  (let* ((export-table (module-export-table *module*))
	 (old-group (table-entry export-table (group-name group))))
    (when (or (eq? old-group '#f)
	      (and (hidden-constructors? old-group)
		   (not (hidden-constructors? group))))
      (setf (table-entry export-table (group-name group)) group)
      (dolist (n-d group)
        (setf (def-exported? (tuple-2-2 n-d)) '#t))
      (push group (module-fresh-exports *module*))
      (setf *new-exports-found?* '#t))))

(define (show-export-tables modules)
  (walk-modules modules
    (lambda ()
      (format '#t "~%Exports from module ~A~%" *module-name*)
      (let ((exports '()))
	(table-for-each (lambda (key val)
			  (push (cons key val) exports))
			(module-export-table *module*))
	(setf exports (sort-list exports
				 (lambda (x y)
				   (string-ci<? (symbol->string (car x))
						(symbol->string (car y))))))
	(dolist (e exports)
          (print-exported-group (car e) (group-definition (cdr e))
				(cdr (cdr e))))))))

(define (print-exported-group name def extras)
  (if (eq? (def-module def) *module-name*)
      (format '#t " ")
      (format '#t "*"))
  (cond ((synonym? def)
	 (format '#t "type  "))
	((algdata? def)
	 (format '#t "data  "))
	((class? def)
	 (format '#t "class "))
	(else
	 (format '#t "      ")))
  (format '#t "~A" name)
  (when (not (eq? name (def-name def)))
     (format '#t "[~A]" (def-name def)))
  (when extras
     (format '#t " (")
     (print-exported-group-1 extras (algdata? def)))
  (format '#t "~%"))

(define (print-exported-group-1 extras alg?)
  (let* ((name (tuple-2-1 (car extras)))
	 (ns (symbol->string name))
	 (def (tuple-2-2 (car extras))))
    (format '#t "~A" (if alg? (remove-con-prefix ns) ns))
    (when (not (eq? name (def-name def)))
      (let ((name1 (symbol->string (def-name def))))
	  (format '#t "[~A]" (if alg? (remove-con-prefix name1) name1))))
    (if (null? (cdr extras))
	(format '#t ")")
	(begin
	  (format '#t ",")
	  (print-exported-group-1 (cdr extras) alg?)))))