Write the CLI frontend.

1 files changed, 101 insertions, 0 deletions

diff --git a/csc/flag.csc b/csc/flag.csc
new file mode 100644
index 0000000..ea699db
--- /dev/null
+++ b/csc/flag.csc
@@ -0,0 +1,101 @@
+(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 (csc hash-map)
+            compare-strings
+            key-not-found-error?
+            lookup
+            make-map)
+          (only (csc loop)
+            loop)
+          (only (csc strings)
+            prefix?
+            contains?))
+  (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))
+
+
+    (define-syntax define-flag
+      (syntax-rules ()
+        ((define-flag name flag type default)
+          (define name (begin
+                         (set! *parsers* (insert *parsers* flag (lambda (x) (set! name (type x)))))
+                         default)))))
+
+
+    (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 parser (guard (e ((key-not-found-error? e)
+                                       (raise (make-parse-error "flag provided but not defined" s))))
+                             (lookup *parsers* name)))
+            (if (eq? parser bool-flag)  ; Special case: doesn't need an arg.
+              (if value
+                (parser value)
+                (parser "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-flag "flag needs an argument" s)))
+                (parser value)))
+            #t)))
+      (loop while (parse-one))
+      (set! *args* args))))