;;; cli/clap/cmd.lisp --- Clap Commands

 ;; Command Objects used to build CLI Applications.

 ;;; Commentary:

 ;; 

 ;;; Code:

 (in-package :cli/clap/obj)

 (defclass cli-cmd ()

   ;; name slot is required and must be a string

   ((name :initarg :name :initform (required-argument :name) :accessor cli-name :type string)

    (opts :initarg :opts :initform (make-array 0 :element-type 'cli-opt :adjustable t)

          :accessor cli-opts :type (vector cli-opt))

    (cmds :initarg :cmds :initform (make-array 0 :element-type 'cli-cmd :adjustable t)

          :accessor cli-cmds :type (vector cli-cmd))

    (thunk :initform #'default-thunk :initarg :thunk :accessor cli-thunk :type function-lambda-expression)

    (lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean)

    (description :initarg :description :accessor cli-description :type string)

    (args :initform nil :initarg :args :accessor cli-cmd-args))

   (:documentation "CLI command class inherited by both the 'main' command which is executed when

 a CLI is called without arguments, and all subcommands."))

 (defmethod initialize-instance :after ((self cli-cmd) &key)

   (with-slots (name thunk opts cmds) self

     (unless (stringp name) (setf name (format nil "~(~A~)" name)))

     (unless (vectorp cmds) (setf cmds (make-cmds cmds)))

     (unless (vectorp opts) (setf opts (make-opts opts)))

     (when (symbolp thunk) (setf thunk (symbol-function thunk)))

     self))

 (defmethod print-object ((self cli-cmd) stream)

   (print-unreadable-object (self stream :type t)

     (format stream "~A :opts ~A :cmds ~A :args ~A"

             (cli-name self)

             (length (cli-opts self))

             (length (cli-cmds self))

             (length (cli-cmd-args self)))))

 (defmethod print-usage ((self cli-cmd) &optional stream)

   (with-slots (opts cmds) self

     (format stream "~(~A~) ~A~A~A"

             (cli-name self)

             (if-let ((d (and (slot-boundp self 'description) (cli-description self))))

               (format nil ": ~A" d)

               "")

             (if (null opts)

                 ""

                 (format nil "~{~%    ~A~^~}" (loop for o across opts collect (print-usage o nil))))

             (if (null cmds)

                 ""

                 (format nil "~{!~A~}" (loop for c across cmds collect (print-usage c nil)))))))

 (defmethod push-cmd ((self cli-cmd) (place cli-cmd))

   (vector-push self (cli-cmds place)))

 (defmethod push-opt ((self cli-opt) (place cli-cmd))

   (vector-push self (cli-opts place)))

 (defmethod pop-cmd ((self cli-cmd))

   (vector-pop (cli-cmds self)))

 (defmethod pop-opt ((self cli-opt))

   (vector-pop (cli-opts self)))

 (defmethod handle-unknown-opt ((self cli-cmd) (opt string))

   (with-opt-restart-case opt

     (clap-unknown-argument opt 'cli-opt)))

 (defmethod handle-invalid-opt ((self cli-cmd) (opt string) &optional reason)

   (clap-invalid-argument opt :kind 'cli-opt :reason reason))

 (defmethod handle-missing-opt ((self cli-cmd) (opt string))

   (clap-missing-argument opt 'cli-opt))

 (defmethod cli-equal ((a cli-cmd) (b cli-cmd))

   (with-slots (name opts cmds) a

     (with-slots ((bn name) (bo opts) (bc cmds)) b

       (and (string= name bn)

            (if (and (null opts) (null bo))

                t

                (unless (member nil (loop for oa across opts

                                          for ob across bo

                                          collect (cli-equal oa ob)))

                  t))

            (if (and (null cmds) (null bc))

                t

                (unless (member nil (loop for ca across cmds

                                          for cb across bc

                                          collect (cli-equal ca cb)))

                  t))))))

 (defmethod find-cmd ((self cli-cmd) name &optional active)

   (when-let ((c (find name (cli-cmds self) :key #'cli-name :test #'string=)))

     (if active 

         ;; maybe issue warning here? report to user

         (when (cli-lock-p c)

           c)

         c)))

 (defmethod active-cmds ((self cli-cmd))

   (remove-if-not #'cli-lock-p (cli-cmds self)))

 (defmethod find-opts ((self cli-cmd) name &key active recurse)

   (let ((ret))

     (flet ((%find (o obj)

              (when-let ((found (find o (cli-opts obj) :key #'cli-opt-name :test 'equal)))

                (push found ret))))

       (when (and recurse (cli-cmds self))

         (loop for c across (cli-cmds self)

               do (%find name c)))

       (%find name self)

       (when active

         (setf ret (remove-if-not #'cli-lock-p ret)))

       ret)))

 (defmethod active-opts ((self cli-cmd) &optional global)

   (remove-if-not 

    (if global 

        #'active-global-opt-p

        #'cli-opt-lock)

    (cli-opts self)))

 (defmethod find-short-opts ((self cli-cmd) ch &key recurse)

   (let ((ret))

     (flet ((%find (ch obj)

              (when-let ((found (find ch (cli-opts obj) :key #'cli-opt-name :test #'opt-string-prefix-eq)))

                (push found ret))))

       (when (and recurse (cli-cmds self))

         (loop for c across (cli-cmds self)

               do (%find ch c)))

       (%find ch self)

       ret)))

 (declaim (inline solop))

 (defun solop (self)

   (and (= 0 (length (active-cmds self)) (length (active-opts self)))))

 (defmacro with-opt-restart-case (arg condition)

   "Bind restarts 'use-as-arg' and 'discard-arg' for duration of BODY."

   `(restart-case ,condition

      (use-as-arg () () (make-cli-node 'arg ,arg))

      (discard-arg () () (setf ,arg nil))))

 (defmethod proc-args ((self cli-cmd) args)

   "Process ARGS into an ast. Each element of the ast is a node with a

 :kind slot, indicating the type of node and a :form slot which stores

 a value."

   (make-cli-ast

              (with-opt-restart-case a

 (defmethod install-ast ((self cli-cmd) (ast cli-ast))

   "Install the given AST, recursively filling in value slots."

   (with-slots (cmds opts) self

     ;; we assume all nodes in the ast have been validated and the ast

     ;; itself is consumed. validation is performed in proc-args.

     ;; before doing anything else we lock SELF, which should remain

     (loop named install

           until (null node)

           do 

              (let ((kind (cli-node-kind node)) (form (cli-node-form node)))

                (case kind

                  ;; opts 

                  (opt

                   (let ((name (cli-opt-name form)))

                     (when-let ((o (car (find-opts self name))))

                       (setf o form)

                       (setf (cli-opt-lock o) t))))

                  ;; when we encounter a command we recurse over the tail

                  (cmd 

                   (when-let ((c (find-cmd self (cli-name form))))

                     ;; handle the rest of the AST

                     (setf c (install-ast c (make-cli-ast tail)))

                     (return-from install)))

                  (arg (push-arg form self)))))

     (setf (cli-cmd-args self) (nreverse (cli-cmd-args self)))

     self))

 (defmethod install-thunk ((self cli-cmd) (lambda function) &optional compile)

   "Install THUNK into the corresponding slot in cli-cmd SELF."

   (let ((%thunk (if compile (compile nil lambda) lambda)))

     (setf (cli-thunk self) %thunk)

     self))

 (defmethod push-arg (arg (self cli-cmd))

   "Push an ARG onto the corresponding slot of a CLI-CMD."

   (push arg (cli-cmd-args self)))

 (defmethod parse-args ((self cli-cmd) args &key (compile t))

   "Parse ARGS and return the updated object SELF.

 ARGS is assumed to be a valid cli-ast (list of cli-nodes), unless COMPILE is

 t, in which case a list of strings is assumed."

   (with-slots (opts cmds) self

     (let ((args (if compile (proc-args self args) args)))

       (install-ast self args))))

 ;; WARNING: make sure to fill in the opt and cmd slots with values

 ;; from the top-level args before calling a command.

 (defmethod call-cmd ((self cli-cmd) args opts)

   (trace! "calling command:" args opts)

   (funcall (cli-thunk self) args opts))

 (defmethod do-cmd ((self cli-cmd))

   "Perform the command, recursively calling child commands and opts if necessary."

   (loop for o across (active-opts self)

         do (do-opt o))

   (if (solop self)

       (call-cmd self (cli-cmd-args self) (active-opts self))

       (loop for c across (active-cmds self)

             do (do-cmd c))))