conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

command-line now prints detailed message on "--help"

This commit is contained in:
Abdulaziz Ghuloum 2008-12-29 00:38:50 -05:00
parent 120a6dab52
commit e72effdb73
1 changed files with 146 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
lab/command-line.ss
View File

@ -11,23 +11,12 @@
(import (ikarus))
(define (dispatch-opts arguments data* proc*)
(define-condition-type &help &condition
make-help-condition help-condition?
(extended? help-extended?))
(define-condition-type &unmatched &condition
make-unmatched-condition unmatched-condition?)
(define (help x)
(raise (make-help-condition x)))
(define (unmatched)
(raise (make-unmatched-condition)))
(define (print-usage detailed?)
(define-record-type f (fields id char type def))
(define (mkf x id)
(make-f id (car x) (cadr x) (cddr x)))
(define (get type ls)
(let-values ([(ls _) (partition (lambda (x) (eq? (f-type x) type)) ls)])
ls))
(filter (lambda (x) (eq? (f-type x) type)) ls))
(define (fmt-req x)
(format " -~a <~a>" (f-char x) (f-id x)))
(define (fmt-req-no-value x)
@ -74,7 +63,8 @@
(lambda (x)
(printf " -~a defaults to ~a\n" (f-char x)
(f-def x)))
def*))))))
def*)))
(newline))))
(printf "\nUsage:\n")
(for-each (lambda (x) (apply print-usage-line x)) data*)
(print-usage-line "Display this help message"
@ -84,19 +74,33 @@
#f
#f)
#f)
(define (arguments-match)
(define-condition-type &help &condition
make-help-condition help-condition?
(extended? help-extended?))
(define-condition-type &unmatched &condition
make-unmatched-condition unmatched-condition?)
(define (help x)
(raise (make-help-condition x)))
(define (unmatched)
(raise (make-unmatched-condition)))
(define (option? x)
(or (equal? x "--help") ;;; hack
(and (string? x)
(>= (string-length x) 2)
(char=? (string-ref x 0) #\-)
(not (char=? (string-ref x 1) #\-))))
(not (char=? (string-ref x 1) #\-)))))
(define (fill-char-opt c ls fields)
;;; field = [c required ]
;;; | [c flag . default]
;;; | [c zero-plus . list]
;;; | [c one-plus . list]
;;; | [c optional . str]
;;; field = [c required0 . _] ; requires 0 args
;;; | [c required1 . _] ; requires 1 arg
;;; | [c flag . default] ; toggles default to #t
;;; | [c zero-plus . reversed-list]
;;; | [c one-plus . reversed-list]
;;; | [c optional . default] ; overridden by value
;;; | [c ok . value] ; already used, not on input
(let f ([fields fields])
(when (null? fields) (unmatched))
(let ([field (car fields)])
@ -121,6 +125,7 @@
(values (cons field fields) ls))))))
(define (fill-option a ls fields)
(when (string=? a "--help") (help #t))
(if (= (string-length a) 2)
(let ([char (string-ref a 1)])
(when (char=? char #\h) (help #f))
@ -199,9 +204,9 @@
[(unmatched-condition? con)
(f (cdr data*) (cdr proc*))])
(apply (car proc*) (apply match (car data*))))))))
(arguments-match))
(define-syntax parse-command-line
(define-syntax command-line-interface
(lambda (stx)
(define (parse-format stx)
(define (err str x)
@ -229,7 +234,7 @@
(free-identifier=? x #'(... ...))))
(define (id? x)
(and (identifier? x) (not (dots? x))))
(define (parse-command-line ls)
(define (command-line-interface ls)
(define (str? x)
(let ([d (syntax->datum x)])
(and (string? d) (not (string=? d "--")))))
@ -280,7 +285,7 @@
(f (car ls) (cdr ls)))))
ls))
(let-values ([(prog opt-strs opt-ids args args-rest dash-rest)
(parse-command-line stx)])
(command-line-interface stx)])
(list (get-fmls prog opt-ids args args-rest dash-rest)
opt-strs opt-ids args args-rest dash-rest)))
(define (parse-clause stx)
@ -312,7 +317,7 @@
(printf "OK\n")))]))
(define (command1 ls)
(parse-command-line ls
(command-line-interface ls
[(p) "Help0" (list 0 p)]
[(p p1) "Help1" (list 1 p p1)]
[(p p1 p2) "Help2" (list 2 p p1 p2)]
@ -325,7 +330,7 @@
(test command1 ("./prog" "p1" "p2" "p3" "p4") #f)
(define (command2 ls)
(parse-command-line ls
(command-line-interface ls
[(p p1 p2 p3) "Help3" (list 3 p p1 p2 p3)]
[(p p1 p2 ps ...) "Help2" (list 2 p p1 p2 ps)]
[(p p1 ps ...) "Help1" (list 1 p p1 ps)]
@ -339,7 +344,7 @@
(test command2 ("./prog" "-h") #f)
(define (command3 ls)
(parse-command-line ls
(command-line-interface ls
[(p "-X" xopt "-Y" yopt) (list 'xy p xopt yopt)]
[(p "-X" xopt) (list 'x p xopt)]
[(p "-Y" yopt) (list 'y p yopt)]))
@ -352,7 +357,7 @@
(test command3 ("./prog" "-h") #f)
(define (command4 ls)
(parse-command-line ls
(command-line-interface ls
[(p "-X?" xopt "-Y?" yopt) (list p xopt yopt)]
[(p "-X?" xopt rest ...) (list p xopt rest)]))
@ -366,7 +371,7 @@
(test command4 ("./prog" "-h") #f)
(define (command5 ls)
(parse-command-line ls
(command-line-interface ls
[(p "-X=default" xopt) (list p xopt)]))
(test command5 ("p") ("p" "default"))
@ -374,7 +379,7 @@
(test command5 ("./prog" "-h") #f)
(define (command6 ls)
(parse-command-line ls
(command-line-interface ls
[(p "-X*" xopts) (list p xopts)]
[(p "-X*" xopts "-Y*" yopts) (list p xopts yopts)]))
@ -388,7 +393,7 @@
(test command6 ("./prog" "-h") #f)
(define (command7 ls)
(parse-command-line ls
(command-line-interface ls
[(p "-X+" xopts) (list p xopts)]
[(p "-X*" xopts "-Y+" yopts) (list p xopts yopts)]))
@ -402,17 +407,18 @@
(test command7 ("./prog" "-h") #f)
(define (command8 ls)
(parse-command-line ls
(command-line-interface ls
[(p "-Q=foobar" q "-R=blabla" r "-X?" xopts "-Y?" yopt "-L*" libs "-f" file file* ...)
"Does something nice"
#t]))
(test command8 ("./prog") #f)
(test command8 ("./prog" "-h") #f)
(test command8 ("./prog" "--help") #f)
(define (ls-command ls)
(parse-command-line ls
(command-line-interface ls
[(ls "-A?" A "-B?" B "-C?" C "-F?" F "-G?" G "-H?" H "-L?" L
"-P?" P "-R?" R "-S?" S "-T?" T "-W?" W "-Z?" Z "-a?" a
"-b?" b "-c?" c "-d?" d "-e?" e "-f?" f "-g?" g "-i?" i