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))
(end (vector-ref v 4)))
(if init (init cfg))
(apply proc cfg spec args)
(if end (end cfg)))))
(let ((res (apply proc cfg spec args)))
(if end (end cfg))
res))))
((null? (cdr args))
(app-help spec args)
(error "Expected a command"))
@ -335,7 +336,7 @@
(define (next-prefix prefix name)
(append (if (null? prefix) '(command) prefix) (list name)))
(define (prev-prefix prefix)
(cond ((and (= 2 (length prefix))))
(cond ((and (= 2 (length prefix))) '())
((null? prefix) '())
(else (reverse (cdr (reverse prefix))))))
(let ((fail (if (pair? o)
@ -346,13 +347,24 @@
(cond
((null? 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))
(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
(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))
(config (conf-append (car cfg+args) config))
(args (cdr cfg+args)))