;;; ==================================================================
 
 ;;; This deals with incremental compilation as used by the command interface.
 ;;; The basic theory is to create new modules which import the entire
 ;;; symbol table of an existing module.
 
 
 ;;; This adds a new module to the extension environment.  This env is an alist
 ;;; of module names & extended modules.
 
 (define *extension-env* '())
 
 (define (extend-module mod-name new-ast)
   (push (tuple mod-name new-ast) *extension-env*))
 
 ;;; This cleans out extensions for a module.
 
 (define (remove-extended-modules mod-name)
   (setf *extension-env* (rem-ext1 *extension-env* mod-name)))
 
 (define (rem-ext1 env name)
   (cond ((null? env)
 	 '())
 	((eq? (tuple-2-1 (car env)) name)
 	 (rem-ext1 (cdr env) name))
 	(else
 	 (cons (car env) (rem-ext1 (cdr env) name)))))
 
 (define (clear-extended-modules)
   (setf *extension-env* '()))
 
 ;;; This retrieves the current extension to a module (if any).
 
 (define (updated-module name)
   (let ((name+mod (assq name *extension-env*)))
     (if (not (eq? name+mod '#f))
 	(tuple-2-2 name+mod)
 	(let ((mod-in-table (table-entry *modules* name)))
 	  (cond ((eq? mod-in-table '#f)
 		 (signal-module-not-ready name))
 		((eq? (module-type mod-in-table) 'interface)
 		 (signal-cant-eval-interface name))
 		(else mod-in-table))))))
 
 (define (signal-module-not-ready name)
   (fatal-error 'module-not-ready
 	       "Module ~A is not loaded and ready."
 	       name))
 
 (define (signal-cant-eval-interface name)
   (fatal-error 'no-evaluation-in-interface
 	       "Module ~A is an interface: evaluation not allowed."
 	       name))
 
 (define (compile-fragment module str filename)
   (let ((mod-ast (updated-module module)))
     (dynamic-let
        ((*printers* (if (memq 'extension *printers*) *printers* '()))
 	(*abort-phase*   '#f))
      (mlet (((t-code new-ast) (compile-fragment1 module mod-ast str filename)))
        (cond ((eq? t-code 'error)
 	      'error)
 	     (else
 	      (eval t-code)
 	      new-ast))))))
 
 (define (compile-fragment1 mod-name mod-ast str filename)
   (let/cc x
     (dynamic-let ((*abort-compilation* (lambda () (funcall x 'error '()))))
      (let* ((mods (parse-from-string
 		   (format '#f "module ~A where~%~A~%" mod-name str)
 		   (function parse-module-list)
 		   filename))
 	   (new-mod (car mods)))
 	(when (not (null? (cdr mods)))
 	  (signal-module-decl-in-extension))
 	(when (not (null? (module-imports new-mod)))
 	  (signal-import-decl-in-extension))
 	(fragment-initialize new-mod mod-ast)
 	(values (modules->lisp-code mods) new-mod)))))
 
 (define (signal-module-decl-in-extension)
   (fatal-error 'module-decl-in-extension
 	       "Module declarations are not allowed in extensions."))
 
 (define (signal-import-decl-in-extension)
   (fatal-error 'import-decl-in-extension
 	       "Import declarations are not allowed in extensions."))
 
 
 ;;; Copy stuff into the fragment module structure from its parent module.
 ;;; The inverted symbol table is not necessary since the module contains
 ;;; no imports.
 
 (define (fragment-initialize new old)
   (setf (module-name new) (gensym))
   (setf (module-type new) 'extension)
   (setf (module-unit new) (module-unit old))
   (setf (module-uses-standard-prelude? new)
 	(module-uses-standard-prelude? old))
   (setf (module-inherited-env new) old)
   (setf (module-fixity-table new)
         (copy-table (module-fixity-table old)))
   (setf (module-default new) (module-default old)))
   
 ;;; This code deals with the actual evaluation of Haskell code.
 
 ;;; This decides whether a variable has type `Dialogue'.
 
 (define (io-type? var)
   (let ((type (var-type var)))
     (when (not (gtype? type))
       (error "~s is not a Gtype." type))
     (and (null? (gtype-context type))
 	 (is-dialogue? (gtype-type type)))))
 
 (define (is-dialogue? type)
   (let ((type (expand-ntype-synonym type)))
     (and (ntycon? type)
 	 (eq? (ntycon-tycon type) (core-symbol "Arrow"))
 	 (let* ((args (ntycon-args type))
 		(a1 (expand-ntype-synonym (car args)))
 		(a2 (expand-ntype-synonym (cadr args))))
 	   (and
 	    (ntycon? a1)
 	    (eq? (ntycon-tycon a1) (core-symbol "SystemState"))
 	    (ntycon? a2)
 	    (eq? (ntycon-tycon a2) (core-symbol "IOResult")))))))
 
 (define (is-list-of? type con)
   (and (ntycon? type)
        (eq? (ntycon-tycon type) (core-symbol "List"))
        (let ((arg (expand-ntype-synonym (car (ntycon-args type)))))
 	 (and (ntycon? arg) (eq? (ntycon-tycon arg) con)))))
 
 (define (apply-exec var)
    (initialize-io-system)
    (mlet (((_ sec)
 	   (time-execution
 	     (lambda ()
 	       (let/cc x
 		 (setf *runtime-abort* (lambda () (funcall x 'error)))
 		 (let ((fn (eval (fullname var))))
 		   (unless (var-strict? var)
 		       (setf fn (force fn)))
 		   (funcall fn (box 'state))))))))
       (say "~%")
       (when (memq 'time *printers*)
 	 (say "Execution time: ~A seconds~%" sec)))
    'done)
 
 (define (eval-module mod)
   (dolist (v (module-vars mod))
      (when (io-type? v)
 	(when (not (string-starts? "temp_" (symbol->string (def-name v))))
 	   (say/ne "~&Evaluating ~A.~%" v))
 	(apply-exec v))))
 
 (define (run-program name)
   (compile/load name)
   (let ((main-mod (table-entry *modules* '|Main|)))
     (if main-mod
 	(let ((main-var (table-entry (module-symbol-table main-mod) '|main|)))
 	  (if main-var
 	      (apply-exec main-var)
 	      (error "Variable main missing")))
 	(error "module Main missing"))))