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

Support integer/real options with better error handling.

Browse source
This commit is contained in:
Alex Shinn 2015-02-13 19:03:54 +09:00
parent a7877b773b
commit 1f08bd90c1
1 changed files with 63 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

110
lib/chibi/app.scm
View file

@ -1,5 +1,5 @@
;; app.scm -- unified option parsing and config ;; app.scm -- unified option parsing and config
;; Copyright (c) 2012-2013 Alex Shinn. All rights reserved. ;; Copyright (c) 2012-2015 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
;;> Parses command-line options into a config object. ;;> Parses command-line options into a config object.
@ -8,17 +8,33 @@
(define (parse-value type str) (define (parse-value type str)
(cond (cond
((not (string? str)) ((not (string? str))
str) (list str #f))
((and (pair? type) (eq? 'list (car type))) ((and (pair? type) (eq? 'list (car type)))
(map (lambda (x) (parse-value (cadr type) x)) (let ((res (map (lambda (x) (parse-value (cadr type) x))
(string-split str #\,))) (string-split str #\,))))
(list (map car res) (any string? (map cdr res)))))
(else (else
(case type (case type
((boolean) (not (member str '("#f" "#false" "#F" "#FALSE")))) ((boolean)
((number) (string->number str)) (list (not (member str '("#f" "#false" "#F" "#FALSE" "false" "FALSE")))
((symbol) (string->symbol str)) #f))
((char) (string-ref str 0)) ((number integer real)
(else str))))) (let ((n (string->number str)))
(cond
((and (eq? type 'integer) (not (integer? n)))
(list n "expected an integer"))
((and (eq? type 'real) (not (real? n)))
(list n "expected a real number"))
(else
(list n #f)))))
((symbol)
(list (string->symbol str) #f))
((char)
(if (not (= 1 (string-length str)))
(list #f "expected a single character")
(list (string-ref str 0) #f)))
(else
(list str #f))))))
(define (lookup-conf-spec conf-spec syms strs) (define (lookup-conf-spec conf-spec syms strs)
(let ((sym (car syms)) (let ((sym (car syms))
(str (car strs))) (str (car strs)))
@ -55,43 +71,44 @@
((and (pair? (cddr x)) (member `(not ,ch) (car (cddr x)))) ((and (pair? (cddr x)) (member `(not ,ch) (car (cddr x))))
`(not ,x)) `(not ,x))
(else (lp (cdr ls)))))))) (else (lp (cdr ls))))))))
(define (parse-conf-spec str args) (define (parse-long-option str args fail)
(let* ((strs (string-split str #\.)) (let* ((str+val (string-split str #\= 2))
(str (car str+val))
(args (if (pair? (cdr str+val)) (cons (cadr str+val) args) args))
(strs (string-split str #\.))
(syms (map string->symbol strs)) (syms (map string->symbol strs))
(spec (lookup-conf-spec conf-spec syms strs))) (spec (lookup-conf-spec conf-spec syms strs)))
(cond (cond
((not spec) ((not spec)
#f) ;; check for 'no' prefix on boolean
((and (pair? spec) (eq? 'not (car spec))) (if (not (string-prefix? "no" str))
(cons (cons (append prefix (list (car spec))) #f) args)) (fail prefix conf-spec (car args) args "unknown option")
((eq? 'boolean (cadr spec)) (let ((res (parse-long-option (substring str 2) args (lambda args #f))))
(cons (cons (append prefix (list (car spec))) #t) args))
((null? args)
(error "missing argument to option " str))
(else
(cons (cons (append prefix syms) (parse-value (cadr spec) (car args)))
(cdr args))))))
(define (parse-long-option str args)
(let* ((str+val (string-split str #\= 2))
(str (car str+val))
(args2 (if (pair? (cdr str+val)) (cons (cadr str+val) args) args)))
(or (parse-conf-spec str args2)
(and (string-prefix? "no-" str)
(let ((res (parse-long-option (substring str 3) args)))
(cond (cond
((not res) ((not res)
#f) (fail prefix conf-spec (car args) args "unknown option"))
((not (boolean? (cdar res))) ((not (boolean? (cdar res)))
(error "'no-' prefix only valid on boolean options")) (error "'no' prefix only valid on boolean options"))
(else (else
`(((,@prefix ,(caar res)) . ,(not (cdar res))) `((,(caar res) . #f) ,@(cdr res)))))))
,@(cdr res))))))))) ((and (pair? spec) (eq? 'not (car spec)))
(define (parse-short-option str args) (cons (cons (append prefix (list (car spec))) #f) args))
((and (eq? 'boolean (cadr spec)) (null? (cdr str+val)))
(cons (cons (append prefix (list (car spec))) #t) args))
((null? args)
(fail prefix conf-spec (car args) args "missing argument to option"))
(else
(let ((val+err (parse-value (cadr spec) (car args))))
(if (cadr val+err)
(fail prefix conf-spec (car args) args (cadr val+err))
(cons (cons (append prefix syms) (car val+err))
(cdr args))))))))
(define (parse-short-option str args fail)
(let* ((ch (string-ref str 0)) (let* ((ch (string-ref str 0))
(x (lookup-short-option ch conf-spec))) (x (lookup-short-option ch conf-spec)))
(cond (cond
((not x) ((not x)
#f) (fail prefix conf-spec (car args) args "unknown option"))
((and (pair? x) (eq? 'not (car x))) ((and (pair? x) (eq? 'not (car x)))
(cons (cons (append prefix (list (car (cadr x)))) #f) (cons (cons (append prefix (list (car (cadr x)))) #f)
(if (= 1 (string-length str)) (if (= 1 (string-length str))
@ -103,17 +120,18 @@
args args
(cons (string-append "-" (substring str 1)) args)))) (cons (string-append "-" (substring str 1)) args))))
((> (string-length str) 1) ((> (string-length str) 1)
(cons (cons (append prefix (list (car x))) (let ((val+err (parse-value (cadr x) (substring str 1))))
(parse-value (cadr x) (substring str 1))) (if (cadr val+err)
args)) (fail prefix conf-spec (car args) args (cadr val+err))
(cons (cons (append prefix (list (car x))) (car val+err))
args))))
((null? args) ((null? args)
(error "missing argument to option " x)) (fail prefix conf-spec (car args) args "missing argument to option"))
(else (else
(cons (cons (append prefix (list (car x))) (car args)) (cdr args)))))) (cons (cons (append prefix (list (car x))) (car args)) (cdr args))))))
(or (if (eqv? #\- (string-ref (car args) 1)) (if (eqv? #\- (string-ref (car args) 1))
(parse-long-option (substring (car args) 2) (cdr args)) (parse-long-option (substring (car args) 2) (cdr args) fail)
(parse-short-option (substring (car args) 1) (cdr args))) (parse-short-option (substring (car args) 1) (cdr args) fail)))
(fail prefix conf-spec (car args) args)))
(define (parse-options prefix conf-spec orig-args fail) (define (parse-options prefix conf-spec orig-args fail)
(let lp ((args orig-args) (let lp ((args orig-args)
@ -138,9 +156,9 @@
(else (reverse (cdr (reverse prefix)))))) (else (reverse (cdr (reverse prefix))))))
(let ((fail (if (pair? o) (let ((fail (if (pair? o)
(car o) (car o)
(lambda (prefix spec opt args) (lambda (prefix spec opt args reason)
;; TODO: search for closest option ;; TODO: search for closest option in "unknown" case
(error "unknown option: " opt))))) (error reason opt)))))
(cond (cond
((null? spec) ((null? spec)
(error "no procedure in application spec")) (error "no procedure in application spec"))
@ -149,7 +167,7 @@
((@) ((@)
(let* ((new-opt-spec (cadr (car spec))) (let* ((new-opt-spec (cadr (car spec)))
(new-fail (new-fail
(lambda (new-prefix new-spec opt args) (lambda (new-prefix new-spec opt args reason)
(parse-option (prev-prefix prefix) opt-spec args fail))) (parse-option (prev-prefix prefix) opt-spec 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))