1 files changed, 119 insertions, 0 deletions
diff --git a/lib/csc/flag.csc b/lib/csc/flag.csc
new file mode 100644
index 0000000..c0a28a8
--- /dev/null
+++ b/lib/csc/flag.csc
@@ -0,0 +1,119 @@
+(define-library (csc flag)
+  (export
+    *args*
+    bool-flag
+    define-bool-flag
+    define-flag
+    parse-error-flag
+    parse-error-msg
+    parse-error?
+    parse-flags)
+  (import (scheme base)
+          (only (scheme process-context)
+            command-line)
+          (only (csc hash-map)
+            compare-strings
+            insert
+            key-not-found-error?
+            lookup
+            make-map)
+          (only (csc loop)
+            loop)
+          (only (csc match)
+            match)
+          (only (csc strings)
+            contains?
+            has-prefix?
+            split))
+  (begin
+
+
+    (define (bool-flag s)
+      (cond
+        ((member s '("1" "t" "T" "true" "TRUE" "True"))
+          #t)
+        ((member s '("0" "f" "F" "false" "FALSE" "False"))
+          #f)
+        (else (error "Argument could not be parsed as a boolean" s))))
+
+
+    (define *parsers* (make-map compare-strings))
+    ; I'm working around a Guile bug, which wrongly concludes
+    ; that *parsers* is immutable.
+    (set! *parsers* *parsers*)
+
+
+    (define-record-type <flag>
+      (make-flag bool? setter)
+      flag?
+      (bool? flag-bool?)
+      (setter flag-setter))
+
+
+    (define-syntax define-flag
+      (syntax-rules ()
+        ((define-flag name flag type default)
+          (begin
+            (define name default)
+            (set! *parsers* (insert *parsers* flag
+                              (make-flag (eq? type bool-flag)
+                                         (lambda (x) (set! name (type x))))))))))
+
+
+    (define *args* '())
+
+
+    (define-record-type <parse-error>
+      (make-parse-error msg flag)
+      parse-error?
+      (msg parse-error-msg)
+      (flag parse-error-flag))
+
+
+    (define (parse-flags)
+      (define args (cdr (command-line)))
+      ; Is this legal?
+      (define (parse-one)
+        (match args
+          ('() #f)
+          ((s . _) when (or (not (has-prefix? s "-"))
+                            (string=? "-" s))
+            #f)
+          ((s . rest) when (string=? "--" s)
+            (set! args rest)
+            #f)
+          ((s . rest)
+            (define name (if (has-prefix? s "--")
+                           (string-copy s 2)
+                           (string-copy s 1)))
+            (when (or (string=? "" name)
+                      (has-prefix? name "-")
+                      (has-prefix? name "="))
+              (raise (make-parse-error "bad flag syntax" s)))
+            ; It's a flag. Does it have an argument?
+            (set! args rest)
+            (define value (match (split name "=" 2)
+                            ((a b)
+                              (set! name a)
+                              b)
+                            (_ #f)))
+            (define flag (guard (e ((key-not-found-error? e)
+                                     (raise (make-parse-error "flag provided but not defined" s))))
+                           (lookup *parsers* name)))
+            (if (flag-bool? flag)  ; Special case: doesn't need an arg.
+              (if value
+                ((flag-setter flag) value)
+                ((flag-setter flag) "true"))
+              (begin
+                ; It must have a value, which might be the next argument.
+                (when (and (not value)
+                           (not (null? args)))
+                  ; value is the next arg
+                  (set! value (car args))
+                  (set! args (cdr args)))
+                (unless value
+                  (raise (make-parse-error "flag needs an argument" s)))
+                ((flag-setter flag) value)))
+            #t)))
+      (loop while (parse-one))
+      (set! *args* args))))