de-cpsed command-line pattern-matching code.
This commit is contained in:
Abdulaziz Ghuloum
parent
75aaa0b235
commit
120a6dab52
|
|
@ -11,7 +11,17 @@
|
||||||
(import (ikarus))
|
(import (ikarus))
|
||||||
|
|
||||||
(define (dispatch-opts arguments data* proc*)
|
(define (dispatch-opts arguments data* proc*)
|
||||||
(define (print-usage)
|
(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-record-type f (fields id char type def))
|
||||||
(define (mkf x id)
|
(define (mkf x id)
|
||||||
(make-f id (car x) (cadr x) (cddr x)))
|
(make-f id (car x) (cadr x) (cddr x)))
|
||||||
|
|
@ -27,44 +37,45 @@
|
||||||
(format " [-~a <~a>]~a" (f-char x) (f-id x) c)))
|
(format " [-~a <~a>]~a" (f-char x) (f-id x) c)))
|
||||||
(define (fmt-<> x)
|
(define (fmt-<> x)
|
||||||
(format " <~a>" x))
|
(format " <~a>" x))
|
||||||
(define (print-usage-line help fields field-ids args args-rest dash-rest)
|
(define (synopsis f* args args-rest)
|
||||||
(let ([f* (map mkf fields field-ids)])
|
|
||||||
(let ([opt* (get 'optional f*)]
|
(let ([opt* (get 'optional f*)]
|
||||||
[flag* (get 'flag f*)]
|
[flag* (get 'flag f*)]
|
||||||
[req0* (get 'required0 f*)]
|
[req0* (get 'required0 f*)]
|
||||||
[req1* (get 'required1 f*)]
|
[req1* (get 'required1 f*)]
|
||||||
[z0* (get 'zero-plus f*)]
|
[z0* (get 'zero-plus f*)]
|
||||||
[z1* (get 'one-plus f*)])
|
[z1* (get 'one-plus f*)])
|
||||||
(display
|
(let-values ([(p e) (open-string-output-port)])
|
||||||
(string-append
|
(display (car arguments) p)
|
||||||
"\n "
|
(display (apply string-append (map fmt-req-no-value req0*)) p)
|
||||||
(car arguments)
|
(unless (null? flag*)
|
||||||
(apply string-append (map fmt-req-no-value req0*))
|
(fprintf p " [-~a]"
|
||||||
(if (null? flag*)
|
|
||||||
""
|
|
||||||
(format " [-~a]"
|
|
||||||
(list->string (map f-char flag*))))
|
(list->string (map f-char flag*))))
|
||||||
(apply string-append (map (fmt-z "") opt*))
|
(display (apply string-append (map (fmt-z "") opt*)) p)
|
||||||
(apply string-append (map (fmt-z "*") z0*))
|
(display (apply string-append (map (fmt-z "*") z0*)) p)
|
||||||
(apply string-append (map (fmt-z "+") z1*))
|
(display (apply string-append (map (fmt-z "+") z1*)) p)
|
||||||
(apply string-append (map fmt-req req1*))
|
(display (apply string-append (map fmt-req req1*)) p)
|
||||||
(apply string-append (map fmt-<> args))
|
(display (apply string-append (map fmt-<> args)) p)
|
||||||
(if args-rest
|
(when args-rest
|
||||||
(string-append (fmt-<> args-rest) " ...")
|
(display (string-append (fmt-<> args-rest) " ...") p))
|
||||||
"")
|
(e))))
|
||||||
"\n"))
|
(define (print-usage-line help fields field-ids args args-rest dash-rest)
|
||||||
|
(let ([f* (map mkf fields field-ids)])
|
||||||
|
(display " ")
|
||||||
|
(display (synopsis f* args args-rest))
|
||||||
|
(newline)
|
||||||
(unless (string=? help "")
|
(unless (string=? help "")
|
||||||
(printf "\n ~a\n" help))
|
(display " ")
|
||||||
(let ([def* (filter f-def opt*)])
|
(display help)
|
||||||
|
(newline))
|
||||||
|
(when detailed?
|
||||||
|
(let ([def* (filter f-def (get 'optional f*))])
|
||||||
(unless (null? def*)
|
(unless (null? def*)
|
||||||
(printf "\n")
|
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(printf " -~a defaults to ~a\n" (f-char x)
|
(printf " -~a defaults to ~a\n" (f-char x)
|
||||||
(f-def x)))
|
(f-def x)))
|
||||||
def*)
|
def*))))))
|
||||||
)))))
|
(printf "\nUsage:\n")
|
||||||
(printf "\nUsage:")
|
|
||||||
(for-each (lambda (x) (apply print-usage-line x)) data*)
|
(for-each (lambda (x) (apply print-usage-line x)) data*)
|
||||||
(print-usage-line "Display this help message"
|
(print-usage-line "Display this help message"
|
||||||
'([#\h required0 . #f])
|
'([#\h required0 . #f])
|
||||||
|
|
@ -80,127 +91,114 @@
|
||||||
(char=? (string-ref x 0) #\-)
|
(char=? (string-ref x 0) #\-)
|
||||||
(not (char=? (string-ref x 1) #\-))))
|
(not (char=? (string-ref x 1) #\-))))
|
||||||
|
|
||||||
(define (fill-char-opt c ls fields k)
|
(define (fill-char-opt c ls fields)
|
||||||
;;; field = [c required ]
|
;;; field = [c required ]
|
||||||
;;; | [c flag . default]
|
;;; | [c flag . default]
|
||||||
;;; | [c zero-plus . list]
|
;;; | [c zero-plus . list]
|
||||||
;;; | [c one-plus . list]
|
;;; | [c one-plus . list]
|
||||||
;;; | [c optional . str]
|
;;; | [c optional . str]
|
||||||
(let f ([fields fields] [k k])
|
(let f ([fields fields])
|
||||||
(and (pair? fields)
|
(when (null? fields) (unmatched))
|
||||||
(let ([field (car fields)])
|
(let ([field (car fields)])
|
||||||
(if (char=? c (car field))
|
(if (char=? c (car field))
|
||||||
(let ([t (cadr field)])
|
(let ([t (cadr field)])
|
||||||
(case t
|
(case t
|
||||||
[(required1 optional)
|
[(required1 optional)
|
||||||
(and (not (null? ls))
|
(when (null? ls) (unmatched))
|
||||||
(let ([val (car ls)] [ls (cdr ls)])
|
(let ([val (car ls)] [ls (cdr ls)])
|
||||||
(k (cons
|
(values (cons (cons* c 'ok val) (cdr fields)) ls))]
|
||||||
(cons* c 'ok val)
|
|
||||||
(cdr fields))
|
|
||||||
ls)))]
|
|
||||||
[(flag)
|
[(flag)
|
||||||
(k (cons (cons* c 'ok #t) (cdr fields)) ls)]
|
(values (cons (cons* c 'ok #t) (cdr fields)) ls)]
|
||||||
[(zero-plus one-plus)
|
[(zero-plus one-plus)
|
||||||
(and (not (null? ls))
|
(when (null? ls) (unmatched))
|
||||||
(let ([val (car ls)])
|
(let ([val (car ls)])
|
||||||
(k (cons (cons* c 'zero-plus
|
(values
|
||||||
(cons val (cddr field)))
|
(cons (cons* c 'zero-plus (cons val (cddr field)))
|
||||||
(cdr fields))
|
(cdr fields))
|
||||||
(cdr ls))))]
|
(cdr ls)))]
|
||||||
[else #f]))
|
[else (unmatched)]))
|
||||||
(f (cdr fields)
|
(let-values ([(fields ls) (f (cdr fields))])
|
||||||
(lambda (fields ls)
|
(values (cons field fields) ls))))))
|
||||||
(k (cons field fields) ls))))))))
|
|
||||||
|
|
||||||
(define (fill-option a ls fields k)
|
(define (fill-option a ls fields)
|
||||||
(if (= (string-length a) 2)
|
(if (= (string-length a) 2)
|
||||||
(let ([char (string-ref a 1)])
|
(let ([char (string-ref a 1)])
|
||||||
(fill-char-opt char ls fields
|
(when (char=? char #\h) (help #f))
|
||||||
(lambda (fields ls)
|
(fill-char-opt char ls fields))
|
||||||
(match-fields fields ls k))))
|
|
||||||
(error 'fill-option "not yet")))
|
(error 'fill-option "not yet")))
|
||||||
|
|
||||||
(define (match-fields fields ls k)
|
(define (match-fields fields ls)
|
||||||
(if (null? ls)
|
(if (null? ls)
|
||||||
(k fields ls)
|
(values fields ls)
|
||||||
(let ([a (car ls)])
|
(let ([a (car ls)])
|
||||||
(if (option? a)
|
(if (option? a)
|
||||||
(fill-option a (cdr ls) fields k)
|
(let-values ([(fields ls) (fill-option a (cdr ls) fields)])
|
||||||
(k fields ls)))))
|
(match-fields fields ls))
|
||||||
|
(values fields ls)))))
|
||||||
|
|
||||||
(define (match-args args ls k)
|
(define (match-args args ls)
|
||||||
(if (null? args)
|
(cond
|
||||||
(k '() ls)
|
[(null? args) (values '() ls)]
|
||||||
(and (not (null? ls))
|
[(null? ls) (unmatched)]
|
||||||
|
[else
|
||||||
(let ([a (car ls)])
|
(let ([a (car ls)])
|
||||||
(and (not (option? a))
|
(when (option? a) (unmatched))
|
||||||
(match-args (cdr args) (cdr ls)
|
(let-values ([(a* ls) (match-args (cdr args) (cdr ls))])
|
||||||
(lambda (a* ls)
|
(values (cons a a*) ls)))]))
|
||||||
(k (cons a a*) ls))))))))
|
|
||||||
|
|
||||||
(define (match-args-rest a/f ls k)
|
(define (match-args-rest a/f ls)
|
||||||
(if a/f
|
(if a/f
|
||||||
(let f ([ls ls] [k (lambda (a ls) (k (list a) ls))])
|
(let-values ([(x ls)
|
||||||
|
(let f ([ls ls])
|
||||||
(if (null? ls)
|
(if (null? ls)
|
||||||
(k '() ls)
|
(values '() ls)
|
||||||
(let ([a (car ls)])
|
(let ([a (car ls)])
|
||||||
(if (string=? a "--")
|
(if (string=? a "--")
|
||||||
(k '() ls)
|
(values '() ls)
|
||||||
(and (not (option? a))
|
(if (option? a)
|
||||||
(f (cdr ls)
|
(unmatched)
|
||||||
(lambda (a* ls)
|
(let-values ([(a* ls) (f (cdr ls))])
|
||||||
(k (cons a a*) ls))))))))
|
(values (cons a a*) ls)))))))])
|
||||||
(and (or (null? ls) (string=? (car ls) "--"))
|
(values (list x) ls))
|
||||||
(k '() ls))))
|
(if (or (null? ls) (string=? (car ls) "--"))
|
||||||
|
(values '() ls)
|
||||||
|
(unmatched))))
|
||||||
|
|
||||||
(define (match-dash-rest a/f ls k)
|
(define (match-dash-rest a/f ls)
|
||||||
(if a/f
|
(if a/f
|
||||||
(if (null? ls)
|
(if (null? ls)
|
||||||
(k '(()))
|
'(())
|
||||||
(and (string=? (car ls) "--")
|
(if (string=? (car ls) "--")
|
||||||
(k (list (cdr ls)))))
|
(list (cdr ls))
|
||||||
(and (null? ls) (k '()))))
|
(unmatched)))
|
||||||
|
(if (null? ls) '() (unmatched))))
|
||||||
|
|
||||||
(define (fix-fields ls k)
|
(define (fix-field x)
|
||||||
(cond
|
(let ([type (cadr x)] [value (cddr x)])
|
||||||
[(null? ls) (k '())]
|
|
||||||
[else
|
|
||||||
(let ([a (car ls)]
|
|
||||||
[k (lambda (a)
|
|
||||||
(fix-fields (cdr ls)
|
|
||||||
(lambda (ls)
|
|
||||||
(k (cons a ls)))))])
|
|
||||||
(let ([type (cadr a)] [value (cddr a)])
|
|
||||||
(case type
|
(case type
|
||||||
[(ok flag optional) (k value)]
|
[(ok flag optional) value]
|
||||||
[(zero-plus) (k (reverse value))]
|
[(zero-plus) (reverse value)]
|
||||||
[else #f])))]))
|
[else (unmatched)])))
|
||||||
|
|
||||||
(define (match _help fields _field-ids args args-rest dash-rest)
|
(define (match _help fields _field-ids args args-rest dash-rest)
|
||||||
(let ([prog (car arguments)])
|
(cons (car arguments)
|
||||||
(match-fields fields (cdr arguments)
|
(let*-values ([(fields ls) (match-fields fields (cdr arguments))]
|
||||||
(lambda (fields ls)
|
[(fields) (map fix-field fields)]
|
||||||
(fix-fields fields
|
[(args ls) (match-args args ls)]
|
||||||
(lambda (fields)
|
[(args-rest ls) (match-args-rest args-rest ls)]
|
||||||
(match-args args ls
|
[(dash-rest) (match-dash-rest dash-rest ls)])
|
||||||
(lambda (args ls)
|
(append fields args args-rest dash-rest))))
|
||||||
(match-args-rest args-rest ls
|
|
||||||
(lambda (args-rest ls)
|
|
||||||
(match-dash-rest dash-rest ls
|
|
||||||
(lambda (dash-rest)
|
|
||||||
(cons prog
|
|
||||||
(append fields
|
|
||||||
args args-rest
|
|
||||||
dash-rest))))))))))))))
|
|
||||||
|
|
||||||
|
(guard (con
|
||||||
|
[(help-condition? con)
|
||||||
|
(print-usage (help-extended? con))])
|
||||||
(let f ([data* data*] [proc* proc*])
|
(let f ([data* data*] [proc* proc*])
|
||||||
(if (null? data*)
|
(if (null? data*)
|
||||||
(print-usage)
|
(help #f)
|
||||||
(let ([opts (apply match (car data*))])
|
(guard (con
|
||||||
(if opts
|
[(unmatched-condition? con)
|
||||||
(apply (car proc*) opts)
|
(f (cdr data*) (cdr proc*))])
|
||||||
(f (cdr data*) (cdr proc*)))))))
|
(apply (car proc*) (apply match (car data*))))))))
|
||||||
|
|
||||||
|
|
||||||
(define-syntax parse-command-line
|
(define-syntax parse-command-line
|
||||||
|
|
@ -413,6 +411,19 @@
|
||||||
(test command8 ("./prog" "-h") #f)
|
(test command8 ("./prog" "-h") #f)
|
||||||
|
|
||||||
|
|
||||||
|
(define (ls-command ls)
|
||||||
|
(parse-command-line 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
|
||||||
|
"-k?" k "-l?" l "-m?" m "-n?" n "-o?" o "-p?" p "-q?" q
|
||||||
|
"-r?" r "-s?" s "-t?" t "-u?" u "-w?" w "-x?" x "-1?" o1
|
||||||
|
files ...)
|
||||||
|
#t]))
|
||||||
|
|
||||||
|
(test ls-command ("ls" "-h") #f)
|
||||||
|
|
||||||
|
|
||||||
#!eof
|
#!eof
|
||||||
(define (real-test ls)
|
(define (real-test ls)
|
||||||
(command-line-interface ls
|
(command-line-interface ls
|
||||||
|
|
@ -438,14 +449,14 @@
|
||||||
(list 2 program libdirs script-file)]
|
(list 2 program libdirs script-file)]
|
||||||
[(program "-O0" "-L" libdirs ... "-l" library-files ...
|
[(program "-O0" "-L" libdirs ... "-l" library-files ...
|
||||||
init-files ... "--script" script-file args ...)
|
init-files ... "--script" script-file args ...)
|
||||||
"Run <script-file> in R5RS-script mode
|
"Run <script-file> in R5RS-script mode"
|
||||||
Each of <library-files> must contain a library and are
|
"Each of <library-files> must contain a library and are"
|
||||||
installed before <init-files> are loaded and
|
"installed before <init-files> are loaded and"
|
||||||
<script-file> is run."
|
"<script-file> is run."
|
||||||
(list 3 program libdirs library-files init-files script-file args)]
|
(list 3 program libdirs library-files init-files script-file args)]
|
||||||
[(program "-O0" "-L" libdirs ... "-l" library-files init-files ...
|
[(program "-O0" "-L" libdirs ... "-l" library-files init-files ...
|
||||||
"--" args ...)
|
"--" args ...)
|
||||||
"Run Ikarus in interactive mode. Each of <library-files>
|
"Run Ikarus in interactive mode."
|
||||||
must contain a library and are installed before the
|
"Each of <library-files> must contain a library and are"
|
||||||
<init-files> are loaded"
|
"installed before the <init-files> are loaded"
|
||||||
(list 4 program libdirs library-files init-files args)]))
|
(list 4 program libdirs library-files init-files args)]))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue