ChrysaLisp Argument Processor

argparse.lisp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; argparse - ChrysaLisp Argument Processor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defq +nl+      (ascii-char 10))
(defq +indent2+    2)
(defq +indent4+    4)

; Potential utility macros to embed in ChrysaLisp

(defmacro seq? (form)
  ; (seq? form) -> t|nil
  `(or (lst? ,form) (str? ,form)))

(defmacro first (seq)
    ; (first seq) -> el
    ; Retrieves first element of sequence
    ; Example: (first '(1 2 3)) -> 1
    `(elem 0 ,seq))

(defmacro second (seq)
    ; (second seq) -> el
    ; Retrieves second element from sequence
    ; Example: (second '(1 2 3)) -> 2
    `(elem 1 ,seq))

(defmacro last (seq)
  ; (last seq) -> el
  ; Retrieves last element in sequence
  ; Example: (last '(1 2 3)) -> 3
  `(elem (dec (length ,seq)) ,seq))

(defmacro rest (seq)
  ; (rest seq) -> seq
  ; Returns all but first in sequence
  ; Example: (rest '(1 2 3)) -> (2 3)
  `(if (seq? ,seq)
       (slice 1 -1 ,seq)
       (throw "rest error - not a sequence" ,seq)))

(defmacro stack-peek (stack)
  ; (stack-peek stack) -> el|nil
  `(last ,stack))

(defmacro stack-pop (stack)
  ; (stack-pop stack) -> el|nil
  `(pop ,stack))

(defmacro stack-push (stack el)
  ; (stack-push stack) -> el|nil
  `(push ,stack ,el))

(defmacro stack-empty? (stack)
  `(= (length ,stack) 0))

(defmacro sfind (ss slst)
    `(some (lambda (_tvar)
           (if (eql ,ss _tvar) _)) ,slst))

(defmacro mapcat (fn seq)
  ; (mapcat fn seq)
  `(if (seq? ,seq)
       (reduce (lambda (acc el) (push acc (eval el))) (map ,fn ,seq) (list))
       (throw "mapcat error - not a sequence" ,seq)))

(defun reverse (inlist)
  ; (reverse inlist)
  ; Reverses contents of list
  (if (/= (length inlist) 0)
    (reduce-rev (lambda (acc el)
                (push acc el)) inlist (list))))

; DSL
(def: '(type_none
        type_string
        type_integer
        type_float
        type_boolean
        type_file
        arguments
        in_args
        commands
        application
        version
        help
        argument
        counter
        dest
        type
        validator
        handler
        command) (env))

(defun noop (&rest _) _)

; Main argparse structure template
(defun parser_template ()
      (list
        (list arguments (list))     ; Collection of high level arguments
        (list commands (list))      ; Collection of high level commands
        (list in_args nil)          ; Retain the original command line arguments
        (list application "")       ; Application name string
        (list version "")           ; Application version string
        (list counter 0)            ; Number of free form (not arg or cmd) values
        (list handler noop)         ; fn for parsed command line result
        (list help "")))            ; Help string

;
(defun arg_template ()
      (list
        (list argument nil)         ; The argument flags e.g. ("-s" "--string")
        (list counter 0)            ; Number of values accepted for argument
        (list type type_none)       ; Type for term validation
        (list dest argument)        ; Term for argument parse results
        (list validator noop)       ; Argument value type validator fn
        (list handler noop)         ; fn for parsed argument
        (list help "")))            ; Help string

(defun cmd_template ()
      (list
        (list arguments (list))     ; Arguments for command
        (list command "")           ; Single command string
        (list counter 0)            ; Number of values accepted for command
        (list dest command)         ; Term for command parse results
        (list validator noop)       ; Command value type validator fn
        (list handler noop)         ; fn for parsed command
        (list help "")))            ; Help string

(defun get-property-container (self prop_id)
  ; (get-property-container self prop_id)
  (some (lambda (il)
          (if (eql prop_id (first il))
              il)) self))

(defun get-property (self prop_id &optional ifnil)
  ; (get-property self prop_id [ifnil])
  (defq propc (get-property-container self prop_id))
  (if (second propc)
      (second propc)
      ifnil))

(defun set-property (self prop_id value)
  ; (set-property self prop_id value) -> self
  (defq property (get-property-container self prop_id))
  (when property
      (elem-set 1 property value))
  self)

(defun set-properties (self &rest in_props)
  ; (set-properties self [in_prop]) -> self
  (defq props (reverse in_props))
  (if (/= (logand (length props ) 1) 1)
    (while (/= (length props) 0)
           (set-property self (pop props) (pop props)))
    (throw "Uneven property pairs" in_props))
  self)

(defun extend (self property value)
  ; (extend self property value)
  (defq container (get-property-container self property))
  (when container
    (push (second container) value))
  self)

(defun add-argument (self in_argument)
  ; (add-argument self in_argument)
  (extend self arguments in_argument))

(defun add-command (self in_cmd)
  ; (add-command self in_cmd)
  (extend self commands in_cmd))

(defun container-for (self value container property)
  ; (container-for self value container property)
  ; For a containing type, find a match of
  ; value for a specific properties value
  (defq res (get-property self container '()))
  (some (lambda (el)
                (defq argp (get-property el property))
                (if (or (sfind value argp) (eql value argp))
                    el))
              res))

(defun get-either-container (self value)
  ; (get-either-container self value)
  (if (defq res (container-for self value commands command))
      res
      (container-for self value arguments argument)))

(defun isarg? (arg)
  ; (isarg? value)
  ; tests if argument type which has
  ; '-x' or, by definition, '--xname' prefix
  (cond ((starts-with "-" arg) t) (t nil)))

(defun consume-argument (root self argstack result)
  ; (consume-argument root self argstack result)
  (stack-pop argstack)
  (push result (get-property self dest))
  (defq cnt 0)
  (while
    (and
      (< cnt (get-property self counter))
      (not (stack-empty? argstack))
      (not (get-either-container root (stack-peek argstack))))
        (push result (stack-pop argstack))
        (setq cnt (inc cnt)))
  argstack)

(defun consume-command (root self argstack result)
  ; (consume-command root self argstack result)
  (stack-pop argstack)
  (if (defq cmdi (get-property self handler))
      (push result cmdi)
      (push result (get-property self dest)))
  (defq cmdres (list))
  (push result (walk self argstack cmdres))
  argstack)

(defun walk (self arglist &optional res)
  ; (walk-arguments self arglist)
  (defq result (opt res (list)))
  (while (/= (length arglist) 0)
         (defq current (stack-peek arglist))
         (cond
           ((defq arg_object (container-for self current arguments argument))
              (if arg_object
                  (setq arglist (consume-argument self arg_object arglist result))
                  (throw "Unrecognized argument " current)))
           ((defq cmd_object (container-for self current commands command))
              (if cmd_object
                (setq arglist (consume-command self cmd_object arglist result))
                (throw "Unrecognized command " current)))
           (t (push result (stack-pop arglist)))))
  result)

(defun process-args (self arglist)
  ; (process-args self arglist)
  (if arglist
      (progn
        (defq
          res (walk self arglist)
          invoke (get-property self handler))
        (if (and invoke (/= (length res) 0))
          (invoke self res)
          res))
      arglist))

(defun argcontains (self argstring)
  ; (argcontains self argstring) -> t | nil
  ; Finds a match for string in argument list
  (reduced-reduce
    (lambda (acc el)
      (if (sfind argstring (get-property el argument))
          (reduced el)
          nil))
    (get-property self arguments) '()))

(defun parse (self)
  ; (parse argparse)
  ; Parses and optinally executes command line
  (cond
    ((opt
       (sfind "-h" (get-property self in_args))
       (sfind "--help" (get-property self in_args)))
     (let ((targ (argcontains self "-h")))
       ((get-property targ handler) self)))
    ((opt
       (sfind "-v" (get-property self in_args))
       (sfind "--version" (get-property self in_args)))
     (let ((targ (argcontains self "-v")))
       ((get-property targ handler) self)))
    ((not (get-property self in_args))
      (let ((targ (argcontains self "-h")))
       ((get-property targ handler) self)))
    (t
      (let ((cargs (copy (get-property self in_args))))
        (process-args self cargs)))))

; Help dump

(defun format-row (arg arghelp)
  ;(format-row arg arghelp) -> "-arg,--arg  arghelp"
  (defq colbuff (-  30 (+ (length arg) +indent4+)))
  (str (pad "" +indent4+) arg (pad "" colbuff) arghelp))

(defun format-command-str(cmds)
  ; (format-command-str seq) -> "{el [,el]}"
  (str "{" (join (reduce (lambda (acc el)
              (push acc (get-property el command))) cmds (list))
        ",") "}"))

(defun format-usage-str (self arglist cmdstr)
  ; (format-usage-str self arglist cmdstr) -> "usage ..."
  (str (reduce
         (lambda (acc el)
           (cat acc (str "[" (first (get-property el argument)) "] ")))
         arglist
         (str "usage: " (get-property self application) " "))
    cmdstr " ..."))

(defun dump-help (self)
  ; (dump-help self)
  ; Spits the help tree
  (defq
    arglist (get-property self arguments)
    cmdlist (get-property self commands)
    cmdstr  (format-command-str cmdlist))
  ; Print usage string
  (print (format-usage-str self arglist cmdstr))
  ; Print application help
  (print +nl+ (get-property self help) +nl+)
  ; Print argparse arguments
  (print "optional arguments:")
  (print (reduce (lambda (acc el)
                 (defq args (get-property el argument))
                 (cat acc
                      (format-row (join args ",") (get-property el help))
                      +nl+))
                 arglist ""))
  ; Print argparse commands
  ; TODO: Need additional {cmd [,cmd]} when memory exception fixed
  (when (/= (length cmdlist) 0)
    (print "Actions:" +nl+
           (pad "" +indent2+) cmdstr +nl+
           (reduce (lambda (acc el)
                     (cat acc
                          (format-row
                            (get-property el command)
                            (get-property el help))
                          +nl+))
                   cmdlist ""))))

(defun dump-version (self)
  ; (dump-version self)
  ; Spit the version
  (print (get-property self application)
         (pad "" +indent2+)
         (get-property self version)))

(defun create-argument (args arg_help &optional handler_fn)
  ; (create-argument args arg_help &optional handler_fn)
  ; Create argument block
  (defq instance (arg_template))
  (set-properties instance
                  argument args
                  help arg_help
                  handler (opt handler_fn noop)))

(defun create-command (cmds cmd_help)
  ; (create-command cmds cmd_help)
  ; Create command block
  (defq instance (cmd_template))
  (set-properties instance
                  command cmds
                  help cmd_help))

(defun create-argparse (app_name app_version argstring)
  ; (create-argparse app_name app_version argstring)
  ; Creates the argument processor
  (defq instance (parser_template))
  (defq ha (create-argument
                 '("-h" "--help")
                 "displays application help and exits"
                 dump-help))
  (set-properties ha type type_none)
  (defq va (create-argument
                 '("-v" "--version")
                 "displays application version and exits"
                 dump-version))
  (set-properties va type type_none)
  ; Load up the parser
  (set-properties instance
                  application app_name
                  version app_version
                  in_args (reverse argstring))
  ; Add help and version arguments
  (add-argument instance ha)
  (add-argument instance va))

tstap.lisp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; tstap - Test driver for ChrysaLisp Argument Processor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;imports
(import 'class/lisp.inc)
(import 'cmd/argparse.lisp)

;cat a file to stdout
(defun cat-file (_)
  (if (setq _ (file-stream _))
    (while (defq c (read-char _))
      (prin (char c)))
    (stream-flush (file-stream 'stdout))))

; Designated handler for 'cat' command
(defun fake-cat (self args)
  (when (/= (length args) 0)
    (if (find 'file_name args)
        (cat-file (elem (inc (find 'file_name args)) args))
        (print "cat-> " (join (slice 0 -1 args) " ")))))

; Designated handler for main processor
(defun main-invoke (self args)
  (if (and (first args) (str? (first args)))
      (print args)
      ((first args) self (second args))))

; Build the argparser, command and command arguments
(defun argparse (argv)
  (defq parser (create-argparse (elem 0 argv) "v0.1" (slice 1 -1 argv)))
  (set-properties parser
                  help "Test argparse module"
                  handler main-invoke
                  counter 0)
  (defq cmd (create-command "cat" "emulates the cat command"))
  (set-properties cmd
                  type type_string
                  dest 'cat
                  handler fake-cat)
  (defq fn (create-argument
                 '("-f" "--file")
                 "name of file to cat to stdout"))
  (set-properties fn
                  type type_string
                  counter 1
                  dest 'file_name)
  (add-argument cmd fn)
  (add-command parser cmd)
  parser)

(defun main ()
  (defq stdio (create-stdio))
  (when stdio
    (defq ap (argparse (stdio-get-args stdio)))
    (parse ap)))