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

svn-style planet command interface

Browse Source 
svn: r9306
This commit is contained in:
Jacob Matthews 2008-04-14 22:31:27 +00:00
parent 83ce4d4754
commit 5a09a11288
3 changed files with 267 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

163
collects/planet/planet.ss
View File

@ -9,8 +9,7 @@ PLANNED FEATURES:
that if it's a tool it won't start w/ DrScheme, etc)
4. Examine and alter linkage table
|#
(require mzlib/cmdline
mzlib/string
(require mzlib/string
mzlib/file
(only mzlib/list sort)
net/url
@ -18,109 +17,89 @@ PLANNED FEATURES:
"config.ss"
"private/planet-shared.ss"
"private/command.ss"
"resolver.ss" ;; the code I need should be pulled out into a common library
"util.ss")
(define actions '())
(define erase? (make-parameter #f))
(define displayer (make-parameter (λ () (show-installed-packages))))
(define (start)
(make-directory* (PLANET-DIR))
(make-directory* (CACHE-DIR))
(command-line
"planet"
(current-command-line-arguments)
(once-each
(("--force")
""
"Used in conjunction with --create-package; force a package to be"
"created even its info.ss file contains errors."
(force-package-building? #t)))
(once-any
(("-f" "--file")
plt-file owner maj min
""
"Install local file <plt-file> as though it had been downloaded from"
"the planet server. The installed package has path"
" (planet (<owner> <plt-file's filename> <maj> <min>))"
(set! actions (cons (lambda () (install-plt-file plt-file owner maj min)) actions)))
(("-c" "--create-archive")
path
""
"Create a PLaneT archive in the current directory"
"whose contents are the directory <path>"
(set! actions (cons (lambda () (do-archive path)) actions)))
(("-i" "--install")
owner pkg maj min
""
"Download and install the package"
" (require (planet \"file.ss\" (<owner> <pkg> <maj> <min>)))"
"would install"
(set! actions (cons (lambda () (download/install owner pkg maj min)) actions)))
(("-d" "--download")
owner pkg maj min
""
"Download the given package file without installing it"
(set! actions (cons (lambda () (download/no-install owner pkg maj min)) actions)))
(("-r" "--remove")
owner pkg maj min
""
"Remove the specified package from the local cache"
(set! actions (cons (lambda () (remove owner pkg maj min)) actions)))
(("-e" "--erase")
owner pkg maj min
""
"Erase the specified package, removing it as -r does and "
"eliminating the package's distribution file from the "
"uninstalled-package cache"
(set! actions (cons (lambda () (erase owner pkg maj min)) actions)))
(("-U" "--unlink-all")
""
"Clear the linkage table, unlinking all packages and allowing upgrades"
(set! actions (cons unlink-all actions)))
(("-p" "--packages")
""
"List the packages installed in the local cache"
(set! actions (cons show-installed-packages actions)))
(("-l" "--linkage")
""
"List the current linkage table"
(set! actions (cons show-linkage actions)))
(("-a" "--associate")
owner pkg maj min path
""
"Create a development link between the specified package specifier "
"and the specified directory name"
(set! actions (cons (lambda () (add-hard-link-cmd owner pkg maj min path)) actions)))
(("-u" "--unassociate")
owner pkg maj min
""
"Remove any development link associated with the specified package"
(set! actions (cons (lambda () (remove-hard-link-cmd owner pkg maj min)) actions)))
(("--url")
owner pkg maj min
"Get a URL for the given package"
(set! actions (cons (lambda () (get-download-url owner pkg maj min)) actions)))
(("--unpack")
plt-file target
"Unpack the contents of the given package into the given directory without installing"
(set! actions (cons (lambda () (do-unpack plt-file target)) actions)))
(svn-style-command-line
#:program "planet"
#:argv (current-command-line-arguments)
"PLT Scheme PLaneT command-line tool. Provides commands to help you manipulate your local planet cache."
["create" "create a PLaneT archive from a directory"
'("" "Create a PLaneT archive in the current directory whose contents are the directory <path>.")
#:once-each
[("-f" "--force") "force a package to be created even its info.ss file contains errors."
(force-package-building? #t)]
#:args (path)
(do-archive path)]
["install" "download and install a given package"
'("" "Download and install the package that"
" (require (planet \"file.ss\" (<owner> <pkg> <maj> <min>)))"
"would install")
#:args (owner pkg maj min)
(download/install owner pkg maj min)]
["remove" "remove the specified package from the local cache"
'("" "Remove the specified package from the local cache, optionally also removing its distribution file")
#:once-each
[("-e" "--erase") "also remove the package's distribution file from the uninstalled-package cache"
(erase? #t)]
#:args (owner pkg maj min)
((if (erase?) erase remove) owner pkg maj min)]
["show" "list the packages installed in the local cache"
'("" "List the packages installed in the local cache")
#:once-any
[("-p" "--packages") "show packages only (default)" (displayer show-installed-packages)]
[("-l" "--linkage") "show linkage table only" (displayer show-linkage)]
[("-a" "--all") "show packages and linkage" (displayer (λ () (show-installed-packages) (newline) (show-linkage)))]
#:args ()
((displayer))]
["clearlinks" "clear the linkage table, unlinking all packages and allowing upgrades"
'("" "Clear the linkage table, unlinking all packages and allowing upgrades")
#:args ()
(unlink-all)]
["fileinject" "install a local file to the planet cache"
'("" "Install local file <plt-file> into the planet cache as though it had been downloaded from the planet server. The installed package has path"
" (planet (<owner> <plt-file's filename> <maj> <min>))")
#:args (owner plt-file maj min)
(install-plt-file plt-file owner maj min)]
["link" "create a development link"
'("" "Create a development link between the specified package specifier and the specified directory name")
#:args (owner pkg maj min path)
(add-hard-link-cmd owner pkg maj min path)]
["unlink" "remove development link associated with the given package"
'("" "Remove development link associated with the given package")
#:args (owner pkg maj min)
(remove-hard-link-cmd owner pkg maj min)]
["fetch" "download a package file without installing it"
'("" "Download the given package file without installing it")
#:args (owner pkg maj min)
(download/no-install owner pkg maj min)]
["url" "get a URL for the given package"
'("" "Get a URL for the given package."
"This is not necessary for normal use of planet, but may be helpful in some circumstances for retrieving packages.")
#:args (owner pkg maj min)
(get-download-url owner pkg maj min)]
["open" "unpack the contents of the given package"
'("" "Unpack the contents of the given package into the given directory without installing."
"This command is not necessary for normal use of planet. It is intended to allow you to inspect package contents"
"offline without needing to install the package.")
#:args (plt-file target)
(do-unpack plt-file target)]
;; unimplemented so far:
#;(("-u" "--unlink")
;; unimplemented so far:
#;(("-u" "--unlink")
module
"Remove all linkage the given module has, forcing it to upgrade"
...)))
(cond
; make showing the installed packages the default thing to do.
[(null? actions) (show-installed-packages)]
[else (for-each (lambda (f) (f)) actions)]))
;; ============================================================
;; FEATURE IMPLEMENTATIONS

107
collects/planet/private/command.ss Normal file
View File

@ -0,0 +1,107 @@
#lang scheme/base
(require "prefix-dispatcher.ss"
scheme/cmdline
(for-syntax scheme/base))
(provide svn-style-command-line)
;; implements an "svn-style" command-line interface as a wrapper around scheme/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-listof-strings>
... 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)) long-description)
(newline)
(display "Usage:\n")
(display help-string)
(exit)))] ...
["help" (help)]
[else (help)]))))]))
;; display-help-message : 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))])
(begin
(printf "Usage: ~a <subcommand> [option ...] <arg ...>\n" prog)
(printf "[note: you can name a subcommand by typing any unambiguous prefix of it.]\n\n")
(display general-description)
(newline)
(newline)
(display "For help on a particular subcommand, type 'planet <subcommand> --help'\n")
(display "Available subcommands:\n")
(for-each (λ (command)
(let ([padded-name (pad (car command) maxlen)]
[desc (cadr command)])
(printf " ~a ~a\n" padded-name desc)))
commands))))
;; ----------------------------------------
;; 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)]))

89
collects/planet/private/prefix-dispatcher.ss Normal file
View File

@ -0,0 +1,89 @@
#lang scheme/base
(require (for-syntax scheme/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)
(syntax-case stx (else)
[(_ elt
[option result] ...
[else alternative])
#'(with-handlers ([exn:prefix-dispatcher? (λ (e) alternative)])
(((get-prefix-dispatcher (list (list option (λ () result)) ...))
elt)))]
[(_ elt [option result] ...)
#'(let ([e elt]) (prefix-case e [option result] ... [else (error 'prefix-case "element ~e was not a prefix" e)]))]))