brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Add support for free-form text in command-line description.

Browse source
This commit is contained in:
Dominik Pantůček 2023-04-01 18:46:17 +02:00
parent aeb7ec1d6e
commit 8d514783a0
2 changed files with 56 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/bbstool.scm
View file

@ -74,6 +74,9 @@ CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
(-license () "Show licensing terms"
(print license-text)
(exit 0))
""
"Test"
""
(-members (dir) "Members base directory" (*members-directory* dir))
(-context (n) "Member-File parser Error Context (lines)" (*member-file-context* (string->number n)))
(-mi (id) "Specify member by id" (-member-id- (string->number id)))

89
src/command-line.scm
View file

@ -38,6 +38,7 @@
(chicken base)
(chicken process-context)
(chicken format)
utils
testing)
;; Consumes given number of arguments from the list and returns the
@ -64,21 +65,22 @@
(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))))))
(define (command-line:parse-command-line specs+comments)
(let ((specs (filter (lambda (s) (not (string? s))) specs+comments)))
(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)
@ -92,46 +94,61 @@
;; Prints options descriptions.
(define (command-line:print-options specs)
(let* ((descrs (map (lambda (spec)
(list (car spec)
(procedure->argstring (caddr spec))
(cadr spec)))
(if (string? spec)
spec
(list (car spec)
(procedure->argstring (caddr spec))
(cadr spec))))
specs))
(owidth (apply max (map (lambda (desc)
(string-length (car desc)))
(if (string? desc)
0
(string-length (car desc))))
descrs)))
(awidth (apply max (map (lambda (desc)
(string-length (cadr desc)))
(if (string? desc)
0
(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)
(let ((desc (car descrs)))
(if (string? desc)
(print desc)
(let* ((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 ...)
((_ (opt (args ...) help body ...))
(list (symbol->string 'opt)
help
(lambda (args ...) body ...)))))
(lambda (args ...) body ...)))
((_ str)
str)))
(define-syntax make-options
(syntax-rules ()
((_ exp ...)
(list (make-option exp) ...))))
;; 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 exps ...)
(letrec ((specs (make-options exps ...))
(print-help (lambda ()
(command-line:print-options specs))))
(command-line:parse-command-line specs)))))