135 lines
5.4 KiB
Racket
135 lines
5.4 KiB
Racket
#lang racket/base
|
|
|
|
(provide check-valid-module-source
|
|
[struct-out exn:invalid-module-source])
|
|
|
|
(require syntax/kerncase
|
|
syntax/modresolve
|
|
racket/path
|
|
"../parameters.rkt"
|
|
"../parser/path-rewriter.rkt")
|
|
|
|
|
|
(struct exn:invalid-module-source exn:fail ())
|
|
|
|
|
|
(define (abort-abort #:reason (reason "Invalid module source"))
|
|
(fprintf (current-report-port) "Aborting compilation.\n")
|
|
(raise (exn:invalid-module-source reason
|
|
(current-continuation-marks))))
|
|
|
|
|
|
(define ns (make-base-namespace))
|
|
|
|
|
|
|
|
|
|
(define (looks-like-old-moby-or-js-vm? module-source-path)
|
|
(or (call-with-input-file* module-source-path
|
|
(lambda (ip) (regexp-match #px"^\\s*#lang\\s+planet\\s+dyoo/moby" ip)))
|
|
(call-with-input-file* module-source-path
|
|
(lambda (ip) (regexp-match #px"^\\s*#lang\\s+planet\\s+dyoo/js-vm" ip)))))
|
|
|
|
|
|
|
|
|
|
(define (check-valid-module-source module-source-path)
|
|
;; Check that the file exists.
|
|
(unless (file-exists? module-source-path)
|
|
(fprintf (current-report-port) "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
|
|
(fprintf (current-report-port)
|
|
"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)])
|
|
|
|
|
|
;; Does it look like something out of moby or js-vm? Abort early, because if we don't do
|
|
;; this up front, Racket will try to install the deprecated module, and that's bad.
|
|
(when (looks-like-old-moby-or-js-vm? module-source-path)
|
|
(fprintf (current-report-port) "ERROR: The program in ~e appears to be written using the deprecated project js-vm or Moby.\n\nPlease change the lang line to:\n\n #lang planet dyoo/whalesong\n\ninstead.\n"
|
|
module-source-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.
|
|
(fprintf (current-report-port) "ERROR: Can't read a Racket module from ~e. The file may be ill-formed or be written in a language that Whalesong doesn't recognize.\n"
|
|
module-source-path)
|
|
(fprintf (current-report-port) "\nFor reference, the error message produced when trying to read ~e is:\n\n" module-source-path)
|
|
(fprintf (current-report-port) "~a\n" (exn-message exn))
|
|
(abort-abort))])
|
|
(parameterize ([read-accept-reader #t]
|
|
[read-accept-lang #t])
|
|
(call-with-input-file* module-source-path
|
|
(lambda (ip)
|
|
(port-count-lines! ip)
|
|
(read-syntax module-source-path ip))))))
|
|
|
|
(define relative-language-stx
|
|
(kernel-syntax-case stx #t
|
|
[(module name language body ...)
|
|
#'language]
|
|
[else
|
|
(fprintf (current-report-port) "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)]))
|
|
|
|
|
|
;; 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
|
|
(fprintf (current-report-port) "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)])])
|
|
|
|
|
|
;; Once we know that the module is in a language we allow, we
|
|
;; check that the file compiles.
|
|
(with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(fprintf (current-report-port) "ERROR: the racket module ~e raises a compile-time error during compilation." module-source-path)
|
|
(fprintf (current-report-port) "\n\nFor reference, the error message produced during compilation is the following:\n\n")
|
|
(fprintf (current-report-port) "~a\n" (exn-message exn))
|
|
(newline (current-report-port))
|
|
(abort-abort))])
|
|
(parameterize ([current-namespace ns]
|
|
[current-load-relative-directory
|
|
(path-only module-source-path)]
|
|
[current-directory
|
|
(path-only module-source-path)])
|
|
(compile stx)))) |