From 2a0e53dcb00dcf55e6b3cff2355651bde453972b Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Tue, 2 Jun 2009 01:12:07 +0300 Subject: [PATCH] minor work on command-line: - no dependence on ikarus - split tests from main library --- lab/command-line-tests.sps | 215 ++++++++++++++++ lab/command-line.sls | 319 +++++++++++++++++++++++ lab/command-line.ss | 513 ------------------------------------- scheme/ikarus.main.ss | 129 +++++----- scheme/last-revision | 2 +- 5 files changed, 594 insertions(+), 584 deletions(-) create mode 100644 lab/command-line-tests.sps create mode 100644 lab/command-line.sls delete mode 100644 lab/command-line.ss diff --git a/lab/command-line-tests.sps b/lab/command-line-tests.sps new file mode 100644 index 0000000..746fb9f --- /dev/null +++ b/lab/command-line-tests.sps @@ -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 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 depends on" + (list 2 program libdirs script-file)] + [(program "-O0" "-L" libdirs ... "-l" library-files ... + init-files ... "--script" script-file args ...) + "Run in R5RS-script mode" + "Each of must contain a library and are" + "installed before are loaded and" + " 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 must contain a library and are" + "installed before the 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]... + diff --git a/lab/command-line.sls b/lab/command-line.sls new file mode 100644 index 0000000..5b49122 --- /dev/null +++ b/lab/command-line.sls @@ -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* ...)))]))) +) diff --git a/lab/command-line.ss b/lab/command-line.ss deleted file mode 100644 index 08b20a8..0000000 --- a/lab/command-line.ss +++ /dev/null @@ -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 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 depends on" - (list 2 program libdirs script-file)] - [(program "-O0" "-L" libdirs ... "-l" library-files ... - init-files ... "--script" script-file args ...) - "Run in R5RS-script mode" - "Each of must contain a library and are" - "installed before are loaded and" - " 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 must contain a library and are" - "installed before the 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]... - diff --git a/scheme/ikarus.main.ss b/scheme/ikarus.main.ss index b84752f..b4bccb1 100644 --- a/scheme/ikarus.main.ss +++ b/scheme/ikarus.main.ss @@ -88,79 +88,68 @@ (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!) (init-library-path) (let-values ([(files script script-type args init-command-line-args) - (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))]))]) + (parse-command-line-arguments)]) (define (assert-null files who) (unless (null? files) diff --git a/scheme/last-revision b/scheme/last-revision index 2f3a0e4..1f258a4 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1804 +1805