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

Extract command-line help information.

Browse source
This commit is contained in:
Dominik Pantůček 2023-03-14 10:53:24 +01:00
parent 70e5079239
commit 9a438758b3
1 changed files with 31 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

32
command-line.scm
View file

@ -33,6 +33,7 @@
(import scheme
(chicken base)
(chicken process-context)
(chicken format)
testing)
;; Consumes given number of arguments from the list and returns the
@ -75,9 +76,35 @@
(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)
(print "options"))
(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)))
(print (car desc)
(cadr desc)
(caddr desc))
(loop (cdr descrs)))))))
;; Syntax for expanding various types of options.
(define-syntax make-option
@ -109,6 +136,9 @@
(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)) "")
))
)