changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/cli/clap/opt.lisp

changeset 683: c5fe76568de0
parent: 65102f74d1ae
child: 517c65b51e6b
author: Richard Westhaver <ellis@rwest.io>
date: Sat, 28 Sep 2024 17:48:06 -0400
permissions: -rw-r--r--
description: fixed clap objects to support make-load-form method - thunk is symbol only 
     1 ;;; cli/clap/opt.lisp --- Clap Opts
     2 
     3 ;; CLI Opt Objects
     4 
     5 ;;; Code:
     6 (in-package :cli/clap/obj)
     7 
     8 ;;; Parsers
     9 (make-opt-parser string *arg*)
    10 
    11 (make-opt-parser boolean (when *arg* t))
    12 
    13 (make-opt-parser (form string) (read-from-string *arg*))
    14 
    15 (make-opt-parser (list form) (when (listp *arg*) *arg*))
    16 
    17 (make-opt-parser (symbol form) (when (symbolp *arg*) *arg*))
    18 
    19 (make-opt-parser (keyword form) (when (keywordp *arg*) *arg*))
    20 
    21 (make-opt-parser number (when *arg* (parse-number *arg*)))
    22 
    23 (make-opt-parser integer (when *arg* (parse-integer *arg*)))
    24 
    25 (make-opt-parser (file string) 
    26   (parse-native-namestring *arg* nil *default-pathname-defaults* :as-directory nil))
    27 
    28 (make-opt-parser (directory string)
    29   (sb-ext:parse-native-namestring *arg* nil *default-pathname-defaults* :as-directory t))
    30 
    31 (make-opt-parser (pathname string)
    32   (pathname *arg*))
    33 
    34 ;;; Objects
    35 (defstruct cli-opt
    36   ;; note that cli-opts can have a nil or unbound name slot
    37   (name "" :type string)
    38   (kind 'boolean :type (or symbol list))
    39   (thunk 'identity :type symbol)
    40   (val nil)
    41   (global nil :type boolean)
    42   (description nil :type (or null string))
    43   (lock nil :type boolean))
    44 
    45 (defmethod cli-name ((self cli-opt))
    46   (cli-opt-name self))
    47 
    48 (defmethod activate-opt ((self cli-opt))
    49   (setf (cli-opt-lock self) t))
    50 
    51 (defun %compose-short-opt (o)
    52   (setf (cli-opt-val o) t)
    53   (make-cli-node 'opt o))
    54 
    55 (defun %compose-long-opt (o &optional val)
    56   (setf (cli-opt-val o) val)
    57   (make-cli-node 'opt o))
    58 
    59 (defun %compose-keyword-opt (o val)
    60   (setf (cli-opt-val o) val)
    61   (make-cli-node 'opt o))
    62 
    63 (defmethod handle-unknown-argument ((self cli-opt) arg))
    64 (defmethod handle-missing-argument ((self cli-opt) arg))
    65 (defmethod handle-invalid-argument ((self cli-opt) arg))
    66 
    67 (defmethod initialize-instance :after ((self cli-opt) &key)
    68   (with-slots (name thunk) self
    69     (unless (stringp name) (setf name (format nil "~(~A~)" name)))
    70     self))
    71 
    72 (defmethod make-load-form ((obj cli-opt) &optional env)
    73   (make-load-form-saving-slots
    74    obj
    75    :slot-names '(name kind thunk val global description lock)
    76    :environment env))
    77 
    78 (defmethod install-thunk ((self cli-opt) (lambda function) &optional compile)
    79   "Install THUNK into the corresponding slot in cli-cmd SELF."
    80   (let ((%thunk (if compile (compile nil lambda) lambda)))
    81     (setf (cli-thunk self) %thunk)
    82     self))
    83 
    84 (defmethod print-object ((self cli-opt) stream)
    85   (print-unreadable-object (self stream :type t)
    86     (format stream "~A :global ~A :val ~A"
    87             (cli-opt-name self)
    88             (cli-opt-global self)
    89             (cli-opt-val self))))
    90 
    91 (defmethod print-usage ((self cli-opt) &optional stream)
    92   (format stream "-~(~{~A~^/--~}~)~A~A"
    93           (let ((n (cli-opt-name self)))
    94             (declare (simple-string n))
    95             (list (make-shorty n) n))
    96           (if (cli-opt-global self) "* " " ")
    97           (if-let ((d (and (slot-boundp self 'description) (cli-opt-description self))))
    98             (format stream ":  ~A" d)
    99             "")))
   100 
   101 (defmethod cli-equal ((a cli-opt) (b cli-opt))
   102   (with-slots (name global kind) a
   103     (with-slots ((bn name) (bg global) (bk kind)) b
   104       (and (equal name bn)
   105            (eq global bg)
   106            (equal kind bk)))))
   107 
   108 (defmethod call-opt ((self cli-opt) arg)
   109   (funcall (cli-opt-thunk self) arg))
   110 
   111 (defmethod do-opt ((self cli-opt))
   112   (setf (cli-opt-val self) (call-opt self (cli-opt-val self))))
   113 
   114 (defmethod do-opts ((self vector) &optional global)
   115   (loop for opt across self
   116         do (if global 
   117                (when (cli-opt-global opt)
   118                  (do-opt opt))
   119                (do-opt opt))))
   120 
   121 (defun active-global-opt-p (opt)
   122   "Return non-nil if OPT is active at runtime and global."
   123   (and (cli-opt-lock opt) (cli-opt-global opt)))