diff --git a/src/bbstool.scm b/src/bbstool.scm index 708f7b5..b26921a 100644 --- a/src/bbstool.scm +++ b/src/bbstool.scm @@ -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))) diff --git a/src/command-line.scm b/src/command-line.scm index 825ce65..c0c24ad 100644 --- a/src/command-line.scm +++ b/src/command-line.scm @@ -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)))))