152 lines
4.6 KiB
Scheme
152 lines
4.6 KiB
Scheme
;;
|
|
;; command-line.scm
|
|
;;
|
|
;; Argument parsing on command-line with interpreter -- support.
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023 Brmlab, z.s.
|
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; Permission to use, copy, modify, and/or distribute this software
|
|
;; for any purpose with or without fee is hereby granted, provided
|
|
;; that the above copyright notice and this permission notice appear
|
|
;; in all copies.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
;;
|
|
|
|
(declare (unit command-line))
|
|
|
|
(module
|
|
command-line
|
|
(
|
|
command-line
|
|
command-line:parse-command-line
|
|
command-line:print-options
|
|
command-line-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken process-context)
|
|
(chicken format)
|
|
testing)
|
|
|
|
;; Consumes given number of arguments from the list and returns the
|
|
;; remainder of the list and a list of arguments consumed.
|
|
(define (consume-args args num)
|
|
(let loop ((args args)
|
|
(res '())
|
|
(num num))
|
|
(if (= num 0)
|
|
(list args (reverse res))
|
|
(if (null? args)
|
|
(error 'consume-args "Not enough arguments" num)
|
|
(loop (cdr args)
|
|
(cons (car args) res)
|
|
(- num 1))))))
|
|
|
|
;; Gets command-line arguments after the "--" of csi (not useful when
|
|
;; compiled)
|
|
(define (get-command-line-arguments . explicit-argv)
|
|
(let* ((args (if (null? explicit-argv) (argv) explicit-argv))
|
|
(rargs (member "--" args)))
|
|
(if rargs
|
|
(cdr rargs)
|
|
(cdr args))))
|
|
|
|
;; Performs the actual parsing based on specification.
|
|
(define (command-line:parse-command-line specs)
|
|
(let loop ((args (get-command-line-arguments)))
|
|
(when (not (null? args))
|
|
(let* ((arg (car args))
|
|
(specp (assoc arg specs)))
|
|
(when (not specp)
|
|
(error 'parse-command-line "Unknown argument" arg))
|
|
(let* ((proc (caddr specp))
|
|
(info (procedure-information proc))
|
|
(nargs (- (length info) 1))
|
|
(aargsl (consume-args (cdr args) nargs))
|
|
(args (car aargsl))
|
|
(aargs (cadr aargsl)))
|
|
(apply proc aargs)
|
|
(loop args))))))
|
|
|
|
;; String representation of procedure arguments.
|
|
(define (procedure->argstring proc)
|
|
(let* ((info (procedure-information proc))
|
|
(args (cdr info))
|
|
(argss (sprintf "~A" args)))
|
|
(substring
|
|
(substring argss 0 (- (string-length argss) 1))
|
|
1)))
|
|
|
|
;; Prints options descriptions.
|
|
(define (command-line:print-options specs)
|
|
(let* ((descrs (map (lambda (spec)
|
|
(list (car spec)
|
|
(procedure->argstring (caddr spec))
|
|
(cadr spec)))
|
|
specs))
|
|
(owidth (apply max (map (lambda (desc)
|
|
(string-length (car desc)))
|
|
descrs)))
|
|
(awidth (apply max (map (lambda (desc)
|
|
(string-length (cadr desc)))
|
|
descrs))))
|
|
(let loop ((descrs descrs))
|
|
(when (not (null? descrs))
|
|
(let* ((desc (car descrs))
|
|
(opt (car desc))
|
|
(args (cadr desc))
|
|
(help (caddr desc)))
|
|
(print " "
|
|
opt
|
|
(make-string (- owidth (string-length opt)) #\space)
|
|
" "
|
|
args
|
|
(make-string (- awidth (string-length args)) #\space)
|
|
" "
|
|
help)
|
|
(loop (cdr descrs)))))))
|
|
|
|
;; Syntax for expanding various types of options.
|
|
(define-syntax make-option
|
|
(syntax-rules ()
|
|
((_ opt (args ...) help body ...)
|
|
(list (symbol->string 'opt)
|
|
help
|
|
(lambda (args ...) body ...)))))
|
|
|
|
;; Simple syntax wrapper for command-line arguments specification and
|
|
;; immediate parsing.
|
|
(define-syntax command-line
|
|
(syntax-rules ()
|
|
((_ print-help (exps ...) ...)
|
|
(letrec ((specs (list (make-option exps ...) ...))
|
|
(print-help (lambda ()
|
|
(command-line:print-options specs))))
|
|
(command-line:parse-command-line specs)))))
|
|
|
|
;; Performs self-tests of the command-line module
|
|
(define (command-line-tests!)
|
|
(run-tests
|
|
command-line
|
|
(test-exn consume-args (consume-args '(1 2 3) 4))
|
|
(test-equal? consume-args (consume-args '(1 2 3 4) 2) '((3 4) (1 2)))
|
|
(test-equal? get-command-line-arguments (get-command-line-arguments 1 2 3) '(2 3))
|
|
(test-equal? get-command-line-arguments (get-command-line-arguments 1 "--" 2 3) '(2 3))
|
|
(test-equal? procedure->argstring (procedure->argstring (lambda (x . y) 1)) "x . y")
|
|
(test-equal? procedure->argstring (procedure->argstring (lambda (x) 1)) "x")
|
|
(test-equal? procedure->argstring (procedure->argstring (lambda () 1)) "")
|
|
))
|
|
|
|
)
|