diff --git a/lib/chibi/app.scm b/lib/chibi/app.scm new file mode 100644 index 00000000..b7f5dcde --- /dev/null +++ b/lib/chibi/app.scm @@ -0,0 +1,164 @@ +;; app.scm -- unified option parsing and config +;; Copyright (c) 2012 Alex Shinn. All rights reserved. +;; BSD-style license: http://synthcode.com/license.txt + +;;> Parses command-line options into a config object. + +(define (parse-option prefix conf-spec args fail) + (define (lookup-conf-spec conf-spec syms strs) + (let ((sym (car syms)) + (str (car strs))) + (cond + ((= 1 (length syms)) + (let lp ((ls conf-spec)) + (and (pair? ls) + (let ((x (car ls))) + (cond + ((eq? sym (car x)) x) + ((and (pair? (cddr x)) (member str (car (cddr x)))) x) + ((and (pair? (cddr x)) (member `(not ,str) (car (cddr x)))) + `(not ,x)) + (else (lp (cdr ls)))))))) + (else + (let lp ((ls conf-spec)) + (and (pair? ls) + (let ((x (car ls))) + (cond + ((or (eq? sym (car x)) + (and (pair? (cddr x)) (member str (car (cddr x))))) + (let ((type (cadr x))) + (if (not (and (pair? type) (eq? 'conf (car type)))) + (error "option prefix not a subconf" sym) + (lookup-conf-spec (cdr type) (cdr syms) (cdr strs))))) + (else (lp (cdr ls))))))))))) + (define (lookup-short-option ch spec) + (let lp ((ls spec)) + (and (pair? ls) + (let ((x (car ls))) + (cond + ((and (pair? (cddr x)) (memv ch (car (cddr x)))) + x) + ((and (pair? (cddr x)) (member `(not ,ch) (car (cddr x)))) + `(not ,x)) + (else (lp (cdr ls)))))))) + (define (parse-conf-spec str args) + (let* ((strs (string-split str #\.)) + (syms (map string->symbol strs)) + (spec (lookup-conf-spec conf-spec syms strs))) + (cond + ((not spec) + #f) + ((and (pair? spec) (eq? 'not (car spec))) + (cons (cons (append prefix (list (car spec))) #f) args)) + ((eq? 'boolean (cadr spec)) + (cons (cons (append prefix (list (car spec))) #t) args)) + ((null? args) + (error "missing argument to option " str)) + (else + (cons (cons (append prefix syms) (car args)) (cdr args)))))) + (define (parse-long-option str args) + (let* ((str+val (string-split str #\= 2)) + (str (car str+val)) + (args (if (pair? (cdr str+val)) (cons (cadr str+val) args) args))) + (or (parse-conf-spec str args) + (and (string-prefix? "no-" str) + (let ((res (parse-long-option (substring str 3) args))) + (cond + ((not res) + #f) + ((not (boolean? (cdar res))) + (error "'no-' prefix only valid on boolean options")) + (else + `(((,@prefix ,(caar res)) . ,(not (cdar res))) + ,@(cdr res))))))))) + (define (parse-short-option str args) + (let* ((ch (string-ref str 0)) + (x (lookup-short-option ch conf-spec))) + (cond + ((not x) + #f) + ((and (pair? x) (eq? 'not (car x))) + (cons (cons (append prefix (list (car (cadr x)))) #f) + (if (= 1 (string-length str)) + args + (cons (string-append "-" (substring str 1)) args)))) + ((eq? 'boolean (cadr x)) + (cons (cons (append prefix (list (car x))) #t) + (if (= 1 (string-length str)) + args + (cons (string-append "-" (substring str 1)) args)))) + ((> (string-length str) 1) + (cons (cons (append prefix (list (car x))) (substring str 1)) args)) + ((null? args) + (error "missing argument to option " x)) + (else + (cons (cons (append prefix (list (car x))) (car args)) (cdr args)))))) + (or (if (eqv? #\- (string-ref (car args) 1)) + (parse-long-option (substring (car args) 2) (cdr args)) + (parse-short-option (substring (car args) 1) (cdr args))) + (fail prefix conf-spec (car args) args))) + +(define (parse-options prefix conf-spec orig-args fail) + (let lp ((args orig-args) + (opts (make-conf '() #f (cons 'options orig-args) #f))) + (cond + ((null? args) + (cons opts args)) + ((or (member (car args) '("" "-" "--")) + (not (eqv? #\- (string-ref (car args) 0)))) + (cons opts (if (equal? (car args) "--") (cdr args) args))) + (else + (let ((val+args (parse-option prefix conf-spec args fail))) + (lp (cdr val+args) + (conf-set opts (caar val+args) (cdar val+args)))))))) + +(define (parse-app prefix spec opt-spec args config . o) + (define (next-prefix prefix name) + (append (if (null? prefix) '(command) prefix) (list name))) + (define (prev-prefix prefix) + (cond ((and (= 2 (length prefix)))) + ((null? prefix) '()) + (else (reverse (cdr (reverse prefix)))))) + (let ((fail (if (pair? o) + (car o) + (lambda (prefix spec opt args) + ;; TODO: search for closest option + (error "unknown option: " opt))))) + (cond + ((null? spec) + (error "no procedure in application spec")) + ((pair? (car spec)) + (case (caar spec) + ((@) + (let* ((new-opt-spec (cadr (car spec))) + (new-fail + (lambda (new-prefix new-spec opt args) + (parse-option (prev-prefix prefix) opt-spec args fail))) + (cfg+args (parse-options prefix new-opt-spec args new-fail)) + (config (conf-append (car cfg+args) config)) + (args (cdr cfg+args))) + (parse-app prefix (cdr spec) new-opt-spec args config new-fail))) + ((or) + (any (lambda (x) (parse-app prefix x opt-spec args config)) (cdar spec))) + (else + (if (procedure? (caar spec)) + (list (caar spec) config args) ; TODO: verify, apply defaults + (parse-app prefix (car spec) opt-spec args config fail))))) + ((symbol? (car spec)) + (and (pair? args) + (eq? (car spec) (string->symbol (car args))) + (let ((prefix (next-prefix prefix (car spec)))) + (parse-app prefix (cdr spec) opt-spec (cdr args) config fail)))) + ((procedure? (car spec)) + (list (car spec) config args)) + (else + (if (not (string? (car spec))) + (error "unknown application spec" (car spec))) + (parse-app prefix (cdr spec) opt-spec args config fail))))) + +(define (run-application spec . o) + (let ((args (if (pair? o) (car o) (command-line)))) + (let ((ls (parse-app '() (cdr spec) '() (cdr args) #f))) + (if ls + (apply (car ls) (cadr ls) (car (cddr ls))) + (error "Unknown command: " args))))) diff --git a/lib/chibi/app.sld b/lib/chibi/app.sld new file mode 100644 index 00000000..b89f300b --- /dev/null +++ b/lib/chibi/app.sld @@ -0,0 +1,9 @@ + +(define-library (chibi app) + (export parse-option parse-options parse-app run-application) + (import (scheme base) + (scheme process-context) + (srfi 1) + (chibi config) + (chibi string)) + (include "app.scm"))