working on error messages

js-assembler/check-valid-module-source.rkt

@@ -0,0 +1,90 @@
+#lang racket/base
+
+(provide check-valid-module-source)
+
+(require syntax/kerncase
+         syntax/modresolve
+         racket/path
+         "../parameters.rkt"
+         "../parser/path-rewriter.rkt")
+
+
+(define (abort-abort)
+  (printf "Aborting compilation.\n")
+  (exit))
+
+
+
+(define (check-valid-module-source module-source-path)
+  ;; Check that the file exists.
+  (unless (file-exists? module-source-path)
+    (printf "ERROR: Can't read a Racket module from ~e.  The file does not appear to exist.\n"
+            module-source-path)
+    (abort-abort))
+
+
+  ;; Is the file one that we know how to symbolically resolve?
+  (cond [(rewrite-path module-source-path)
+         (void)]
+        [else
+         (printf "ERROR: The file ~e appears to be outside the root package directory ~e.  You may need to use --root-dir.\n"
+                 module-source-path
+                 (current-root-path))
+         (abort-abort)])
+                 
+  
+
+  ;; Check that it looks like a module.
+  (define stx
+    (with-handlers ([exn:fail?
+                     (lambda (exn)
+                       ;; We can't even get the bytecode for the file.
+                       ;; Fail immediately.
+                       (printf "ERROR: Can't read a Racket module from ~e.  The file may be ill-formed.\n"
+                               module-source-path)
+                       (printf "\nFor reference, the error message produced when trying to read ~e is:\n\n" module-source-path)
+                       (printf "~a\n" (exn-message exn))
+                       (abort-abort))])
+      (parameterize ([read-accept-reader #t])
+        (call-with-input-file* module-source-path
+                               (lambda (ip)
+                                 (read-syntax #f ip))))))
+
+  (define relative-language-stx
+    (kernel-syntax-case stx #t
+      [(module name language body ...)
+       #'language]
+      [else
+       (printf "ERROR: Can't read a Racket module from ~e.  The file exists, but does not appear to be a Racket module.\n"
+               module-source-path)
+       (abort-abort)]))
+
+
+  ;; Finally, check that the module is written in a language that we allow.
+  (define resolved-language-path
+    (resolve-module-path (syntax->datum relative-language-stx)
+                         module-source-path))
+  (cond
+   [(eq? resolved-language-path '#%kernel)
+    (void)]
+   [(path? resolved-language-path)
+    (define normalized-resolved-language-path
+      (normalize-path resolved-language-path))
+
+    (cond
+     [(within-root-path? normalized-resolved-language-path)
+      (void)]
+
+     [(within-whalesong-path? normalized-resolved-language-path)
+      (void)]
+
+     [else
+      ;; Something bad is about to happen, as the module is written
+      ;; in a language that we, most likely, can't compile.
+      ;;
+      ;; Let's see if we can provide a good error message here
+      (printf "ERROR: The file ~e is a Racket module, but is written in the language ~a [~e], which Whalesong does not know how to compile.\n"
+              module-source-path
+              (syntax->datum relative-language-stx)
+              normalized-resolved-language-path)
+      (abort-abort)])]))

js-assembler/package.rkt

@@ -12,6 +12,7 @@
          "../resource/structs.rkt"
 	 "../promise.rkt"
          "../get-module-bytecode.rkt"
+         "check-valid-module-source.rkt"
          (prefix-in hash-cache: "hash-cache.rkt")
          racket/match
          racket/list
@@ -22,6 +23,7 @@
          racket/port
          syntax/modread
          syntax/kerncase
+         syntax/modresolve
          (prefix-in query: "../lang/js/query.rkt")
          (prefix-in resource-query: "../resource/query.rkt")
          (prefix-in runtime: "get-runtime.rkt")
@@ -110,44 +112,6 @@
    [(UninterpretedSource? src)
     (void)]))
 
-(define (check-valid-module-source module-source-path)
-  ;; Check that the file exists.
-  (unless (file-exists? module-source-path)
-    (printf "Can't read a Racket module from ~e.  The file does not appear to exist.\n"
-            module-source-path)
-    (error 'check-valid-module-source))
-
-  ;; Check that it looks like a module.
-  (define stx
-    (with-handlers ([exn:fail?
-                     (lambda (exn)
-                       ;; We can't even get the bytecode for the file.
-                       ;; Fail immediately.
-                       (printf "Can't read a Racket module from ~e.  The file may be ill-formed.\n"
-                               module-source-path)
-                       (printf "\nFor reference, the error message produced when trying to read ~e is:\n\n" module-source-path)
-                       (printf "~a\n" (exn-message exn))
-                       (error 'check-valid-module-source))])
-      (parameterize ([read-accept-reader #t])
-        (call-with-input-file* module-source-path
-                               (lambda (ip)
-                                 (read-syntax #f ip))))))
-
-  (define language-stx
-    (kernel-syntax-case stx #t
-      [(module name language body ...)
-       #'language]
-      [else
-       (printf "Can't read a Racket module from ~e.\nThe file exists, but does not appear to be a Racket module.\n"
-               module-source-path)
-       (error 'check-valid-module-source)]))
-
-  ;; Check that the module is written in a language that we allow.
-  (displayln language-stx)
-  (void))
-
-   
-
 
 
 ;; source-is-javascript-module?: Source -> boolean

parser/path-rewriter.rkt

@@ -10,6 +10,7 @@
 
 
 (provide/contract [rewrite-path (complete-path? . -> . (or/c symbol? false/c))]
+                  [within-root-path? (complete-path? . -> . boolean?)]
                   [within-whalesong-path? (complete-path? . -> . boolean?)])
 
 
@@ -42,7 +43,7 @@
        (string-append "collects/"
                       (path->string
                        (find-relative-path collects-path a-path))))]
-     [(within-root? a-path)
+     [(within-root-path? a-path)
       (string->symbol
        (string-append "root/"
                       (path->string
@@ -53,7 +54,7 @@
 
        
 
-(define (within-root? a-path)
+(define (within-root-path? a-path)
   (within? (current-root-path) a-path))
 
 

whalesong-helpers.rkt

@@ -87,7 +87,7 @@
                                               (resource-path r))
                                   (void)]
                                  [else
-                                  (error 'whalesong "Unable to write resource ~s; this will overwrite a file"
+                                  (error 'whalesong "Unable to write resource ~s; this will overwrite a file that already exists."
                                          (build-path (current-output-dir)
                                                      (resource-key r)))])]
                           [else
@@ -141,7 +141,7 @@
                                           (resource-key r))))
              (void)]
             [else
-             (error 'whalesong "Unable to write resource ~s; this will overwrite a file"
+             (error 'whalesong "Unable to write resource ~s; this will overwrite a file that already exists."
                     (build-path (current-output-dir)
                                 (resource-key r)))])]
      [else

whalesong.rkt

@@ -5,6 +5,7 @@
          "parameters.rkt"
          "whalesong-helpers.rkt"
          profile profile/render-text
+         racket/path
          (for-syntax racket/base))
 
 ;; Command line for running Whalesong.
@@ -49,6 +50,15 @@
            expr))]))
 
 
+(define (set-root-path! root-path)
+  (unless (directory-exists? root-path)
+    (printf "ERROR: root path ~a does not appear to exist.\n" root-path)
+    (printf "Aborting compilation.\n")
+    (exit))
+  (current-root-path (normalize-path root-path)))
+
+
+
 (define (at-toplevel)
   (svn-style-command-line
    #:program "whalesong"
@@ -78,6 +88,10 @@
             [("--split-modules")
              ("Write one file per module")
              (current-one-module-per-file? #t)]
+            [("--root-dir")
+             root-path
+             ("Set the root package path (default: current-directory)")
+             (set-root-path! root-path)]
             [("--dest-dir")
              dest-dir
              ("Set destination directory (default: current-directory)")
@@ -110,6 +124,10 @@
                   [("--without-cache")
                    ("Turn off the internal compilation cache")
                    (current-with-cache? #f)]
+                  [("--root-dir")
+                   root-path
+                   ("Set the root package path (default: current-directory)")
+                   (set-root-path! root-path)]
                   [("--compress-javascript")
                    ("Compress JavaScript with Google Closure (requires Java)")
                    (current-compress-javascript? #t)]
@@ -135,6 +153,11 @@
                      [("--without-cache")
                       ("Turn off the internal compilation cache")
                       (current-with-cache? #f)]
+                     [("--root-dir")
+                      root-path
+                      ("Set the root package path (default: current-directory)")
+                      (set-root-path! root-path)]
+                     
                      [("--compress-javascript")
                       ("Compress JavaScript with Google Closure (requires Java)")
                       (current-compress-javascript? #t)]