From f0d231bd8105f498bc23704d0cf7776d3114a1c6 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 3 Oct 2011 13:05:19 -0400 Subject: [PATCH] working on error messages --- js-assembler/check-valid-module-source.rkt | 90 ++++++++++++++++++++++ js-assembler/package.rkt | 40 +--------- parser/path-rewriter.rkt | 5 +- whalesong-helpers.rkt | 4 +- whalesong.rkt | 23 ++++++ 5 files changed, 120 insertions(+), 42 deletions(-) create mode 100644 js-assembler/check-valid-module-source.rkt diff --git a/js-assembler/check-valid-module-source.rkt b/js-assembler/check-valid-module-source.rkt new file mode 100644 index 0000000..e3d27af --- /dev/null +++ b/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)])])) diff --git a/js-assembler/package.rkt b/js-assembler/package.rkt index c9bf6d7..f554935 100644 --- a/js-assembler/package.rkt +++ b/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 diff --git a/parser/path-rewriter.rkt b/parser/path-rewriter.rkt index abaaada..0e7df35 100644 --- a/parser/path-rewriter.rkt +++ b/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)) diff --git a/whalesong-helpers.rkt b/whalesong-helpers.rkt index 41e8978..16f4f13 100644 --- a/whalesong-helpers.rkt +++ b/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 diff --git a/whalesong.rkt b/whalesong.rkt index 05c27c6..6808de0 100755 --- a/whalesong.rkt +++ b/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)]