From 70d77bf34ab9b1d2c2a259c1624a21bd91195bcd Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 17 Jun 2011 15:20:48 -0400 Subject: [PATCH] trying to incorporate the command line parser used by PLaneT. I hate code copying, but here I am doing it all over again. --- private/command.rkt | 133 ++++++++++++++++++++++++++++++++++ private/prefix-dispatcher.rkt | 124 +++++++++++++++++++++++++++++++ scribblings/manual.scrbl | 47 +++++++++--- whalesong.rkt | 24 +++++- 4 files changed, 316 insertions(+), 12 deletions(-) create mode 100644 private/command.rkt create mode 100644 private/prefix-dispatcher.rkt diff --git a/private/command.rkt b/private/command.rkt new file mode 100644 index 0000000..93716b3 --- /dev/null +++ b/private/command.rkt @@ -0,0 +1,133 @@ +#lang racket/base +(require "prefix-dispatcher.ss" + racket/cmdline + (for-syntax racket/base)) + + +;; dyoo: this is directly copied out of planet/private/command.rkt. +;; Maybe someone should generalize this so there's no duplication... + + +(provide svn-style-command-line) + +;; implements an "svn-style" command-line interface as a wrapper around racket/cmdline. At the moment, +;; it is light on error-checking and makes choices that are somewhat specific to the PLaneT commandline +;; tool, thus its inclusion in planet/private rather than somewhere more visible. The idea is that you +;; write +#| + +(svn-style-command-line + #:program + #:argv + + [ + ... arguments just like the command-line macro takes, until ... + #:args formals + body-expr] ...) +|# + +;; This macro turns that into a command-line type of thing that implements +;; program command1 ... args ... +;; program command2 ... args ... +;; etc. +;; It provides two nonobvious features: +;; 1. It automatically includes a help feature that prints out all available subcommands +;; 2. It automatically lets users use any unambiguous prefix of any command. +;; This means that no command name may be a prefix of any other command name, because it +;; would mean there was no way to unambiguously name the shorter one. + +(define-syntax (svn-style-command-line stx) + (syntax-case stx () + [(_ #:program prog + #:argv args + general-description + [name description long-description body ... #:args formals final-expr] ...) + (with-syntax ([(n ...) (generate-temporaries #'(name ...))]) + #'(let* ([p prog] + [a args] + [n name] ... + [argslist (cond + [(list? a) a] + [(vector? a) (vector->list a)] + [else (error 'command "expected a vector or list for arguments, received ~e" a)])] + [help (λ () (display-help-message p general-description `((name description) ...)))]) + (let-values ([(the-command remainder) + (if (null? argslist) + (values "help" '()) + (values (car argslist) (cdr argslist)))]) + (prefix-case the-command + [n + (command-line + #:program (format "~a ~a" p n) + #:argv remainder + body ... + #:handlers + (λ (_ . formals) final-expr) + (pimap symbol->string 'formals) + (λ (help-string) + (for-each (λ (l) (display l) (newline)) (wrap-to-count long-description 80)) + (newline) + (display "Usage:\n") + (display help-string) + (exit)))] ... + ["help" (help)] + [else (help)]))))])) + + +;; display-help-message : string string (listof (list string string)) -> void +;; prints out the help message +(define (display-help-message prog general-description commands) + (let* ([maxlen (apply max (map (λ (p) (string-length (car p))) commands))] + [message-lines + `(,(format "Usage: ~a [option ...] " prog) + ,(format " where any unambiguous prefix can be used for a subcommand") + "" + ,@(wrap-to-count general-description 80) + "" + ,(format "For help on a particular subcommand, use '~a --help'" prog) + ,@(map (λ (command) + (let* ([padded-name (pad (car command) maxlen)] + [desc (cadr command)] + [msg (format " ~a ~a ~a" prog padded-name desc)]) + msg)) + commands))]) + (for-each (λ (line) (display line) (newline)) message-lines))) + +;; ---------------------------------------- +;; utility + +;; pad : string nat[>= string-length str] -> string +;; pads the given string up to the given length. +(define (pad str n) + (let* ([l (string-length str)] + [extra (build-string (- n l) (λ (n) #\space))]) + (string-append str extra))) + +;; pimap : (A -> B) improper-listof A -> improper-listof B +(define (pimap f pil) + (cond + [(null? pil) '()] + [(pair? pil) (cons (pimap f (car pil)) + (pimap f (cdr pil)))] + [else (f pil)])) + +;; wrap-to-count : string nat -> (listof string) +;; breaks str into substrings such that no substring +;; is longer than n characters long. Only breaks on spaces, which +;; are eaten in the process. +(define (wrap-to-count str n) + (cond + [(< (string-length str) n) (list str)] + [(regexp-match-positions #rx"\n" str 0 n) + => + (λ (posn) + (let-values ([(x y) (values (car (car posn)) (cdr (car posn)))]) + (cons (substring str 0 x) (wrap-to-count (substring str y) n))))] + [else + ;; iterate backwards from char n looking for a good break + (let loop ([k n]) + (cond + [(= k 0) (error wrap-to-count "could not break string")] + [(char=? (string-ref str k) #\space) + (cons (substring str 0 k) (wrap-to-count (substring str (add1 k)) n))] + [else (loop (sub1 k))]))])) diff --git a/private/prefix-dispatcher.rkt b/private/prefix-dispatcher.rkt new file mode 100644 index 0000000..4aa48d8 --- /dev/null +++ b/private/prefix-dispatcher.rkt @@ -0,0 +1,124 @@ +#lang racket/base + +(require (for-syntax racket/base)) +(provide (all-defined-out)) + +;; ============================================================ +;; PREFIX DISPATCHER +;; Code to determine the entry specified by an arbitrary +;; (unambiguous) prefix of a set of possible entries + +(define-struct (exn:prefix-dispatcher exn:fail) ()) +(define-struct (exn:unknown-command exn:prefix-dispatcher) (entry)) +(define-struct (exn:ambiguous-command exn:prefix-dispatcher) (possibilities)) + +;; get-prefix-dispatcher : (listof (list string A)) -> string -> A +;; gets the +(define (get-prefix-dispatcher options) + ;; implementation strategy is dumb regexp-filter. It is possible to do a trie or something fancy like that, + ;; but it would cost more to build than it would be worth, and we're only expecting lists of a few items anyway + (let ([pre/full (get-prefix-and-suffix (map car options))]) + (when pre/full + (error 'get-prefix-dispatcher "No element may be a strict prefix of any other element; given ~a and ~a" + (car pre/full) + (cadr pre/full)))) + + (λ (target) + (let* ([re (format "^~a" (regexp-quote target))] + [matches (filter (λ (x) (regexp-match re (car x))) options)]) + (cond + [(length=? matches 1) (cadr (car matches))] + [(null? matches) + (raise (make-exn:unknown-command (format "Unknown command: ~a" target) + (current-continuation-marks) + target))] + [else + (raise (make-exn:ambiguous-command (format "Ambiguous command: ~a" target) + (current-continuation-marks) + (map car matches)))])))) +;; length=? : list nat -> boolean +;; determines if the given list has the given length. Running time is proportional +;; to the shorter of the magnitude of the number or the actual length of the list +(define (length=? lst len) + (cond + [(and (null? lst) (zero? len)) #t] + [(null? lst) #f] + [(zero? len) #f] + [else (length=? (cdr lst) (sub1 len))])) + +;; get-prefix-and-suffix : (listof string) -> (list string string) | #f +;; returns a pair of strings in the given list such that the first string is a prefix of the second, +;; or #f if no such pair exists +(define (get-prefix-and-suffix strs) + (cond + [(null? strs) #f] + [else + (sorted-nelist-contains-prefix? (sort strs string (list string string) | #f +;; given a lexicographically-sorted, nonempty list of strings, returns either +;; two strings from the list such that the first is a prefix of the second, or #f if +;; no such pair exists +(define (sorted-nelist-contains-prefix? nel) + (cond + [(null? (cdr nel)) #f] + [(prefix? (car nel) (cadr nel)) + (list (car nel) (cadr nel))] + [else (sorted-nelist-contains-prefix? (cdr nel))])) + +;; prefix? : string string -> boolean +;; determins if s1 is a prefix of s2 +(define (prefix? s1 s2) + (and (<= (string-length s1) (string-length s2)) + (string=? s1 (substring s2 0 (string-length s1))))) + + +(define-syntax (prefix-case stx) + + (define (else? stx) + (syntax-case stx (else) + [(else clause) #t] + [_ #f])) + + (define (amb? stx) + (syntax-case stx (ambiguous) + [(ambiguous (name) body) #t] + [_ #f])) + + (define (extract-clause name options transformer default) + (case (length options) + [(0) default] + [(1) (transformer (car options))] + [else + (raise-syntax-error #f (format "only 1 ~a clause is allowed" name) stx (list-ref options 1))])) + + (define (else-clause->body c) + (syntax-case c (else) + [(else body) #'body] + [_ (raise-syntax-error #f "malformed else clause" stx c)])) + + (define (amb-clause->body c) + (syntax-case c (ambiguous) + [(ambiguous (name) body) #'(λ (name) body)] + [_ (raise-syntax-error #f "malformed ambiguous clause" stx c)])) + + (syntax-case stx () + [(_ elt + clause ...) + (let* ([clauses (syntax-e #'(clause ...))] + [else-clauses (filter else? clauses)] + [amb-clauses (filter amb? clauses)] + [rest (filter (λ (x) (not (or (else? x) (amb? x)))) clauses)] + [else (extract-clause "else" else-clauses else-clause->body + #'(error 'prefix-case "element ~e was not a prefix" e))] + [amb (extract-clause "ambiguous" amb-clauses amb-clause->body + #'(λ (opts) (error 'prefix-case "element matches more than one option: ~s" opts)))]) + (with-syntax ([else-clause else] + [amb-clause amb] + [((option result) ...) rest]) + #'(with-handlers ([exn:ambiguous-command? + (λ (e) (amb-clause (exn:ambiguous-command-possibilities e)))] + [exn:unknown-command? + (λ (e) else-clause)]) + (((get-prefix-dispatcher (list (list option (λ () result)) ...)) + elt)))))])) diff --git a/scribblings/manual.scrbl b/scribblings/manual.scrbl index ef12dbf..b930eca 100644 --- a/scribblings/manual.scrbl +++ b/scribblings/manual.scrbl @@ -42,7 +42,7 @@ Whalesong is a compiler from Racket to JavaScript; it takes Racket programs and translates them so that they can run stand-alone on a user's web browser. It should allow Racket programs to run with -little modification, and provide access through the foreign-function +(hopefully!) little modification, and provide access through the foreign-function interface to native JavaScript APIs. The included runtime library also includes a framework to programming the web in functional event-driven style. @@ -73,14 +73,16 @@ Prerequisites: at least @link["http://racket-lang.org/"]{Racket @subsection{Installing Whalesong} -At the time of this writing, Whalesong hasn't been deployed to -@link["http://planet.racket-lang.org"]{PLaneT} yet, so getting it +At the time of this writing, although Whalesong has been deployed to +@link["http://planet.racket-lang.org"]{PLaneT}, what's up there is probably +already out of date! You may want to get the latest sources instead +of using the version on PLaneT. Doing so requires doing a little bit of manual work. The steps are: @itemlist[ @item{Check Whalesong out of Github.} @item{Set up the PLaneT development link to your local Whalesong instance.} -@item{Run @tt{raco setup} over Whalesong to finish the installation}] +@item{Run @link["http://docs.racket-lang.org/raco/setup.html"]{@tt{raco setup}} over Whalesong to finish the installation}] We can check it out of the source repository in @link["https://github.com/"]{GitHub}; the repository can be checked out by @@ -96,6 +98,9 @@ then run this on your command line: @verbatim|{ $ planet link dyoo whalesong.plt 1 0 whalesong }| +(You may need to adjust the @tt{1} and @tt{0} major/minor numbers a bit to be larger +than the latest version that's on PLaneT at the time.) + Finally, we need to set up Whalesong with @tt{raco setup}. @@ -123,9 +128,10 @@ and if this does appear, then Whalesong should be installed successfully. Let's try making a simple, standalone executable. At the moment, the program must be written in the base language of @racket[(planet -dyoo/whalesong)]. This restriction currently prevents arbitrary -racket/base programs from compiling, and the developers will be working -to remove this restriction. +dyoo/whalesong)]. This restriction unfortunately prevents arbitrary +@racketmodname[racket/base] programs from compiling at the moment; +the developers (namely, dyoo) will be working to remove this +restriction as quickly as possible. Write a @filepath{hello.rkt} with the following content @@ -135,13 +141,13 @@ Write a @filepath{hello.rkt} with the following content (display "hello world") (newline) }} -This program can be executed in Racket, +This program is a regular Racket program, and can be executed normally, @verbatim|{ $ racket hello.rkt hello world $ }| -and it can also be packaged with @filepath{whalesong}. +However, it can also be packaged with @filepath{whalesong}. @verbatim|{ $ whalesong build hello.rkt @@ -206,6 +212,11 @@ web browser, we should see a pale, green page with some output. @section{Extended example} @;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(This example needs to use modules. It should also show how we can use the +other command-line options to compress the javascript, and how to +use @tt{get-javascript} and @tt{get-runtime}, to allow the user to +build a customized html file.) + @@ -227,6 +238,24 @@ we can use.) (We also need an example that shows how to use the get-javascript and get-runtime commands to do something interesting...) +@subsection{@tt{build}} + +@subsection{@tt{get-runtime}} + +@subsection{@tt{get-javascript}} + + + +@section{The JavaScript API} + +(This needs to describe what hooks we've got from the JavaScript side of things. + +In particular, we need to talk about the plt namespace constructed by the runtime, +and the major, external bindings, like @tt{plt.runtime.invokeMains}) + + + + @;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @section{Internals} diff --git a/whalesong.rkt b/whalesong.rkt index b026a5a..7d39310 100755 --- a/whalesong.rkt +++ b/whalesong.rkt @@ -4,7 +4,9 @@ (require racket/list racket/string "make/make-structs.rkt" - "js-assembler/package.rkt") + "js-assembler/package.rkt" + "private/command.rkt" + raco/command-name) ;; Usage: @@ -47,8 +49,24 @@ (string-join command-names ", "))) (define (at-toplevel) - (define args (vector->list (current-command-line-arguments))) - (cond [(empty? args) + (svn-style-command-line + #:program (short-program+command-name) + #:argv (current-command-line-arguments) + "The Whalesong command-line tool for compiling Racket to JavaScript" + ["build" "build a standalone xhtml package" + "Builds a Racket program and its required dependencies into a standalone .xhtml file." + #:args paths + (do-the-build paths)] + ["get-runtime" "print the runtime library to standard output" + "Prints the runtime JavaScript library that's used by Whalesong programs." + #:args () + (print-the-runtime)] + ["get-javascript" "Gets just the JavaScript code and prints it to standard output" + "Builds a racket program into JavaScript. The outputted file depends on the runtime." + #:args (file) + (get-javascript-code file)]) + #;(define args (vector->list (current-command-line-arguments))) + #;(cond [(empty? args) (print-expected-command)] [else (cond