134 lines
5.5 KiB
Racket
134 lines
5.5 KiB
Racket
#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))]))]))
|