Much better code now -- directly setting up the user's environment

instead of constructing syntax expressions to do so.  This is all done
with the new `front-end/finished-complete-program' hook.

svn: r11099

collects/drscheme/private/module-language.ss

@@ -136,55 +136,27 @@
       (define/public (get-auto-text settings)
         (module-language-settings-auto-text settings))
       
-      ;; utility for the front-end methods: return a function that will return
+      ;; utility for the front-end method: return a function that will return
       ;; each of the given syntax values on each call, executing thunks when
-      ;; included; when done with the list, use the given getter thunk.
+      ;; included; when done with the list, send eof.
-      (define (expr-getter getter . exprs/thunks)
+      (define (expr-getter . exprs/thunks)
         (define (loop)
           (if (null? exprs/thunks)
-            (getter)
+            eof
             (let ([x (car exprs/thunks)])
               (set! exprs/thunks (cdr exprs/thunks))
               (if (procedure? x) (begin (x) (loop)) x))))
         loop)
       
       (inherit get-reader)
-      (define hopeless-repl (make-thread-cell #t))
+      (define repl-init-thunk (make-thread-cell #f))
       
-      (define/override (front-end/interaction port settings)
-        (let ([x (thread-cell-ref hopeless-repl)])
-          (cond
-            [(not x) (super front-end/interaction port settings)]
-            [(not (syntax? x)) (raise-hopeless-syntax-error)]
-            ;; this means that there was a problem getting into the
-            ;; module's namespace, and we have a language to try to require
-            [else
-             (let ([default-handler (uncaught-exception-handler)])
-               (expr-getter (super front-end/interaction port settings)
-                #`(current-module-declare-name #f)
-                (λ ()
-                  (uncaught-exception-handler
-                   (λ (e)
-                     (uncaught-exception-handler default-handler)
-                     (raise-hopeless-syntax-error "invalid language" x))))
-                #`(require #,x)
-                (λ ()
-                  (uncaught-exception-handler default-handler)
-                  (unless (memq '#%top-interaction (namespace-mapped-symbols))
-                    (raise-hopeless-syntax-error
-                     "invalid language (existing module, but no language bindings)"
-                     x)))))])))
-      
-      ;; This is used to setup the user environment.  There's a subtle hack
-      ;; here: instead of doing things like (namespace-require ...), construct
-      ;; and return a #'(require ...) syntax: this way when we're not going to
-      ;; run the code (eg, when it's used by the syntax checker or the macro
-      ;; debugger), it won't run.
       (define/override (front-end/complete-program port settings)
         (define (super-thunk) ((get-reader) (object-name port) port))
-        (define path (cond [(get-filename port)
+        (define path
-                            => (compose simplify-path cleanse-path)]
+          (cond [(get-filename port) => (compose simplify-path cleanse-path)]
-                           [else #f]))
+                [else #f]))
+        (define resolved-modpath (and path (make-resolved-module-path path)))
         (define-values (name lang module-expr)
           (let ([expr
                  ;; just reading the definitions might be a syntax error,
@@ -199,31 +171,44 @@
                  "there can only be one expression in the definitions window"
                  more)))
             (transform-module path expr)))
-        (define require-spec
+        (define modspec (or path `',(syntax-e name)))
-          (or path
+        ;; We're about to send the module expression to drscheme now, the rest
-              ;; "clearing out" the module-name via datum->syntax ensures that
+        ;; of the setup is done in `front-end/finished-complete-program' below,
-              ;; check syntax doesn't think the original module name is being
+        ;; so use `repl-init-thunk' to store an appropriate continuation for
-              ;; used in this require (so it doesn't get turned red)
+        ;; this setup.  Once we send the expression, we'll be called again only
-              (quasisyntax ''#,(datum->syntax #'here (syntax-e name)))))
+        ;; if it was evaluated (or expanded) with no errors, so begin with a
-        ;; we have a language, so put it here, so front-end/interaction can
+        ;; continuation that deals with an error, and if we're called again,
-        ;; require the language if we fail to go into the module -- most
+        ;; change it to a continuation that initializes the repl for the
-        ;; commonly due to a syntax error, in attempt to still provide a
+        ;; module.  So the code is split among several thunks that follow.
-        ;; working repl
+        (define (*pre)
-        (thread-cell-set! hopeless-repl lang)
+          (thread-cell-set! repl-init-thunk *error)
-        (expr-getter (λ () eof)
+          (current-module-declare-name resolved-modpath))
-         #`(current-module-declare-name
+        (define (*post)
-            (and #,path (make-resolved-module-path '#,path)))
+          (current-module-declare-name #f)
-         module-expr
+          (when path ((current-module-name-resolver) resolved-modpath))
-         #`(current-module-declare-name #f)
+          (thread-cell-set! repl-init-thunk *init))
-         (if path
+        (define (*error)
-           #`(#%app (#%app current-module-name-resolver)
+          (current-module-declare-name #f)
-                    (#%app make-resolved-module-path #,path))
+          ;; syntax error => try to require the language to get a working repl
-           void)
+          (with-handlers ([void (λ (e)
-         ;; the prompt makes it continue after an error
+                                  (raise-hopeless-exception
-         #`(#%app call-with-continuation-prompt
+                                   e "invalid language specification"))])
-                  (λ () (#%app dynamic-require #,require-spec #f)))
+            (namespace-require lang))
-         #`(#%app current-namespace (#%app module->namespace #,require-spec))
+          (unless (memq '#%top-interaction (namespace-mapped-symbols))
-         (λ () (thread-cell-set! hopeless-repl #f))))
+            (raise-hopeless-syntax-error
+             "invalid language (existing module, but no language bindings)"
+             lang)))
+        (define (*init)
+          ;; the prompt makes it continue after an error
+          (call-with-continuation-prompt
+           (λ () (dynamic-require modspec #f)))
+          (current-namespace (module->namespace modspec)))
+        ;; here's where they're all combined with the module expression
+        (expr-getter *pre module-expr *post))
+      
+      (define/override (front-end/finished-complete-program settings)
+        (cond [(thread-cell-ref repl-init-thunk)
+               => (λ (t) (thread-cell-set! repl-init-thunk #f) (t))]))
       
       ;; printer settings are just ignored here.
       (define/override (create-executable setting parent program-filename)
@@ -476,7 +461,7 @@
        (update-buttons)]))
   
   ;; transform-module : (union #f path) syntax
-  ;;   -> (values syntax[name-of-module] syntax[module])
+  ;;   -> (values syntax[name-of-module] syntax[lang-of-module] syntax[module])
   ;; = User =
   (define (transform-module filename stx)
     (define-values (mod name lang body)