diff options
| author | Hugo Hörnquist <hugo@lysator.liu.se> | 2021-12-30 17:14:35 +0100 |
|---|---|---|
| committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-01-21 11:24:34 +0100 |
| commit | a5e3000659db309cfd23f8b50fa852a1fee25b60 (patch) | |
| tree | 635ed35d8c12666ff07459b025fe396b1063e7db /module | |
| parent | Move config print to own flag. (diff) | |
| download | calp-a5e3000659db309cfd23f8b50fa852a1fee25b60.tar.gz calp-a5e3000659db309cfd23f8b50fa852a1fee25b60.tar.xz | |
Clean up (calp util options).
Diffstat (limited to 'module')
| -rw-r--r-- | module/calp/util/options.scm | 72 |
1 files changed, 29 insertions, 43 deletions
diff --git a/module/calp/util/options.scm b/module/calp/util/options.scm index e7158210..20263c45 100644 --- a/module/calp/util/options.scm +++ b/module/calp/util/options.scm @@ -1,56 +1,42 @@ (define-module (calp util options) :use-module (calp util) + :use-module (ice-9 match) :use-module (srfi srfi-1) -) + :use-module (text markup) + ) ;; option-assoc → getopt-valid option-assoc (define-public (getopt-opt options) - (map (lambda (optline) - (cons (car optline) - (map (lambda (opt-field) - (cons (car opt-field) - (cond [(eq? 'value (car opt-field)) - (cond [(cadr opt-field) - list? => (lambda (opts) - (case (car opts) - ;; TODO this should also generate a validator - ((options) '(#t)) - (else '(#t))))] - [(symbol? (cadr opt-field)) '(optional)] - [else (cdr opt-field)])] - [else (cdr opt-field)]))) - (lset-intersection (lambda (a b) (eqv? b (car a))) - (cdr optline) - '(single-char required? value predicate))))) - options)) - - + (define ice-9-names '(single-char required? value predicate)) + (for (option-name flags ...) in options + (cons option-name + (map (match-lambda + (('value (_ ...)) `(value #t)) + (('value (? symbol? _)) `(value optional)) + ((key v) `(,key ,v))) + (filter (match-lambda ((key _ ...) (memv key ice-9-names))) + flags))))) ;; (name (key value) ...) → sxml (define (fmt-help option-line) - (let ((name (car option-line)) - (args (cdr option-line))) - (let ((valuefmt (case (and=> (assoc-ref args 'value) car) - [(#t) '(" " (i value))] - [(#f) '()] - [else => (lambda (s) - (if (list? s) - (case (car s) - [(options) - `(" {" ,(string-join (cdr s) "|") "}")]) - `(" [" (i ,s) "]")))]))) - `(*TOP* (b "--" ,name) ,@valuefmt - ,@(awhen (assoc-ref args 'single-char) - `("," (ws) - (b "-" ,(car it)) - ,@valuefmt)) - (br) - ,@(awhen (assoc-ref args 'description) - `((blockquote ,@it) - (br))))))) - -(use-modules (text markup)) + (match option-line + ((name args ...) + (let ((valuefmt (match (assoc-ref args 'value) + [(#t) '(" " (i value))] + [(or #f (#f)) '()] + [(('options options ...)) + `(" {" ,(string-join options "|") "}")] + [(s) `(" [" (i ,s) "]")]))) + `(*TOP* (b "--" ,name) ,@valuefmt + ,@(awhen (assoc-ref args 'single-char) + `("," (ws) + (b "-" ,(car it)) + ,@valuefmt)) + (br) + ,@(awhen (assoc-ref args 'description) + `((blockquote ,@it) + (br)))))))) (define-public (format-arg-help options) (sxml->ansi-text (cons '*TOP* (map sxml->ansi-text (map fmt-help options))))) |