Move sources to separate directory.

command-line.scm

@@ -1,152 +0,0 @@
-;;
-;; command-line.scm
-;;
-;; Argument parsing on command-line with interpreter -- support.
-;;
-;; ISC License
-;;
-;; Copyright 2023 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
-  command-line-tests!
-  )
-
- (import scheme
-	 (chicken base)
-	 (chicken process-context)
-	 (chicken format)
-	 testing)
-
- ;; 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)
-   (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)
-   (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)
-   (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))
-		(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 ...)))))
-
- ;; 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 (lambda ()
-			     (command-line:print-options specs))))
-	(command-line:parse-command-line specs)))))
-
- ;; Performs self-tests of the command-line module
- (define (command-line-tests!)
-   (run-tests
-    command-line
-    (test-exn consume-args (consume-args '(1 2 3) 4))
-    (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)) "")
-    ))
-
- )