diff --git a/command-line.scm b/command-line.scm index d989aee..d758e0c 100644 --- a/command-line.scm +++ b/command-line.scm @@ -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)) "") )) )