diff --git a/info.rkt b/info.rkt index d8efc43..7159bc5 100644 --- a/info.rkt +++ b/info.rkt @@ -13,4 +13,5 @@ (define scribblings '(("scribblings/manual.scrbl"))) (define compile-omit-paths '("tests" "examples" - "experiments")) \ No newline at end of file + "experiments" + "simulator")) \ No newline at end of file diff --git a/js-assembler/assemble.rkt b/js-assembler/assemble.rkt index 7dcf542..002906b 100644 --- a/js-assembler/assemble.rkt +++ b/js-assembler/assemble.rkt @@ -516,9 +516,9 @@ EOF (define-predicate natural? Natural) (: ensure-natural (Any -> Natural)) -(define (ensure-natural x) - (if (natural? x) - x +(define (ensure-natural n) + (if (natural? n) + n (error 'ensure-natural))) diff --git a/whalesong-helpers.rkt b/whalesong-helpers.rkt new file mode 100644 index 0000000..f444c50 --- /dev/null +++ b/whalesong-helpers.rkt @@ -0,0 +1,88 @@ +#lang racket/base + +(require racket/match + racket/file + racket/path + racket/port + "make/make-structs.rkt" + "js-assembler/package.rkt" + "resource/structs.rkt" + "logger.rkt") + +(provide (all-defined-out)) + + +(define current-verbose? (make-parameter #f)) +(define current-output-dir (make-parameter (build-path (current-directory)))) +(define current-write-resources? (make-parameter #t)) + +(define (same-file? p1 p2) + (or (equal? (normalize-path p1) (normalize-path p2)) + (bytes=? (call-with-input-file p1 port->bytes) + (call-with-input-file p2 port->bytes)))) + + +(define (turn-on-logger!) + (void (thread (lambda () + (let ([receiver + (make-log-receiver whalesong-logger + (if (current-verbose?) + 'debug + 'info))]) + (let loop () + (let ([msg (sync receiver)]) + (match msg + [(vector level msg data) + (fprintf (current-error-port)"~a: ~a\n" level msg) + (flush-output (current-error-port))])) + (loop))))))) + +(define (build f) + (turn-on-logger!) + (let-values ([(base filename dir?) + (split-path f)]) + (let ([output-filename + (build-path + (regexp-replace #rx"[.](rkt|ss)$" + (path->string filename) + ".xhtml"))]) + (unless (directory-exists? (current-output-dir)) + (make-directory* (current-output-dir))) + (parameterize ([current-on-resource + (lambda (r) + (log-info (format "Writing resource ~s" (resource-path r))) + (cond + [(file-exists? (build-path (current-output-dir) + (resource-key r))) + (cond [(same-file? (build-path (current-output-dir) + (resource-key r)) + (resource-path r)) + (void)] + [else + (error 'whalesong "Unable to write resource ~s; this will overwrite a file" + (build-path (current-output-dir) + (resource-key r)))])] + [else + (copy-file (resource-path r) + (build-path (current-output-dir) + (resource-key r)))]))]) + (call-with-output-file* (build-path (current-output-dir) output-filename) + (lambda (op) + (package-standalone-xhtml + (make-ModuleSource (build-path f)) + op)) + #:exists 'replace))))) + + + +(define (print-the-runtime) + (turn-on-logger!) + (display (get-runtime) (current-output-port))) + + + +(define (get-javascript-code filename) + (turn-on-logger!) + (display (get-standalone-code + (make-ModuleSource (build-path filename))) + (current-output-port))) diff --git a/whalesong.rkt b/whalesong.rkt index 7cfab08..0db2870 100755 --- a/whalesong.rkt +++ b/whalesong.rkt @@ -1,19 +1,16 @@ #!/usr/bin/env racket #lang racket/base -(require racket/list - racket/string - racket/match - racket/file - racket/path - racket/port - "make/make-structs.rkt" - "js-assembler/package.rkt" - "resource/structs.rkt" - "private/command.rkt" - "logger.rkt" +(require "private/command.rkt" "parameters.rkt" - raco/command-name) + "whalesong-helpers.rkt") + +;; Command line for running Whalesong. + + +;; TODO: we may want to adopt this as a raco command, as described in: +;; +;; http://docs.racket-lang.org/raco/command.html ;; Usage: @@ -34,14 +31,10 @@ -(define current-verbose? (make-parameter #f)) -(define current-resource-dir (make-parameter (build-path (current-directory)))) -(define current-write-resources? (make-parameter #t)) - (define (at-toplevel) (svn-style-command-line - #:program "whalesong" ; (short-program+command-name) + #:program "whalesong" #:argv (current-command-line-arguments) "The Whalesong command-line tool for compiling Racket to JavaScript" ["build" "build a standalone xhtml package" @@ -53,9 +46,12 @@ [("--compress-javascript") ("Compress JavaScript with Google Closure (requires Java)") (current-compress-javascript? #t)] - + [("--dest-dir") + dest-dir + ("Set destination directory (default: current-directory)") + (current-output-dir dest-dir)] #:args (path) - (do-the-build path)] + (build path)] ["get-runtime" "print the runtime library to standard output" "Prints the runtime JavaScript library that's used by Whalesong programs." #:once-each @@ -65,7 +61,7 @@ [("--compress-javascript") ("Compress JavaScript with Google Closure (requires Java)") (current-compress-javascript? #t)] - + #:args () (print-the-runtime)] ["get-javascript" "Gets just the JavaScript code and prints it to standard output" @@ -74,96 +70,14 @@ [("-v" "--verbose") ("Display verbose messages.") (current-verbose? #t)] - + [("--compress-javascript") ("Compress JavaScript with Google Closure (requires Java)") (current-compress-javascript? #t)] - - + + #:args (file) (get-javascript-code file)])) - - -(define (turn-on-logger!) - (void (thread (lambda () - (let ([receiver - (make-log-receiver whalesong-logger - (if (current-verbose?) - 'debug - 'info))]) - (let loop () - (let ([msg (sync receiver)]) - (match msg - [(vector level msg data) - (fprintf (current-error-port)"~a: ~a\n" level msg) - (flush-output (current-error-port))])) - (loop))))))) - - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (same-file? p1 p2) - (or (equal? (normalize-path p1) (normalize-path p2)) - (bytes=? (call-with-input-file p1 port->bytes) - (call-with-input-file p2 port->bytes)))) - - -(define (do-the-build f) - (turn-on-logger!) - (let-values ([(base filename dir?) - (split-path f)]) - (let ([output-filename - (build-path - (regexp-replace #rx"[.](rkt|ss)$" - (path->string filename) - ".xhtml"))]) - (parameterize ([current-on-resource - (lambda (r) - (make-directory* (current-resource-dir)) - (log-info (format "Writing resource ~s" (resource-path r))) - (cond - [(file-exists? (build-path (current-resource-dir) - (resource-key r))) - (cond [(same-file? (build-path (current-resource-dir) - (resource-key r)) - (resource-path r)) - (void)] - [else - (error 'whalesong "Unable to write resource ~s; this will overwrite a file" - (build-path (current-resource-dir) - (resource-key r)))])] - [else - (copy-file (resource-path r) - (build-path (current-resource-dir) - (resource-key r)))]))]) - (call-with-output-file* output-filename - (lambda (op) - (package-standalone-xhtml - (make-ModuleSource (build-path f)) - op)) - #:exists 'replace))))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (print-the-runtime) - (turn-on-logger!) - (display (get-runtime) (current-output-port))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (get-javascript-code filename) - (turn-on-logger!) - (display (get-standalone-code - (make-ModuleSource (build-path filename))) - (current-output-port))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (at-toplevel) diff --git a/world/kernel.js b/world/kernel.js index 969d074..edde2e1 100644 --- a/world/kernel.js +++ b/world/kernel.js @@ -134,7 +134,7 @@ var adaptWorldFunction = function(worldFunction) { // FIXME: do error trapping console.log(err); }].concat([].slice.call(arguments, 0, arguments.length - 1))); - } + }; };