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

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)))

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)
+ (define (command-line:parse-command-line specs+comments)
-   (let loop ((args (get-command-line-arguments)))
+   (let ((specs (filter (lambda (s) (not (string? s))) specs+comments)))
-     (when (not (null? args))
+     (let loop ((args (get-command-line-arguments)))
-       (let* ((arg (car args))
+       (when (not (null? args))
-	      (specp (assoc arg specs)))
+	 (let* ((arg (car args))
-	 (when (not specp)
+		(specp (assoc arg specs)))
-	   (error 'parse-command-line "Unknown argument" arg))
+	   (when (not specp)
-	 (let* ((proc (caddr specp))
+	     (error 'parse-command-line "Unknown argument" arg))
-		(info (procedure-information proc))
+	   (let* ((proc (caddr specp))
-		(nargs (- (length info) 1))
+		  (info (procedure-information proc))
-		(aargsl (consume-args (cdr args) nargs))
+		  (nargs (- (length info) 1))
-		(args (car aargsl))
+		  (aargsl (consume-args (cdr args) nargs))
-		(aargs (cadr aargsl)))
+		  (args (car aargsl))
-	   (apply proc aargs)
+		  (aargs (cadr aargsl)))
-	   (loop args))))))
+	     (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)
+			 (if (string? spec)
-			       (procedure->argstring (caddr spec))
+			     spec
-			       (cadr 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))
+	 (let ((desc (car descrs)))
-		(opt (car desc))
+	   (if (string? desc)
-		(args (cadr desc))
+	       (print desc)
-		(help (caddr desc)))
+	       (let* ((opt (car desc))
-	   (print "  "
+		      (args (cadr desc))
-		  opt
+		      (help (caddr desc)))
-		  (make-string (- owidth (string-length opt)) #\space)
+		 (print "  "
-		  " "
+			opt
-		  args
+			(make-string (- owidth (string-length opt)) #\space)
-		  (make-string (- awidth (string-length args)) #\space)
+			" "
-		  "  "
+			args
-		  help)
+			(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 ...) ...)
+     ((_ print-help exps ...)
-      (letrec ((specs (list (make-option exps ...) ...))
+      (letrec ((specs (make-options exps ...))
 	       (print-help (lambda ()
 			     (command-line:print-options specs))))
 	(command-line:parse-command-line specs)))))