argparse.zp

(module "argparse"

  (export (list "handle-args" handle-args))

  (no? ($ (eq? % :no)))
  (wrong? ($ (eq? % :wrong)))
  (our-args zepto:args)

  (in-booleans? (lambda (x) "checks whether x is in booleans"
    (let* ((arg-prefix "-"))
      (begin
        (define all
          (string:join
            (filter (lambda (y) (and
                                  (string=? arg-prefix (substring y 0 1))
                                  (not (string=? arg-prefix (substring y 1 2)))))
                     our-args)))
        (list:matches? (lambda (el) (string=? (string el) x)) (string->list all))))))

  (in-args? (lambda (x) "checks whether x is in args"
    (let* ((arg-prefix "--")
           (search (++ arg-prefix x)))
      (list:matches? (lambda (y) (string=? search y)) our-args))))

  (arg-value? (lambda (x) "return value of x; otherwise returns nil"
    (let* ((args-vec (list->vector our-args))
           (arg-prefix "--")
           (search (++ arg-prefix x))
           (string-prefix (lambda (prefix el) 
                            (let ((len (string:length prefix)))
                              (eq? prefix (substring el 0 len)))))
           (i (+ (list:index our-args search) 1)))
      (if (or (>= i (vector:length args-vec)) (= i 0))
        :no
        (let ((found (vector:ref args-vec i)))
          (if (string-prefix arg-prefix found)
            :wrong
            found))))))

  (print-usage (lambda (desc l)
    (let ((names (reduce (lambda (acc x) (++ acc (x "name") "|")) "" l))
          (make-cap-alnum ($
            (string:upper-case (string:filter char:alphanum? (->string %))))))
      (display (++ "usage: " zepto:name " ["))
      (display (substring names 0 (- (string:length names) 1)))
      (display "]\n\n  ")
      (write desc)
      (write "\nArguments:")
      (map (lambda (x) 
                (display "  ")
                (if (in? x "short")
                  (display (++ "-" (x "short") ", ")))
                (display (++ "--" (x "name")))
                (if (not (eqv? (x "type") :boolean))
                  (display (++ " "
                               (make-cap-alnum (get-from x "type" "string")))))
                (display (++ "  " (get-from x "usage" "")))
                (if (or (get-from x "required" #f)
                        (eq? (x "type") :boolean)
                        (not (in? x "default")))
                  (display " [required argument]"))
                (write ""))
            l)
      nil)))

  (arg-list-parse (lambda (l) 
    "return specified arguments as hash-map"
    (let ((handle (lambda (el)
      (let* ((dflt (lambda (x)
              (if (hash:contains? x "default")
                (x "default")
                :wrong)))
             (default (dflt el))
             (type (el "type"))
             (name (el "name"))
             (short (el "short"))
             (options (el "options"))
             (required (let ((req (el "required"))) (if (nil? req) #t req)))
             (value (arg-value? name))
             (value-correct (if (not (nil? options)) (in? options value) #t))
             (write-not-in-opts (lambda () (begin
                (display (++ "error: argument \"" name "\" must be one of the following: "))
                (display (string:join options ", "))
                (write ".")
                (write ""))))
             (make (curry list name))
             (wrap-wrong (lambda (x) (if x :wrong default)))
             (string->small (lambda (x)
                              (if (boolean? (string->integer x)
                                x
                                (make-small (string->integer x))))))
             (wrong (lambda (x) (if (boolean? x) :wrong x))))
        (cond ((no? value)
                (if (eq? type :boolean)
                  (make (or (in-args? name) 
                            (if (nil? short)
                              #f
                              (in-booleans? short))))
                  (if required
                    (make (wrap-wrong (in-args? name)))
                    (make #f))))
              ((wrong? value) (make value))
              ((not value-correct)
                (begin
                  (write-not-in-opts)
                  (make :wrong)))
              (else (cond ((eq? type :number) (make (wrong (string->number value))))
                          ((eq? type :string) (make value))
                          ((eq? type :list) (make (string->list value)))
                          ((eq? type :vector) (make (list->vector (string->list value))))
                          ((eq? type :symbol) (make (string->symbol value)))
                          ((eq? type :atom) (make (string->symbol (++ ":" value))))
                          ((eq? type :integer) (make (wrong (string->integer value))))
                          ((eq? type :small) (make (wrong (string->small value))))
                          ((eq? type :float) (make (wrong (string->float value))))
                          ((eq? type :rational) (make (wrong (string->rational value))))
                          ((eq? type :complex) (make (wrong (string->complex value))))
                          (else (make :wrong)))))))))
    (make-hash [(handle x) | x <- l]))))

  (handle-args (lambda (desc l . args)
    "parses a program's arguments according to the specifications described by
     <par>l</par>. <par>desc</par> is the program description string.

     A few words about <par>l</par>'s format are in order: it is a list of hashmaps
     of the form:
     <zepto>
     #{\"name\" \"arg-name\"
       \"type\" :arg-type
       \"default\" arg-dflt-value
       \"required\" true-or-false
       \"usage\" \"a string describing the argument\"
       \"options\" (\"a\" \"list\" \"of\" \"allowed\" \"values\")
       \"short\" \"a\"}
      </zepto>

      params:
        - desc: the program description
        - l: a list of known cli options
      complexity: O(n)
      returns: a hashmap of values or nil if an error occurred"
    (if (not (null? args))
      (set! our-args (car args)))
    (let ((x (arg-list-parse l)))
      (if (in? (hash:values x) :wrong)
        (print-usage desc l)
        x)))))