suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

trying to incorporate the command line parser used by PLaneT. I hate code copying, but here I am doing it all over again.

Browse Source
This commit is contained in:
Danny Yoo 2011-06-17 15:20:48 -04:00
parent f59f9d7500
commit 70d77bf34a
4 changed files with 316 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

133
private/command.rkt Normal file
View File

@ -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 <name-of-the-program-string>
#:argv <argument vector, generally (current-command-line-arguments)>
<program-general-description string>
[<command1> <brief-help-string> <long-help-description-string>
... 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 <subcommand> [option ...] <arg ...>" 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 <subcommand> --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))]))]))

124
private/prefix-dispatcher.rkt Normal file
View File

@ -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<?))]))
;; sorted-nelist-contains-prefix? : (nonempty-listof 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)))))]))

47
scribblings/manual.scrbl
View File

@ -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}

24
whalesong.rkt
View File

@ -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