Add command line argument options parser

embddr/optargs.scm

@@ -0,0 +1,67 @@
+(define-module (embddr optargs))
+
+(import (srfi srfi-1)
+        (srfi srfi-11)
+        (srfi srfi-37))
+
+(export parse-opts
+        option-get)
+
+;;;
+;;; TODO: Write docs
+;;;
+(define (option-get opts name)
+  (let ((opt (assq name opts)))
+    (if opt
+        (cdr opt)
+        #f)))
+
+(define (option-set opts name value)
+  (if (assq name opts)
+      (map (lambda (opt)
+             (if (eq? (car opt) name)
+                 (cons name value)
+                 opt))
+           opts)
+      (alist-cons name value opts)))
+
+(define (option-add opts name value)
+  (if (assq name opts)
+      (option-set opts name
+                  (cons value
+                        (option-get opts name)))
+      (alist-cons name `(,value) opts)))
+
+;;; opt-spec - '(#\o "option" [none | required | optional | multiple])
+(define (parse-opts args . opt-spec)
+  (args-fold
+   ;; args
+   args
+   ;; options
+   (map (lambda (spec)
+          (let ((char (list-ref spec 0))
+                (name (list-ref spec 1))
+                (type (list-ref spec 2)))
+            (let ((name-str (symbol->string name))
+                  (req? (eq? type 'required))
+                  (opt? (eq? type 'optional))
+                  (many? (eq? type 'multiple)))
+              (option (list char name-str) (or many? req?) opt?
+                      (if many?
+                          (lambda (opt nm arg opts rest error)
+                            (values (if arg
+                                        (option-add opts name arg)
+                                        opts)
+                                    rest
+                                    error))
+                          (lambda (opt nm arg opts rest error)
+                            (values (option-set opts name (if arg arg #t)) rest error)))))))
+        opt-spec)
+   ;; unrecognized options
+   (lambda (opt name arg opts rest error)
+     (values opts rest #t))
+   ;; operands
+   (lambda (operand opts rest error)
+     (values opts (cons operand rest) error))
+   ;; seeds
+   '() '() #f))