changelog shortlog graph tags branches changeset files revisions annotate raw help

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

changeset 698: 96958d3eb5b0
parent: 65102f74d1ae
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; cli/clap/macs.lisp --- Clap Macros
     2 
     3 ;; 
     4 
     5 ;;; Code:
     6 (in-package :cli/clap/macs)
     7 
     8 (defmacro argp (arg &optional (args (args)))
     9   "Test for presence of ARG in ARGS. Return the tail of
    10 ARGS starting from the position of ARG."
    11   `(member ,arg ,args :test 'equal))
    12 
    13 (defmacro make-shorty (name)
    14   "Return the first char of symbol or string NAME."
    15   `(character (aref (if (stringp ,name) ,name (symbol-name ,name)) 0)))
    16 
    17 (defmacro with-cli-handlers (&body body)
    18   "A wrapper which handles common cli errors that may occur during
    19 evaluation of BODY."
    20   `(progn
    21      (if *no-exit*
    22          (sb-ext:enable-debugger)
    23          (sb-ext:disable-debugger))
    24      (unwind-protect
    25           (restart-case
    26               (progn ,@body)
    27             (sb-sys:interactive-interrupt ()
    28               (println ":SIGINT")
    29               (sb-ext:exit :code 130))
    30             (abort ()
    31               :report (lambda (s)
    32                         (write-string
    33                          "Skip to toplevel READ/EVAL/PRINT loop."
    34                          s)
    35                         (log:debug! "CONTINUEing from pre-REPL RESTART-CASE")
    36                         (values)))
    37             (exit ()
    38               :report "Exit SBCL (calling #'EXIT, killing the process)."
    39               ;; :test (lambda (c) (declare (ignore c)) t)
    40               (log:debug! "falling through to EXIT from pre-REPL RESTART-CASE")
    41               (exit :code 1))))
    42      (sb-impl::flush-standard-output-streams)
    43        ;; reset terminal state
    44        #+nil (.ris)))
    45 
    46 ;; TODO fix these macros
    47 (defmacro defcmd (name &body body)
    48   `(defun ,name (args opts)
    49      (declare (ignorable args opts)
    50               (sequence args opts))
    51      (let ((*argc* (length args))
    52            (*optc* (length opts))
    53            (*args* args)
    54            (*opts* opts))
    55        ,@body)))
    56 
    57 (defmacro defopt (name &body body)
    58   `(defun ,name (&optional arg)
    59      (let ((*arg* arg))
    60        ,@body)))
    61 
    62 ;; TODO 2023-10-06: 
    63 ;; (defmacro gen-cli-thunk (pvars &rest thunk)
    64 ;;   "Generate and return a function based on THUNK suitable for the :thunk
    65 ;; slot of cli objects with pandoric bindings PVARS.")
    66 (eval-always
    67   (defmacro make-opt-parser (kind-spec &body body)
    68     "Return a KIND-opt-parser function based on KIND-SPEC which is either a
    69 symbol from *cli-opt-kinds* or a list, and optional BODY which
    70 is a list of handlers for the opt-val."
    71     (let* ((kind (if (consp kind-spec) (car kind-spec) kind-spec))
    72            (super (when (consp kind-spec) (cadr kind-spec)))
    73            (fn-name (symbolicate 'parse- kind '-opt)))
    74       ;; thread em
    75     (let ((fn1 (unless (null super) (symbolicate "PARSE-" super "-OPT"))))
    76       `(defun ,fn-name (&optional arg)
    77          "Parse the cli-opt-val *ARG*."
    78          (declare (ignorable arg))
    79          ,@(if fn1
    80                `((setf *arg* (print (funcall #',fn1 arg))))
    81                `((setf *arg* arg)))
    82          ,@body)))))