minor work on command-line:
- no dependence on ikarus - split tests from main library
This commit is contained in:
Abdulaziz Ghuloum
parent
471921fcc7
commit
2a0e53dcb0
|
|
@ -0,0 +1,215 @@
|
||||||
|
|
||||||
|
|
||||||
|
;;; WORK IN PROGRESS, NOT FOR CONSUMPTION
|
||||||
|
;;; TODO: long options
|
||||||
|
;;; multiple options in one go, e.g., -XYZ
|
||||||
|
;;; concat value with option, e.g., -Xxvalue
|
||||||
|
;;; usage error message [ok?]
|
||||||
|
;;; -h --help should not be user-defined
|
||||||
|
;;; check duplicate options
|
||||||
|
|
||||||
|
|
||||||
|
(import (ikarus) (command-line))
|
||||||
|
|
||||||
|
((pretty-format 'command-line-interface)
|
||||||
|
'(_ ls tab [0 e ...] ...))
|
||||||
|
|
||||||
|
(define-syntax define-command
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ (name arg) . body)
|
||||||
|
(begin
|
||||||
|
(define (name arg) . body)
|
||||||
|
(display "================================================\n")
|
||||||
|
(pretty-print '(define (name arg) . body))
|
||||||
|
(newline))]))
|
||||||
|
|
||||||
|
(define-syntax test
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ command
|
||||||
|
[ls* expected*] ...)
|
||||||
|
(for-each
|
||||||
|
(lambda (ls expected)
|
||||||
|
(printf "~s => " `(command ',ls))
|
||||||
|
(let ([a1 (command ls)]
|
||||||
|
[a2 expected])
|
||||||
|
(unless (equal? a1 a2)
|
||||||
|
(error #f "failed/got/expected" a1 expected))
|
||||||
|
(printf "~s OK\n" expected)))
|
||||||
|
'(ls* ...)
|
||||||
|
'(expected* ...))]))
|
||||||
|
|
||||||
|
(define-command (command1 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)]
|
||||||
|
[(p p1 p2 p3) "Help3" (list 3 p p1 p2 p3)]))
|
||||||
|
|
||||||
|
(test command1
|
||||||
|
[("p") (0 "p")]
|
||||||
|
[("p" "p1") (1 "p" "p1")]
|
||||||
|
[("p" "p1" "p2") (2 "p" "p1" "p2")]
|
||||||
|
[("p" "p1" "p2" "p3") (3 "p" "p1" "p2" "p3")]
|
||||||
|
[("./prog" "p1" "p2" "p3" "p4") #f])
|
||||||
|
|
||||||
|
(define-command (command2 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)]
|
||||||
|
[(p ps ...) "Help0" (list 0 p ps)]))
|
||||||
|
|
||||||
|
(test command2
|
||||||
|
[("p") (0 "p" ())]
|
||||||
|
[("p" "a") (1 "p" "a" ())]
|
||||||
|
[("p" "a" "b") (2 "p" "a" "b" ())]
|
||||||
|
[("p" "a" "b" "c") (3 "p" "a" "b" "c")]
|
||||||
|
[("p" "a" "b" "c" "d") (2 "p" "a" "b" ("c" "d"))]
|
||||||
|
[("./prog" "-h") #f])
|
||||||
|
|
||||||
|
(define-command (command3 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)]))
|
||||||
|
|
||||||
|
(test command3
|
||||||
|
[("p" "-X" "xopt") (x "p" "xopt")]
|
||||||
|
[("p" "-Y" "yopt") (y "p" "yopt")]
|
||||||
|
[("p" "-X" "xopt" "-Y" "yopt") (xy "p" "xopt" "yopt")]
|
||||||
|
[("p" "-Y" "yopt" "-X" "xopt") (xy "p" "xopt" "yopt")]
|
||||||
|
[("./prog") #f]
|
||||||
|
[("./prog" "-h") #f])
|
||||||
|
|
||||||
|
(define-command (command4 ls)
|
||||||
|
(command-line-interface ls
|
||||||
|
[(p "-X?" xopt "-Y?" yopt) (list p xopt yopt)]
|
||||||
|
[(p "-X?" xopt rest ...) (list p xopt rest)]))
|
||||||
|
|
||||||
|
(test command4
|
||||||
|
[("p") ("p" #f #f)]
|
||||||
|
[("p" "-X") ("p" #t #f)]
|
||||||
|
[("p" "-Y") ("p" #f #t)]
|
||||||
|
[("p" "-X" "-Y") ("p" #t #t)]
|
||||||
|
[("p" "-Y" "-X") ("p" #t #t)]
|
||||||
|
[("p" "-X" "a") ("p" #t ("a"))]
|
||||||
|
[("p" "a") ("p" #f ("a"))]
|
||||||
|
[("./prog" "-h") #f])
|
||||||
|
|
||||||
|
(define-command (command5 ls)
|
||||||
|
(command-line-interface ls
|
||||||
|
[(p "-X=default" xopt) (list p xopt)]))
|
||||||
|
|
||||||
|
(test command5
|
||||||
|
[("p") ("p" "default")]
|
||||||
|
[("p" "-X" "hello") ("p" "hello")]
|
||||||
|
[("./prog" "-h") #f])
|
||||||
|
|
||||||
|
(define-command (command6 ls)
|
||||||
|
(command-line-interface ls
|
||||||
|
[(p "-X*" xopts) (list p xopts)]
|
||||||
|
[(p "-X*" xopts "-Y*" yopts) (list p xopts yopts)]))
|
||||||
|
|
||||||
|
(test command6
|
||||||
|
[("p") ("p" ())]
|
||||||
|
[("p" "-X" "a" "-X" "b") ("p" ("a" "b"))]
|
||||||
|
[("p" "-X" "a" "-Y" "b") ("p" ("a") ("b"))]
|
||||||
|
[("p" "-Y" "b") ("p" () ("b"))]
|
||||||
|
[("p" "-X" "a" "-Y" "b" "-X" "c" "-Y" "d") ("p" ("a" "c") ("b" "d"))]
|
||||||
|
[("./prog" "-Q" "12") #f]
|
||||||
|
[("./prog" "-h") #f])
|
||||||
|
|
||||||
|
(define-command (command7 ls)
|
||||||
|
(command-line-interface ls
|
||||||
|
[(p "-X+" xopts) (list p xopts)]
|
||||||
|
[(p "-X*" xopts "-Y+" yopts) (list p xopts yopts)]))
|
||||||
|
|
||||||
|
(test command7
|
||||||
|
[("p" "-X" "a") ("p" ("a"))]
|
||||||
|
[("p" "-X" "a" "-X" "b") ("p" ("a" "b"))]
|
||||||
|
[("p" "-X" "a" "-Y" "b") ("p" ("a") ("b"))]
|
||||||
|
[("p" "-Y" "b") ("p" () ("b"))]
|
||||||
|
[("p" "-X" "a" "-Y" "b" "-X" "c" "-Y" "d") ("p" ("a" "c") ("b" "d"))]
|
||||||
|
[("./prog") #f]
|
||||||
|
[("./prog" "-h") #f])
|
||||||
|
|
||||||
|
(define-command (command8 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]
|
||||||
|
[("./prog" "-h") #f]
|
||||||
|
[("./prog" "--help") #f])
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(define-command (ls-command 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
|
||||||
|
"-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
|
||||||
|
(define (real-test ls)
|
||||||
|
(command-line-interface ls
|
||||||
|
(options:
|
||||||
|
[("-O" "--optimize-level")
|
||||||
|
"Specify optimization level"
|
||||||
|
numeric-option
|
||||||
|
(lambda (n err)
|
||||||
|
(if (memv n '(0 1 2))
|
||||||
|
(begin (optimize-level n) n)
|
||||||
|
(err "valid options are 0, 1, and 2")))]
|
||||||
|
[("-L" "--library-path")
|
||||||
|
"Adds path to library search path"
|
||||||
|
(lambda (s err)
|
||||||
|
(library-path (cons s (library-path))))])
|
||||||
|
[(program "-O1" "-L" libdirs ... "-l" library-files ...
|
||||||
|
"--r6rs-script" script-file args ...)
|
||||||
|
"Run <script-file> in R6RS-script mode."
|
||||||
|
(list 1 program libdirs library-files script-file args)]
|
||||||
|
[(program "-O2" "-L" libdirs ...
|
||||||
|
"--compile-dependencies" script-file)
|
||||||
|
"Compile all libraries that <script-file> depends on"
|
||||||
|
(list 2 program libdirs script-file)]
|
||||||
|
[(program "-O0" "-L" libdirs ... "-l" library-files ...
|
||||||
|
init-files ... "--script" script-file args ...)
|
||||||
|
"Run <script-file> in R5RS-script mode"
|
||||||
|
"Each of <library-files> must contain a library and are"
|
||||||
|
"installed before <init-files> are loaded and"
|
||||||
|
"<script-file> is run."
|
||||||
|
(list 3 program libdirs library-files init-files script-file args)]
|
||||||
|
[(program "-O0" "-L" libdirs ... "-l" library-files init-files ...
|
||||||
|
"--" args ...)
|
||||||
|
"Run Ikarus in interactive mode."
|
||||||
|
"Each of <library-files> must contain a library and are"
|
||||||
|
"installed before the <init-files> are loaded"
|
||||||
|
(list 4 program libdirs library-files init-files args)]))
|
||||||
|
|
||||||
|
#!eof
|
||||||
|
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
gimp-request - send a request to GIMP's Script-Fu Server
|
||||||
|
|
||||||
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
Syntax:
|
||||||
|
|
||||||
|
$ gimp-request \
|
||||||
|
[--server=HOST][--port=PORT] \
|
||||||
|
[SCHEME_FILE] [ARGS]...
|
||||||
|
|
||||||
|
|
@ -0,0 +1,319 @@
|
||||||
|
|
||||||
|
|
||||||
|
;;; WORK IN PROGRESS, NOT FOR CONSUMPTION
|
||||||
|
;;; TODO: long options
|
||||||
|
;;; multiple options in one go, e.g., -XYZ
|
||||||
|
;;; concat value with option, e.g., -Xxvalue
|
||||||
|
;;; usage error message [ok?]
|
||||||
|
;;; -h --help should not be user-defined
|
||||||
|
;;; check duplicate options
|
||||||
|
|
||||||
|
(library (command-line)
|
||||||
|
(export command-line-interface)
|
||||||
|
(import (rnrs))
|
||||||
|
|
||||||
|
(define (dispatch-opts arguments data* proc*)
|
||||||
|
(define (print p . args)
|
||||||
|
(for-each (lambda (x) (display x p)) args))
|
||||||
|
(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)
|
||||||
|
(filter (lambda (x) (eq? (f-type x) type)) ls))
|
||||||
|
(define (fmt-req p)
|
||||||
|
(lambda (x)
|
||||||
|
(print p " -" (f-char x) " <" (f-id x) ">")))
|
||||||
|
(define (fmt-req-no-value p)
|
||||||
|
(lambda (x)
|
||||||
|
(display " -" p)
|
||||||
|
(display (f-char x) p)))
|
||||||
|
(define (fmt-z p c)
|
||||||
|
(lambda (x)
|
||||||
|
(print p " [-" (f-char x) " <" (f-id x) ">]" c)))
|
||||||
|
(define (fmt-<> p)
|
||||||
|
(lambda (x)
|
||||||
|
(display " <" p)
|
||||||
|
(display x p)
|
||||||
|
(display ">" p)))
|
||||||
|
(define (synopsis f* args args-rest)
|
||||||
|
(let ([opt* (get 'optional f*)]
|
||||||
|
[flag* (get 'flag f*)]
|
||||||
|
[req0* (get 'required0 f*)]
|
||||||
|
[req1* (get 'required1 f*)]
|
||||||
|
[z0* (get 'zero-plus f*)]
|
||||||
|
[z1* (get 'one-plus f*)])
|
||||||
|
(let-values ([(p e) (open-string-output-port)])
|
||||||
|
(display (car arguments) p)
|
||||||
|
(for-each (fmt-req-no-value p) req0*)
|
||||||
|
(unless (null? flag*)
|
||||||
|
(display " [-" p)
|
||||||
|
(apply print p (map f-char flag*))
|
||||||
|
(display "]" p))
|
||||||
|
(for-each (fmt-z p "") opt*)
|
||||||
|
(for-each (fmt-z p "*") z0*)
|
||||||
|
(for-each (fmt-z p "+") z1*)
|
||||||
|
(for-each (fmt-req p) req1*)
|
||||||
|
(for-each (fmt-<> p) args)
|
||||||
|
(when args-rest
|
||||||
|
((fmt-<> p) args-rest)
|
||||||
|
(display " ..." p))
|
||||||
|
(e))))
|
||||||
|
(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 "")
|
||||||
|
(display " ")
|
||||||
|
(display help)
|
||||||
|
(newline))
|
||||||
|
(when detailed?
|
||||||
|
(let ([def* (filter f-def (get 'optional f*))])
|
||||||
|
(unless (null? def*)
|
||||||
|
(for-each
|
||||||
|
(lambda (x)
|
||||||
|
(print (current-output-port)
|
||||||
|
" -" (f-char x)
|
||||||
|
" defaults to " (f-def x)
|
||||||
|
"\n"))
|
||||||
|
def*)))
|
||||||
|
(newline))))
|
||||||
|
(display "\nUsage:\n")
|
||||||
|
(for-each (lambda (x) (apply print-usage-line x)) data*)
|
||||||
|
(print-usage-line "Display this help message"
|
||||||
|
'([#\h required0 . #f])
|
||||||
|
'(dummy)
|
||||||
|
'()
|
||||||
|
#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) #\-)))))
|
||||||
|
;;;
|
||||||
|
(define (fill-char-opt c ls fields)
|
||||||
|
;;; 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)])
|
||||||
|
(if (char=? c (car field))
|
||||||
|
(let ([t (cadr field)])
|
||||||
|
(case t
|
||||||
|
[(required1 optional)
|
||||||
|
(when (null? ls) (unmatched))
|
||||||
|
(let ([val (car ls)] [ls (cdr ls)])
|
||||||
|
(values (cons (cons* c 'ok val) (cdr fields)) ls))]
|
||||||
|
[(flag)
|
||||||
|
(values (cons (cons* c 'ok #t) (cdr fields)) ls)]
|
||||||
|
[(zero-plus one-plus)
|
||||||
|
(when (null? ls) (unmatched))
|
||||||
|
(let ([val (car ls)])
|
||||||
|
(values
|
||||||
|
(cons (cons* c 'zero-plus (cons val (cddr field)))
|
||||||
|
(cdr fields))
|
||||||
|
(cdr ls)))]
|
||||||
|
[else (unmatched)]))
|
||||||
|
(let-values ([(fields ls) (f (cdr fields))])
|
||||||
|
(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))
|
||||||
|
(fill-char-opt char ls fields))
|
||||||
|
(error 'fill-option "not yet")))
|
||||||
|
;;;
|
||||||
|
(define (match-fields fields ls)
|
||||||
|
(if (null? ls)
|
||||||
|
(values fields ls)
|
||||||
|
(let ([a (car ls)])
|
||||||
|
(if (option? a)
|
||||||
|
(let-values ([(fields ls) (fill-option a (cdr ls) fields)])
|
||||||
|
(match-fields fields ls))
|
||||||
|
(values fields ls)))))
|
||||||
|
;;;
|
||||||
|
(define (match-args args ls)
|
||||||
|
(cond
|
||||||
|
[(null? args) (values '() ls)]
|
||||||
|
[(null? ls) (unmatched)]
|
||||||
|
[else
|
||||||
|
(let ([a (car ls)])
|
||||||
|
(when (option? a) (unmatched))
|
||||||
|
(let-values ([(a* ls) (match-args (cdr args) (cdr ls))])
|
||||||
|
(values (cons a a*) ls)))]))
|
||||||
|
;;;
|
||||||
|
(define (match-args-rest a/f ls)
|
||||||
|
(if a/f
|
||||||
|
(let-values ([(x ls)
|
||||||
|
(let f ([ls ls])
|
||||||
|
(if (null? ls)
|
||||||
|
(values '() ls)
|
||||||
|
(let ([a (car ls)])
|
||||||
|
(if (string=? a "--")
|
||||||
|
(values '() ls)
|
||||||
|
(if (option? a)
|
||||||
|
(unmatched)
|
||||||
|
(let-values ([(a* ls) (f (cdr ls))])
|
||||||
|
(values (cons a a*) ls)))))))])
|
||||||
|
(values (list x) ls))
|
||||||
|
(if (or (null? ls) (string=? (car ls) "--"))
|
||||||
|
(values '() ls)
|
||||||
|
(unmatched))))
|
||||||
|
;;;
|
||||||
|
(define (match-dash-rest a/f ls)
|
||||||
|
(if a/f
|
||||||
|
(if (null? ls)
|
||||||
|
'(())
|
||||||
|
(if (string=? (car ls) "--")
|
||||||
|
(list (cdr ls))
|
||||||
|
(unmatched)))
|
||||||
|
(if (null? ls) '() (unmatched))))
|
||||||
|
;;;
|
||||||
|
(define (fix-field x)
|
||||||
|
(let ([type (cadr x)] [value (cddr x)])
|
||||||
|
(case type
|
||||||
|
[(ok flag optional) value]
|
||||||
|
[(zero-plus) (reverse value)]
|
||||||
|
[else (unmatched)])))
|
||||||
|
;;;
|
||||||
|
(define (match _help fields _field-ids args args-rest dash-rest)
|
||||||
|
(cons (car arguments)
|
||||||
|
(let*-values ([(fields ls) (match-fields fields (cdr arguments))]
|
||||||
|
[(fields) (map fix-field fields)]
|
||||||
|
[(args ls) (match-args args ls)]
|
||||||
|
[(args-rest ls) (match-args-rest args-rest ls)]
|
||||||
|
[(dash-rest) (match-dash-rest dash-rest ls)])
|
||||||
|
(append fields args args-rest dash-rest))))
|
||||||
|
;;;
|
||||||
|
(guard (con
|
||||||
|
[(help-condition? con)
|
||||||
|
(print-usage (help-extended? con))])
|
||||||
|
(let f ([data* data*] [proc* proc*])
|
||||||
|
(if (null? data*)
|
||||||
|
(help #f)
|
||||||
|
(guard (con
|
||||||
|
[(unmatched-condition? con)
|
||||||
|
(f (cdr data*) (cdr proc*))])
|
||||||
|
(apply (car proc*) (apply match (car data*))))))))
|
||||||
|
(arguments-match))
|
||||||
|
|
||||||
|
(define-syntax command-line-interface
|
||||||
|
(lambda (stx)
|
||||||
|
(define (parse-format stx)
|
||||||
|
(define (err str x)
|
||||||
|
(syntax-violation #f str stx x))
|
||||||
|
(define (prep-str stx)
|
||||||
|
(let* ([str (syntax->datum stx)]
|
||||||
|
[n (string-length str)]
|
||||||
|
[err (lambda (why) (err why stx))])
|
||||||
|
(when (< n 2) (err "invalid option string"))
|
||||||
|
(unless (char=? (string-ref str 0) #\-)
|
||||||
|
(err "option string must start with a dash: -"))
|
||||||
|
(cons (string-ref str 1)
|
||||||
|
(cond
|
||||||
|
[(= n 2) #'(required1)]
|
||||||
|
[else
|
||||||
|
(case (string-ref str 2)
|
||||||
|
[(#\?) #'(flag . #f)]
|
||||||
|
[(#\*) #'(zero-plus . ())]
|
||||||
|
[(#\+) #'(one-plus . ())]
|
||||||
|
[(#\=)
|
||||||
|
(cons #'optional (substring str 3 n))]
|
||||||
|
[else (err "invalid option")])]))))
|
||||||
|
(define (dots? x)
|
||||||
|
(and (identifier? x)
|
||||||
|
(free-identifier=? x #'(... ...))))
|
||||||
|
(define (id? x)
|
||||||
|
(and (identifier? x) (not (dots? x))))
|
||||||
|
;;;
|
||||||
|
(define (command-line-interface ls)
|
||||||
|
(define (str? x)
|
||||||
|
(let ([d (syntax->datum x)])
|
||||||
|
(and (string? d) (not (string=? d "--")))))
|
||||||
|
(define (parse-head x)
|
||||||
|
(syntax-case x ()
|
||||||
|
[(prog . rest)
|
||||||
|
(if (id? #'prog)
|
||||||
|
(values #'prog #'rest)
|
||||||
|
(err "pattern head is not an identifier" #'prog))]
|
||||||
|
[_ (err "invalid pattern" x)]))
|
||||||
|
(define (parse-opts x)
|
||||||
|
(syntax-case x ()
|
||||||
|
[(str id . rest)
|
||||||
|
(and (id? #'id) (str? #'str))
|
||||||
|
(let-values ([(opt-strs opt-ids rest) (parse-opts #'rest)])
|
||||||
|
(values (cons (prep-str #'str) opt-strs)
|
||||||
|
(cons #'id opt-ids) rest))]
|
||||||
|
[_ (values '() '() x)]))
|
||||||
|
(define (parse-args x)
|
||||||
|
(syntax-case x ()
|
||||||
|
[(id dots . rest)
|
||||||
|
(and (id? #'id) (dots? #'dots))
|
||||||
|
(values '() #'id #'rest)]
|
||||||
|
[(id . rest) (id? #'id)
|
||||||
|
(let-values ([(args args-rest rest) (parse-args #'rest)])
|
||||||
|
(values (cons #'id args) args-rest rest))]
|
||||||
|
[_ (values '() #f x)]))
|
||||||
|
(define (parse-tail x)
|
||||||
|
(syntax-case x ()
|
||||||
|
[("--" id) (id? #'id) #'id]
|
||||||
|
[() #f]
|
||||||
|
[_ (err "invalid pattern segment" x)]))
|
||||||
|
(let-values ([(prog ls) (parse-head ls)])
|
||||||
|
(let-values ([(opts opt-ids ls) (parse-opts ls)])
|
||||||
|
(let-values ([(args args-rest ls) (parse-args ls)])
|
||||||
|
(values prog opts opt-ids args args-rest (parse-tail ls))))))
|
||||||
|
(define (get-fmls x ls1 ls2 m1 m2)
|
||||||
|
(define (cons? x ls) (if x (cons x ls) ls))
|
||||||
|
(define (bound-id-member? x ls)
|
||||||
|
(and (pair? ls)
|
||||||
|
(or (bound-identifier=? x (car ls))
|
||||||
|
(bound-id-member? x (cdr ls)))))
|
||||||
|
(let ([ls (cons x (append ls1 ls2 (cons? m1 (cons? m2 '()))))])
|
||||||
|
(let f ([x (car ls)] [ls (cdr ls)])
|
||||||
|
(unless (null? ls)
|
||||||
|
(if (bound-id-member? x ls)
|
||||||
|
(err "duplicate identifier" x)
|
||||||
|
(f (car ls) (cdr ls)))))
|
||||||
|
ls))
|
||||||
|
(let-values ([(prog opt-strs opt-ids args args-rest dash-rest)
|
||||||
|
(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)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(format help-str body body* ...)
|
||||||
|
(string? (syntax->datum #'help-str))
|
||||||
|
(with-syntax ([((fmls ...) . args)
|
||||||
|
(parse-format #'format)])
|
||||||
|
(list #'(lambda (fmls ...) body body* ...)
|
||||||
|
#'(help-str . args)))]
|
||||||
|
[(format body body* ...)
|
||||||
|
(parse-clause #'(format "" body body* ...))]))
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ expr clause* ...)
|
||||||
|
(with-syntax ([((proc* data*) ...)
|
||||||
|
(map parse-clause #'(clause* ...))])
|
||||||
|
#'(dispatch-opts expr '(data* ...) (list proc* ...)))])))
|
||||||
|
)
|
||||||
|
|
@ -1,513 +0,0 @@
|
||||||
|
|
||||||
|
|
||||||
;;; WORK IN PROGRESS, NOT FOR CONSUMPTION
|
|
||||||
;;; TODO: long options
|
|
||||||
;;; multiple options in one go, e.g., -XYZ
|
|
||||||
;;; concat value with option, e.g., -Xxvalue
|
|
||||||
;;; usage error message [ok?]
|
|
||||||
;;; -h --help should not be user-defined
|
|
||||||
;;; check duplicate options
|
|
||||||
|
|
||||||
(import (ikarus))
|
|
||||||
|
|
||||||
(define (dispatch-opts arguments data* proc*)
|
|
||||||
(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)
|
|
||||||
(filter (lambda (x) (eq? (f-type x) type)) ls))
|
|
||||||
(define (fmt-req p)
|
|
||||||
(lambda (x)
|
|
||||||
(display* (list " -" (f-char x) " <" (f-id x) ">") p)))
|
|
||||||
(define (fmt-req-no-value x)
|
|
||||||
(format " -~a" (f-char x)))
|
|
||||||
(define (fmt-z c)
|
|
||||||
(lambda (x)
|
|
||||||
(format " [-~a <~a>]~a" (f-char x) (f-id x) c)))
|
|
||||||
(define (fmt-<> x)
|
|
||||||
(format " <~a>" x))
|
|
||||||
(define (display* ls p)
|
|
||||||
(for-each (lambda (x) (display x p)) ls))
|
|
||||||
(define (synopsis f* args args-rest)
|
|
||||||
(let ([opt* (get 'optional f*)]
|
|
||||||
[flag* (get 'flag f*)]
|
|
||||||
[req0* (get 'required0 f*)]
|
|
||||||
[req1* (get 'required1 f*)]
|
|
||||||
[z0* (get 'zero-plus f*)]
|
|
||||||
[z1* (get 'one-plus f*)])
|
|
||||||
(let-values ([(p e) (open-string-output-port)])
|
|
||||||
(display (car arguments) p)
|
|
||||||
(display* (map fmt-req-no-value req0*) p)
|
|
||||||
(unless (null? flag*)
|
|
||||||
(display " [-" p)
|
|
||||||
(display* (map f-char flag*) p)
|
|
||||||
(display "]" p))
|
|
||||||
(display* (map (fmt-z "") opt*) p)
|
|
||||||
(display* (map (fmt-z "*") z0*) p)
|
|
||||||
(display* (map (fmt-z "+") z1*) p)
|
|
||||||
(for-each (fmt-req p) req1*)
|
|
||||||
(display* (map fmt-<> args) p)
|
|
||||||
(when args-rest
|
|
||||||
(display* (list (fmt-<> args-rest) " ...") p))
|
|
||||||
(e))))
|
|
||||||
(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 "")
|
|
||||||
(display " ")
|
|
||||||
(display help)
|
|
||||||
(newline))
|
|
||||||
(when detailed?
|
|
||||||
(let ([def* (filter f-def (get 'optional f*))])
|
|
||||||
(unless (null? def*)
|
|
||||||
(for-each
|
|
||||||
(lambda (x)
|
|
||||||
(display*
|
|
||||||
(list " -" (f-char x)
|
|
||||||
" defaults to" (f-def x)
|
|
||||||
"\n")
|
|
||||||
(current-output-port)))
|
|
||||||
def*)))
|
|
||||||
(newline))))
|
|
||||||
(display "\nUsage:\n")
|
|
||||||
(for-each (lambda (x) (apply print-usage-line x)) data*)
|
|
||||||
(print-usage-line "Display this help message"
|
|
||||||
'([#\h required0 . #f])
|
|
||||||
'(dummy)
|
|
||||||
'()
|
|
||||||
#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) #\-)))))
|
|
||||||
|
|
||||||
(define (fill-char-opt c ls fields)
|
|
||||||
;;; 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)])
|
|
||||||
(if (char=? c (car field))
|
|
||||||
(let ([t (cadr field)])
|
|
||||||
(case t
|
|
||||||
[(required1 optional)
|
|
||||||
(when (null? ls) (unmatched))
|
|
||||||
(let ([val (car ls)] [ls (cdr ls)])
|
|
||||||
(values (cons (cons* c 'ok val) (cdr fields)) ls))]
|
|
||||||
[(flag)
|
|
||||||
(values (cons (cons* c 'ok #t) (cdr fields)) ls)]
|
|
||||||
[(zero-plus one-plus)
|
|
||||||
(when (null? ls) (unmatched))
|
|
||||||
(let ([val (car ls)])
|
|
||||||
(values
|
|
||||||
(cons (cons* c 'zero-plus (cons val (cddr field)))
|
|
||||||
(cdr fields))
|
|
||||||
(cdr ls)))]
|
|
||||||
[else (unmatched)]))
|
|
||||||
(let-values ([(fields ls) (f (cdr fields))])
|
|
||||||
(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))
|
|
||||||
(fill-char-opt char ls fields))
|
|
||||||
(error 'fill-option "not yet")))
|
|
||||||
|
|
||||||
(define (match-fields fields ls)
|
|
||||||
(if (null? ls)
|
|
||||||
(values fields ls)
|
|
||||||
(let ([a (car ls)])
|
|
||||||
(if (option? a)
|
|
||||||
(let-values ([(fields ls) (fill-option a (cdr ls) fields)])
|
|
||||||
(match-fields fields ls))
|
|
||||||
(values fields ls)))))
|
|
||||||
|
|
||||||
(define (match-args args ls)
|
|
||||||
(cond
|
|
||||||
[(null? args) (values '() ls)]
|
|
||||||
[(null? ls) (unmatched)]
|
|
||||||
[else
|
|
||||||
(let ([a (car ls)])
|
|
||||||
(when (option? a) (unmatched))
|
|
||||||
(let-values ([(a* ls) (match-args (cdr args) (cdr ls))])
|
|
||||||
(values (cons a a*) ls)))]))
|
|
||||||
|
|
||||||
(define (match-args-rest a/f ls)
|
|
||||||
(if a/f
|
|
||||||
(let-values ([(x ls)
|
|
||||||
(let f ([ls ls])
|
|
||||||
(if (null? ls)
|
|
||||||
(values '() ls)
|
|
||||||
(let ([a (car ls)])
|
|
||||||
(if (string=? a "--")
|
|
||||||
(values '() ls)
|
|
||||||
(if (option? a)
|
|
||||||
(unmatched)
|
|
||||||
(let-values ([(a* ls) (f (cdr ls))])
|
|
||||||
(values (cons a a*) ls)))))))])
|
|
||||||
(values (list x) ls))
|
|
||||||
(if (or (null? ls) (string=? (car ls) "--"))
|
|
||||||
(values '() ls)
|
|
||||||
(unmatched))))
|
|
||||||
|
|
||||||
(define (match-dash-rest a/f ls)
|
|
||||||
(if a/f
|
|
||||||
(if (null? ls)
|
|
||||||
'(())
|
|
||||||
(if (string=? (car ls) "--")
|
|
||||||
(list (cdr ls))
|
|
||||||
(unmatched)))
|
|
||||||
(if (null? ls) '() (unmatched))))
|
|
||||||
|
|
||||||
(define (fix-field x)
|
|
||||||
(let ([type (cadr x)] [value (cddr x)])
|
|
||||||
(case type
|
|
||||||
[(ok flag optional) value]
|
|
||||||
[(zero-plus) (reverse value)]
|
|
||||||
[else (unmatched)])))
|
|
||||||
|
|
||||||
(define (match _help fields _field-ids args args-rest dash-rest)
|
|
||||||
(cons (car arguments)
|
|
||||||
(let*-values ([(fields ls) (match-fields fields (cdr arguments))]
|
|
||||||
[(fields) (map fix-field fields)]
|
|
||||||
[(args ls) (match-args args ls)]
|
|
||||||
[(args-rest ls) (match-args-rest args-rest ls)]
|
|
||||||
[(dash-rest) (match-dash-rest dash-rest ls)])
|
|
||||||
(append fields args args-rest dash-rest))))
|
|
||||||
|
|
||||||
(guard (con
|
|
||||||
[(help-condition? con)
|
|
||||||
(print-usage (help-extended? con))])
|
|
||||||
(let f ([data* data*] [proc* proc*])
|
|
||||||
(if (null? data*)
|
|
||||||
(help #f)
|
|
||||||
(guard (con
|
|
||||||
[(unmatched-condition? con)
|
|
||||||
(f (cdr data*) (cdr proc*))])
|
|
||||||
(apply (car proc*) (apply match (car data*))))))))
|
|
||||||
(arguments-match))
|
|
||||||
|
|
||||||
(define-syntax command-line-interface
|
|
||||||
(lambda (stx)
|
|
||||||
(define (parse-format stx)
|
|
||||||
(define (err str x)
|
|
||||||
(syntax-violation #f str stx x))
|
|
||||||
(define (prep-str stx)
|
|
||||||
(let* ([str (syntax->datum stx)]
|
|
||||||
[n (string-length str)]
|
|
||||||
[err (lambda (why) (err why stx))])
|
|
||||||
(when (< n 2) (err "invalid option string"))
|
|
||||||
(unless (char=? (string-ref str 0) #\-)
|
|
||||||
(err "option string must start with a dash: -"))
|
|
||||||
(cons (string-ref str 1)
|
|
||||||
(cond
|
|
||||||
[(= n 2) #'(required1)]
|
|
||||||
[else
|
|
||||||
(case (string-ref str 2)
|
|
||||||
[(#\?) #'(flag . #f)]
|
|
||||||
[(#\*) #'(zero-plus . ())]
|
|
||||||
[(#\+) #'(one-plus . ())]
|
|
||||||
[(#\=)
|
|
||||||
(cons #'optional (substring str 3 n))]
|
|
||||||
[else (err "invalid option")])]))))
|
|
||||||
(define (dots? x)
|
|
||||||
(and (identifier? x)
|
|
||||||
(free-identifier=? x #'(... ...))))
|
|
||||||
(define (id? x)
|
|
||||||
(and (identifier? x) (not (dots? x))))
|
|
||||||
(define (command-line-interface ls)
|
|
||||||
(define (str? x)
|
|
||||||
(let ([d (syntax->datum x)])
|
|
||||||
(and (string? d) (not (string=? d "--")))))
|
|
||||||
(define (parse-head x)
|
|
||||||
(syntax-case x ()
|
|
||||||
[(prog . rest)
|
|
||||||
(if (id? #'prog)
|
|
||||||
(values #'prog #'rest)
|
|
||||||
(err "pattern head is not an identifier" #'prog))]
|
|
||||||
[_ (err "invalid pattern" x)]))
|
|
||||||
(define (parse-opts x)
|
|
||||||
(syntax-case x ()
|
|
||||||
[(str id . rest)
|
|
||||||
(and (id? #'id) (str? #'str))
|
|
||||||
(let-values ([(opt-strs opt-ids rest) (parse-opts #'rest)])
|
|
||||||
(values (cons (prep-str #'str) opt-strs)
|
|
||||||
(cons #'id opt-ids) rest))]
|
|
||||||
[_ (values '() '() x)]))
|
|
||||||
(define (parse-args x)
|
|
||||||
(syntax-case x ()
|
|
||||||
[(id dots . rest)
|
|
||||||
(and (id? #'id) (dots? #'dots))
|
|
||||||
(values '() #'id #'rest)]
|
|
||||||
[(id . rest) (id? #'id)
|
|
||||||
(let-values ([(args args-rest rest) (parse-args #'rest)])
|
|
||||||
(values (cons #'id args) args-rest rest))]
|
|
||||||
[_ (values '() #f x)]))
|
|
||||||
(define (parse-tail x)
|
|
||||||
(syntax-case x ()
|
|
||||||
[("--" id) (id? #'id) #'id]
|
|
||||||
[() #f]
|
|
||||||
[_ (err "invalid pattern segment" x)]))
|
|
||||||
(let-values ([(prog ls) (parse-head ls)])
|
|
||||||
(let-values ([(opts opt-ids ls) (parse-opts ls)])
|
|
||||||
(let-values ([(args args-rest ls) (parse-args ls)])
|
|
||||||
(values prog opts opt-ids args args-rest (parse-tail ls))))))
|
|
||||||
(define (get-fmls x ls1 ls2 m1 m2)
|
|
||||||
(define (cons? x ls) (if x (cons x ls) ls))
|
|
||||||
(define (bound-id-member? x ls)
|
|
||||||
(and (pair? ls)
|
|
||||||
(or (bound-identifier=? x (car ls))
|
|
||||||
(bound-id-member? x (cdr ls)))))
|
|
||||||
(let ([ls (cons x (append ls1 ls2 (cons? m1 (cons? m2 '()))))])
|
|
||||||
(let f ([x (car ls)] [ls (cdr ls)])
|
|
||||||
(unless (null? ls)
|
|
||||||
(if (bound-id-member? x ls)
|
|
||||||
(err "duplicate identifier" x)
|
|
||||||
(f (car ls) (cdr ls)))))
|
|
||||||
ls))
|
|
||||||
(let-values ([(prog opt-strs opt-ids args args-rest dash-rest)
|
|
||||||
(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)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(format help-str body body* ...)
|
|
||||||
(string? (syntax->datum #'help-str))
|
|
||||||
(with-syntax ([((fmls ...) . args)
|
|
||||||
(parse-format #'format)])
|
|
||||||
(list #'(lambda (fmls ...) body body* ...)
|
|
||||||
#'(help-str . args)))]
|
|
||||||
[(format body body* ...)
|
|
||||||
(parse-clause #'(format "" body body* ...))]))
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ expr clause* ...)
|
|
||||||
(with-syntax ([((proc* data*) ...)
|
|
||||||
(map parse-clause #'(clause* ...))])
|
|
||||||
#'(dispatch-opts expr '(data* ...) (list proc* ...)))])))
|
|
||||||
|
|
||||||
|
|
||||||
(define-syntax define-command
|
|
||||||
(syntax-rules ()
|
|
||||||
[(_ (name arg) . body)
|
|
||||||
(begin
|
|
||||||
(define (name arg) . body)
|
|
||||||
(display "================================================\n")
|
|
||||||
(pretty-print '(define (name arg) . body))
|
|
||||||
(newline))]))
|
|
||||||
|
|
||||||
(define-syntax test
|
|
||||||
(syntax-rules ()
|
|
||||||
[(_ command
|
|
||||||
[ls* expected*] ...)
|
|
||||||
(for-each
|
|
||||||
(lambda (ls expected)
|
|
||||||
(printf "~s => " `(command ',ls))
|
|
||||||
(let ([a1 (command ls)]
|
|
||||||
[a2 expected])
|
|
||||||
(unless (equal? a1 a2)
|
|
||||||
(error #f "failed/got/expected" a1 expected))
|
|
||||||
(printf "~s OK\n" expected)))
|
|
||||||
'(ls* ...)
|
|
||||||
'(expected* ...))]))
|
|
||||||
|
|
||||||
(define-command (command1 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)]
|
|
||||||
[(p p1 p2 p3) "Help3" (list 3 p p1 p2 p3)]))
|
|
||||||
|
|
||||||
(test command1
|
|
||||||
[("p") (0 "p")]
|
|
||||||
[("p" "p1") (1 "p" "p1")]
|
|
||||||
[("p" "p1" "p2") (2 "p" "p1" "p2")]
|
|
||||||
[("p" "p1" "p2" "p3") (3 "p" "p1" "p2" "p3")]
|
|
||||||
[("./prog" "p1" "p2" "p3" "p4") #f])
|
|
||||||
|
|
||||||
(define-command (command2 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)]
|
|
||||||
[(p ps ...) "Help0" (list 0 p ps)]))
|
|
||||||
|
|
||||||
(test command2
|
|
||||||
[("p") (0 "p" ())]
|
|
||||||
[("p" "a") (1 "p" "a" ())]
|
|
||||||
[("p" "a" "b") (2 "p" "a" "b" ())]
|
|
||||||
[("p" "a" "b" "c") (3 "p" "a" "b" "c")]
|
|
||||||
[("p" "a" "b" "c" "d") (2 "p" "a" "b" ("c" "d"))]
|
|
||||||
[("./prog" "-h") #f])
|
|
||||||
|
|
||||||
(define-command (command3 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)]))
|
|
||||||
|
|
||||||
(test command3
|
|
||||||
[("p" "-X" "xopt") (x "p" "xopt")]
|
|
||||||
[("p" "-Y" "yopt") (y "p" "yopt")]
|
|
||||||
[("p" "-X" "xopt" "-Y" "yopt") (xy "p" "xopt" "yopt")]
|
|
||||||
[("p" "-Y" "yopt" "-X" "xopt") (xy "p" "xopt" "yopt")]
|
|
||||||
[("./prog") #f]
|
|
||||||
[("./prog" "-h") #f])
|
|
||||||
|
|
||||||
(define-command (command4 ls)
|
|
||||||
(command-line-interface ls
|
|
||||||
[(p "-X?" xopt "-Y?" yopt) (list p xopt yopt)]
|
|
||||||
[(p "-X?" xopt rest ...) (list p xopt rest)]))
|
|
||||||
|
|
||||||
(test command4
|
|
||||||
[("p") ("p" #f #f)]
|
|
||||||
[("p" "-X") ("p" #t #f)]
|
|
||||||
[("p" "-Y") ("p" #f #t)]
|
|
||||||
[("p" "-X" "-Y") ("p" #t #t)]
|
|
||||||
[("p" "-Y" "-X") ("p" #t #t)]
|
|
||||||
[("p" "-X" "a") ("p" #t ("a"))]
|
|
||||||
[("p" "a") ("p" #f ("a"))]
|
|
||||||
[("./prog" "-h") #f])
|
|
||||||
|
|
||||||
(define-command (command5 ls)
|
|
||||||
(command-line-interface ls
|
|
||||||
[(p "-X=default" xopt) (list p xopt)]))
|
|
||||||
|
|
||||||
(test command5
|
|
||||||
[("p") ("p" "default")]
|
|
||||||
[("p" "-X" "hello") ("p" "hello")]
|
|
||||||
[("./prog" "-h") #f])
|
|
||||||
|
|
||||||
(define-command (command6 ls)
|
|
||||||
(command-line-interface ls
|
|
||||||
[(p "-X*" xopts) (list p xopts)]
|
|
||||||
[(p "-X*" xopts "-Y*" yopts) (list p xopts yopts)]))
|
|
||||||
|
|
||||||
(test command6
|
|
||||||
[("p") ("p" ())]
|
|
||||||
[("p" "-X" "a" "-X" "b") ("p" ("a" "b"))]
|
|
||||||
[("p" "-X" "a" "-Y" "b") ("p" ("a") ("b"))]
|
|
||||||
[("p" "-Y" "b") ("p" () ("b"))]
|
|
||||||
[("p" "-X" "a" "-Y" "b" "-X" "c" "-Y" "d") ("p" ("a" "c") ("b" "d"))]
|
|
||||||
[("./prog" "-Q" "12") #f]
|
|
||||||
[("./prog" "-h") #f])
|
|
||||||
|
|
||||||
(define-command (command7 ls)
|
|
||||||
(command-line-interface ls
|
|
||||||
[(p "-X+" xopts) (list p xopts)]
|
|
||||||
[(p "-X*" xopts "-Y+" yopts) (list p xopts yopts)]))
|
|
||||||
|
|
||||||
(test command7
|
|
||||||
[("p" "-X" "a") ("p" ("a"))]
|
|
||||||
[("p" "-X" "a" "-X" "b") ("p" ("a" "b"))]
|
|
||||||
[("p" "-X" "a" "-Y" "b") ("p" ("a") ("b"))]
|
|
||||||
[("p" "-Y" "b") ("p" () ("b"))]
|
|
||||||
[("p" "-X" "a" "-Y" "b" "-X" "c" "-Y" "d") ("p" ("a" "c") ("b" "d"))]
|
|
||||||
[("./prog") #f]
|
|
||||||
[("./prog" "-h") #f])
|
|
||||||
|
|
||||||
(define-command (command8 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]
|
|
||||||
[("./prog" "-h") #f]
|
|
||||||
[("./prog" "--help") #f])
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define-command (ls-command 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
|
|
||||||
"-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
|
|
||||||
(define (real-test ls)
|
|
||||||
(command-line-interface ls
|
|
||||||
(options:
|
|
||||||
[("-O" "--optimize-level")
|
|
||||||
"Specify optimization level"
|
|
||||||
numeric-option
|
|
||||||
(lambda (n err)
|
|
||||||
(if (memv n '(0 1 2))
|
|
||||||
(begin (optimize-level n) n)
|
|
||||||
(err "valid options are 0, 1, and 2")))]
|
|
||||||
[("-L" "--library-path")
|
|
||||||
"Adds path to library search path"
|
|
||||||
(lambda (s err)
|
|
||||||
(library-path (cons s (library-path))))])
|
|
||||||
[(program "-O1" "-L" libdirs ... "-l" library-files ...
|
|
||||||
"--r6rs-script" script-file args ...)
|
|
||||||
"Run <script-file> in R6RS-script mode."
|
|
||||||
(list 1 program libdirs library-files script-file args)]
|
|
||||||
[(program "-O2" "-L" libdirs ...
|
|
||||||
"--compile-dependencies" script-file)
|
|
||||||
"Compile all libraries that <script-file> depends on"
|
|
||||||
(list 2 program libdirs script-file)]
|
|
||||||
[(program "-O0" "-L" libdirs ... "-l" library-files ...
|
|
||||||
init-files ... "--script" script-file args ...)
|
|
||||||
"Run <script-file> in R5RS-script mode"
|
|
||||||
"Each of <library-files> must contain a library and are"
|
|
||||||
"installed before <init-files> are loaded and"
|
|
||||||
"<script-file> is run."
|
|
||||||
(list 3 program libdirs library-files init-files script-file args)]
|
|
||||||
[(program "-O0" "-L" libdirs ... "-l" library-files init-files ...
|
|
||||||
"--" args ...)
|
|
||||||
"Run Ikarus in interactive mode."
|
|
||||||
"Each of <library-files> must contain a library and are"
|
|
||||||
"installed before the <init-files> are loaded"
|
|
||||||
(list 4 program libdirs library-files init-files args)]))
|
|
||||||
|
|
||||||
#!eof
|
|
||||||
|
|
||||||
|
|
||||||
=head1 NAME
|
|
||||||
|
|
||||||
gimp-request - send a request to GIMP's Script-Fu Server
|
|
||||||
|
|
||||||
=head1 SYNOPSIS
|
|
||||||
|
|
||||||
Syntax:
|
|
||||||
|
|
||||||
$ gimp-request \
|
|
||||||
[--server=HOST][--port=PORT] \
|
|
||||||
[SCHEME_FILE] [ARGS]...
|
|
||||||
|
|
||||||
|
|
@ -88,79 +88,68 @@
|
||||||
|
|
||||||
(define rcfiles #t) ;; #f for no rcfile, list for specific list
|
(define rcfiles #t) ;; #f for no rcfile, list for specific list
|
||||||
|
|
||||||
|
(define (parse-command-line-arguments)
|
||||||
|
(let f ([args (command-line-arguments)] [k void])
|
||||||
|
(define (invalid-rc-error)
|
||||||
|
(die 'ikarus "--no-rcfile is invalid with --rcfile"))
|
||||||
|
(cond
|
||||||
|
[(null? args) (values '() #f #f '() k)]
|
||||||
|
[(member (car args) '("-d" "--debug"))
|
||||||
|
(f (cdr args) (lambda () (k) (generate-debug-calls #t)))]
|
||||||
|
[(member (car args) '("-nd" "--no-debug"))
|
||||||
|
(f (cdr args) (lambda () (k) (generate-debug-calls #f)))]
|
||||||
|
[(string=? (car args) "-O2")
|
||||||
|
(f (cdr args) (lambda () (k) (optimize-level 2)))]
|
||||||
|
[(string=? (car args) "-O1")
|
||||||
|
(f (cdr args) (lambda () (k) (optimize-level 1)))]
|
||||||
|
[(string=? (car args) "-O0")
|
||||||
|
(f (cdr args) (lambda () (k) (optimize-level 0)))]
|
||||||
|
[(string=? (car args) "--no-rcfile")
|
||||||
|
(unless (boolean? rcfiles) (invalid-rc-error))
|
||||||
|
(set! rcfiles #f)
|
||||||
|
(f (cdr args) k)]
|
||||||
|
[(string=? (car args) "--rcfile")
|
||||||
|
(let ([d (cdr args)])
|
||||||
|
(when (null? d) (die 'ikarus "--rcfile requires a script name"))
|
||||||
|
(set! rcfiles
|
||||||
|
(cons (car d)
|
||||||
|
(case rcfiles
|
||||||
|
[(#t) '()]
|
||||||
|
[(#f) (invalid-rc-error)]
|
||||||
|
[else rcfiles])))
|
||||||
|
(f (cdr d) k))]
|
||||||
|
[(string=? (car args) "--")
|
||||||
|
(values '() #f #f (cdr args) k)]
|
||||||
|
[(string=? (car args) "--script")
|
||||||
|
(let ([d (cdr args)])
|
||||||
|
(cond
|
||||||
|
[(null? d) (die 'ikarus "--script requires a script name")]
|
||||||
|
[else (values '() (car d) 'script (cdr d) k)]))]
|
||||||
|
[(string=? (car args) "--r6rs-script")
|
||||||
|
(let ([d (cdr args)])
|
||||||
|
(cond
|
||||||
|
[(null? d) (die 'ikarus "--r6rs-script requires a script name")]
|
||||||
|
[else (values '() (car d) 'r6rs-script (cdr d) k)]))]
|
||||||
|
[(string=? (car args) "--r6rs-repl")
|
||||||
|
(let ([d (cdr args)])
|
||||||
|
(cond
|
||||||
|
[(null? d) (die 'ikarus "--r6rs-repl requires a script name")]
|
||||||
|
[else (values '() (car d) 'r6rs-repl (cdr d) k)]))]
|
||||||
|
[(string=? (car args) "--compile-dependencies")
|
||||||
|
(let ([d (cdr args)])
|
||||||
|
(cond
|
||||||
|
[(null? d)
|
||||||
|
(die 'ikarus "--compile-dependencies requires a script name")]
|
||||||
|
[else
|
||||||
|
(values '() (car d) 'compile (cdr d) k)]))]
|
||||||
|
[else
|
||||||
|
(let-values ([(f* script script-type a* k) (f (cdr args) k)])
|
||||||
|
(values (cons (car args) f*) script script-type a* k))])))
|
||||||
|
|
||||||
(initialize-symbol-table!)
|
(initialize-symbol-table!)
|
||||||
(init-library-path)
|
(init-library-path)
|
||||||
(let-values ([(files script script-type args init-command-line-args)
|
(let-values ([(files script script-type args init-command-line-args)
|
||||||
(let f ([args (command-line-arguments)] [k void])
|
(parse-command-line-arguments)])
|
||||||
(define (invalid-rc-error)
|
|
||||||
(die 'ikarus "--no-rcfile is invalid with --rcfile"))
|
|
||||||
(cond
|
|
||||||
[(null? args) (values '() #f #f '() k)]
|
|
||||||
[(member (car args) '("-d" "--debug"))
|
|
||||||
(f (cdr args)
|
|
||||||
(lambda () (k) (generate-debug-calls #t)))]
|
|
||||||
[(member (car args) '("-nd" "--no-debug"))
|
|
||||||
(f (cdr args)
|
|
||||||
(lambda () (k) (generate-debug-calls #f)))]
|
|
||||||
[(string=? (car args) "-O2")
|
|
||||||
(f (cdr args)
|
|
||||||
(lambda () (k) (optimize-level 2)))]
|
|
||||||
[(string=? (car args) "-O1")
|
|
||||||
(f (cdr args)
|
|
||||||
(lambda () (k) (optimize-level 1)))]
|
|
||||||
[(string=? (car args) "-O0")
|
|
||||||
(f (cdr args)
|
|
||||||
(lambda () (k) (optimize-level 0)))]
|
|
||||||
[(string=? (car args) "--no-rcfile")
|
|
||||||
(unless (boolean? rcfiles) (invalid-rc-error))
|
|
||||||
(set! rcfiles #f)
|
|
||||||
(f (cdr args) k)]
|
|
||||||
[(string=? (car args) "--rcfile")
|
|
||||||
(let ([d (cdr args)])
|
|
||||||
(when (null? d)
|
|
||||||
(die 'ikarus "--rcfile requires a script name"))
|
|
||||||
(set! rcfiles
|
|
||||||
(cons (car d)
|
|
||||||
(case rcfiles
|
|
||||||
[(#t) '()]
|
|
||||||
[(#f) (invalid-rc-error)]
|
|
||||||
[else rcfiles])))
|
|
||||||
(f (cdr d) k))]
|
|
||||||
[(string=? (car args) "--")
|
|
||||||
(values '() #f #f (cdr args) k)]
|
|
||||||
[(string=? (car args) "--script")
|
|
||||||
(let ([d (cdr args)])
|
|
||||||
(cond
|
|
||||||
[(null? d)
|
|
||||||
(die 'ikarus "--script requires a script name")]
|
|
||||||
[else
|
|
||||||
(values '() (car d) 'script (cdr d) k)]))]
|
|
||||||
[(string=? (car args) "--r6rs-script")
|
|
||||||
(let ([d (cdr args)])
|
|
||||||
(cond
|
|
||||||
[(null? d)
|
|
||||||
(die 'ikarus "--r6rs-script requires a script name")]
|
|
||||||
[else
|
|
||||||
(values '() (car d) 'r6rs-script (cdr d) k)]))]
|
|
||||||
[(string=? (car args) "--r6rs-repl")
|
|
||||||
(let ([d (cdr args)])
|
|
||||||
(cond
|
|
||||||
[(null? d)
|
|
||||||
(die 'ikarus "--r6rs-repl requires a script name")]
|
|
||||||
[else
|
|
||||||
(values '() (car d) 'r6rs-repl (cdr d) k)]))]
|
|
||||||
[(string=? (car args) "--compile-dependencies")
|
|
||||||
(let ([d (cdr args)])
|
|
||||||
(cond
|
|
||||||
[(null? d)
|
|
||||||
(die 'ikarus
|
|
||||||
"--compile-dependencies requires a script name")]
|
|
||||||
[else
|
|
||||||
(values '() (car d) 'compile (cdr d) k)]))]
|
|
||||||
[else
|
|
||||||
(let-values ([(f* script script-type a* k)
|
|
||||||
(f (cdr args) k)])
|
|
||||||
(values (cons (car args) f*) script script-type a* k))]))])
|
|
||||||
|
|
||||||
(define (assert-null files who)
|
(define (assert-null files who)
|
||||||
(unless (null? files)
|
(unless (null? files)
|
||||||
|
|
|
||||||
|
|
@ -1 +1 @@
|
||||||
1804
|
1805
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue