changelog shortlog graph tags branches changeset files revisions annotate raw help

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

changeset 561: 42bc1432f217
parent: b9c64be96888
child: 18143155dc5c
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 26 Jul 2024 23:55:27 -0400
permissions: -rw-r--r--
description: bin 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           (handler-case (progn ,@body)
    26             (sb-sys:interactive-interrupt ()
    27               (println ":SIGINT")
    28               (sb-ext:exit :code 130)))
    29        ;; reset terminal state
    30        #+nil (.ris))))
    31 
    32 ;; TODO fix these macros
    33 (defmacro defcmd (name &body body)
    34   `(defun ,name (args opts) 
    35      (declare (ignorable args opts))
    36      (setq *argc* (length args)
    37            *optc* (length opts))
    38      ,@body))
    39 
    40 (defmacro defopt (name &body body)
    41   `(defun ,name (&optional arg)
    42      (declare (ignorable arg))
    43      (setq *arg* arg)
    44        ,@body))
    45 
    46 (declaim (inline walk-cli-slots))
    47 (defun walk-cli-slots (cli)
    48   "Walk the plist CLI, performing actions as necessary based on the slot
    49 keys."
    50   (loop for kv in (group cli 2)
    51         when (eql :thunk (car kv))
    52         return (let ((th (cdr kv)))
    53                  (if (or (functionp th) (symbolp th)) (funcall th) (compile nil (lambda () th)))))
    54   cli)
    55 
    56 ;; TODO 2023-10-06: 
    57 ;; (defmacro gen-cli-thunk (pvars &rest thunk)
    58 ;;   "Generate and return a function based on THUNK suitable for the :thunk
    59 ;; slot of cli objects with pandoric bindings PVARS.")
    60 (eval-always
    61   (defmacro make-opt-parser (kind-spec &body body)
    62     "Return a KIND-opt-parser function based on KIND-SPEC which is either a
    63 symbol from *cli-opt-kinds* or a list, and optional BODY which
    64 is a list of handlers for the opt-val."
    65     (let* ((kind (if (consp kind-spec) (car kind-spec) kind-spec))
    66            (super (when (consp kind-spec) (cadr kind-spec)))
    67            (fn-name (symbolicate 'parse- kind '-opt)))
    68       ;; thread em
    69     (let ((fn1 (unless (null super) (symbolicate "PARSE-" super "-OPT"))))
    70       `(defun ,fn-name (&optional arg)
    71          "Parse the cli-opt-val *ARG*."
    72          (declare (ignorable arg))
    73          ,@(when fn1 `((setf *arg* (funcall #',fn1 arg))))
    74          ,@body)))))