* Single function for syntax errors, used in all places for uniformity

* Improved some error messages and detection
* When this function is used, it also kills the repl.

svn: r10501

collects/drscheme/private/module-language.ss

@@ -120,9 +120,7 @@
       (inherit get-reader)
       (define/override (front-end/interaction port settings)
         (if (thread-cell-ref hopeless-repl)
-            (begin (fprintf (current-error-port)
+            (raise-hopeless-syntax-error)
-                            "Module Language: ~a\n" hopeless-message)
-                   (λ x eof))
             (super front-end/interaction port settings)))
       
       (define/override (front-end/complete-program port settings)
@@ -146,7 +144,7 @@
               [(2)
                (let ([super-result (super-thunk)])
                  (if (eof-object? super-result)
-                     (raise-syntax-error 'Module\ Language hopeless-message)
+                   (raise-hopeless-syntax-error)
                    (let-values ([(name new-module)
                                  (transform-module path super-result)])
                      (set! module-name name)
@@ -155,8 +153,7 @@
                (let ([super-result (super-thunk)])
                  (if (eof-object? super-result)
                    #`(current-module-declare-name #f)
-                     (raise-syntax-error
+                   (raise-hopeless-syntax-error
-                      'module-language
                     "there can only be one expression in the definitions window"
                     super-result)))]
               [(4)
@@ -223,14 +220,24 @@
        [language-numbers (list -32768)])))
   
   (define hopeless-repl (make-thread-cell #t))
-  (define hopeless-message
+  (define (raise-hopeless-syntax-error . error-args)
-    (string-append
+    (define rep (drscheme:rep:current-rep))
-     "There must be a module in the\n"
+    (send rep set-show-no-user-evaluation-message? #f)
+    (let/ec k
+      (parameterize ([error-escape-handler k])
+        (apply raise-syntax-error '|Module Language|
+               (if (null? error-args)
+                 (list (string-append
+                        "There must be a valid module in the\n"
                         "definitions window.  Try starting your program with\n"
                         "\n"
                         "  #lang scheme\n"
                         "\n"
                         "and clicking ‘Run’."))
+                 error-args))))
+    ;; This would be nice, but it removes the text selection from the error
+    ;; (fprintf (current-error-port)"\n[Interactions disabled]")
+    (custodian-shutdown-all (send rep get-user-custodian)))
   
   ;; module-language-config-panel : panel -> (case-> (-> settings) (settings -> void))
   (define (module-language-config-panel parent)
@@ -395,16 +402,19 @@
     (syntax-case* stx (module) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
       [(module name lang . rest)
        (eq? 'module (syntax-e #'module))
-       (let ([v-name #'name])
+       (let* ([v-name #'name]
-         (when filename (check-filename-matches filename v-name stx))
+              [datum (syntax-e v-name)])
+         (unless (symbol? datum)
+           (raise-hopeless-syntax-error "bad syntax in name position of module"
+                                        stx v-name))
+         (when filename (check-filename-matches filename datum stx))
          (thread-cell-set! hopeless-repl #f)
          (values
           v-name
           ;; rewrite the module to use the scheme/base version of `module'
           (let ([module (datum->syntax #'here 'module #'form)])
             (datum->syntax stx `(,module ,#'name ,#'lang . ,#'rest) stx))))]
-      [else (raise-syntax-error
+      [else (raise-hopeless-syntax-error
-             'module-language
              (string-append "only a module expression is allowed, either\n"
                             "    #lang <language-name>\n or\n"
                             "    (module <name> <language> ...)\n")
@@ -430,20 +440,15 @@
                              filename))))))]
         [else #f])))
   
-  ;; check-filename-matches : string syntax syntax -> void
+  ;; check-filename-matches : string datum syntax -> void
-  (define (check-filename-matches filename name unexpanded-stx)
+  (define (check-filename-matches filename datum unexpanded-stx)
-    (define datum (syntax-e name))
-    (unless (symbol? datum)
-      (raise-syntax-error 'module-language
-                          "bad syntax in name position of module"
-                          unexpanded-stx name))
     (let-values ([(base name dir?) (split-path filename)])
       (let ([expected (string->symbol
                        (path->string (path-replace-suffix name #"")))])
         (unless (equal? expected datum)
-          (raise-syntax-error
+          (raise-hopeless-syntax-error
-           'module-language
+           (format
-           (format "module name doesn't match saved filename, got ~s and expected ~a"
+            "module name doesn't match saved filename, got ~s and expected ~s"
             datum
             expected)
            unexpanded-stx)))))