Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Allowing option parsing to fallback to top-level options from within subcommands.

Browse source
This commit is contained in:
Alex Shinn 2015-06-05 22:46:45 +09:00
parent a1c8862aba
commit a3f5b10d62
2 changed files with 61 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

44
lib/chibi/app-test.sld Normal file
View file

@ -0,0 +1,44 @@
(define-library (chibi app-test)
(import (scheme base) (chibi app) (chibi config) (chibi test))
(export run-tests)
(begin
(define (feed cfg spec . args)
(let ((animals (conf-get-list cfg 'animals '())))
(cons (if (conf-get cfg 'lions) (cons 'lions animals) animals) args)))
(define (wash cfg spec . args)
(let ((animals (conf-get-list cfg 'animals '())))
(cons (cons 'soap (conf-get cfg '(command wash soap))) animals)))
(define zoo-app-spec
`(zoo
"Zookeeper Application"
(@
(animals (list symbol) "list of animals to act on (default all)")
(lions boolean (#\l) "also apply the action to lions"))
(or
(feed "feed the animals" (,feed animals ...))
(wash "wash the animals" (@ (soap boolean)) (,wash animals ...))
(help "print help" (,app-help-command)))
))
(define (run-tests)
(test-begin "app")
(test '((camel elephant) "today")
(run-application
zoo-app-spec
'("zoo" "--animals" "camel,elephant" "feed" "today")))
(test '((lions camel elephant) "tomorrow")
(run-application
zoo-app-spec
'("zoo" "--animals" "camel,elephant" "--lions" "feed" "tomorrow")))
(test '((soap . #f) rhino)
(run-application zoo-app-spec '("zoo" "--animals" "rhino" "wash")))
(test '((soap . #t) rhino)
(run-application zoo-app-spec
'("zoo" "--animals" "rhino" "wash" "--soap")))
(test '((soap . #t) rhino)
(run-application zoo-app-spec
'("zoo" "wash" "--soap" "--animals" "rhino")))
(test 'error
(guard (exn (else 'error))
(run-application zoo-app-spec
'("zoo" "--soap" "wash" "--animals" "rhino"))))
(test-end))))

22
lib/chibi/app.scm
View file

@ -133,8 +133,9 @@
(init (vector-ref v 3)) (init (vector-ref v 3))
(end (vector-ref v 4))) (end (vector-ref v 4)))
(if init (init cfg)) (if init (init cfg))
(apply proc cfg spec args) (let ((res (apply proc cfg spec args)))
(if end (end cfg))))) (if end (end cfg))
res))))
((null? (cdr args)) ((null? (cdr args))
(app-help spec args) (app-help spec args)
(error "Expected a command")) (error "Expected a command"))
@ -335,7 +336,7 @@
(define (next-prefix prefix name) (define (next-prefix prefix name)
(append (if (null? prefix) '(command) prefix) (list name))) (append (if (null? prefix) '(command) prefix) (list name)))
(define (prev-prefix prefix) (define (prev-prefix prefix)
(cond ((and (= 2 (length prefix)))) (cond ((and (= 2 (length prefix))) '())
((null? prefix) '()) ((null? prefix) '())
(else (reverse (cdr (reverse prefix)))))) (else (reverse (cdr (reverse prefix))))))
(let ((fail (if (pair? o) (let ((fail (if (pair? o)
@ -346,13 +347,24 @@
(cond (cond
((null? spec) ((null? spec)
(error "no procedure in application spec")) (error "no procedure in application spec"))
((or (null? (car spec)) (equal? '(@) (car spec)))
(parse-app prefix (cdr spec) opt-spec args config init end fail))
((pair? (car spec)) ((pair? (car spec))
(case (caar spec) (case (caar spec)
((@) ((@)
(let* ((new-opt-spec (cadr (car spec))) (let* ((tail (cdar spec))
(new-opt-spec
(cond
((not (pair? tail))
'())
((or (pair? (cdr tail))
(and (pair? (car tail)) (symbol? (caar tail))))
tail)
(else
(car tail))))
(new-fail (new-fail
(lambda (new-prefix new-spec new-opt new-args reason) (lambda (new-prefix new-spec new-opt new-args reason)
(parse-options (prev-prefix prefix) opt-spec new-args fail))) (parse-option (prev-prefix prefix) opt-spec new-args fail)))
(cfg+args (parse-options prefix new-opt-spec args new-fail)) (cfg+args (parse-options prefix new-opt-spec args new-fail))
(config (conf-append (car cfg+args) config)) (config (conf-append (car cfg+args) config))
(args (cdr cfg+args))) (args (cdr cfg+args)))