Reuse sources from hackerbase.

backend/command-line.scm

@@ -0,0 +1,154 @@
+;;
+;; command-line.scm
+;;
+;; Argument parsing on command-line with interpreter -- support.
+;;
+;; ISC License
+;;
+;; Copyright 2023-2025 Brmlab, z.s.
+;; Dominik Pantůček <dominik.pantucek@trustica.cz>
+;;
+;; Permission to use, copy, modify, and/or distribute this software
+;; for any purpose with or without fee is hereby granted, provided
+;; that the above copyright notice and this permission notice appear
+;; in all copies.
+;; 
+;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
+;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
+;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
+;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
+;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(declare (unit command-line))
+
+(module
+ command-line
+ (
+  command-line
+
+  command-line:parse-command-line
+  command-line:print-options
+  )
+
+ (import scheme
+	 (chicken base)
+	 (chicken process-context)
+	 (chicken format)
+	 srfi-1
+	 util-proc)
+
+ ;; Consumes given number of arguments from the list and returns the
+ ;; remainder of the list and a list of arguments consumed.
+ (define (consume-args args num)
+   (let loop ((args args)
+	      (res '())
+	      (num num))
+     (if (= num 0)
+	 (list args (reverse res))
+	 (if (null? args)
+	     (error 'consume-args "Not enough arguments" num)
+	     (loop (cdr args)
+		   (cons (car args) res)
+		   (- num 1))))))
+
+ ;; Gets command-line arguments after the "--" of csi (not useful when
+ ;; compiled)
+ (define (get-command-line-arguments . explicit-argv)
+   (let* ((args (if (null? explicit-argv) (argv) explicit-argv))
+	  (rargs (member "--" args)))
+     (if rargs
+	 (cdr rargs)
+	 (cdr args))))
+
+ ;; Performs the actual parsing based on specification.
+ (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))
+		  (nargs (procedure-num-args proc))
+		  (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)
+   (let* ((args (procedure-arg-names proc))
+	  (argss (sprintf "~A" args)))
+     (substring
+      (substring argss 0 (- (string-length argss) 1))
+      1)))
+
+ ;; Prints options descriptions.
+ (define (command-line:print-options specs)
+   (let* ((descrs (map (lambda (spec)
+			 (if (string? spec)
+			     spec
+			     (list (car spec)
+				   (procedure->argstring (caddr spec))
+				   (cadr spec))))
+		       specs))
+	  (owidth (apply max (map (lambda (desc)
+				    (if (string? desc)
+					0
+					(string-length (car desc))))
+				  descrs)))
+	  (awidth (apply max (map (lambda (desc)
+				    (if (string? desc)
+					0
+					(string-length (cadr desc))))
+				  descrs))))
+     (let loop ((descrs descrs))
+       (when (not (null? descrs))
+	 (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 ...))
+      (list (symbol->string 'opt)
+	    help
+	    (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 (make-options exps ...))
+	       (print-help (lambda ()
+			     (command-line:print-options specs))))
+	(command-line:parse-command-line specs)))))
+
+ )