home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / command-interface / interface-prims.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  12.4 KB  |  280 lines  |  [TEXT/CCL2]
  1.  
  2. ;;;=========================================================================
  3. ;;; Top-level command loop
  4. ;;;=========================================================================
  5.  
  6.  
  7. (define *init-complete* '#f)
  8.  
  9. ;;; The savesys code arranges for this function to be called at 
  10. ;;; startup time.
  11.  
  12. (define (heval)
  13.   (initialize-haskell-system)
  14.   (format '#t "~&Yale Haskell ~A~A   ~A~%Type :? for help.~%"
  15.       *haskell-compiler-version*
  16.       *haskell-compiler-update*
  17.       (identify-system))
  18.   (funcall *haskell-initialize-hook*)
  19.   (do () ('#f)
  20.       (let/cc croak
  21.     (dynamic-let ((*abort-compilation*
  22.                 (lambda ()
  23.               (when *haskell-compilation-error-hook*
  24.                 (funcall *haskell-compilation-error-hook*))
  25.               (funcall croak '#f)))
  26.               (*abort-phase*        '#f)
  27.               (*phase*              'toplevel)
  28.               (*in-error-handler*   '#f))
  29.       (funcall *haskell-command-hook*)))))
  30.  
  31.  
  32. ;;; This is an alternative entry point for emulating a standalone
  33. ;;; executable.
  34.  
  35. (define (hrun file args)
  36.   (initialize-haskell-system)
  37.   (funcall *haskell-initialize-hook*)
  38.   (let/cc croak
  39.     (dynamic-let ((*abort-compilation*
  40.            (lambda ()
  41.              (when *haskell-compilation-error-hook*
  42.                (funcall *haskell-compilation-error-hook*))
  43.              (funcall croak '#f)))
  44.           (*abort-phase*        '#f)
  45.           (*phase*              'toplevel)
  46.           (*in-error-handler*   '#f))
  47.       (compile/run file args)
  48.       (force-output)
  49.       (exit))))
  50.  
  51.  
  52.  
  53. ;;;=========================================================================
  54. ;;; Eval and run in extension
  55. ;;;=========================================================================
  56.  
  57. (define (haskell-eval exp extension-name extension module-name maybe-file)
  58.   (declare (ignore extension-name))
  59.   (when (memq 'interactive (dynamic *printers*))
  60.     (format '#t "~%Evaluating ~a...~%" exp))
  61.   (when maybe-file
  62.     (compile/load maybe-file))
  63.   (let* ((module    (find-executable-module module-name))
  64.      (module+pad (add-pad-definitions module extension)))
  65.     (haskell-exec-aux
  66.       exp
  67.       (format '#f "~A = putText (~a)~%" *magic-temp-name* exp)
  68.       module+pad
  69.       )))
  70.  
  71. (define (haskell-run exp extension-name extension module-name maybe-file)
  72.   (declare (ignore extension-name))
  73.   (when (memq 'interactive (dynamic *printers*))
  74.     (format '#t "~%Running ~a...~%" exp))
  75.   (when maybe-file
  76.     (compile/load maybe-file))
  77.   (let* ((module     (find-executable-module module-name))
  78.      (module+pad (add-pad-definitions module extension)))
  79.     (haskell-exec-aux
  80.       exp
  81.       (format '#f "~a = ~a~%~a :: IO ()~%"
  82.           *magic-temp-name* exp *magic-temp-name*)
  83.       module+pad)))
  84.  
  85. (define (haskell-run-print exp extension-name extension module-name maybe-file)
  86.   (declare (ignore extension-name))
  87.   (when (memq 'interactive (dynamic *printers*))
  88.     (format '#t "~%Running ~a...~%" exp))
  89.   (when maybe-file
  90.     (compile/load maybe-file))
  91.   (let* ((module     (find-executable-module module-name))
  92.      (module+pad (add-pad-definitions module extension)))
  93.     (haskell-exec-aux
  94.       exp
  95.       (format '#f "~a = (~a) >>= putText~%~a :: IO ()~%"
  96.           *magic-temp-name* exp *magic-temp-name*)
  97.       module+pad)))
  98.  
  99.  
  100. (define (haskell-report-type exp extension-name extension
  101.                  module-name maybe-file)
  102.   (declare (ignore extension-name))
  103.   (when (memq 'interactive (dynamic *printers*))
  104.     (format '#t "~%Type checking ~a...~%" exp))
  105.   (when maybe-file
  106.     (compile/load maybe-file))
  107.   (let* ((module     (find-executable-module module-name))
  108.      (module+pad (add-pad-definitions module extension)))
  109.     (haskell-report-type-aux
  110.       exp
  111.       (format '#f "~A = ~A~%" *magic-temp-name* exp)
  112.       module+pad)))
  113.  
  114. (define (add-pad-definitions module pad)
  115.   (if (string=? pad "")
  116.       module
  117.       (dynamic-let ((*printers*
  118.              (if (memq 'pad (dynamic *printers*))
  119.              (dynamic *printers*)
  120.              (if (memq 'time *printers*)
  121.                  '(time)
  122.                  '()))))
  123.     (let ((new-module
  124.            (parse-fragment
  125.         (module-name module)
  126.         "-pad"
  127.         pad
  128.         (format '#f "~A pad" (module-name module))
  129.         '#t)))
  130.       (fragment-initialize new-module module)
  131.       (eval (modules->lisp-code (list new-module)))
  132.       new-module))))
  133.  
  134. (define (haskell-exec-aux extension-name fragment module)
  135.   (dynamic-let ((*printers* '()))
  136.     (prepare-execution)
  137.     (let ((new-module  (parse-fragment
  138.             (module-name module)
  139.             "-exp"
  140.             fragment
  141.             extension-name
  142.             '#f)))
  143.       (fragment-initialize new-module module)
  144.       (eval (modules->lisp-code (list new-module)))
  145.       (run-dialogue *magic-temp-name* new-module)
  146.       new-module)))
  147.  
  148. (define (haskell-report-type-aux extension-name fragment module)
  149.   (dynamic-let ((*printers* '()))
  150.     (let ((new-module  (parse-fragment
  151.             (module-name module)
  152.             "-exp"
  153.             fragment
  154.             extension-name
  155.             '#f)))
  156.       (fragment-initialize new-module module)
  157.       (modules->lisp-code (list new-module))
  158.       (report-type fragment *magic-temp-name* new-module)
  159.       new-module)))
  160.  
  161.  
  162. ;;; Helper functions for above
  163.  
  164. (define (parse-fragment mod-name mod-type fragment filename has-lines?)
  165.   (let* ((new-mod-name (string-append (symbol->string mod-name) mod-type))
  166.      (module (parse-module-body-from-string
  167.           (string->symbol new-mod-name)
  168.           fragment 
  169.           filename
  170.           has-lines?)))
  171.     (when (not (null? (module-imports module)))
  172.       (signal-import-decl-in-extension))
  173.     module))
  174.  
  175. (define (signal-import-decl-in-extension)
  176.   (fatal-error 'import-decl-in-extension
  177.                "Import declarations are not allowed in scratch pads."))
  178.  
  179.  
  180. (define (fragment-initialize new old)
  181.   (setf (module-type new) 'extension)
  182.   (setf (module-unit new) (module-unit old))
  183.   (setf (module-uses-standard-prelude? new)
  184.     (module-uses-standard-prelude? old))
  185.   (setf (module-inherited-env new) old)
  186.   (setf (module-fixity-table new)
  187.     (copy-table (module-fixity-table old)))
  188.   (setf (module-default new) (module-default old)))
  189.  
  190.  
  191. (define (report-type exp name module)
  192.   (let ((var  (table-entry (module-symbol-table module) name)))
  193.     (if (var? var)
  194.         (format '#t "~&~A :: ~A~%" exp (var-type var))
  195.     (signal-no-definition-of-var name module))))
  196.  
  197.  
  198.  
  199. ;;;=========================================================================
  200. ;;; Support for operations on files
  201. ;;;=========================================================================
  202.  
  203. ;;; This keeps track of modules which are currently available.
  204.  
  205. (define *modules-available* '())
  206.  
  207.  
  208. ;;; These both load the code associated with the file
  209. ;;; Do NOT mess with the return values from these functions.
  210. ;;; The stuff in vanilla.scm depends on getting the unit back.
  211.  
  212. (define (compile/compile file)
  213.   (compile/common file *compile/compile-cflags*))
  214.  
  215. (define (compile/load file)
  216.   (compile/common file *compile/load-cflags*))
  217.  
  218. (define (compile/common file flags)
  219.   (let ((unit  (haskell-compile file flags)))
  220.     (setf *modules-available* (ucache-modules unit))
  221.     unit))
  222.     
  223.  
  224.     
  225. ;;; This loads the compilation unit, then runs the dialogue called 
  226. ;;; "main".  If there's more than one module, it looks for the one
  227. ;;; called "Main".
  228.  
  229. (define *haskell-command-line-args* '())
  230. (define *haskell-program-name* "haskell")
  231.  
  232. (define (compile/run file args)
  233.   (let ((unit (compile/load file)))
  234.     (when unit
  235.       (when (memq 'interactive (dynamic *printers*))
  236.     (format '#t "~%Running main...~%"))
  237.       (let ((mod (find-executable-module/inner '|Main|)))
  238.     (unless mod
  239.        (if (eqv? (length (ucache-modules-defined unit)) 1)
  240.            (setf mod (car (ucache-modules unit)))
  241.            (fatal-error 'ambiguous-module "No Main module found.")))
  242.     (dynamic-let ((*haskell-command-line-args* args)
  243.               (*haskell-program-name* file))
  244.         (run-dialogue '|main| mod))))
  245.     unit))
  246.  
  247.  
  248. (define (find-executable-module mod-name)
  249.   (or (find-executable-module/inner mod-name)
  250.       (signal-module-not-found mod-name)))
  251.  
  252. (define (find-executable-module/inner mod-name)
  253.   (find-executable-module-1 mod-name *modules-available*))
  254.  
  255. (define (find-executable-module-1 name mods)
  256.   (if (null? mods)
  257.       '#f
  258.       (if (and (eq? name (module-name (car mods)))
  259.            (not (interface-module? (car mods))))
  260.       (car mods)
  261.       (find-executable-module-1 name (cdr mods)))))
  262.  
  263. (define (signal-module-not-found mod-name)
  264.   (fatal-error 'module-not-found
  265.            "Module ~a is not currently compiled and loaded."
  266.            mod-name))
  267.  
  268.  
  269.  
  270.  
  271. ;;;=========================================================================
  272. ;;; Support for running dialogues
  273. ;;;=========================================================================
  274.  
  275. (define (run-dialogue name module)
  276.   (let ((var  (table-entry (module-symbol-table module) name)))
  277.     (cond ((not var)
  278.        (signal-no-definition-of-var name module))
  279.       ((not (is-dialogue? var))
  280.        (signal-var-not-dialogue var modul