changelog shortlog graph tags branches changeset files revisions annotate raw help

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

changeset 643: f901de70a80e
parent: f8b76ced5e2d
child: 65102f74d1ae
author: Richard Westhaver <ellis@rwest.io>
date: Tue, 10 Sep 2024 21:26:30 -0400
permissions: -rw-r--r--
description: opt fixes and test updates 
     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      (setq
    52       *argc* (length args)
    53       *optc* (length opts)
    54       *args* args
    55       *opts* opts)
    56      ,@body))
    57 
    58 (defmacro defopt (name &body body)
    59   `(defun ,name (&optional arg)
    60      (declare (ignorable arg))
    61      (setq *arg* arg)
    62        ,@body))
    63 
    64 ;; TODO 2023-10-06: 
    65 ;; (defmacro gen-cli-thunk (pvars &rest thunk)
    66 ;;   "Generate and return a function based on THUNK suitable for the :thunk
    67 ;; slot of cli objects with pandoric bindings PVARS.")
    68 (eval-always
    69   (defmacro make-opt-parser (kind-spec &body body)
    70     "Return a KIND-opt-parser function based on KIND-SPEC which is either a
    71 symbol from *cli-opt-kinds* or a list, and optional BODY which
    72 is a list of handlers for the opt-val."
    73     (let* ((kind (if (consp kind-spec) (car kind-spec) kind-spec))
    74            (super (when (consp kind-spec) (cadr kind-spec)))
    75            (fn-name (symbolicate 'parse- kind '-opt)))
    76       ;; thread em
    77     (let ((fn1 (unless (null super) (symbolicate "PARSE-" super "-OPT"))))
    78       `(defun ,fn-name (&optional arg)
    79          "Parse the cli-opt-val *ARG*."
    80          (declare (ignorable arg))
    81          ,@(if fn1
    82                `((setf *arg* (print (funcall #',fn1 arg))))
    83                `((setf *arg* arg)))
    84          ,@body)))))