1.1--- a/lisp/ffi/btrfs.asd	Mon Oct 16 19:33:42 2023 -0400
     1.2+++ b/lisp/ffi/btrfs.asd	Mon Oct 16 22:25:50 2023 -0400
     1.3@@ -9,7 +9,7 @@
     1.4   :maintainer "ellis <ellis@rwest.io>"
     1.5   :homepage "https://nas-t.net"
     1.6   :bug-tracker "https://lab.rwest.io/comp/core/issues"
     1.7-  :depends-on (:macs :sxp)
     1.8+  :depends-on (:std :sxp)
     1.9   :in-order-to ((test-op (test-op "btrfs/tests")))
    1.10   :components ((:file "btrfs/btrfs")))))
    1.11 

     2.1--- a/lisp/lib/cli.asd	Mon Oct 16 19:33:42 2023 -0400
     2.2+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.3@@ -1,14 +0,0 @@
     2.4-(defsystem "cli"
     2.5-  :version "0.1.0"
     2.6-  :author "ellis <ellis@rwest.io>"
     2.7-  :description "command-line ui framework"
     2.8-  :bug-tracker "https://lab.rwest.io/ellis/macs/issues"
     2.9-  :source-control (:hg "https://lab.rwest.io/ellis/macs")
    2.10-  :depends-on (:macs :sxp)
    2.11-  :in-order-to ((test-op (test-op "cli/tests")))
    2.12-  :components ((:file "cli/cli")))
    2.13-
    2.14-(defsystem :cli/tests
    2.15-  :depends-on (:macs :rt :cli)
    2.16-  :components ((:file "cli/tests"))
    2.17-  :perform (test-op (op c) (uiop:symbol-call '#:rt '#:do-tests :cli)))

     3.1--- a/lisp/lib/cli/cli.lisp	Mon Oct 16 19:33:42 2023 -0400
     3.2+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.3@@ -1,781 +0,0 @@
     3.4-;;; cli.lisp --- cli programming api and utils
     3.5-
     3.6-;; This package contains a simple api and macros for building lisp CLI
     3.7-;; programs.
     3.8-
     3.9-;;; Commentary:
    3.10-
    3.11-;; - inspired by: clingon, uiop
    3.12-
    3.13-;; Basic assumptions at runtime:
    3.14-;;   - running in a POSIX-compliant shell
    3.15-;;   - output stream supports UTF-8
    3.16-
    3.17-;; TODO 2023-10-14: install-ast, install-thunk, proc-args, etc should
    3.18-;; return IR types - CLI-IR THUNK and CLI-IR respectively.
    3.19-
    3.20-;; TODO 2023-10-14: rename cli-ast to cli-ir, install-ast to
    3.21-;; install-ir, etc.
    3.22-
    3.23-;;; Code:
    3.24-(pkg:defpkg :cli
    3.25-  (:use :cl :sym :cond :fu :str :ana :fmt :log)
    3.26-  (:import-from :ana :alet)
    3.27-  (:import-from :uiop :println)
    3.28-  (:import-from :sb-posix :filename-designator)
    3.29-  (:import-from :sb-ext :parse-native-namestring)
    3.30-  (:shadowing-import-from :sb-ext :exit)
    3.31-  (:export
    3.32-   :*argv*
    3.33-   :init-args
    3.34-   :cli-arg0
    3.35-   :cli-args
    3.36-   :command-line-args
    3.37-   :*cli-group-separator*
    3.38-   :*cli-opt-kinds*
    3.39-   :global-opt-p
    3.40-   :exec-path-list
    3.41-   :argp
    3.42-   :$val
    3.43-   :$args
    3.44-   :$argc
    3.45-   :$opts
    3.46-   :$optc
    3.47-   :make-shorty
    3.48-   :with-cli-handlers
    3.49-   :completing-read
    3.50-   :make-prompt!
    3.51-   :defmain
    3.52-   :main
    3.53-   :with-cli
    3.54-   :make-cli
    3.55-   ;; opt-parsers
    3.56-   :make-opt-parser
    3.57-   :parse-bool-opt
    3.58-   :parse-str-opt
    3.59-   :parse-form-opt
    3.60-   :parse-list-opt
    3.61-   :parse-sym-opt
    3.62-   :parse-key-opt
    3.63-   :parse-num-opt
    3.64-   :parse-str-opt
    3.65-   :parse-file-opt
    3.66-   :parse-dir-opt
    3.67-   :make-opts
    3.68-   :make-cmds
    3.69-   :active-opts
    3.70-   :active-cmds
    3.71-   :proc-args
    3.72-   :make-cli-node
    3.73-   :make-cli-ast
    3.74-   :proc-args
    3.75-   :parse-args
    3.76-   :debug-opts
    3.77-   :do-cmd
    3.78-   :do-opt
    3.79-   :call-opt
    3.80-   :call-cmd
    3.81-   :apply-cmd
    3.82-   :print-help
    3.83-   :print-version
    3.84-   :print-usage
    3.85-   :handle-unknown-argument
    3.86-   :handle-missing-argument
    3.87-   :handle-invalid-argument
    3.88-   :cli-opt
    3.89-   :cli-val
    3.90-   :cli-cmd-args
    3.91-   :cli-cmd
    3.92-   :cli-cwd
    3.93-   :find-cmd
    3.94-   :find-opt
    3.95-   :find-short-opt
    3.96-   :install-ast
    3.97-   ;; :gen-cli-thunk
    3.98-   :install-thunk
    3.99-   :cli
   3.100-   :cli-equal
   3.101-   :defopt
   3.102-   :defcmd
   3.103-   :define-cli
   3.104-   ;; ast types
   3.105-   :opt
   3.106-   :cmd
   3.107-   :arg
   3.108-   :cli-name
   3.109-   :cli-opts
   3.110-   :cli-cmds
   3.111-   :cli-thunk
   3.112-   :cli-description
   3.113-   :cli-version
   3.114-   :cli-usage))
   3.115-
   3.116-(in-package :cli)
   3.117-
   3.118-(defun cli-arg0 () (car sb-ext:*posix-argv*))
   3.119-(defun cli-args () (cdr sb-ext:*posix-argv*))
   3.120-
   3.121-(declaim (inline exec-path-list))
   3.122-(defun exec-path-list ()
   3.123-  (let ((var (sb-posix:getenv "PATH")))
   3.124-    (mapcar #'directory
   3.125-	    (loop for i = 0 then (1+ j)
   3.126-		  as j = (position #\: var :start i)
   3.127-		  collect (subseq var i j)
   3.128-		while j))))
   3.129-
   3.130-(defparameter *cli-group-separator*
   3.131-  "--"
   3.132-  "A marker specifying the end of a unique group of CLI args.")
   3.133-
   3.134-;; uiop:command-line-arguments
   3.135-
   3.136-;;; Macros
   3.137-(defmacro argp (arg &optional (args (cli-args)))
   3.138-  "Test for presence of ARG in ARGS. Return the tail of
   3.139-ARGS starting from the position of ARG."
   3.140-  `(member ,arg ,args :test #'string=))
   3.141-
   3.142-(defmacro make-shorty (name)
   3.143-  "Return the first char of symbol or string NAME."
   3.144-  `(character (aref (if (stringp ,name) ,name (symbol-name ,name)) 0)))
   3.145-
   3.146-;; (defun treat-as-argument (condition)
   3.147-;;   "A handler which can be used to invoke the `treat-as-argument' restart"
   3.148-;;   (invoke-restart (find-restart 'treat-as-argument condition)))
   3.149-
   3.150-;; (defun discard-argument (condition)
   3.151-;;   "A handler which can be used to invoke the `discard-argument' restart"
   3.152-;;   (invoke-restart (find-restart 'discard-argument condition)))
   3.153-
   3.154-(defmacro with-cli-handlers (form)
   3.155-  "A wrapper which handles common cli errors that may occur during
   3.156-evaluation of FORM."
   3.157-  `(handler-case ,form
   3.158-     (sb-sys:interactive-interrupt ()
   3.159-       (format *error-output* "~&(:SIGINT)~&")
   3.160-       (exit :code 130))
   3.161-     (error (c)
   3.162-       (format *error-output* "~&~A~&" c)
   3.163-       (exit :code 1))))
   3.164-
   3.165-(defun init-args () (setq *argv* (cons (cli-arg0) (cli-args))))
   3.166-
   3.167-(defmacro with-cli (slots cli &body body)
   3.168-  "Like with-slots with some extra bindings."
   3.169-  ;; (with-gensyms (cli-body)
   3.170-  ;;  (let ((cli-body (mapcar (lambda (x) ()) cli-body)
   3.171-  `(progn
   3.172-     (init-args)
   3.173-     (setf (cli-cwd ,cli) (sb-posix:getcwd))
   3.174-     (with-slots ,slots (parse-args ,cli *argv* :compile t)
   3.175-       ,@body)))
   3.176-
   3.177-;;; Prompts
   3.178-(declaim (inline completing-read))
   3.179-(defun completing-read (prompt collection
   3.180-			&key (history nil) (default nil)
   3.181-			(key nil) (test nil))
   3.182-
   3.183-  "A simplified COMPLETING-READ for common-lisp.
   3.184-
   3.185-The Emacs completion framework includes a function called
   3.186-`completing-read' which prompts the user for input from the
   3.187-mini-buffer. It is a very flexible interface which can be used to read
   3.188-user input programatically. This is incredibly useful for building
   3.189-data entry interfaces -- for example see the `make-prompt!' macro.
   3.190-
   3.191-Obviously writing a completion framework is out-of-scope, but we can
   3.192-simulate one by embedding a DSL in our prompters if we choose. For
   3.193-example, perhaps we treat a single '?' character as a request from the
   3.194-user to list valid options while continue waiting for input."
   3.195-  (princ prompt)
   3.196-  ;; ensure we empty internal buffer
   3.197-  (finish-output)
   3.198-  (let* ((coll (symbol-value collection))
   3.199-	 (r (if coll
   3.200-		(find (read-line) coll :key key :test test)
   3.201-		(or (read-line) default))))
   3.202-    (prog1
   3.203-	r
   3.204-    (setf (symbol-value history) (push r history)))))
   3.205-
   3.206-(defmacro make-prompt! (var &optional prompt)
   3.207-  "Generate a 'prompter' from list or variable VAR and optional
   3.208-PROMPT string.
   3.209-
   3.210-This isn't an ideal solution as it does in fact expose a dynamic
   3.211-variable (VAR-prompt-history). We should generate accessors and
   3.212-keep the variables within lexical scope of the generated
   3.213-closure."
   3.214-  (with-gensyms (s p h)
   3.215-    `(let ((,s (if (boundp ',var) (symbol-value ',var) 
   3.216-		   (progn 
   3.217-		     (defvar ,(symb var) nil)
   3.218-		     ',(symb var))))
   3.219-           (,p (when (stringp ,prompt) ,prompt)) ;; prompt string
   3.220-           (,h ',(symb var '-prompt-history))) ;; history symbol
   3.221-       (defvar ,(symb var '-prompt-history) nil)
   3.222-       (defun ,(symb var '-prompt) ()
   3.223-	 ,(format nil "Prompt for a value from `~A', use DEFAULT if non-nil
   3.224-and no value is provided by user, otherwise fallback to the `car'
   3.225-of `~A-PROMPT-HISTORY'." var var)
   3.226-	 (completing-read
   3.227-          (format nil "~A [~A]: "
   3.228-		  (or ,p ">")
   3.229-		  (car (symbol-value ,h)))
   3.230-	  ,s :history ,h :default nil)))))
   3.231-
   3.232-(defmacro define-cli-constant (name cli &optional doc)
   3.233-  `(define-constant ,name ,cli ,@doc :test #'cli-equal))
   3.234-
   3.235-(defvar *default-cli-def* 'defparameter)
   3.236-
   3.237-(defmacro defcmd (name &body body)
   3.238-  `(defun ,name ($args $opts) 
   3.239-     (declare (ignorable $args $opts))
   3.240-     (let (($argc (length $args))
   3.241-	   ($optc (length $opts)))
   3.242-       (declare (ignorable $argc $optc))
   3.243-       ,@body)))
   3.244-
   3.245-(defmacro defopt (name &body body)
   3.246-  `(defun ,name ($val)
   3.247-     (declare (ignorable $val))
   3.248-     ,@body))
   3.249-
   3.250-(declaim (inline walk-cli-slots))
   3.251-(defun walk-cli-slots (cli)
   3.252-  "Walk the plist CLI, performing actions as necessary based on the slot
   3.253-keys."
   3.254-  (loop for kv in (group cli 2)
   3.255-	when (eql :thunk (car kv))
   3.256-	  return (let ((th (cdr kv)))
   3.257-		   (if (or (functionp th) (symbolp th)) (funcall th) (compile nil (lambda () th)))))
   3.258-	cli)
   3.259-
   3.260-(defmacro define-cli (name &body body)
   3.261-  "Define a symbol NAME bound to a top-level CLI object."
   3.262-  (declare (type symbol name))
   3.263-      `(,*default-cli-def* ,name (apply #'make-cli t (walk-cli-slots ',body))))
   3.264-
   3.265-(defmacro defmain (ret &body body)
   3.266-  "Define a main function in the current package which returns RET.
   3.267-
   3.268-Note that this macro does not export the defined function and requires
   3.269-`cli:main' to be an external symbol."
   3.270-  `(progn
   3.271-     (declaim (type stream output))
   3.272-     (defun main (&key (output *standard-output*))
   3.273-       "Run the top-level function and print to OUTPUT."
   3.274-       (let ((*standard-output* output))
   3.275-	 (with-cli-handlers
   3.276-	     (progn ,@body ,ret))))))
   3.277-
   3.278-;;; Utils
   3.279-(defvar *argv*)
   3.280-
   3.281-(defun make-cli (kind &rest slots)
   3.282-  "Creates a new CLI object of the given kind."
   3.283-  (declare (type (member :opt :cmd :cli t) kind))
   3.284-  (apply #'make-instance
   3.285-   (cond
   3.286-     ((eql kind :cli) 'cli)
   3.287-     ((eql kind :opt) 'cli-opt)
   3.288-     ((eql kind :cmd) 'cli-cmd)
   3.289-     (t 'cli))
   3.290-    slots))
   3.291-
   3.292-;; RESEARCH 2023-09-12: closed over hash-table with short/long flags
   3.293-;; to avoid conflicts. if not, need something like a flag-function
   3.294-;; slot at class allocation.
   3.295-(defmacro make-opts (&body opts)
   3.296-  `(map 'vector
   3.297-	(lambda (x)
   3.298-	  (etypecase x
   3.299-	    (string (make-cli :opt :name x))
   3.300-	    (list (apply #'make-cli :opt x))
   3.301-	    (t (make-cli :opt :name (format nil "~(~A~)" x) :global t))))
   3.302-	(walk-cli-slots ',opts)))
   3.303-
   3.304-(defmacro make-cmds (&body opts)
   3.305-  `(map 'vector
   3.306-	(lambda (x)
   3.307-	  (etypecase x
   3.308-	    (string (make-cli :cmd :name x))
   3.309-	    (list (apply #'make-cli :cmd x))
   3.310-	    (t (make-cli :cmd :name (format nil "~(~A~)" x)))))
   3.311-	(walk-cli-slots ',opts)))
   3.312-
   3.313-(defun long-opt-p (str)
   3.314-  (and (char= (aref str 0) (aref str 1) #\-)
   3.315-       (> (length str) 2)))
   3.316-
   3.317-(defun short-opt-p (str)
   3.318-  (and (char= (aref str 0) #\-)
   3.319-       (not (char= (aref str 1) #\-))
   3.320-       (> (length str) 1)))
   3.321-
   3.322-(defun opt-group-p (str)
   3.323-  (string= str *cli-group-separator*))
   3.324-
   3.325-(defun opt-prefix-eq (ch str)
   3.326-  (char= (aref str 0) ch))
   3.327-
   3.328-(defun gen-thunk-ll (origin args)
   3.329-  (let ((a0 (list (symb '$a 0) origin)))
   3.330-    (group 
   3.331-     (nconc (loop for i from 1 for a in args nconc (list (symb '$a i) a)) a0 )
   3.332-     2)))
   3.333-
   3.334-;; TODO 2023-10-06: 
   3.335-;; (defmacro gen-cli-thunk (pvars &rest thunk)
   3.336-;;   "Generate and return a function based on THUNK suitable for the :thunk
   3.337-;; slot of cli objects with pandoric bindings PVARS.")
   3.338-
   3.339-;;; Protocol
   3.340-(defgeneric push-cmd (cmd place))
   3.341-
   3.342-(defgeneric push-opt (opt place))
   3.343-
   3.344-(defgeneric pop-cmd (place))
   3.345-
   3.346-(defgeneric pop-opt (place))
   3.347-
   3.348-(defgeneric find-cmd (self name &optional active))
   3.349-
   3.350-(defgeneric find-opt (self name &optional active))
   3.351-
   3.352-(defgeneric active-cmds (self))
   3.353-
   3.354-(defgeneric active-opts (self &optional global))
   3.355-
   3.356-(defgeneric find-short-opt (self ch))
   3.357-
   3.358-(defgeneric call-opt (self arg))
   3.359-
   3.360-(defgeneric do-opt (self))
   3.361-
   3.362-(defgeneric call-cmd (self args opts))
   3.363-
   3.364-(defgeneric parse-args (self args &key &allow-other-keys)
   3.365-  (:documentation "Parse list of strings ARGS using SELF.
   3.366-
   3.367-A list of the same length as ARGS is returned containing 'cli-ast'
   3.368-objects: (OPT . (or char string)) (CMD . string) NIL"))
   3.369-
   3.370-(defgeneric do-cmd (self)
   3.371-  (:documentation "Run the command SELF with args parsed at runtime."))
   3.372-
   3.373-(defgeneric print-help (self &optional stream)
   3.374-  (:documentation "Format cli SELF as a helpful string."))
   3.375-
   3.376-(defgeneric print-version (self &optional stream)
   3.377-  (:documentation "Print the version of SELF."))
   3.378-
   3.379-(defgeneric print-usage (self &optional stream)
   3.380-  (:documentation "Format cli SELF as a useful string."))
   3.381-
   3.382-(defgeneric handle-unknown-argument (self arg)
   3.383-  (:documentation "Handle an unknown argument."))
   3.384-
   3.385-(defgeneric handle-missing-argument (self arg)
   3.386-  (:documentation "Handle a missing argument."))
   3.387-
   3.388-(defgeneric handle-invalid-argument (self arg)
   3.389-  (:documentation "Handle an invalid argument."))
   3.390-
   3.391-(defgeneric cli-equal (a b))
   3.392-
   3.393-(defun default-thunk (cli) (lambda (x) (declare (ignore x)) (print-help cli)))
   3.394-
   3.395-(defvar *cli-opt-kinds* '(bool str form list sym key num file dir))
   3.396-
   3.397-(defun cli-opt-kind-p (s)
   3.398-  (declare (type symbol s))
   3.399-  (find s *cli-opt-kinds*))
   3.400-
   3.401-(defmacro make-opt-parser (kind-spec &body body)
   3.402-  "Return a KIND-opt-parser function based on KIND-SPEC which is either a
   3.403-symbol from *cli-opt-kinds* or a list, and optional BODY which
   3.404-is a list of handlers for the opt-val."
   3.405-  (let* ((kind (if (consp kind-spec) (car kind-spec) kind-spec))
   3.406-	 (super (when (consp kind-spec) (cadr kind-spec)))
   3.407-	 (fn-name (symb 'parse- kind '-opt)))
   3.408-    ;; thread em
   3.409-    (let ((fn1 (when (not (eql 'nil super)) (symb 'parse- super '-opt))))
   3.410-      `(progn
   3.411-	 (defun ,fn-name ($val)
   3.412-	   "Parse the cli-opt-val $VAL."
   3.413-	   ;; do stuff
   3.414-	   (when (not (eql ',fn1 'nil)) (setq $val (funcall ',fn1 $val)))
   3.415-	   ,@body)))))
   3.416-
   3.417-(make-opt-parser bool $val)
   3.418-
   3.419-(make-opt-parser (str bool) (when (stringp $val) $val))
   3.420-
   3.421-(make-opt-parser (form str) (read-from-string $val))
   3.422-
   3.423-(make-opt-parser (list form) (when (listp $val) $val))
   3.424-
   3.425-(make-opt-parser (sym form) (when (symbolp $val) $val))
   3.426-
   3.427-(make-opt-parser (key form) (when (keywordp $val) $val))
   3.428-
   3.429-(make-opt-parser (num form) (when (numberp $val) $val))
   3.430-
   3.431-(make-opt-parser (file str) 
   3.432-  (when $val (parse-native-namestring $val nil *default-pathname-defaults* :as-directory nil)))
   3.433-
   3.434-(make-opt-parser (dir str) 
   3.435-  (when $val (sb-ext:parse-native-namestring $val nil *default-pathname-defaults* :as-directory t)))
   3.436-
   3.437-;;; Objects
   3.438-(defclass cli-opt ()
   3.439-  ;; note that cli-opts can have a nil or unbound name slot
   3.440-  ((name :initarg :name :initform (required-argument :name) :accessor cli-name :type string)
   3.441-   (kind :initarg :kind :initform 'boolean :accessor cli-opt-kind :type cli-opt-kind-p)
   3.442-   (thunk :initform #'default-thunk :initarg :thunk :type function-lambda-expression :accessor cli-thunk)
   3.443-   (val :initarg :val :initform nil :accessor cli-val :type form)
   3.444-   (global :initarg :global :initform nil :accessor global-opt-p :type boolean)
   3.445-   (description :initarg :description :accessor cli-description :type string)
   3.446-   (lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean))
   3.447-  (:documentation "CLI option"))
   3.448-
   3.449-(defmethod handle-unknown-argument ((self cli-opt) arg))
   3.450-(defmethod handle-missing-argument ((self cli-opt) arg))
   3.451-(defmethod handle-invalid-argument ((self cli-opt) arg))
   3.452-
   3.453-(defmethod initialize-instance :after ((self cli-opt) &key)
   3.454-  (with-slots (name thunk) self
   3.455-    (unless (stringp name) (setf name (format nil "~(~A~)" name)))
   3.456-    (when (symbolp thunk) (setf thunk (funcall (compile nil `(lambda () ,(symbol-function thunk))))))
   3.457-    self))
   3.458-
   3.459-(defmethod install-thunk ((self cli-opt) (lambda function) &optional compile)
   3.460-  "Install THUNK into the corresponding slot in cli-cmd SELF."
   3.461-  (let ((%thunk (if compile (compile nil lambda) lambda)))
   3.462-    (setf (cli-thunk self) %thunk)
   3.463-    self))
   3.464-
   3.465-(defmethod print-object ((self cli-opt) stream)
   3.466-  (print-unreadable-object (self stream :type t)
   3.467-    (format stream "~A :global ~A :val ~A"
   3.468-            (cli-name self)
   3.469-	    (global-opt-p self)
   3.470-	    (cli-val self))))
   3.471-
   3.472-(defmethod print-usage ((self cli-opt) &optional stream)
   3.473-  (format stream " -~(~{~A~^/--~}~)~A~A"
   3.474-	  (if-let ((n (cli-name self)))
   3.475-	    (list (make-shorty n) n)
   3.476-	    'dyn)
   3.477-	  (if (global-opt-p self) "* " "  ")
   3.478-	  (if-let ((d (and (slot-boundp self 'description) (cli-description self))))
   3.479-	    (format stream ":  ~A" d)
   3.480-	    "")))
   3.481-
   3.482-(defmethod cli-equal ((a cli-opt) (b cli-opt))
   3.483-  (with-slots (name global kind) a
   3.484-    (with-slots ((bn name) (bg global) (bk kind)) b
   3.485-      (and (string= name bn)
   3.486-	   (eql global bg)
   3.487-	   (eql kind bk)))))
   3.488-
   3.489-(defmethod call-opt ((self cli-opt) arg)
   3.490-  (funcall (compile nil (cli-thunk self)) arg))
   3.491-
   3.492-(defmethod do-opt ((self cli-opt))
   3.493-  (call-opt self (cli-val self)))
   3.494-
   3.495-(defclass cli-cmd ()
   3.496-  ;; name slot is required and must be a string
   3.497-  ((name :initarg :name :initform (required-argument :name) :accessor cli-name :type string)
   3.498-   (opts :initarg :opts :initform (make-array 0 :element-type 'cli-opt)
   3.499-	 :accessor cli-opts :type (vector cli-opt))
   3.500-   (cmds :initarg :cmds :initform (make-array 0 :element-type 'cli-cmd)
   3.501-	 :accessor cli-cmds :type (vector cli-cmd))
   3.502-   (thunk :initform #'default-thunk :initarg :thunk :accessor cli-thunk :type function-lambda-expression)
   3.503-   (lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean)
   3.504-   (description :initarg :description :accessor cli-description :type string)
   3.505-   (args :initform nil :initarg :args :accessor cli-cmd-args))
   3.506-  (:documentation "CLI command"))
   3.507-
   3.508-(defmethod initialize-instance :after ((self cli-cmd) &key)
   3.509-  (with-slots (name cmds opts thunk) self
   3.510-    (unless (stringp name) (setf name (format nil "~(~A~)" name)))
   3.511-    (unless (vectorp cmds) (setf cmds (funcall (compile nil `(lambda () ,cmds)))))
   3.512-    (unless (vectorp opts) (setf opts (funcall (compile nil `(lambda () ,opts)))))
   3.513-    (when (symbolp thunk) (setf thunk (symbol-function thunk)))
   3.514-    self))
   3.515-
   3.516-(defmethod print-object ((self cli-cmd) stream)
   3.517-  (print-unreadable-object (self stream :type t)
   3.518-    (format stream "~A :opts ~A :cmds ~A :args ~A"
   3.519-	  (cli-name self)
   3.520-          (length (cli-opts self))
   3.521-	  (length (cli-cmds self))
   3.522-	  (length (cli-cmd-args self)))))
   3.523-
   3.524-(defmethod print-usage ((self cli-cmd) &optional stream)
   3.525-  (with-slots (opts cmds) self
   3.526-    (format stream "~(~A~)  ~A~A~A"
   3.527-	    (cli-name self)
   3.528-	    (if-let ((d (and (slot-boundp self 'description) (cli-description self))))
   3.529-	      (format nil ":  ~A" d)
   3.530-	      "")
   3.531-	    (if (null opts)
   3.532-		""
   3.533-		(format nil "~{~%    ~A~^~}" (loop for o across opts collect (print-usage o nil))))
   3.534-	    (if (null cmds)
   3.535-		""
   3.536-		(format nil "~%    ~{!  ~A~}" (loop for c across cmds collect (print-usage c nil)))))))
   3.537-
   3.538-(defmethod push-cmd ((self cli-cmd) (place cli-cmd))
   3.539-  (vector-push self (cli-cmds place)))
   3.540-
   3.541-(defmethod push-opt ((self cli-opt) (place cli-cmd))
   3.542-  (vector-push self (cli-opts place)))
   3.543-
   3.544-(defmethod pop-cmd ((self cli-cmd))
   3.545-  (vector-pop (cli-cmds self)))
   3.546-
   3.547-(defmethod pop-opt ((self cli-opt))
   3.548-  (vector-pop (cli-opts self)))
   3.549-
   3.550-(defmethod cli-equal ((a cli-cmd) (b cli-cmd))
   3.551-  (with-slots (name opts cmds) a
   3.552-    (with-slots ((bn name) (bo opts) (bc cmds)) b
   3.553-      (and (string= name bn)
   3.554-	   (if (and (null opts) (null bo))
   3.555-	       t
   3.556-	       (unless (member nil (loop for oa across opts
   3.557-					 for ob across bo
   3.558-					 collect (cli-equal oa ob)))
   3.559-		 t))
   3.560-	   (if (and (null cmds) (null bc))
   3.561-	       t
   3.562-	       (unless (member nil (loop for ca across cmds
   3.563-					 for cb across bc
   3.564-					 collect (cli-equal ca cb)))
   3.565-		 t))))))
   3.566-
   3.567-;; typically when starting from a top-level `cli', the global
   3.568-;; `cli-opts' will be parsed first, followed by the first command
   3.569-;; found. If a command is found, the tail of the list is passed as
   3.570-;; arguments to this function, which can pass additonal arguments to
   3.571-;; nested commands.
   3.572-
   3.573-;;  TODO 2023-09-12: Parsing restarts at the `*cli-group-separator*'
   3.574-;; if present, or stops at EOI.
   3.575-
   3.576-(declaim (inline %make-cli-node))
   3.577-(defstruct (cli-node (:constructor %make-cli-node)) kind form)
   3.578-
   3.579-(defun make-cli-node (kind form)
   3.580-  (%make-cli-node :kind kind :form form))
   3.581-
   3.582-(declaim (inline %make-cli-ast))
   3.583-(defstruct (cli-ast (:constructor %make-cli-ast)) ast)
   3.584-
   3.585-(defun make-cli-ast (nodes)  
   3.586-  (%make-cli-ast :ast nodes))
   3.587-
   3.588-(defmethod find-cmd ((self cli-cmd) name &optional active)
   3.589-  (when-let ((c (find name (cli-cmds self) :key #'cli-name :test #'string=)))
   3.590-    (if active 
   3.591-	;; maybe issue warning here? report to user
   3.592-	(when (cli-lock-p c) c)
   3.593-	c)))
   3.594-
   3.595-(defmethod active-cmds ((self cli-cmd))
   3.596-  (remove-if-not #'cli-lock-p (cli-cmds self)))
   3.597-
   3.598-
   3.599-(defmethod find-opt ((self cli-cmd) name &optional active)
   3.600-  (when-let ((o (find name (cli-opts self) :key #'cli-name :test #'string=)))
   3.601-    (if active 
   3.602-	(when (cli-lock-p o) o)
   3.603-	o)))
   3.604-
   3.605-(defun active-global-opt-p (opt)
   3.606-  "Return non-nil if OPT is active at runtime and global."
   3.607-  (when (and (cli-lock-p opt) (global-opt-p opt)) t))
   3.608-
   3.609-(defmethod active-opts ((self cli-cmd) &optional global)
   3.610-  (remove-if-not 
   3.611-   (if global 
   3.612-       #'active-global-opt-p 
   3.613-       #'cli-lock-p)
   3.614-   (cli-opts self)))
   3.615-
   3.616-(defmethod find-short-opt ((self cli-cmd) ch)
   3.617-  (find ch (cli-opts self) :key #'cli-name :test #'opt-prefix-eq))
   3.618-
   3.619-(defmethod proc-args ((self cli-cmd) args)
   3.620-  "process ARGS into an ast. Each element of the ast is a node with a
   3.621-:kind slot, indicating the type of node and a :form slot which stores
   3.622-a value.
   3.623-
   3.624-For now we parse group separators '--' and insert a nil into the tree,
   3.625-this will likely change to generating a new branch in the ast as it
   3.626-should be."
   3.627-  (make-cli-ast
   3.628-   (loop 
   3.629-     for a in args
   3.630-     if (= (length a) 1) collect (make-cli-node 'arg a)
   3.631-     ;; SHORT OPT
   3.632-     else if (short-opt-p a)
   3.633-	    collect (if-let ((o (find-short-opt self (aref a 1))))
   3.634-		      (progn
   3.635-			(setf (cli-val o) t)
   3.636-			(make-cli-node 'opt o))
   3.637-		      (make-cli-node 'arg a))
   3.638-
   3.639-     ;; LONG OPT
   3.640-     else if (long-opt-p a)
   3.641-	    ;; what we actually want to do is consume the next sequence of args - TBD
   3.642-	    collect (if-let ((o (find-opt self (string-trim "-" a))))
   3.643-		      (progn
   3.644-			(setf (cli-val o) (string-trim "-" a))
   3.645-			(make-cli-node 'opt o))
   3.646-		      (make-cli-node 'arg a))
   3.647-     ;; OPT GROUP
   3.648-     else if (opt-group-p a)
   3.649-	    collect nil
   3.650-     ;; CMD
   3.651-     else if (find-cmd self a)
   3.652-	    ;; TBD
   3.653-	    collect (make-cli-node 'cmd (find-cmd self a))
   3.654-     ;; ARG
   3.655-     else collect (make-cli-node 'arg a))))
   3.656-
   3.657-(defmethod install-ast ((self cli-cmd) (ast cli-ast))
   3.658-  "Install the given AST, recursively filling in value slots."
   3.659-  (with-slots (cmds opts) self
   3.660-    ;; we assume all nodes in the ast have been validated and the ast
   3.661-    ;; itself is consumed. validation is performed in proc-args.
   3.662-
   3.663-    ;; before doing anything else we lock SELF, which should remain
   3.664-    ;; locked for the full runtime duration.
   3.665-    (setf (cli-lock-p self) t)
   3.666-    (loop named install
   3.667-	  for (node . tail) on (cli-ast-ast ast)
   3.668-	  unless (null node) 
   3.669-	    do 
   3.670-	       (with-slots (kind form) node
   3.671-		 (case kind
   3.672-		   ;; opts 
   3.673-		   (opt 
   3.674-		    (let ((name (cli-name form))
   3.675-			  (val (cli-val form)))
   3.676-		      (when-let ((o (find-opt self name)))
   3.677-			(setf (cli-val o) val
   3.678-			      (cli-lock-p o) t))))
   3.679-		   ;; when we encounter a command we recurse over the tail
   3.680-		   (cmd 
   3.681-		    (when-let ((c (find-cmd self (cli-name form))))
   3.682-		      (setf (cli-lock-p c) t)
   3.683-		      ;; handle the rest of the AST
   3.684-		      (install-ast c (make-cli-ast tail))
   3.685-		      (return-from install)))
   3.686-		   (arg (push-arg form self)))))
   3.687-    (setf (cli-cmd-args self) (nreverse (cli-cmd-args self)))
   3.688-    self))
   3.689-
   3.690-(defmethod install-thunk ((self cli-cmd) (lambda function) &optional compile)
   3.691-  "Install THUNK into the corresponding slot in cli-cmd SELF."
   3.692-  (let ((%thunk (if compile (compile nil lambda) lambda)))
   3.693-    (setf (cli-thunk self) %thunk)
   3.694-    self))
   3.695-
   3.696-(defmethod push-arg (arg (self cli-cmd))
   3.697-  (push arg (cli-cmd-args self)))
   3.698-
   3.699-(defmethod parse-args ((self cli-cmd) args &key (compile nil))
   3.700-  "Parse ARGS and return the updated object SELF.
   3.701-
   3.702-ARGS is assumed to be a valid cli-ast (list of cli-nodes), unless
   3.703-COMPILE is t, in which case a list of strings is assumed."
   3.704-  (with-slots (opts cmds) self
   3.705-    (let ((args (if compile (proc-args self args) args)))
   3.706-      (print (install-ast self args)))))
   3.707-
   3.708-;; warning: make sure to fill in the opt and cmd slots with values
   3.709-;; from the top-level args before doing a command.
   3.710-(defmethod call-cmd ((self cli-cmd) args opts)
   3.711-  ;; TODO 2023-09-12: handle args/env
   3.712-  (funcall (cli-thunk self) args opts))
   3.713-
   3.714-(defmethod do-cmd ((self cli-cmd))
   3.715-  (call-cmd self (cli-cmd-args self) (cli-opts self)))
   3.716-
   3.717-(defclass cli (cli-cmd)
   3.718-  ;; name slot defaults to *package*, must be string
   3.719-  ((name :initarg :name :initform (string-downcase (package-name *package*)) :accessor cli-name :type string)
   3.720-   (version :initarg :version :initform "0.1.0" :accessor cli-version :type string)
   3.721-   ;; TODO 2023-10-11: look into pushd popd - wd-stack?
   3.722-   (cwd :initarg :cwd :initform (sb-posix:getcwd) :type string :accessor cli-cwd
   3.723-	:documentation "working directory of the top-level CLI."))
   3.724-  (:documentation "CLI"))
   3.725-
   3.726-(defmethod print-usage ((self cli) &optional stream)
   3.727-  (iprintln (format nil "usage: ~A [global] <command> [<arg>]~%" (cli-name self)) 2 stream))
   3.728-
   3.729-(defmethod print-version ((self cli) &optional stream)
   3.730-  (println (cli-version self) stream))
   3.731-
   3.732-(defmethod print-help ((self cli) &optional stream) 
   3.733-  (println (format nil "~A v~A" (cli-name self) (cli-version self)) stream)
   3.734-  (print-usage self stream)
   3.735-  (iprintln (cli-description self) 2 stream)
   3.736-  ;; (terpri stream)
   3.737-  (iprintln "options:" 2 stream)
   3.738-  (with-slots (opts cmds) self
   3.739-    (unless (null opts)
   3.740-      (loop for o across opts
   3.741-	    do (iprintln (print-usage o) 4 stream)))
   3.742-    ;; (terpri stream)
   3.743-    (iprintln "commands:" 2 stream)
   3.744-    (unless (null cmds)
   3.745-      (loop for c across cmds
   3.746-	    do (iprintln (print-usage c) 4 stream)))))
   3.747-
   3.748-(defmethod cli-equal :before ((a cli) (b cli))
   3.749-  "Return T if A is the same cli object as B.
   3.750-
   3.751-Currently this function is intended only for instances of the CLI
   3.752-class and is used as a specialized EQL for DEFINE-CONSTANT."
   3.753-  (with-slots (version) a
   3.754-    (with-slots ((bv version)) b
   3.755-      (string= version bv))))
   3.756-
   3.757-;; same as cli-cmd method, default is to compile though
   3.758-(defmethod parse-args ((self cli) (args list) &key (compile t))
   3.759-  "Parse list of string arguments ARGS and return the updated object SELF."
   3.760-  (with-slots (opts cmds) self
   3.761-    (let ((args (if compile (proc-args self args) args)))
   3.762-      (install-ast self args))))
   3.763-
   3.764-(declaim (inline debug-opts))
   3.765-(defun debug-opts (cli)
   3.766-  (let ((o (active-opts cli))
   3.767-	(a (cli-cmd-args cli))
   3.768-	(c (active-cmds cli)))
   3.769-    (debug! (cli-cwd cli) o a c)))
   3.770-
   3.771-(declaim (inline solop))
   3.772-(defun solop (self)
   3.773-  (and (= 0 (length (active-opts self t)) (length (active-cmds self)))))
   3.774-
   3.775-(defmethod do-cmd ((self cli))
   3.776-  (if (solop self)
   3.777-      (call-cmd self (cli-cmd-args self) (cli-opts self))
   3.778-      (progn
   3.779-	(loop for o across (active-opts self t)
   3.780-	      do (do-opt o))
   3.781-	(loop for c across (active-cmds self)
   3.782-	      do (do-cmd c)))))
   3.783-
   3.784-(provide :cli)

     4.1--- a/lisp/lib/cli/tests.lisp	Mon Oct 16 19:33:42 2023 -0400
     4.2+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.3@@ -1,46 +0,0 @@
     4.4-;; we should be able to call this from the body of the test, but we
     4.5-;; get an undefined-function error for 'MACS.RT::MAKE-PROMPT!'
     4.6-(defpkg :cli/tests
     4.7-    (:use :cl :rt :cli))
     4.8-
     4.9-(defsuite :cli)
    4.10-(in-suite :cli)
    4.11-(unless *compile-tests*
    4.12-  (deftest cli-prompt ()
    4.13-    "Test MACS.CLI prompts"
    4.14-    (make-prompt! tpfoo "testing: ")
    4.15-    (defvar tcoll nil)
    4.16-    (defvar thist nil)
    4.17-    (let ((*standard-input* (make-string-input-stream 
    4.18-			     (format nil "~A~%~A~%" "foobar" "foobar"))))
    4.19-      ;; prompts 
    4.20-      (is (string= (tpfoo-prompt) "foobar"))
    4.21-      (is (string= "foobar"
    4.22-		   (cli:completing-read "nothing: " tcoll :history thist :default "foobar"))))))
    4.23-
    4.24-(defparameter *opts* (cli:make-opts (:name foo :global t :description "bar")
    4.25-			    (:name bar :description "foo")))
    4.26-
    4.27-(defparameter *cmd1* (make-cli :cmd :name "holla" :opts *opts* :description "cmd1 description"))
    4.28-(defparameter *cmd2* (make-cli :cmd :name "ayo" :cmds #(*cmd1*) :opts *opts* :description "cmd1 description"))
    4.29-(defparameter *cmds* (cli:make-cmds (:name "baz" :description "baz" :opts *opts*)))
    4.30-
    4.31-(defparameter *cli* (make-cli t :opts *opts* :cmds *cmds* :description "test cli"))
    4.32-
    4.33-(deftest cli ()
    4.34-  "test MACS.CLI OOS."
    4.35-  (let ((cli *cli*))
    4.36-    (is (eq (make-shorty "test") #\t))
    4.37-    (is (equalp (proc-args cli '("-f" "baz" "--bar" "fax")) ;; not eql
    4.38-		(make-cli-ast 
    4.39-		 (list (make-cli-node 'opt (find-short-opt cli #\f))
    4.40-		       (make-cli-node 'cmd (find-cmd cli "baz"))
    4.41-		       (make-cli-node 'opt (find-opt cli "bar"))
    4.42-		       (make-cli-node 'arg "fax")))))
    4.43-    (is (parse-args cli '("--bar" "baz" "-f" "yaks")))
    4.44-    (is (stringp
    4.45-	 (with-output-to-string (s)
    4.46-	   (print-version cli s)
    4.47-	   (print-usage cli s)
    4.48-	   (print-help cli s))))
    4.49-    (is (string= "foobar" (parse-str-opt "foobar")))))

     5.1--- a/lisp/lib/rt.asd	Mon Oct 16 19:33:42 2023 -0400
     5.2+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.3@@ -1,14 +0,0 @@
     5.4-(defsystem :rt
     5.5-  :version "0.1.0"
     5.6-  :author "ellis <ellis@rwest.io>"
     5.7-  :description "regression test framework"
     5.8-  :bug-tracker "https://lab.rwest.io/ellis/macs/issues"
     5.9-  :source-control (:hg "https://lab.rwest.io/ellis/macs")
    5.10-  :depends-on (:macs :sxp)
    5.11-  :in-order-to ((test-op (test-op "rt/tests")))
    5.12-  :components ((:file "rt/rt")))
    5.13-
    5.14-(defsystem :rt/tests
    5.15-  :depends-on (:macs :rt)
    5.16-  :components ((:file "rt/tests"))
    5.17-  :perform (test-op (op c) (uiop:symbol-call '#:rt '#:do-tests :rt)))

     6.1--- a/lisp/lib/rt/rt.lisp	Mon Oct 16 19:33:42 2023 -0400
     6.2+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.3@@ -1,665 +0,0 @@
     6.4-;;; rt.lisp --- regression testing
     6.5-
     6.6-;; Regression Testing framework. inspired by PCL, the original CMUCL
     6.7-;; code, and the SBCL port.
     6.8-
     6.9-;;; Commentary:
    6.10-
    6.11-;; - :rt https://www.merl.com/publications/docs/TR91-04.pdf Chapter 1
    6.12-;; - :com.gigamonkeys.test https://github.com/gigamonkey/monkeylib-test-framework
    6.13-;; - :sb-rt https://github.com/sbcl/sbcl/blob/master/contrib/sb-rt/rt.lisp
    6.14-
    6.15-;; This package is intended to provide a modernized Lisp testing
    6.16-;; library with features found in some of the test frameworks listed
    6.17-;; below.
    6.18-
    6.19-;; - :it.bese.fiveam https://github.com/lispci/fiveam
    6.20-;; - :try https://github.com/melisgl/try
    6.21-;; - :rove https://github.com/fukamachi/rove
    6.22-
    6.23-;;; TODO:
    6.24-#|
    6.25-
    6.26-- [ ] benchmark support: do-bench, test-count, 
    6.27-
    6.28-- [ ] fixtures api
    6.29-
    6.30-- [ ] profiling 
    6.31-|#
    6.32-;;; Code:
    6.33-#+x86-64
    6.34-(eval-when (:compile-toplevel :load-toplevel :execute)
    6.35-  (require 'sb-sprof))
    6.36-
    6.37-(pkg:defpkg :rt
    6.38-  (:use
    6.39-   :cl :sxp
    6.40-   :sym :list :cond :readtables :fu :fmt :log :ana :pan :sb-aprof
    6.41-   #+x86-64 :sb-sprof)
    6.42-  (:nicknames :rt)
    6.43-  (:export
    6.44-   :*default-test-opts*
    6.45-   :*compile-tests*
    6.46-   :*catch-test-errors*
    6.47-   :*test-suffix*
    6.48-   :*default-test-suite-name*
    6.49-   :*test-suite*
    6.50-   :*test-suite-list*
    6.51-   ;;  TODO 2023-09-04: :*test-profiler-list* not yet
    6.52-   :*testing*
    6.53-   :test-suite-designator
    6.54-   :check-suite-designator
    6.55-   :make-test
    6.56-   :make-suite
    6.57-   :test-name=
    6.58-   :do-test
    6.59-   :do-tests
    6.60-   :continue-testing
    6.61-   :with-test-env
    6.62-   :ensure-suite
    6.63-   :test-fixture
    6.64-   :fixture-prototype
    6.65-   :make-fixture-prototype
    6.66-   :make-fixture
    6.67-   :with-fixture
    6.68-   :test-result
    6.69-   :test-pass-p
    6.70-   :test-fail-p
    6.71-   :test-skip-p
    6.72-   :test-failed
    6.73-   :fail!
    6.74-   :is
    6.75-   :signals
    6.76-   :deftest
    6.77-   :defsuite
    6.78-   :in-suite
    6.79-   :eval-test
    6.80-   :compile-test
    6.81-   :locked-tests
    6.82-   :push-test
    6.83-   :pop-test
    6.84-   :delete-test
    6.85-   :find-test
    6.86-   :do-suite
    6.87-   :test-object
    6.88-   :test
    6.89-   :test-fixture
    6.90-   :test-suite
    6.91-   :test-name
    6.92-   :tests
    6.93-   :test-form
    6.94-   :test-results))
    6.95-
    6.96-(in-package :rt)
    6.97-(in-readtable *macs-readtable*)
    6.98-
    6.99-;;; Vars
   6.100-(defvar *default-test-opts* '(optimize sb-c::instrument-consing))
   6.101-(defvar *compile-tests* t
   6.102-  "When nil do not compile tests. With a value of t, tests are compiled
   6.103-with default optimizations else the value is used to configure
   6.104-compiler optimizations.")
   6.105-(defvar *catch-test-errors* t "When non-nil, cause errors in a test to be caught.")
   6.106-(defvar *test-suffix* "-test" "A suffix to append to every `test' defined with `deftest'.")
   6.107-(defvar *test-suite-list* nil "List of available `test-suite' objects.")
   6.108-(defvar *test-suite* nil "A 'test-suite-designator' which identifies the current `test-suite'.")
   6.109-(eval-when (:compile-toplevel :load-toplevel :execute)
   6.110-  (defvar *default-test-suite-name* "default"))
   6.111-(declaim (type (or stream boolean string) *test-input*))
   6.112-(defvar *test-input* nil "When non-nil, specifies an input stream or buffer for `*testing*'.")
   6.113-(defvar *default-bench-count* 100 "Default number of iterations to repeat a bench test for. This value is
   6.114-used when the slot value of :BENCH is t.")
   6.115-(defvar *testing* nil "Testing state var.")
   6.116-
   6.117-;;; Utils
   6.118-(eval-when (:compile-toplevel :load-toplevel :execute)
   6.119-  (defun make-test (&rest slots)
   6.120-    (apply #'make-instance 'test slots))
   6.121-  (defun make-suite (&rest slots)
   6.122-    (apply #'make-instance 'test-suite slots)))
   6.123-
   6.124-;; TODO 2023-09-04: optimize
   6.125-(declaim (inline do-tests))
   6.126-(defun do-tests (&optional (suite *test-suite*) (output *standard-output*))
   6.127-  (if (pathnamep output)
   6.128-      (with-open-file (stream output :direction :output)
   6.129-	(do-suite (ensure-suite suite) :stream stream))
   6.130-      (do-suite (ensure-suite suite) :stream output)))
   6.131-
   6.132-;; this assumes that *test-suite* is re-initialized correctly to the
   6.133-;; correct test-suite object.
   6.134-(defun continue-testing ()
   6.135-  (if-let ((test *testing*))
   6.136-    (throw '%in-test test)
   6.137-    (do-suite *test-suite*)))
   6.138-
   6.139-;; NOTE 2023-09-01: `pushnew' does not return an indication of whether
   6.140-;; place is changed - it returns place. This is functionally sound but
   6.141-;; means that if we want to do something else in the event that place
   6.142-;; is unchanged, we run into some friction,
   6.143-;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure
   6.144-(defun spush (item lst &key (test #'equal))
   6.145-  "Substituting `push'"
   6.146-  (declare (type function test))
   6.147-  (cond
   6.148-    ((null lst) (push item lst))
   6.149-    ((list lst)
   6.150-     (if-let ((found (member item lst
   6.151-			     :test test)))
   6.152-       (progn
   6.153-	 (rplaca found item)
   6.154-	 lst)
   6.155-       (push item lst)))
   6.156-    #|(or nil '(t (cons item lst)))|#))
   6.157-
   6.158-;; FIX 2023-08-31: spush, replace with `add-test' method.
   6.159-;; (declaim (inline normalize-test-name))
   6.160-(defun normalize-test-name (a)
   6.161-  "Return the normalized `test-suite-designator' of A."
   6.162-  (etypecase a
   6.163-    (string a)
   6.164-    (symbol (symbol-name a))
   6.165-    (test-object (test-name a))
   6.166-    (t (format nil "~A" a))))
   6.167-
   6.168-(defun test-name= (a b)
   6.169-  "Return t if A and B are similar `test-suite-designator's."
   6.170-  (let ((a (normalize-test-name a))
   6.171-	(b (normalize-test-name b)))
   6.172-    (string= a b)))
   6.173-
   6.174-;; (declaim (inline assert-suite ensure-suite))
   6.175-(defun ensure-suite (name)
   6.176-  (if-let ((ok (member name *test-suite-list* :test #'test-name=)))
   6.177-    (car ok)
   6.178-    (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*))))
   6.179-
   6.180-(defun check-suite-designator (suite) (check-type suite test-suite-designator))
   6.181-
   6.182-(defun assert-suite (name)
   6.183-  (check-suite-designator name)
   6.184-  (assert (ensure-suite name)))
   6.185-
   6.186-(declaim (inline test-opt-key-p test-opt-valid-p))
   6.187-(defun test-opt-key-p (k)
   6.188-  "Test if K is a `test-opt-key'."
   6.189-  (member k '(:profile :save :stream)))
   6.190-
   6.191-(defun test-opt-valid-p (f)
   6.192-  "Test if F is a valid `test-opt' form. If so, return F else nil."
   6.193-  (when (test-opt-key-p (car f))
   6.194-    f))
   6.195-
   6.196-;;; Conditions
   6.197-(define-condition test-failed (error)
   6.198-  ((reason :accessor fail-reason :initarg :reason :initform "unknown")
   6.199-   (name :accessor fail-name :initarg :name)
   6.200-   (form :accessor fail-form :initarg :form))
   6.201-  (:documentation "Signaled when a test fails.")
   6.202-  (:report (lambda (c s)
   6.203-	     (format s "The following expression failed: ~S~%~A."
   6.204-		     (fail-form c)
   6.205-		     (fail-reason c)))))
   6.206-
   6.207-;;; Protocol
   6.208-(defgeneric eval-test (self)
   6.209-  (:documentation "Eval a `test'."))
   6.210-
   6.211-(defgeneric compile-test (self &key &allow-other-keys)
   6.212-  (:documentation "Compile a `test'."))
   6.213-
   6.214-(defgeneric locked-tests (self)
   6.215-  (:documentation "Return a list of locked tests in `test-suite' object SELF."))
   6.216-
   6.217-(defgeneric push-test (self place)
   6.218-  (:documentation
   6.219-   "Push `test' SELF to the value of slot ':tests' in `test-suite' object PLACE."))
   6.220-
   6.221-(defgeneric pop-test (self)
   6.222-  (:documentation
   6.223-   "Pop the first `test' from the slot-value of ':tests' in `test-suite' object SELF."))
   6.224-
   6.225-(defgeneric push-result (self place)
   6.226-  (:documentation
   6.227-   "Push object SELF to the value of slot ':results' in object PLACE."))
   6.228-
   6.229-(defgeneric pop-result (self)
   6.230-  (:documentation
   6.231-   "Pop the first `test-result' from the slot-value of ':tests' from object SELF."))
   6.232-
   6.233-(defgeneric push-fixture (self place)
   6.234-  (:documentation
   6.235-   "Push object SELF to the value of slot ':results' in object PLACE."))
   6.236-
   6.237-(defgeneric delete-test (self &key &allow-other-keys)
   6.238-  (:documentation "Delete `test' object specified by `test-object' SELF and optional keys."))
   6.239-
   6.240-(defgeneric find-test (self name &key &allow-other-keys)
   6.241-  (:documentation "Find `test' object specified by name and optional keys."))
   6.242-
   6.243-(defgeneric do-test (self &optional test)
   6.244-  (:documentation
   6.245-   "Run `test' SELF, printing results to `*standard-output*'. The second
   6.246-argument is an optional fixture.
   6.247-
   6.248-SELF can also be a `test-suite', in which case the TESTS slot is
   6.249-queried for the value of TEST. If TEST is not provided, pops the car
   6.250-from TESTS."))
   6.251-
   6.252-(defgeneric do-suite (self &key &allow-other-keys)
   6.253-  (:documentation
   6.254-   "Perform actions on `test-suite' object SELF with optional keys."))
   6.255-
   6.256-;;;; Results
   6.257-(deftype result-tag ()
   6.258-  '(or (member :pass :fail :skip) null))
   6.259-
   6.260-(declaim (inline %make-test-result))
   6.261-(defstruct (test-result (:constructor %make-test-result)
   6.262-			(:conc-name  tr-))
   6.263-  (tag nil :type result-tag :read-only t)
   6.264-  (form nil :type form))
   6.265-
   6.266-(defun make-test-result (tag &optional form)
   6.267-  (%make-test-result :tag tag :form form))
   6.268-
   6.269-(defmethod test-pass-p ((res test-result))
   6.270-  (when (eq :pass (tr-tag res)) t))
   6.271-
   6.272-(defmethod test-fail-p ((res test-result))
   6.273-  (when (eq :fail (tr-tag res)) t))
   6.274-
   6.275-(defmethod test-skip-p ((res test-result))
   6.276-  (when (eq :skip (tr-tag res)) t))
   6.277-
   6.278-(defmethod print-object ((self test-result) stream)
   6.279-  (print-unreadable-object (self stream)
   6.280-    (format stream "~A ~A"
   6.281-	    (tr-tag self)
   6.282-	    (tr-form self))))
   6.283-
   6.284-;;; Objects
   6.285-(defclass test-object ()
   6.286-  ((name :initarg :name :initform (required-argument) :type string :accessor test-name)
   6.287-   #+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean))
   6.288-  (:documentation "Super class for all test-related objects."))
   6.289-
   6.290-(defmethod print-object ((self test-object) stream)
   6.291-  "test"
   6.292-  (print-unreadable-object (self stream :type t :identity t)
   6.293-    (format stream "~A"
   6.294-	    (test-name self))))
   6.295-
   6.296-;;;; Tests
   6.297-;; HACK 2023-08-31: inherit sxp?
   6.298-
   6.299-(defclass test (test-object)
   6.300-  ((fn :type symbol :accessor test-fn)
   6.301-   (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench)
   6.302-   (profile :type list :accessor test-profile :initform nil :initarg :profile)
   6.303-   (args :type list :accessor test-args :initform nil :initarg :args)
   6.304-   (decl :type list :accessor test-decl :initform nil :initarg :decl)
   6.305-   (form :initarg :form :initform nil :type function-lambda-expression :accessor test-form)
   6.306-   (doc :initarg :doc :type string :accessor test-doc)
   6.307-   (lock :initarg :lock :type boolean :accessor test-lock-p)
   6.308-   (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p)
   6.309-   (results :initarg :results :type (array test-result) :accessor test-results))
   6.310-  (:documentation "Test class typically made with `deftest'."))
   6.311-
   6.312-(defmethod test-bench-p ((self test))
   6.313-  (when (test-bench self) t))
   6.314-
   6.315-(defmethod get-bench-count ((self test))
   6.316-  (when-let ((v (test-bench self)))
   6.317-    (cond
   6.318-      ((typep v 'fixnum) v)
   6.319-      ((eq v t) *default-bench-count*)
   6.320-      ;; unknown value
   6.321-      (t nil))))
   6.322-
   6.323-(defmethod initialize-instance ((self test) &key name)
   6.324-  ;; (debug! "building test" name)
   6.325-  (setf (test-fn self)
   6.326-	(make-symbol
   6.327-	 (format nil "~A~A"
   6.328-		 name
   6.329-		 (gensym *test-suffix*))))
   6.330-  (setf (test-lock-p self) t)
   6.331-  ;; TODO 2023-09-21: we should count how many checks are in the :form
   6.332-  ;; slot and infer the array dimensions.
   6.333-  (setf (test-results self) (make-array 0 :element-type 'test-result))
   6.334-  (call-next-method))
   6.335-
   6.336-(defmethod print-object ((self test) stream)
   6.337-  (print-unreadable-object (self stream :type t :identity t)
   6.338-    (format stream "~A :fn ~A :args ~A :persist ~A"
   6.339-	    (test-name self)
   6.340-	    (test-fn self)
   6.341-	    (test-args self)
   6.342-	    (test-persist-p self))))
   6.343-
   6.344-;; TODO 2023-09-01: use sxp?
   6.345-;; (defun validate-form (form))
   6.346-
   6.347-(defmethod push-result ((self test-result) (place test))
   6.348-  (with-slots (results) place
   6.349-    (push self results)))
   6.350-
   6.351-(defmethod pop-result ((self test))
   6.352-  (pop (test-results self)))
   6.353-
   6.354-(defmethod eval-test ((self test))
   6.355-  `(progn ,@(test-form self)))
   6.356-
   6.357-(defmethod compile-test ((self test) &key declare &allow-other-keys)
   6.358-  (compile
   6.359-   (test-fn self)
   6.360-   `(lambda ()
   6.361-      ,@(when declare `((declare ,declare)))
   6.362-      ,@(test-form self))))
   6.363-
   6.364-(defun fail! (form &optional fmt &rest args)
   6.365-  (let ((reason (and fmt (apply #'format nil fmt args))))
   6.366-    (with-simple-restart (ignore-fail "Continue testing.")
   6.367-      (error 'test-failed :reason reason :form form))))
   6.368-
   6.369-(defmacro with-test-env (self &body body)
   6.370-  `(catch '%in-test
   6.371-     (setf (test-lock-p ,self) t)
   6.372-     (let* ((*testing* ,self)
   6.373-	    (bail nil)
   6.374-	    r)
   6.375-       (block bail
   6.376-	 ,@body
   6.377-	 (setf (test-lock-p ,self) bail))
   6.378-       r)))
   6.379-
   6.380-(defmethod do-test ((self test) &optional fx)
   6.381-  (declare (ignorable fx))
   6.382-  (with-test-env self
   6.383-    (debug! "running test: " *testing*)
   6.384-    (flet ((%do ()
   6.385-	     (if-let ((opt *compile-tests*))
   6.386-	       ;; RESEARCH 2023-08-31: with-compilation-unit?
   6.387-	       (progn 
   6.388-		 (when (eq opt t) (setq opt *default-test-opts*))
   6.389-		 ;; TODO 2023-09-21: handle failures here
   6.390-		 (funcall (compile-test self :declare opt))
   6.391-		 (setf r (make-test-result :pass (test-fn self))))
   6.392-	       (progn
   6.393-		 (eval-test self)
   6.394-		 (setf r (make-test-result :pass (test-name self)))))))
   6.395-      (if *catch-test-errors*
   6.396-	  (handler-bind
   6.397-	      ((style-warning #'muffle-warning)
   6.398-	       (error 
   6.399-		 #'(lambda (c)
   6.400-		     (setf bail t)
   6.401-		     (setf r (make-test-result :fail c))
   6.402-		     (return-from bail r))))
   6.403-	    (%do))
   6.404-	  (%do)))))
   6.405-
   6.406-(defmacro bench (iter &body body)
   6.407-  `(loop for i from 1 to ,iter
   6.408-	 do ,@body))
   6.409-
   6.410-(defmethod do-bench ((self test) &optional fx)
   6.411-  (declare (ignorable fx))
   6.412-  (with-test-env self
   6.413-    (flet ((%do ()
   6.414-	     (if-let ((opt *compile-tests*))
   6.415-	       (progn 
   6.416-		 (when (eq opt t) (setq opt *default-test-opts*))
   6.417-		 ;; TODO 2023-09-21: handle failures here
   6.418-		 (let ((fn (compile-test self :declare opt)))
   6.419-		   (bench (test-bench self) (funcall fn)))
   6.420-		 (setf r (make-test-result :pass (test-fn self))))
   6.421-	       (progn
   6.422-		 (bench (test-bench self) (eval-test self))
   6.423-		 (setf r (make-test-result :pass (test-name self)))))))
   6.424-      (if *catch-test-errors*
   6.425-	  (handler-bind
   6.426-	      ((style-warning #'muffle-warning)
   6.427-	       (error 
   6.428-		 #'(lambda (c)
   6.429-		     (setf bail t)
   6.430-		     (setf r (make-test-result :fail c))
   6.431-		     (return-from bail r))))
   6.432-	    (%do))
   6.433-	  (%do)))))
   6.434-
   6.435-;;;; Fixtures
   6.436-
   6.437-;; Our fixtures are just closures - with a pandoric environment. You
   6.438-;; might call it a domain-specific object protocol.
   6.439-
   6.440-;; You can build fixtures inside a test or use the push-fixture
   6.441-;; method on a `test-suite' object.
   6.442-
   6.443-(deftype fixture () 'form)
   6.444-
   6.445-(declaim (inline %make-fixture-prototype))
   6.446-(defstruct (fixture-prototype (:constructor %make-fixture-prototype)
   6.447-			      (:conc-name fxp))
   6.448-  (kind :empty :type keyword)
   6.449-  (form nil :type form))
   6.450-
   6.451-(defun make-fixture-prototype (kind form)
   6.452-  (%make-fixture-prototype :kind kind :form form))
   6.453-
   6.454-(defmacro make-fixture (letargs &body ds)
   6.455-  (let ((letargs (let-binding-transform letargs)))
   6.456-    `(let (,@letargs)
   6.457-       (dlambda ,@ds))))
   6.458-
   6.459-(defmacro with-fixture ((var fx) &body body)
   6.460-  `(let ((,var ,fx))
   6.461-     ,@body))
   6.462-
   6.463-;;;; Suites
   6.464-(defclass test-suite (test-object)
   6.465-  ((tests :initarg :set :initform nil :type list :accessor tests
   6.466-	  :documentation "test-suite tests")
   6.467-   (results :initarg :results :initform nil :type list :accessor test-results
   6.468-	    :documentation "test-suite results")
   6.469-   (stream :initarg :stream :initform *standard-output* :type stream :accessor test-stream)
   6.470-   (fixtures :initarg :fixtures :initform nil :type list :accessor test-fixtures))
   6.471-  (:documentation "A class for collections of related `test' objects."))
   6.472-
   6.473-(defmethod print-object ((self test-suite) stream)
   6.474-  (print-unreadable-object (self stream :type t :identity t)
   6.475-    (format stream "~A [~d+~d:~d:~d:~d]"
   6.476-	    (test-name self)
   6.477-	    (count t (map-tests self (lambda (x) (not (test-bench-p x)))))
   6.478-	    (count t (map-tests self #'test-bench-p))
   6.479-	    (count t (map-tests self #'test-lock-p))
   6.480-	    (count t (map-tests self #'test-persist-p))
   6.481-	    (length (test-results self)))))
   6.482-
   6.483-;; (defmethod reinitialize-instance ((self test-suite) &rest initargs &key &allow-other-keys))
   6.484-
   6.485-(deftype test-suite-designator ()
   6.486-  "Either nil, a symbol, a string, or a `test-suite' object."
   6.487-  '(or null symbol string test-suite test keyword))
   6.488-
   6.489-(defmethod map-tests ((self test-suite) function)
   6.490-  (mapcar function (tests self)))
   6.491-
   6.492-(defmethod push-test ((self test) (place test-suite))
   6.493-  (push self (tests place)))
   6.494-
   6.495-(defmethod pop-test ((self test-suite))
   6.496-  (pop (tests self)))
   6.497-
   6.498-(defmethod push-result ((self test-result) (place test-suite))
   6.499-  (with-slots (results) place
   6.500-    (push self results)))
   6.501-
   6.502-(defmethod pop-result ((self test-suite))
   6.503-  (pop (test-results self)))
   6.504-
   6.505-(defmethod find-test ((self test-suite) name &key (test #'test-name=))
   6.506-  (declare (type (or string symbol) name)
   6.507-	   (type function test))
   6.508-  (find name (the list (tests self)) :test test))
   6.509-
   6.510-(defmethod do-test ((self test-suite) &optional test)
   6.511-  (push-result 
   6.512-   (if test
   6.513-       (do-test (find-test self (test-name test)))
   6.514-       (do-test (pop-test self)))
   6.515-   self))
   6.516-
   6.517-;; HACK 2023-09-01: find better method of declaring failures from
   6.518-;; within the body of `deftest'.
   6.519-(defmethod do-suite ((self test-suite) &key stream)
   6.520-  (when stream (setf (test-stream self) stream))
   6.521-  (with-slots (name stream) self
   6.522-    (format stream "in suite ~x with ~A/~A tests:~%"
   6.523-	    name
   6.524-	    (count t (tests self)
   6.525-		   :key (lambda (x) (or (test-lock-p x) (test-persist-p x))))
   6.526-	    (length (tests self)))
   6.527-    ;; loop over each test, calling `do-test' if locked or persistent
   6.528-    (map-tests self 
   6.529-	       (lambda (x)
   6.530-		 (when (or (test-lock-p x) (test-persist-p x))
   6.531-		   (let ((res (do-test x)))
   6.532-		     (push-result res self)
   6.533-		     (format stream "~@[~<~%~:;~:@(~S~) ~>~]~%" res)))))
   6.534-    ;; compare locked vs expected
   6.535-    (let ((locked (remove-if #'null (map-tests self (lambda (x) (when (test-lock-p x) x)))))
   6.536-	  (fails
   6.537-	    ;; collect if locked test not expected
   6.538-	    (loop for r in (test-results self)
   6.539-		  unless (test-pass-p r)
   6.540-		    collect r)))
   6.541-      (if (null locked)
   6.542-	  (format stream "~&No tests failed.~%")
   6.543-	  (progn
   6.544-	    ;;  RESEARCH 2023-09-04: print fails ??
   6.545-	    (format stream "~&~A out of ~A ~
   6.546-                   total tests failed: ~
   6.547-                   ~:@(~{~<~%   ~1:;~S~>~
   6.548-                         ~^, ~}~)."
   6.549-		    (length locked)
   6.550-		    (length (tests self))
   6.551-		    locked)
   6.552-	    (unless (null fails)
   6.553-	      (format stream "~&~A unexpected failures: ~
   6.554-                   ~:@(~{~<~%   ~1:;~S~>~
   6.555-                         ~^, ~}~)."
   6.556-		      (length fails)
   6.557-		      fails))))
   6.558-      ;; close stream
   6.559-      (finish-output stream)
   6.560-      ;; return values (PASS? LOCKED)
   6.561-      (values (not fails) locked))))
   6.562-
   6.563-;;; Checks
   6.564-(flet ((%test (val form)
   6.565-	 (let ((r 
   6.566-		 (if val 
   6.567-		     (make-test-result :pass form)
   6.568-		     (make-test-result :fail form))))
   6.569-	   (debug! r)
   6.570-	   r)))
   6.571-  (defmacro is (test &rest args)
   6.572-    "The DWIM Check.
   6.573-
   6.574-(is (= 1 1) :test 100) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1))
   6.575-If TEST returns a truthy value, return a PASS test-result, else return
   6.576-a FAIL. The TEST is parameterized by ARGS which is a plist or nil.
   6.577-
   6.578-If ARGS is nil, TEST is bound to to the RESULT slot of the test-result
   6.579-and evaluated 'as-is'.
   6.580-
   6.581-(nyi!)
   6.582-ARGS may contain the following keywords followed by a corresponding
   6.583-value:
   6.584-
   6.585-:EXPECTED
   6.586-
   6.587-:TIMEOUT
   6.588-
   6.589-:THEN
   6.590-
   6.591-All other values are treated as let bindings.
   6.592-"
   6.593-    (with-gensyms (form)
   6.594-      `(if ,(null args)
   6.595-	   (if *testing* 
   6.596-	       (push-result (funcall ,#'%test ,test ',test) *testing*)
   6.597-	       (funcall ,#'%test ,test ',test))
   6.598-	   (macrolet ((,form (test) `(let ,,(group args 2) ,,test)))
   6.599-	     ;; TODO 2023-09-21: does this work...
   6.600-	     (if *testing*
   6.601-		 (push-result (funcall ,#'%test (,form ,test) ',test) *testing*)
   6.602-		 (funcall ,#'%test (,form ,test) ',test)))))))
   6.603-
   6.604-(defmacro signals (condition-spec &body body)
   6.605-  "Generates a passing TEST-RESULT if body signals a condition of type
   6.606-CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC
   6.607-is not evaluated."
   6.608-  (let ((block-name (gensym)))
   6.609-    (destructuring-bind (condition &optional reason-control &rest reason-args)
   6.610-        (ensure-list condition-spec)
   6.611-      `(block ,block-name
   6.612-         (handler-bind ((,condition (lambda (c)
   6.613-                                      ;; ok, body threw condition
   6.614-				      ;; TODO 2023-09-05: result collectors
   6.615-                                      ;; (add-result 'test-passed
   6.616-                                      ;;            :test-expr ',condition)
   6.617-                                      (return-from ,block-name (make-test-result :pass ',body)))))
   6.618-           (block nil
   6.619-             ,@body))
   6.620-         (fail!
   6.621-          ',condition
   6.622-          ,@(if reason-control
   6.623-                `(,reason-control ,@reason-args)
   6.624-                `("Failed to signal a ~S" ',condition)))
   6.625-         (return-from ,block-name nil)))))
   6.626-
   6.627-;;; Macros
   6.628-(defmacro deftest (name props &body body)
   6.629-  "Build a test with NAME, parameterized by LAMBDA-LIST and with a test form of BODY."
   6.630-  (destructuring-bind (pr doc dec fn)
   6.631-      (multiple-value-bind (forms dec doc)
   6.632-	  ;; parse body with docstring allowed
   6.633-	  (sb-int:parse-body
   6.634-	   (or body) t)
   6.635-	`(,props ',doc ',dec ',forms))
   6.636-    ;; TODO 2023-09-21: parse plist
   6.637-    `(let ((obj (make-test
   6.638-		 :name ',(format nil "~A" name)
   6.639-		 ;; note: we could leave these unbound if we want,
   6.640-		 ;; personal preference
   6.641-		 :form ,fn
   6.642-		 ,@(when-let ((v (getf pr :persist))) `(:persist ,v))
   6.643-		 ,@(when-let ((v (getf pr :args))) `(:args ,v))
   6.644-		 ,@(when-let ((v (getf pr :bench))) `(:bench ,v))
   6.645-		 ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
   6.646-		 ,@(when doc `(:doc ,doc))
   6.647-		 ,@(when dec `(:decl ,dec)))))
   6.648-       (push-test obj *test-suite*)
   6.649-       obj)))
   6.650-
   6.651-(defmacro defsuite (suite-name &rest props)
   6.652-  "Define a `test-suite' with provided keys. The object returned can be
   6.653-enabled using the `in-suite' macro, similiar to the `defpackage' API."
   6.654-  (check-type suite-name (or symbol string))
   6.655-  `(eval-when (:compile-toplevel :load-toplevel :execute)
   6.656-     (let ((obj (make-suite
   6.657-		 :name (format nil "~A" ',suite-name)
   6.658-		 ,@(when-let ((v (getf props :stream))) `(:stream ,v)))))
   6.659-       (setq *test-suite-list* (spush obj *test-suite-list* :test #'test-name=))
   6.660-       obj)))
   6.661-
   6.662-(defmacro in-suite (name)
   6.663-  "Set `*test-suite*' to the `test-suite' referred to by symbol
   6.664-NAME. Return the `test-suite'."
   6.665-  (assert-suite name)
   6.666-  `(setf *test-suite* (ensure-suite ',name)))
   6.667-
   6.668-(provide :rt)

     7.1--- a/lisp/lib/rt/tests.lisp	Mon Oct 16 19:33:42 2023 -0400
     7.2+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3@@ -1,17 +0,0 @@
     7.4-;;; rt/tests.lisp
     7.5-(defpkg :rt/tests
     7.6- (:use :cl :rt))
     7.7-(defsuite :rt)
     7.8-(in-suite :rt)
     7.9-(deftest rt (:bench 100 :profile t :persist nil)
    7.10-  (is (typep (make-fixture-prototype :empty nil) 'fixture-prototype))
    7.11-  (with-fixture (fx (make-fixture ((a 1) (b 2)) 
    7.12-		      (:+ () (+ (incf a) (incf b)))
    7.13-		      (:- () (- (decf a) (decf b)))
    7.14-		      (t () 0)))
    7.15-    (is (= 5 (funcall fx :+)))
    7.16-    (is (= 7 (funcall fx :+)))
    7.17-    (is (= 5 (funcall fx :-)))
    7.18-    (is (= 0 (funcall fx))))
    7.19-  (signals (error t) (test-form (make-instance 'test-result))))
    7.20-

     8.1--- a/lisp/lib/sxp.asd	Mon Oct 16 19:33:42 2023 -0400
     8.2+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.3@@ -1,27 +0,0 @@
     8.4-;;; sxp.asd
     8.5-(defsystem "sxp"
     8.6-  :version "0.1.0"
     8.7-  :author "ellis <ellis@rwest.io>"
     8.8-  :maintainer "ellis <ellis@rwest.io>"
     8.9-  :depends-on ("macs")
    8.10-  :description "S-eXPressions"
    8.11-  :homepage "https://rwest.io/sxp"
    8.12-  :bug-tracker "https://lab.rwest.io/comp/sxp/issues"
    8.13-  :source-control "https://lab.rwest.io/comp/sxp"
    8.14-  :license "WTF"
    8.15-  :in-order-to ((test-op (test-op :sxp/tests)))
    8.16-  :components ((:file "sxp/sxp")))
    8.17-
    8.18-(defmethod perform :after ((op load-op) (c (eql (find-system :sxp))))
    8.19-  (pushnew :sxp *features*))
    8.20-
    8.21-(defsystem "sxp/tests"
    8.22-  :depends-on ("sxp" "rt" "uiop")
    8.23-  :components ((:file "sxp/tests"))
    8.24-  :perform (test-op (op c)
    8.25-		    (uiop:symbol-call '#:rt '#:do-tests)))
    8.26-
    8.27-(defsystem "sxp/bench"
    8.28-  :depends-on ("sxp" "uiop" "sb-sprof" "flamegraph")
    8.29-  :components ((:file "sxp/bench"))
    8.30-  :perform (test-op (op c) (uiop:symbol-call '#:sxp-bench '#:run-bench)))

     9.1--- a/lisp/lib/sxp/bench.lisp	Mon Oct 16 19:33:42 2023 -0400
     9.2+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3@@ -1,49 +0,0 @@
     9.4-(require :sb-sprof)
     9.5-(defpackage :sxp-bench
     9.6-  (:use :cl :sxp :sb-ext :sb-unix)
     9.7-  (:export :run-bench :*bench-input-file* :*bench-input-string* :*bench-input-object*
     9.8-	   :*bench-output-directory* :*bench-iterations* :*bench-report-file* ;:*bench-flamegraph-file*
     9.9-	   ))
    9.10-(in-package :sxp-bench)
    9.11-(declaim
    9.12- (type (or string pathname) *bench-input-file* *bench-output-directory* *bench-report-file*)
    9.13- (type string *bench-input-string*)
    9.14- (type sxp *bench-input-object*)
    9.15- (type integer *bench-iterations*))
    9.16-(defparameter *bench-input-file* "tests.sxp")
    9.17-(defparameter *bench-input-string* (uiop:read-file-string *bench-input-file*))
    9.18-(defparameter *bench-input-object* (make-instance 'sxp))
    9.19-(read-sxp-string *bench-input-object* *bench-input-string*)
    9.20-
    9.21-(defparameter *bench-output-directory* "/tmp/sxp-bench")
    9.22-(defparameter *bench-iterations* 1000)
    9.23-(defparameter *bench-report-file* "bench.sxp")
    9.24-;; (defparameter *bench-flamegraph-file* "bench.stack")
    9.25-(defmacro bench (&body body)
    9.26-  `(loop for i from 1 to *bench-iterations*
    9.27-	 do ,@body))
    9.28-
    9.29-(defun rbench (fn input)
    9.30-  (let ((res))
    9.31-    (bench (call-with-timing (lambda (&rest x) (push (cons i x) res)) fn input))
    9.32-    (nreverse res)))
    9.33-
    9.34-(defun wbench (fn)
    9.35-  (let ((res))
    9.36-    (bench (let ((out (make-pathname :name (format nil "~d.sxp" i) :directory *bench-output-directory*)))
    9.37-	     (call-with-timing (lambda (&rest x) (push (cons i x) res)) fn *bench-input-object* out :if-exists :supersede)))
    9.38-    (nreverse res)))
    9.39-
    9.40-(defun run-bench (&optional rpt)
    9.41-  (when (probe-file *bench-output-directory*)
    9.42-    (sb-ext:delete-directory *bench-output-directory* :recursive t))
    9.43-  (sb-unix:unix-mkdir *bench-output-directory* #o777)
    9.44-  (let ((rres (sb-sprof:with-profiling (:sample-interval 0.001) (rbench #'sxp:read-sxp-file *bench-input-file*)))
    9.45-	(wres (sb-sprof:with-profiling (:sample-interval 0.001) (wbench #'sxp:write-sxp-file))))
    9.46-    (if rpt
    9.47-	(progn
    9.48-	  (format t "Writing output to ~s" *bench-report-file*)
    9.49-	  (uiop:with-output-file (out *bench-report-file* :if-exists :supersede :if-does-not-exist :create)
    9.50-	    (print `(,@rres ,@wres) out)))
    9.51-	(print (list rres wres))))
    9.52-  (terpri))

    10.1--- a/lisp/lib/sxp/sxp.lisp	Mon Oct 16 19:33:42 2023 -0400
    10.2+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3@@ -1,158 +0,0 @@
    10.4-;;; sxp.lisp --- S-eXPressions
    10.5-
    10.6-;; sxp is a unified S-Expression data format
    10.7-
    10.8-;;; Code:
    10.9-(pkg:defpkg :sxp
   10.10-    (:use :cl :sb-mop :sym :fu)
   10.11-  (:import-from :uiop :read-file-forms :slurp-stream-forms :with-output-file)
   10.12-  ;; TODO: hot-patch readtables into sxp classes/parsers
   10.13-  (:import-from :readtables :defreadtable :in-readtable)
   10.14-  (:export
   10.15-   :sxp-fmt-designator
   10.16-   :form :formp :sxp-error :sxp-fmt-error :sxp-syntax-error :reader :writer :fmt
   10.17-   :wrap :wrap! :wrap-from-string! :unwrap :unwrap! :unwrap-or
   10.18-   :sxpp :build-ast :load-ast :ast
   10.19-   :define-macro :define-fmt :read-sxp-file :write-sxp-file
   10.20-   :read-sxp-string :write-sxp-string :read-sxp-stream :write-sxp-stream
   10.21-   :make-sxp :sxp :formp :form
   10.22-   :wrap-object :unwrap-object))
   10.23-
   10.24-(in-package :sxp)
   10.25-
   10.26-(defun formp (form)
   10.27-  (or (consp form) (atom form)))
   10.28-
   10.29-(deftype form ()
   10.30-  '(satisfies formp))
   10.31-
   10.32-;;; Conditions
   10.33-(define-condition sxp-error (error) ())
   10.34-
   10.35-(define-condition sxp-fmt-error (sxp-error)
   10.36-  ((format-control :initarg :format-control :reader format-control)
   10.37-   (format-arguments :initarg :format-arguments :reader format-arguments))
   10.38-  (:report (lambda (c s)
   10.39-             (apply 'format s (format-control c) (format-arguments c)))))
   10.40-
   10.41-(define-condition sxp-syntax-error (sxp-error) ())
   10.42-
   10.43- ;;; Protocol
   10.44-(defgeneric wrap (self form))
   10.45-(defgeneric wrap! (self form))
   10.46-(defgeneric wrap-from-string! (self str))
   10.47-(defgeneric unwrap (self))
   10.48-(defgeneric unwrap! (self))
   10.49-(defgeneric unwrap-or (self lambda))
   10.50-(defgeneric sxpp (self form))
   10.51-
   10.52-(defgeneric write-sxp-stream (self stream &key pretty case))
   10.53-(defgeneric read-sxp-stream (self stream))
   10.54-
   10.55-(defgeneric build-ast (self &key &allow-other-keys)
   10.56-  (:documentation "build the sxp representation of SELF and store it in the :ast
   10.57-slot. The :ast slot is always ignored."))
   10.58-
   10.59-(defgeneric load-ast (self)
   10.60-  (:documentation "load the object SELF from the :ast slot."))
   10.61-
   10.62-;;; Objects
   10.63-(defclass sxp ()
   10.64-  ((ast :initarg :ast :type form :accessor ast))
   10.65-  (:documentation "Dynamic class representing a SXP form."))
   10.66-
   10.67-(defmethod wrap! ((self sxp) form) (setf (slot-value self 'ast) (ignore-errors form)))
   10.68-
   10.69-(defmethod wrap-from-string! ((self sxp) str) (setf (slot-value self 'ast) (ignore-errors (read str))))
   10.70-
   10.71-(defmethod wrap ((self sxp) form) (setf (slot-value self 'ast) form))
   10.72-
   10.73-(defmethod unwrap ((self sxp)) (slot-value self 'ast))
   10.74-
   10.75-(defmethod unwrap! ((self sxp)) (ignore-errors (slot-value self 'ast)))
   10.76-
   10.77-(defmethod unwrap-or ((self sxp) else-fn)
   10.78-  (if (slot-unbound 'sxp self 'ast)
   10.79-      (slot-value self 'ast)
   10.80-      (if (null (slot-value self 'ast))
   10.81-	  (funcall else-fn))))
   10.82-
   10.83-(defmethod write-sxp-stream ((self sxp) stream &key (pretty *print-pretty*) (case :downcase))
   10.84-  (write (ast self)
   10.85-	 :stream stream
   10.86-	 :pretty pretty
   10.87-	 :case case))
   10.88-
   10.89-(defmethod read-sxp-stream ((self sxp) stream)
   10.90-  (setf (ast self) (slurp-stream-forms stream :count nil)))
   10.91-
   10.92-;; (defsetf unwrap ) (defsetf wrap )
   10.93-
   10.94-;;; Functions
   10.95-(defun read-sxp-file (file)
   10.96-  (make-instance 'sxp :ast (read-file-forms file)))
   10.97-
   10.98-(defun write-sxp-file (sxp file &optional &key if-exists)
   10.99-  (with-output-file (out file) :if-exists if-exists
  10.100-    (write-sxp-stream sxp out)))
  10.101-
  10.102-(defun read-sxp-string (self str) (with-input-from-string (s str) (read-sxp-stream self s)))
  10.103-
  10.104-(defun write-sxp-string (sxp) 
  10.105-  (let ((ast (ast sxp)))
  10.106-    (if (> (length ast) 1)
  10.107-	(write-to-string ast)
  10.108-	(write-to-string (car ast)))))
  10.109-
  10.110-(defun make-sxp (&rest form) (make-instance 'sxp :ast form))
  10.111-
  10.112-(deftype sxp-fmt-designator () '(member :canonical :collapsed)) 
  10.113-
  10.114-(defun unwrap-object (obj &key (slots t) (methods nil)
  10.115-			    (indirect nil) (tag nil)
  10.116-			    (unboundp nil) (nullp nil)
  10.117-			    (exclude nil))
  10.118-  "Build and return a new `form' from OBJ by traversing the class
  10.119-definition. This differs from the generic function `unwrap' which
  10.120-always uses the ast slot as an internal buffer. We can also call this
  10.121-on any class instance (doesn't need to subclass `sxp').
  10.122-
  10.123-SLOTS specifies the slots to be included in the output. If the value
  10.124-is t, all slots are included. The ast slot is not included by default,
  10.125-but this behavior may change in future revisions.
  10.126-
  10.127-When INDIRECT is non-nil, also include methods which indirectly
  10.128-specialize on OBJ.
  10.129-
  10.130-When TAG is non-nil, return a cons where car is TAG and cdr is the
  10.131-output. If TAG is t, use the class-name symbol."
  10.132-  (declare (type standard-object obj)
  10.133-	   (type (or list boolean) slots)
  10.134-	   (type (or list boolean) methods)
  10.135-	   (type boolean indirect)
  10.136-	   (type list exclude))
  10.137-  (unless (or slots methods)
  10.138-    (error "Required one missing key arg: SLOTS or METHODS"))
  10.139-  (let* ((class (class-of obj))
  10.140-	(res (when tag (list (if (eq t tag) (class-name class) tag)))))
  10.141-    (block unwrap
  10.142-      (when-let ((slots (when slots
  10.143-			  (list-class-slots class slots exclude))))
  10.144-	(let ((slot-vals (list-slot-values-using-class class obj (remove-if #'null slots) nullp unboundp)))
  10.145-	  (if methods
  10.146-	      (push slot-vals res)
  10.147-	      (return-from unwrap (push slot-vals res)))))
  10.148-      (when-let ((methods (when methods (list-class-methods class methods indirect))))
  10.149-	(push methods res)))
  10.150-    (flatten res)))
  10.151-
  10.152-(defun wrap-object (class form)
  10.153-  "Given a CLASS prototype and an input FORM, return a new instance of
  10.154-CLASS. FORM is assumed to be the finalized lisp object which has
  10.155-already passed through `read' -- not a string or file-stream for
  10.156-example."
  10.157-  (declare (type class class)
  10.158-	   (type form form)))
  10.159-
  10.160-;; (defmacro define-fmt ())
  10.161-;; (defmacro define-macro ())

    11.1--- a/lisp/lib/sxp/tests.lisp	Mon Oct 16 19:33:42 2023 -0400
    11.2+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3@@ -1,38 +0,0 @@
    11.4-;;; tests.lisp --- SEXP tests
    11.5-(pkg:defpkg :sxp.tests
    11.6-    (:use :cl :sxp :macs :rt)
    11.7-  (:export :*test-file* :*test-string*))
    11.8-
    11.9-(in-package :sxp.tests)
   11.10-(in-readtable *macs-readtable*)
   11.11-(declaim
   11.12- (type (or string pathname) *test-file*)
   11.13- (type string *test-string*))
   11.14-(defparameter *test-file* "tests.sxp")
   11.15-(defparameter *test-string* "(FOO 'BAR `(\"test\" ,BAZ ,@QUX) 123 0.0123 1/3 `(,A1 ,A2))")
   11.16-
   11.17-(defsuite :sxp)
   11.18-(in-suite :sxp)
   11.19-
   11.20-(deftest forms ()
   11.21-  (is (formp nil))
   11.22-  (is (formp t))
   11.23-  (is (formp 3.14))
   11.24-  (is (formp "string"))
   11.25-  (is (formp (mapc #`(',a1) '(a))))
   11.26-  (is (formp ())))
   11.27-
   11.28-(deftest sxp-file ()
   11.29-  (let ((f (read-sxp-file *test-file*)))
   11.30-    (is (equal (unwrap f) (unwrap f)))))
   11.31-
   11.32-(deftest sxp-string ()
   11.33-  (let ((f (make-instance 'sxp)))
   11.34-    (is (formp (read-sxp-string f *test-string*)))
   11.35-    (is (equalp (read-from-string (write-sxp-string f)) (read-from-string *test-string*)))))
   11.36-
   11.37-(deftest sxp-stream ()
   11.38-  (let ((f (make-instance 'sxp)))
   11.39-    (with-input-from-string (s *test-string*)
   11.40-      (read-sxp-stream f s))
   11.41-    (is (write-sxp-stream f nil))))

    12.1--- a/lisp/lib/sxp/tests.sxp	Mon Oct 16 19:33:42 2023 -0400
    12.2+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.3@@ -1,42 +0,0 @@
    12.4-; skip me maybe
    12.5-;; this file does not contain quote characters.
    12.6-(edges-1
    12.7-(
    12.8-(1389.886593 1341.567282)
    12.9-(1383.122623 1339.369530)
   12.10-)
   12.11-(
   12.12-(1383.122623 1339.369530)
   12.13-(1387.706464 1325.261939)
   12.14-)
   12.15-(
   12.16-(1387.706464 1325.261939)
   12.17-(1394.470360 1327.459664)
   12.18-)
   12.19-(
   12.20-(1394.470360 1327.459664)
   12.21-(1389.886593 1341.567282)
   12.22-)
   12.23-) ; edges end
   12.24-
   12.25-(edges-2
   12.26-( ( 1.1 2.2 ) (2.2 3.3) )
   12.27-( ( 2.2 3.3 ) (3.3 3.3) )
   12.28-( ( 3.3 3.3 ) (1.1 2.2) )
   12.29-) ; end edges of triangle room
   12.30-
   12.31-(= 4 4)
   12.32-(= 5 4)
   12.33-(> 4.0 54.0)
   12.34-(= 4 s)
   12.35-(= (= 4 4) (> 5 4))
   12.36-(not (= 3 3))
   12.37-(not 4)
   12.38-(if (= 4 4) 42 666)
   12.39-(if (= 4.0 4.0) (42))
   12.40-(+ 4 4)
   12.41-(+ 5.0 6.5)
   12.42-(- 4 5)
   12.43-(^ 2 3)
   12.44-(^ 3 2)
   12.45-(^ 3 (+ 2 1))

    13.1--- a/lisp/std.asd	Mon Oct 16 19:33:42 2023 -0400
    13.2+++ b/lisp/std.asd	Mon Oct 16 22:25:50 2023 -0400
    13.3@@ -2,6 +2,14 @@
    13.4 (defsystem :std
    13.5   :pathname "std"
    13.6   :class :package-inferred-system
    13.7-  :depends-on (:std/all)
    13.8+  :defsystem-depends-on (:asdf-package-system)
    13.9+  :depends-on (:std/pkg :std/all)
   13.10   :in-order-to ((test-op (test-op "std/tests")))
   13.11   :perform (test-op (o c) (symbol-call :rt :do-tests :std)))
   13.12+
   13.13+(defsystem :std/tests
   13.14+  :pathname "std"
   13.15+  :depends-on (:std :rt)
   13.16+  :components ((:file "tests")))
   13.17+
   13.18+(asdf:register-system-packages "std/all" '(:std))

    14.1--- a/lisp/std/alien.lisp	Mon Oct 16 19:33:42 2023 -0400
    14.2+++ b/lisp/std/alien.lisp	Mon Oct 16 22:25:50 2023 -0400
    14.3@@ -19,9 +19,9 @@
    14.4 ;; represented by objects of type ALIEN-VALUE.
    14.5 
    14.6 ;;; Code:
    14.7-(pkg:defpkg :std/alien
    14.8+(uiop:define-package :std/alien
    14.9   (:nicknames :alien)
   14.10-  (:use :cl :sb-vm :sb-ext :sb-c :str :sym :fu)
   14.11+  (:use :cl :sb-vm :sb-ext :sb-c :std/base :std/fu)
   14.12   (:use-reexport :sb-alien)
   14.13   (:export
   14.14    :copy-c-string

    15.1--- a/lisp/std/all.lisp	Mon Oct 16 19:33:42 2023 -0400
    15.2+++ b/lisp/std/all.lisp	Mon Oct 16 22:25:50 2023 -0400
    15.3@@ -1,14 +1,14 @@
    15.4-(defpkg :std/all
    15.5+;; TODO replace with defpkg
    15.6+(uiop:define-package :std/all
    15.7   (:nicknames :std)
    15.8   (:use-reexport
    15.9-   :pkg
   15.10-   :named-readtables
   15.11-   :alien
   15.12-   :ana
   15.13-   :pan
   15.14-   :log
   15.15-   :str
   15.16-   :sym
   15.17-   :list
   15.18-   :fmt
   15.19-   :fs))
   15.20+   :std/base
   15.21+   :std/ana
   15.22+   :std/pan
   15.23+   :std/log
   15.24+   :std/fu
   15.25+   :std/fmt
   15.26+   :std/sxp
   15.27+   :std/cli
   15.28+   :std/alien
   15.29+   :std/thread))

    16.1--- a/lisp/std/ana.lisp	Mon Oct 16 19:33:42 2023 -0400
    16.2+++ b/lisp/std/ana.lisp	Mon Oct 16 22:25:50 2023 -0400
    16.3@@ -1,9 +1,9 @@
    16.4 ;;; ana.lisp --- anaphoric macros
    16.5 
    16.6 ;;; Code:
    16.7-(defpackage :std/ana
    16.8-  (:use :cl :readtables :fu)
    16.9+(uiop:define-package :std/ana
   16.10   (:nicknames :ana)
   16.11+  (:use :cl :std/named-readtables :std/fu)
   16.12   (:export
   16.13    #:alambda
   16.14    #:nlet-tail
   16.15@@ -15,7 +15,7 @@
   16.16    #:this
   16.17    #:self))
   16.18 
   16.19-(in-package :macs.ana)
   16.20+(in-package :std/ana)
   16.21 
   16.22 (in-readtable :std)
   16.23 

    17.1--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2+++ b/lisp/std/base.lisp	Mon Oct 16 22:25:50 2023 -0400
    17.3@@ -0,0 +1,6 @@
    17.4+(uiop:define-package :std/base
    17.5+  (:use-reexport :cl :std/named-readtables :std/pkg :std/str :std/sym :std/list :std/cond))
    17.6+   
    17.7+   
    17.8+   
    17.9+   

    18.1--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2+++ b/lisp/std/cli.lisp	Mon Oct 16 22:25:50 2023 -0400
    18.3@@ -0,0 +1,782 @@
    18.4+;;; cli.lisp --- cli programming api and utils
    18.5+
    18.6+;; This package contains a simple api and macros for building lisp CLI
    18.7+;; programs.
    18.8+
    18.9+;;; Commentary:
   18.10+
   18.11+;; - inspired by: clingon, uiop
   18.12+
   18.13+;; Basic assumptions at runtime:
   18.14+;;   - running in a POSIX-compliant shell
   18.15+;;   - output stream supports UTF-8
   18.16+
   18.17+;; TODO 2023-10-14: install-ast, install-thunk, proc-args, etc should
   18.18+;; return IR types - CLI-IR THUNK and CLI-IR respectively.
   18.19+
   18.20+;; TODO 2023-10-14: rename cli-ast to cli-ir, install-ast to
   18.21+;; install-ir, etc.
   18.22+
   18.23+;;; Code:
   18.24+(uiop:define-package :std/cli
   18.25+  (:nicknames :cli)
   18.26+  (:use :cl :std/base :std/fu :std/ana :std/fmt :std/log)
   18.27+  (:import-from :std/ana :alet)
   18.28+  (:import-from :uiop :println)
   18.29+  (:import-from :sb-posix :filename-designator)
   18.30+  (:import-from :sb-ext :parse-native-namestring)
   18.31+  (:shadowing-import-from :sb-ext :exit)
   18.32+  (:export
   18.33+   :*argv*
   18.34+   :init-args
   18.35+   :cli-arg0
   18.36+   :cli-args
   18.37+   :command-line-args
   18.38+   :*cli-group-separator*
   18.39+   :*cli-opt-kinds*
   18.40+   :global-opt-p
   18.41+   :exec-path-list
   18.42+   :argp
   18.43+   :$val
   18.44+   :$args
   18.45+   :$argc
   18.46+   :$opts
   18.47+   :$optc
   18.48+   :make-shorty
   18.49+   :with-cli-handlers
   18.50+   :completing-read
   18.51+   :make-prompt!
   18.52+   :defmain
   18.53+   :main
   18.54+   :with-cli
   18.55+   :make-cli
   18.56+   ;; opt-parsers
   18.57+   :make-opt-parser
   18.58+   :parse-bool-opt
   18.59+   :parse-str-opt
   18.60+   :parse-form-opt
   18.61+   :parse-list-opt
   18.62+   :parse-sym-opt
   18.63+   :parse-key-opt
   18.64+   :parse-num-opt
   18.65+   :parse-str-opt
   18.66+   :parse-file-opt
   18.67+   :parse-dir-opt
   18.68+   :make-opts
   18.69+   :make-cmds
   18.70+   :active-opts
   18.71+   :active-cmds
   18.72+   :proc-args
   18.73+   :make-cli-node
   18.74+   :make-cli-ast
   18.75+   :proc-args
   18.76+   :parse-args
   18.77+   :debug-opts
   18.78+   :do-cmd
   18.79+   :do-opt
   18.80+   :call-opt
   18.81+   :call-cmd
   18.82+   :apply-cmd
   18.83+   :print-help
   18.84+   :print-version
   18.85+   :print-usage
   18.86+   :handle-unknown-argument
   18.87+   :handle-missing-argument
   18.88+   :handle-invalid-argument
   18.89+   :cli-opt
   18.90+   :cli-val
   18.91+   :cli-cmd-args
   18.92+   :cli-cmd
   18.93+   :cli-cwd
   18.94+   :find-cmd
   18.95+   :find-opt
   18.96+   :find-short-opt
   18.97+   :install-ast
   18.98+   ;; :gen-cli-thunk
   18.99+   :install-thunk
  18.100+   :cli
  18.101+   :cli-equal
  18.102+   :defopt
  18.103+   :defcmd
  18.104+   :define-cli
  18.105+   ;; ast types
  18.106+   :opt
  18.107+   :cmd
  18.108+   :arg
  18.109+   :cli-name
  18.110+   :cli-opts
  18.111+   :cli-cmds
  18.112+   :cli-thunk
  18.113+   :cli-description
  18.114+   :cli-version
  18.115+   :cli-usage))
  18.116+
  18.117+(in-package :std/cli)
  18.118+
  18.119+(defun cli-arg0 () (car sb-ext:*posix-argv*))
  18.120+(defun cli-args () (cdr sb-ext:*posix-argv*))
  18.121+
  18.122+(declaim (inline exec-path-list))
  18.123+(defun exec-path-list ()
  18.124+  (let ((var (sb-posix:getenv "PATH")))
  18.125+    (mapcar #'directory
  18.126+	    (loop for i = 0 then (1+ j)
  18.127+		  as j = (position #\: var :start i)
  18.128+		  collect (subseq var i j)
  18.129+		while j))))
  18.130+
  18.131+(defparameter *cli-group-separator*
  18.132+  "--"
  18.133+  "A marker specifying the end of a unique group of CLI args.")
  18.134+
  18.135+;; uiop:command-line-arguments
  18.136+
  18.137+;;; Macros
  18.138+(defmacro argp (arg &optional (args (cli-args)))
  18.139+  "Test for presence of ARG in ARGS. Return the tail of
  18.140+ARGS starting from the position of ARG."
  18.141+  `(member ,arg ,args :test #'string=))
  18.142+
  18.143+(defmacro make-shorty (name)
  18.144+  "Return the first char of symbol or string NAME."
  18.145+  `(character (aref (if (stringp ,name) ,name (symbol-name ,name)) 0)))
  18.146+
  18.147+;; (defun treat-as-argument (condition)
  18.148+;;   "A handler which can be used to invoke the `treat-as-argument' restart"
  18.149+;;   (invoke-restart (find-restart 'treat-as-argument condition)))
  18.150+
  18.151+;; (defun discard-argument (condition)
  18.152+;;   "A handler which can be used to invoke the `discard-argument' restart"
  18.153+;;   (invoke-restart (find-restart 'discard-argument condition)))
  18.154+
  18.155+(defmacro with-cli-handlers (form)
  18.156+  "A wrapper which handles common cli errors that may occur during
  18.157+evaluation of FORM."
  18.158+  `(handler-case ,form
  18.159+     (sb-sys:interactive-interrupt ()
  18.160+       (format *error-output* "~&(:SIGINT)~&")
  18.161+       (exit :code 130))
  18.162+     (error (c)
  18.163+       (format *error-output* "~&~A~&" c)
  18.164+       (exit :code 1))))
  18.165+
  18.166+(defun init-args () (setq *argv* (cons (cli-arg0) (cli-args))))
  18.167+
  18.168+(defmacro with-cli (slots cli &body body)
  18.169+  "Like with-slots with some extra bindings."
  18.170+  ;; (with-gensyms (cli-body)
  18.171+  ;;  (let ((cli-body (mapcar (lambda (x) ()) cli-body)
  18.172+  `(progn
  18.173+     (init-args)
  18.174+     (setf (cli-cwd ,cli) (sb-posix:getcwd))
  18.175+     (with-slots ,slots (parse-args ,cli *argv* :compile t)
  18.176+       ,@body)))
  18.177+
  18.178+;;; Prompts
  18.179+(declaim (inline completing-read))
  18.180+(defun completing-read (prompt collection
  18.181+			&key (history nil) (default nil)
  18.182+			(key nil) (test nil))
  18.183+
  18.184+  "A simplified COMPLETING-READ for common-lisp.
  18.185+
  18.186+The Emacs completion framework includes a function called
  18.187+`completing-read' which prompts the user for input from the
  18.188+mini-buffer. It is a very flexible interface which can be used to read
  18.189+user input programatically. This is incredibly useful for building
  18.190+data entry interfaces -- for example see the `make-prompt!' macro.
  18.191+
  18.192+Obviously writing a completion framework is out-of-scope, but we can
  18.193+simulate one by embedding a DSL in our prompters if we choose. For
  18.194+example, perhaps we treat a single '?' character as a request from the
  18.195+user to list valid options while continue waiting for input."
  18.196+  (princ prompt)
  18.197+  ;; ensure we empty internal buffer
  18.198+  (finish-output)
  18.199+  (let* ((coll (symbol-value collection))
  18.200+	 (r (if coll
  18.201+		(find (read-line) coll :key key :test test)
  18.202+		(or (read-line) default))))
  18.203+    (prog1
  18.204+	r
  18.205+    (setf (symbol-value history) (push r history)))))
  18.206+
  18.207+(defmacro make-prompt! (var &optional prompt)
  18.208+  "Generate a 'prompter' from list or variable VAR and optional
  18.209+PROMPT string.
  18.210+
  18.211+This isn't an ideal solution as it does in fact expose a dynamic
  18.212+variable (VAR-prompt-history). We should generate accessors and
  18.213+keep the variables within lexical scope of the generated
  18.214+closure."
  18.215+  (with-gensyms (s p h)
  18.216+    `(let ((,s (if (boundp ',var) (symbol-value ',var) 
  18.217+		   (progn 
  18.218+		     (defvar ,(symb var) nil)
  18.219+		     ',(symb var))))
  18.220+           (,p (when (stringp ,prompt) ,prompt)) ;; prompt string
  18.221+           (,h ',(symb var '-prompt-history))) ;; history symbol
  18.222+       (defvar ,(symb var '-prompt-history) nil)
  18.223+       (defun ,(symb var '-prompt) ()
  18.224+	 ,(format nil "Prompt for a value from `~A', use DEFAULT if non-nil
  18.225+and no value is provided by user, otherwise fallback to the `car'
  18.226+of `~A-PROMPT-HISTORY'." var var)
  18.227+	 (completing-read
  18.228+          (format nil "~A [~A]: "
  18.229+		  (or ,p ">")
  18.230+		  (car (symbol-value ,h)))
  18.231+	  ,s :history ,h :default nil)))))
  18.232+
  18.233+(defmacro define-cli-constant (name cli &optional doc)
  18.234+  `(define-constant ,name ,cli ,@doc :test #'cli-equal))
  18.235+
  18.236+(defvar *default-cli-def* 'defparameter)
  18.237+
  18.238+(defmacro defcmd (name &body body)
  18.239+  `(defun ,name ($args $opts) 
  18.240+     (declare (ignorable $args $opts))
  18.241+     (let (($argc (length $args))
  18.242+	   ($optc (length $opts)))
  18.243+       (declare (ignorable $argc $optc))
  18.244+       ,@body)))
  18.245+
  18.246+(defmacro defopt (name &body body)
  18.247+  `(defun ,name ($val)
  18.248+     (declare (ignorable $val))
  18.249+     ,@body))
  18.250+
  18.251+(declaim (inline walk-cli-slots))
  18.252+(defun walk-cli-slots (cli)
  18.253+  "Walk the plist CLI, performing actions as necessary based on the slot
  18.254+keys."
  18.255+  (loop for kv in (group cli 2)
  18.256+	when (eql :thunk (car kv))
  18.257+	  return (let ((th (cdr kv)))
  18.258+		   (if (or (functionp th) (symbolp th)) (funcall th) (compile nil (lambda () th)))))
  18.259+	cli)
  18.260+
  18.261+(defmacro define-cli (name &body body)
  18.262+  "Define a symbol NAME bound to a top-level CLI object."
  18.263+  (declare (type symbol name))
  18.264+      `(,*default-cli-def* ,name (apply #'make-cli t (walk-cli-slots ',body))))
  18.265+
  18.266+(defmacro defmain (ret &body body)
  18.267+  "Define a main function in the current package which returns RET.
  18.268+
  18.269+Note that this macro does not export the defined function and requires
  18.270+`cli:main' to be an external symbol."
  18.271+  `(progn
  18.272+     (declaim (type stream output))
  18.273+     (defun main (&key (output *standard-output*))
  18.274+       "Run the top-level function and print to OUTPUT."
  18.275+       (let ((*standard-output* output))
  18.276+	 (with-cli-handlers
  18.277+	     (progn ,@body ,ret))))))
  18.278+
  18.279+;;; Utils
  18.280+(defvar *argv*)
  18.281+
  18.282+(defun make-cli (kind &rest slots)
  18.283+  "Creates a new CLI object of the given kind."
  18.284+  (declare (type (member :opt :cmd :cli t) kind))
  18.285+  (apply #'make-instance
  18.286+   (cond
  18.287+     ((eql kind :cli) 'cli)
  18.288+     ((eql kind :opt) 'cli-opt)
  18.289+     ((eql kind :cmd) 'cli-cmd)
  18.290+     (t 'cli))
  18.291+    slots))
  18.292+
  18.293+;; RESEARCH 2023-09-12: closed over hash-table with short/long flags
  18.294+;; to avoid conflicts. if not, need something like a flag-function
  18.295+;; slot at class allocation.
  18.296+(defmacro make-opts (&body opts)
  18.297+  `(map 'vector
  18.298+	(lambda (x)
  18.299+	  (etypecase x
  18.300+	    (string (make-cli :opt :name x))
  18.301+	    (list (apply #'make-cli :opt x))
  18.302+	    (t (make-cli :opt :name (format nil "~(~A~)" x) :global t))))
  18.303+	(walk-cli-slots ',opts)))
  18.304+
  18.305+(defmacro make-cmds (&body opts)
  18.306+  `(map 'vector
  18.307+	(lambda (x)
  18.308+	  (etypecase x
  18.309+	    (string (make-cli :cmd :name x))
  18.310+	    (list (apply #'make-cli :cmd x))
  18.311+	    (t (make-cli :cmd :name (format nil "~(~A~)" x)))))
  18.312+	(walk-cli-slots ',opts)))
  18.313+
  18.314+(defun long-opt-p (str)
  18.315+  (and (char= (aref str 0) (aref str 1) #\-)
  18.316+       (> (length str) 2)))
  18.317+
  18.318+(defun short-opt-p (str)
  18.319+  (and (char= (aref str 0) #\-)
  18.320+       (not (char= (aref str 1) #\-))
  18.321+       (> (length str) 1)))
  18.322+
  18.323+(defun opt-group-p (str)
  18.324+  (string= str *cli-group-separator*))
  18.325+
  18.326+(defun opt-prefix-eq (ch str)
  18.327+  (char= (aref str 0) ch))
  18.328+
  18.329+(defun gen-thunk-ll (origin args)
  18.330+  (let ((a0 (list (symb '$a 0) origin)))
  18.331+    (group 
  18.332+     (nconc (loop for i from 1 for a in args nconc (list (symb '$a i) a)) a0 )
  18.333+     2)))
  18.334+
  18.335+;; TODO 2023-10-06: 
  18.336+;; (defmacro gen-cli-thunk (pvars &rest thunk)
  18.337+;;   "Generate and return a function based on THUNK suitable for the :thunk
  18.338+;; slot of cli objects with pandoric bindings PVARS.")
  18.339+
  18.340+;;; Protocol
  18.341+(defgeneric push-cmd (cmd place))
  18.342+
  18.343+(defgeneric push-opt (opt place))
  18.344+
  18.345+(defgeneric pop-cmd (place))
  18.346+
  18.347+(defgeneric pop-opt (place))
  18.348+
  18.349+(defgeneric find-cmd (self name &optional active))
  18.350+
  18.351+(defgeneric find-opt (self name &optional active))
  18.352+
  18.353+(defgeneric active-cmds (self))
  18.354+
  18.355+(defgeneric active-opts (self &optional global))
  18.356+
  18.357+(defgeneric find-short-opt (self ch))
  18.358+
  18.359+(defgeneric call-opt (self arg))
  18.360+
  18.361+(defgeneric do-opt (self))
  18.362+
  18.363+(defgeneric call-cmd (self args opts))
  18.364+
  18.365+(defgeneric parse-args (self args &key &allow-other-keys)
  18.366+  (:documentation "Parse list of strings ARGS using SELF.
  18.367+
  18.368+A list of the same length as ARGS is returned containing 'cli-ast'
  18.369+objects: (OPT . (or char string)) (CMD . string) NIL"))
  18.370+
  18.371+(defgeneric do-cmd (self)
  18.372+  (:documentation "Run the command SELF with args parsed at runtime."))
  18.373+
  18.374+(defgeneric print-help (self &optional stream)
  18.375+  (:documentation "Format cli SELF as a helpful string."))
  18.376+
  18.377+(defgeneric print-version (self &optional stream)
  18.378+  (:documentation "Print the version of SELF."))
  18.379+
  18.380+(defgeneric print-usage (self &optional stream)
  18.381+  (:documentation "Format cli SELF as a useful string."))
  18.382+
  18.383+(defgeneric handle-unknown-argument (self arg)
  18.384+  (:documentation "Handle an unknown argument."))
  18.385+
  18.386+(defgeneric handle-missing-argument (self arg)
  18.387+  (:documentation "Handle a missing argument."))
  18.388+
  18.389+(defgeneric handle-invalid-argument (self arg)
  18.390+  (:documentation "Handle an invalid argument."))
  18.391+
  18.392+(defgeneric cli-equal (a b))
  18.393+
  18.394+(defun default-thunk (cli) (lambda (x) (declare (ignore x)) (print-help cli)))
  18.395+
  18.396+(defvar *cli-opt-kinds* '(bool str form list sym key num file dir))
  18.397+
  18.398+(defun cli-opt-kind-p (s)
  18.399+  (declare (type symbol s))
  18.400+  (find s *cli-opt-kinds*))
  18.401+
  18.402+(defmacro make-opt-parser (kind-spec &body body)
  18.403+  "Return a KIND-opt-parser function based on KIND-SPEC which is either a
  18.404+symbol from *cli-opt-kinds* or a list, and optional BODY which
  18.405+is a list of handlers for the opt-val."
  18.406+  (let* ((kind (if (consp kind-spec) (car kind-spec) kind-spec))
  18.407+	 (super (when (consp kind-spec) (cadr kind-spec)))
  18.408+	 (fn-name (symb 'parse- kind '-opt)))
  18.409+    ;; thread em
  18.410+    (let ((fn1 (when (not (eql 'nil super)) (symb 'parse- super '-opt))))
  18.411+      `(progn
  18.412+	 (defun ,fn-name ($val)
  18.413+	   "Parse the cli-opt-val $VAL."
  18.414+	   ;; do stuff
  18.415+	   (when (not (eql ',fn1 'nil)) (setq $val (funcall ',fn1 $val)))
  18.416+	   ,@body)))))
  18.417+
  18.418+(make-opt-parser bool $val)
  18.419+
  18.420+(make-opt-parser (str bool) (when (stringp $val) $val))
  18.421+
  18.422+(make-opt-parser (form str) (read-from-string $val))
  18.423+
  18.424+(make-opt-parser (list form) (when (listp $val) $val))
  18.425+
  18.426+(make-opt-parser (sym form) (when (symbolp $val) $val))
  18.427+
  18.428+(make-opt-parser (key form) (when (keywordp $val) $val))
  18.429+
  18.430+(make-opt-parser (num form) (when (numberp $val) $val))
  18.431+
  18.432+(make-opt-parser (file str) 
  18.433+  (when $val (parse-native-namestring $val nil *default-pathname-defaults* :as-directory nil)))
  18.434+
  18.435+(make-opt-parser (dir str) 
  18.436+  (when $val (sb-ext:parse-native-namestring $val nil *default-pathname-defaults* :as-directory t)))
  18.437+
  18.438+;;; Objects
  18.439+(defclass cli-opt ()
  18.440+  ;; note that cli-opts can have a nil or unbound name slot
  18.441+  ((name :initarg :name :initform (required-argument :name) :accessor cli-name :type string)
  18.442+   (kind :initarg :kind :initform 'boolean :accessor cli-opt-kind :type cli-opt-kind-p)
  18.443+   (thunk :initform #'default-thunk :initarg :thunk :type function-lambda-expression :accessor cli-thunk)
  18.444+   (val :initarg :val :initform nil :accessor cli-val :type form)
  18.445+   (global :initarg :global :initform nil :accessor global-opt-p :type boolean)
  18.446+   (description :initarg :description :accessor cli-description :type string)
  18.447+   (lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean))
  18.448+  (:documentation "CLI option"))
  18.449+
  18.450+(defmethod handle-unknown-argument ((self cli-opt) arg))
  18.451+(defmethod handle-missing-argument ((self cli-opt) arg))
  18.452+(defmethod handle-invalid-argument ((self cli-opt) arg))
  18.453+
  18.454+(defmethod initialize-instance :after ((self cli-opt) &key)
  18.455+  (with-slots (name thunk) self
  18.456+    (unless (stringp name) (setf name (format nil "~(~A~)" name)))
  18.457+    (when (symbolp thunk) (setf thunk (funcall (compile nil `(lambda () ,(symbol-function thunk))))))
  18.458+    self))
  18.459+
  18.460+(defmethod install-thunk ((self cli-opt) (lambda function) &optional compile)
  18.461+  "Install THUNK into the corresponding slot in cli-cmd SELF."
  18.462+  (let ((%thunk (if compile (compile nil lambda) lambda)))
  18.463+    (setf (cli-thunk self) %thunk)
  18.464+    self))
  18.465+
  18.466+(defmethod print-object ((self cli-opt) stream)
  18.467+  (print-unreadable-object (self stream :type t)
  18.468+    (format stream "~A :global ~A :val ~A"
  18.469+            (cli-name self)
  18.470+	    (global-opt-p self)
  18.471+	    (cli-val self))))
  18.472+
  18.473+(defmethod print-usage ((self cli-opt) &optional stream)
  18.474+  (format stream " -~(~{~A~^/--~}~)~A~A"
  18.475+	  (if-let ((n (cli-name self)))
  18.476+	    (list (make-shorty n) n)
  18.477+	    'dyn)
  18.478+	  (if (global-opt-p self) "* " "  ")
  18.479+	  (if-let ((d (and (slot-boundp self 'description) (cli-description self))))
  18.480+	    (format stream ":  ~A" d)
  18.481+	    "")))
  18.482+
  18.483+(defmethod cli-equal ((a cli-opt) (b cli-opt))
  18.484+  (with-slots (name global kind) a
  18.485+    (with-slots ((bn name) (bg global) (bk kind)) b
  18.486+      (and (string= name bn)
  18.487+	   (eql global bg)
  18.488+	   (eql kind bk)))))
  18.489+
  18.490+(defmethod call-opt ((self cli-opt) arg)
  18.491+  (funcall (compile nil (cli-thunk self)) arg))
  18.492+
  18.493+(defmethod do-opt ((self cli-opt))
  18.494+  (call-opt self (cli-val self)))
  18.495+
  18.496+(defclass cli-cmd ()
  18.497+  ;; name slot is required and must be a string
  18.498+  ((name :initarg :name :initform (required-argument :name) :accessor cli-name :type string)
  18.499+   (opts :initarg :opts :initform (make-array 0 :element-type 'cli-opt)
  18.500+	 :accessor cli-opts :type (vector cli-opt))
  18.501+   (cmds :initarg :cmds :initform (make-array 0 :element-type 'cli-cmd)
  18.502+	 :accessor cli-cmds :type (vector cli-cmd))
  18.503+   (thunk :initform #'default-thunk :initarg :thunk :accessor cli-thunk :type function-lambda-expression)
  18.504+   (lock :initform nil :initarg :lock :accessor cli-lock-p :type boolean)
  18.505+   (description :initarg :description :accessor cli-description :type string)
  18.506+   (args :initform nil :initarg :args :accessor cli-cmd-args))
  18.507+  (:documentation "CLI command"))
  18.508+
  18.509+(defmethod initialize-instance :after ((self cli-cmd) &key)
  18.510+  (with-slots (name cmds opts thunk) self
  18.511+    (unless (stringp name) (setf name (format nil "~(~A~)" name)))
  18.512+    (unless (vectorp cmds) (setf cmds (funcall (compile nil `(lambda () ,cmds)))))
  18.513+    (unless (vectorp opts) (setf opts (funcall (compile nil `(lambda () ,opts)))))
  18.514+    (when (symbolp thunk) (setf thunk (symbol-function thunk)))
  18.515+    self))
  18.516+
  18.517+(defmethod print-object ((self cli-cmd) stream)
  18.518+  (print-unreadable-object (self stream :type t)
  18.519+    (format stream "~A :opts ~A :cmds ~A :args ~A"
  18.520+	  (cli-name self)
  18.521+          (length (cli-opts self))
  18.522+	  (length (cli-cmds self))
  18.523+	  (length (cli-cmd-args self)))))
  18.524+
  18.525+(defmethod print-usage ((self cli-cmd) &optional stream)
  18.526+  (with-slots (opts cmds) self
  18.527+    (format stream "~(~A~)  ~A~A~A"
  18.528+	    (cli-name self)
  18.529+	    (if-let ((d (and (slot-boundp self 'description) (cli-description self))))
  18.530+	      (format nil ":  ~A" d)
  18.531+	      "")
  18.532+	    (if (null opts)
  18.533+		""
  18.534+		(format nil "~{~%    ~A~^~}" (loop for o across opts collect (print-usage o nil))))
  18.535+	    (if (null cmds)
  18.536+		""
  18.537+		(format nil "~%    ~{!  ~A~}" (loop for c across cmds collect (print-usage c nil)))))))
  18.538+
  18.539+(defmethod push-cmd ((self cli-cmd) (place cli-cmd))
  18.540+  (vector-push self (cli-cmds place)))
  18.541+
  18.542+(defmethod push-opt ((self cli-opt) (place cli-cmd))
  18.543+  (vector-push self (cli-opts place)))
  18.544+
  18.545+(defmethod pop-cmd ((self cli-cmd))
  18.546+  (vector-pop (cli-cmds self)))
  18.547+
  18.548+(defmethod pop-opt ((self cli-opt))
  18.549+  (vector-pop (cli-opts self)))
  18.550+
  18.551+(defmethod cli-equal ((a cli-cmd) (b cli-cmd))
  18.552+  (with-slots (name opts cmds) a
  18.553+    (with-slots ((bn name) (bo opts) (bc cmds)) b
  18.554+      (and (string= name bn)
  18.555+	   (if (and (null opts) (null bo))
  18.556+	       t
  18.557+	       (unless (member nil (loop for oa across opts
  18.558+					 for ob across bo
  18.559+					 collect (cli-equal oa ob)))
  18.560+		 t))
  18.561+	   (if (and (null cmds) (null bc))
  18.562+	       t
  18.563+	       (unless (member nil (loop for ca across cmds
  18.564+					 for cb across bc
  18.565+					 collect (cli-equal ca cb)))
  18.566+		 t))))))
  18.567+
  18.568+;; typically when starting from a top-level `cli', the global
  18.569+;; `cli-opts' will be parsed first, followed by the first command
  18.570+;; found. If a command is found, the tail of the list is passed as
  18.571+;; arguments to this function, which can pass additonal arguments to
  18.572+;; nested commands.
  18.573+
  18.574+;;  TODO 2023-09-12: Parsing restarts at the `*cli-group-separator*'
  18.575+;; if present, or stops at EOI.
  18.576+
  18.577+(declaim (inline %make-cli-node))
  18.578+(defstruct (cli-node (:constructor %make-cli-node)) kind form)
  18.579+
  18.580+(defun make-cli-node (kind form)
  18.581+  (%make-cli-node :kind kind :form form))
  18.582+
  18.583+(declaim (inline %make-cli-ast))
  18.584+(defstruct (cli-ast (:constructor %make-cli-ast)) ast)
  18.585+
  18.586+(defun make-cli-ast (nodes)  
  18.587+  (%make-cli-ast :ast nodes))
  18.588+
  18.589+(defmethod find-cmd ((self cli-cmd) name &optional active)
  18.590+  (when-let ((c (find name (cli-cmds self) :key #'cli-name :test #'string=)))
  18.591+    (if active 
  18.592+	;; maybe issue warning here? report to user
  18.593+	(when (cli-lock-p c) c)
  18.594+	c)))
  18.595+
  18.596+(defmethod active-cmds ((self cli-cmd))
  18.597+  (remove-if-not #'cli-lock-p (cli-cmds self)))
  18.598+
  18.599+
  18.600+(defmethod find-opt ((self cli-cmd) name &optional active)
  18.601+  (when-let ((o (find name (cli-opts self) :key #'cli-name :test #'string=)))
  18.602+    (if active 
  18.603+	(when (cli-lock-p o) o)
  18.604+	o)))
  18.605+
  18.606+(defun active-global-opt-p (opt)
  18.607+  "Return non-nil if OPT is active at runtime and global."
  18.608+  (when (and (cli-lock-p opt) (global-opt-p opt)) t))
  18.609+
  18.610+(defmethod active-opts ((self cli-cmd) &optional global)
  18.611+  (remove-if-not 
  18.612+   (if global 
  18.613+       #'active-global-opt-p 
  18.614+       #'cli-lock-p)
  18.615+   (cli-opts self)))
  18.616+
  18.617+(defmethod find-short-opt ((self cli-cmd) ch)
  18.618+  (find ch (cli-opts self) :key #'cli-name :test #'opt-prefix-eq))
  18.619+
  18.620+(defmethod proc-args ((self cli-cmd) args)
  18.621+  "process ARGS into an ast. Each element of the ast is a node with a
  18.622+:kind slot, indicating the type of node and a :form slot which stores
  18.623+a value.
  18.624+
  18.625+For now we parse group separators '--' and insert a nil into the tree,
  18.626+this will likely change to generating a new branch in the ast as it
  18.627+should be."
  18.628+  (make-cli-ast
  18.629+   (loop 
  18.630+     for a in args
  18.631+     if (= (length a) 1) collect (make-cli-node 'arg a)
  18.632+     ;; SHORT OPT
  18.633+     else if (short-opt-p a)
  18.634+	    collect (if-let ((o (find-short-opt self (aref a 1))))
  18.635+		      (progn
  18.636+			(setf (cli-val o) t)
  18.637+			(make-cli-node 'opt o))
  18.638+		      (make-cli-node 'arg a))
  18.639+
  18.640+     ;; LONG OPT
  18.641+     else if (long-opt-p a)
  18.642+	    ;; what we actually want to do is consume the next sequence of args - TBD
  18.643+	    collect (if-let ((o (find-opt self (string-trim "-" a))))
  18.644+		      (progn
  18.645+			(setf (cli-val o) (string-trim "-" a))
  18.646+			(make-cli-node 'opt o))
  18.647+		      (make-cli-node 'arg a))
  18.648+     ;; OPT GROUP
  18.649+     else if (opt-group-p a)
  18.650+	    collect nil
  18.651+     ;; CMD
  18.652+     else if (find-cmd self a)
  18.653+	    ;; TBD
  18.654+	    collect (make-cli-node 'cmd (find-cmd self a))
  18.655+     ;; ARG
  18.656+     else collect (make-cli-node 'arg a))))
  18.657+
  18.658+(defmethod install-ast ((self cli-cmd) (ast cli-ast))
  18.659+  "Install the given AST, recursively filling in value slots."
  18.660+  (with-slots (cmds opts) self
  18.661+    ;; we assume all nodes in the ast have been validated and the ast
  18.662+    ;; itself is consumed. validation is performed in proc-args.
  18.663+
  18.664+    ;; before doing anything else we lock SELF, which should remain
  18.665+    ;; locked for the full runtime duration.
  18.666+    (setf (cli-lock-p self) t)
  18.667+    (loop named install
  18.668+	  for (node . tail) on (cli-ast-ast ast)
  18.669+	  unless (null node) 
  18.670+	    do 
  18.671+	       (with-slots (kind form) node
  18.672+		 (case kind
  18.673+		   ;; opts 
  18.674+		   (opt 
  18.675+		    (let ((name (cli-name form))
  18.676+			  (val (cli-val form)))
  18.677+		      (when-let ((o (find-opt self name)))
  18.678+			(setf (cli-val o) val
  18.679+			      (cli-lock-p o) t))))
  18.680+		   ;; when we encounter a command we recurse over the tail
  18.681+		   (cmd 
  18.682+		    (when-let ((c (find-cmd self (cli-name form))))
  18.683+		      (setf (cli-lock-p c) t)
  18.684+		      ;; handle the rest of the AST
  18.685+		      (install-ast c (make-cli-ast tail))
  18.686+		      (return-from install)))
  18.687+		   (arg (push-arg form self)))))
  18.688+    (setf (cli-cmd-args self) (nreverse (cli-cmd-args self)))
  18.689+    self))
  18.690+
  18.691+(defmethod install-thunk ((self cli-cmd) (lambda function) &optional compile)
  18.692+  "Install THUNK into the corresponding slot in cli-cmd SELF."
  18.693+  (let ((%thunk (if compile (compile nil lambda) lambda)))
  18.694+    (setf (cli-thunk self) %thunk)
  18.695+    self))
  18.696+
  18.697+(defmethod push-arg (arg (self cli-cmd))
  18.698+  (push arg (cli-cmd-args self)))
  18.699+
  18.700+(defmethod parse-args ((self cli-cmd) args &key (compile nil))
  18.701+  "Parse ARGS and return the updated object SELF.
  18.702+
  18.703+ARGS is assumed to be a valid cli-ast (list of cli-nodes), unless
  18.704+COMPILE is t, in which case a list of strings is assumed."
  18.705+  (with-slots (opts cmds) self
  18.706+    (let ((args (if compile (proc-args self args) args)))
  18.707+      (print (install-ast self args)))))
  18.708+
  18.709+;; warning: make sure to fill in the opt and cmd slots with values
  18.710+;; from the top-level args before doing a command.
  18.711+(defmethod call-cmd ((self cli-cmd) args opts)
  18.712+  ;; TODO 2023-09-12: handle args/env
  18.713+  (funcall (cli-thunk self) args opts))
  18.714+
  18.715+(defmethod do-cmd ((self cli-cmd))
  18.716+  (call-cmd self (cli-cmd-args self) (cli-opts self)))
  18.717+
  18.718+(defclass cli (cli-cmd)
  18.719+  ;; name slot defaults to *package*, must be string
  18.720+  ((name :initarg :name :initform (string-downcase (package-name *package*)) :accessor cli-name :type string)
  18.721+   (version :initarg :version :initform "0.1.0" :accessor cli-version :type string)
  18.722+   ;; TODO 2023-10-11: look into pushd popd - wd-stack?
  18.723+   (cwd :initarg :cwd :initform (sb-posix:getcwd) :type string :accessor cli-cwd
  18.724+	:documentation "working directory of the top-level CLI."))
  18.725+  (:documentation "CLI"))
  18.726+
  18.727+(defmethod print-usage ((self cli) &optional stream)
  18.728+  (iprintln (format nil "usage: ~A [global] <command> [<arg>]~%" (cli-name self)) 2 stream))
  18.729+
  18.730+(defmethod print-version ((self cli) &optional stream)
  18.731+  (println (cli-version self) stream))
  18.732+
  18.733+(defmethod print-help ((self cli) &optional stream) 
  18.734+  (println (format nil "~A v~A" (cli-name self) (cli-version self)) stream)
  18.735+  (print-usage self stream)
  18.736+  (iprintln (cli-description self) 2 stream)
  18.737+  ;; (terpri stream)
  18.738+  (iprintln "options:" 2 stream)
  18.739+  (with-slots (opts cmds) self
  18.740+    (unless (null opts)
  18.741+      (loop for o across opts
  18.742+	    do (iprintln (print-usage o) 4 stream)))
  18.743+    ;; (terpri stream)
  18.744+    (iprintln "commands:" 2 stream)
  18.745+    (unless (null cmds)
  18.746+      (loop for c across cmds
  18.747+	    do (iprintln (print-usage c) 4 stream)))))
  18.748+
  18.749+(defmethod cli-equal :before ((a cli) (b cli))
  18.750+  "Return T if A is the same cli object as B.
  18.751+
  18.752+Currently this function is intended only for instances of the CLI
  18.753+class and is used as a specialized EQL for DEFINE-CONSTANT."
  18.754+  (with-slots (version) a
  18.755+    (with-slots ((bv version)) b
  18.756+      (string= version bv))))
  18.757+
  18.758+;; same as cli-cmd method, default is to compile though
  18.759+(defmethod parse-args ((self cli) (args list) &key (compile t))
  18.760+  "Parse list of string arguments ARGS and return the updated object SELF."
  18.761+  (with-slots (opts cmds) self
  18.762+    (let ((args (if compile (proc-args self args) args)))
  18.763+      (install-ast self args))))
  18.764+
  18.765+(declaim (inline debug-opts))
  18.766+(defun debug-opts (cli)
  18.767+  (let ((o (active-opts cli))
  18.768+	(a (cli-cmd-args cli))
  18.769+	(c (active-cmds cli)))
  18.770+    (debug! (cli-cwd cli) o a c)))
  18.771+
  18.772+(declaim (inline solop))
  18.773+(defun solop (self)
  18.774+  (and (= 0 (length (active-opts self t)) (length (active-cmds self)))))
  18.775+
  18.776+(defmethod do-cmd ((self cli))
  18.777+  (if (solop self)
  18.778+      (call-cmd self (cli-cmd-args self) (cli-opts self))
  18.779+      (progn
  18.780+	(loop for o across (active-opts self t)
  18.781+	      do (do-opt o))
  18.782+	(loop for c across (active-cmds self)
  18.783+	      do (do-cmd c)))))
  18.784+
  18.785+(provide :cli)

    19.1--- a/lisp/std/cond.lisp	Mon Oct 16 19:33:42 2023 -0400
    19.2+++ b/lisp/std/cond.lisp	Mon Oct 16 22:25:50 2023 -0400
    19.3@@ -3,7 +3,6 @@
    19.4 ;;; Code:
    19.5 (defpackage :std/cond
    19.6   (:use :cl)
    19.7-  (:nicknames :cond)
    19.8   (:export
    19.9    #:nyi!
   19.10    #:required-argument
   19.11@@ -27,7 +26,7 @@
   19.12    #:invalid-argument-p
   19.13    #:unwind-protect-case))
   19.14 
   19.15-(in-package :cond)
   19.16+(in-package :std/cond)
   19.17 
   19.18 (defmacro nyi! (&optional comment)
   19.19   `(prog1

    20.1--- a/lisp/std/fmt.lisp	Mon Oct 16 19:33:42 2023 -0400
    20.2+++ b/lisp/std/fmt.lisp	Mon Oct 16 22:25:50 2023 -0400
    20.3@@ -3,11 +3,11 @@
    20.4 ;;; Code:
    20.5 (defpackage :std/fmt
    20.6   (:nicknames :fmt)
    20.7-  (:use :cl :str :fu :list)
    20.8+  (:use :std/base :std/fu)
    20.9   (:import-from :uiop :println)
   20.10   (:export :printer-status :fmt-row :fmt-sxhash :iprintln :fmt-tree))
   20.11 
   20.12-(in-package :fmt)
   20.13+(in-package :std/fmt)
   20.14 
   20.15 (defun iprintln (x &optional (n 2) stream)
   20.16   (println (format nil "~A~A" (make-string n :initial-element #\Space) x) stream))

    21.1--- a/lisp/std/fs.lisp	Mon Oct 16 19:33:42 2023 -0400
    21.2+++ b/lisp/std/fs.lisp	Mon Oct 16 22:25:50 2023 -0400
    21.3@@ -13,4 +13,4 @@
    21.4   (:use :cl :str :cond :fu)
    21.5   (:export))
    21.6 
    21.7-(in-package :fs)
    21.8+(in-package :std/fs)

    22.1--- a/lisp/std/fu.lisp	Mon Oct 16 19:33:42 2023 -0400
    22.2+++ b/lisp/std/fu.lisp	Mon Oct 16 22:25:50 2023 -0400
    22.3@@ -3,7 +3,7 @@
    22.4 ;;; Code:
    22.5 (defpackage :std/fu
    22.6   (:nicknames :fu)
    22.7-  (:use :cl :sb-mop :sb-c :named-readtables :sym :list :cond)
    22.8+  (:use :cl :sb-mop :sb-c :std/named-readtables :std/sym :std/list :std/cond)
    22.9   (:export
   22.10    :until
   22.11    #:mkstr
   22.12@@ -54,7 +54,7 @@
   22.13    :merge! :sort!
   22.14    :list-slot-values-using-class :list-class-methods :list-class-slots :list-indirect-slot-methods))
   22.15 
   22.16-(in-package :fu)  
   22.17+(in-package :std/fu)
   22.18 
   22.19 ;;; Misc
   22.20 (defmacro until (condition &body body)

    23.1--- a/lisp/std/list.lisp	Mon Oct 16 19:33:42 2023 -0400
    23.2+++ b/lisp/std/list.lisp	Mon Oct 16 22:25:50 2023 -0400
    23.3@@ -2,14 +2,20 @@
    23.4 
    23.5 ;;; Code:
    23.6 (defpackage :std/list
    23.7-  (:nicknames :list)
    23.8   (:use :cl)
    23.9+  (:shadowing-import-from
   23.10+   :sb-int 
   23.11+   :ensure-list :recons :memq :assq :ensure-list 
   23.12+   :proper-list-of-length-p :proper-list-p :singleton-p)
   23.13   (:export
   23.14-   #:ensure-car
   23.15-   #:ensure-cons
   23.16-   :let-binding-transform))
   23.17+   :ensure-car
   23.18+   :ensure-cons
   23.19+   :let-binding-transform
   23.20+   ;; reexports
   23.21+   :ensure-list :recons :memq :assq :ensure-list 
   23.22+   :proper-list-of-length-p :proper-list-p :singleton-p))
   23.23 
   23.24-(in-package :list)
   23.25+(in-package :std/list)
   23.26 
   23.27 ;; (reexport-from :sb-int
   23.28 ;; 	       :include '(:recons :memq :assq :ensure-list :proper-list-of-length-p :proper-list-p

    24.1--- a/lisp/std/log.lisp	Mon Oct 16 19:33:42 2023 -0400
    24.2+++ b/lisp/std/log.lisp	Mon Oct 16 22:25:50 2023 -0400
    24.3@@ -19,12 +19,12 @@
    24.4 ;;; Code:
    24.5 (defpackage :std/log
    24.6   (:nicknames :log)
    24.7-  (:use :cl :str :fmt :sym :fu)
    24.8+  (:use :std/base :std/fu)
    24.9   (:export :*log-level* :log-level-designator :log-timestamp-source 
   24.10    :log! :warn! :info! :debug! :trace!  :dbg!
   24.11    :debug-p))
   24.12 
   24.13-(in-package :log)
   24.14+(in-package :std/log)
   24.15 
   24.16 (deftype log-level-designator () '(member :warn :debug :info :trace))
   24.17 (declaim (type (or boolean log-level-designator) *log-level*))

    25.1--- a/lisp/std/named-readtables.lisp	Mon Oct 16 19:33:42 2023 -0400
    25.2+++ b/lisp/std/named-readtables.lisp	Mon Oct 16 22:25:50 2023 -0400
    25.3@@ -12,7 +12,7 @@
    25.4 ;; behavior (using standard) versus your source code (custom).
    25.5 
    25.6 ;;; Code:
    25.7-(pkg:defpkg :std/named-readtables
    25.8+(defpackage :std/named-readtables
    25.9   (:nicknames :named-readtables)
   25.10   (:use :cl)
   25.11   (:export
   25.12@@ -37,7 +37,7 @@
   25.13    #:readtable-does-not-exist
   25.14    #:parse-body))
   25.15 
   25.16-(in-package :named-readtables)
   25.17+(in-package :std/named-readtables)
   25.18 (pushnew :named-readtables *features*)
   25.19 
   25.20 (defmacro without-package-lock ((&rest package-names) &body body)

    26.1--- a/lisp/std/pan.lisp	Mon Oct 16 19:33:42 2023 -0400
    26.2+++ b/lisp/std/pan.lisp	Mon Oct 16 22:25:50 2023 -0400
    26.3@@ -3,7 +3,7 @@
    26.4 ;;; Code:
    26.5 (defpackage :std/pan
    26.6   (:nicknames :pan)
    26.7-  (:use :cl :named-readtables :fu :ana)
    26.8+  (:use :cl :std/named-readtables :std/fu :std/ana)
    26.9   (:export
   26.10    #:pandoriclet
   26.11    #:pandoriclet-get
   26.12@@ -15,7 +15,7 @@
   26.13    #:plambda
   26.14    #:pandoric-eval))
   26.15 
   26.16-(in-package :pan)
   26.17+(in-package :std/pan)
   26.18 (in-readtable :std)
   26.19 
   26.20 (defun pandoriclet-get (letargs)

    27.1--- a/lisp/std/pkg.lisp	Mon Oct 16 19:33:42 2023 -0400
    27.2+++ b/lisp/std/pkg.lisp	Mon Oct 16 22:25:50 2023 -0400
    27.3@@ -15,7 +15,7 @@
    27.4    #:package-definition-form #:parse-defpkg-form
    27.5    #:ensure-package))
    27.6 
    27.7-(in-package :pkg)
    27.8+(in-package :std/pkg)
    27.9 
   27.10 (eval-when (:load-toplevel :compile-toplevel :execute)
   27.11   (defun find-package* (package-designator &optional (error t))

    28.1--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    28.2+++ b/lisp/std/rt.lisp	Mon Oct 16 22:25:50 2023 -0400
    28.3@@ -0,0 +1,665 @@
    28.4+;;; rt.lisp --- regression testing
    28.5+
    28.6+;; Regression Testing framework. inspired by PCL, the original CMUCL
    28.7+;; code, and the SBCL port.
    28.8+
    28.9+;;; Commentary:
   28.10+
   28.11+;; - :rt https://www.merl.com/publications/docs/TR91-04.pdf Chapter 1
   28.12+;; - :com.gigamonkeys.test https://github.com/gigamonkey/monkeylib-test-framework
   28.13+;; - :sb-rt https://github.com/sbcl/sbcl/blob/master/contrib/sb-rt/rt.lisp
   28.14+
   28.15+;; This package is intended to provide a modernized Lisp testing
   28.16+;; library with features found in some of the test frameworks listed
   28.17+;; below.
   28.18+
   28.19+;; - :it.bese.fiveam https://github.com/lispci/fiveam
   28.20+;; - :try https://github.com/melisgl/try
   28.21+;; - :rove https://github.com/fukamachi/rove
   28.22+
   28.23+;;; TODO:
   28.24+#|
   28.25+
   28.26+- [ ] benchmark support: do-bench, test-count, 
   28.27+
   28.28+- [ ] fixtures api
   28.29+
   28.30+- [ ] profiling 
   28.31+|#
   28.32+;;; Code:
   28.33+#+x86-64
   28.34+(eval-when (:compile-toplevel :load-toplevel :execute)
   28.35+  (require 'sb-sprof))
   28.36+
   28.37+(defpackage :std/rt
   28.38+  (:use
   28.39+   :std/base :std/sxp :std/fu :std/fmt :std/log :std/ana :std/pan 
   28.40+   :std/list :std/sym :std/cond :std/str
   28.41+   :sb-aprof #+x86-64 :sb-sprof)
   28.42+  (:nicknames :rt)
   28.43+  (:export
   28.44+   :*default-test-opts*
   28.45+   :*compile-tests*
   28.46+   :*catch-test-errors*
   28.47+   :*test-suffix*
   28.48+   :*default-test-suite-name*
   28.49+   :*test-suite*
   28.50+   :*test-suite-list*
   28.51+   ;;  TODO 2023-09-04: :*test-profiler-list* not yet
   28.52+   :*testing*
   28.53+   :test-suite-designator
   28.54+   :check-suite-designator
   28.55+   :make-test
   28.56+   :make-suite
   28.57+   :test-name=
   28.58+   :do-test
   28.59+   :do-tests
   28.60+   :continue-testing
   28.61+   :with-test-env
   28.62+   :ensure-suite
   28.63+   :test-fixture
   28.64+   :fixture-prototype
   28.65+   :make-fixture-prototype
   28.66+   :make-fixture
   28.67+   :with-fixture
   28.68+   :test-result
   28.69+   :test-pass-p
   28.70+   :test-fail-p
   28.71+   :test-skip-p
   28.72+   :test-failed
   28.73+   :fail!
   28.74+   :is
   28.75+   :signals
   28.76+   :deftest
   28.77+   :defsuite
   28.78+   :in-suite
   28.79+   :eval-test
   28.80+   :compile-test
   28.81+   :locked-tests
   28.82+   :push-test
   28.83+   :pop-test
   28.84+   :delete-test
   28.85+   :find-test
   28.86+   :do-suite
   28.87+   :test-object
   28.88+   :test
   28.89+   :test-fixture
   28.90+   :test-suite
   28.91+   :test-name
   28.92+   :tests
   28.93+   :test-form
   28.94+   :test-results))
   28.95+
   28.96+(in-package :std/rt)
   28.97+(in-readtable :std)
   28.98+
   28.99+;;; Vars
  28.100+(defvar *default-test-opts* '(optimize sb-c::instrument-consing))
  28.101+(defvar *compile-tests* t
  28.102+  "When nil do not compile tests. With a value of t, tests are compiled
  28.103+with default optimizations else the value is used to configure
  28.104+compiler optimizations.")
  28.105+(defvar *catch-test-errors* t "When non-nil, cause errors in a test to be caught.")
  28.106+(defvar *test-suffix* "-test" "A suffix to append to every `test' defined with `deftest'.")
  28.107+(defvar *test-suite-list* nil "List of available `test-suite' objects.")
  28.108+(defvar *test-suite* nil "A 'test-suite-designator' which identifies the current `test-suite'.")
  28.109+(eval-when (:compile-toplevel :load-toplevel :execute)
  28.110+  (defvar *default-test-suite-name* "default"))
  28.111+(declaim (type (or stream boolean string) *test-input*))
  28.112+(defvar *test-input* nil "When non-nil, specifies an input stream or buffer for `*testing*'.")
  28.113+(defvar *default-bench-count* 100 "Default number of iterations to repeat a bench test for. This value is
  28.114+used when the slot value of :BENCH is t.")
  28.115+(defvar *testing* nil "Testing state var.")
  28.116+
  28.117+;;; Utils
  28.118+(eval-when (:compile-toplevel :load-toplevel :execute)
  28.119+  (defun make-test (&rest slots)
  28.120+    (apply #'make-instance 'test slots))
  28.121+  (defun make-suite (&rest slots)
  28.122+    (apply #'make-instance 'test-suite slots)))
  28.123+
  28.124+;; TODO 2023-09-04: optimize
  28.125+(declaim (inline do-tests))
  28.126+(defun do-tests (&optional (suite *test-suite*) (output *standard-output*))
  28.127+  (if (pathnamep output)
  28.128+      (with-open-file (stream output :direction :output)
  28.129+	(do-suite (ensure-suite suite) :stream stream))
  28.130+      (do-suite (ensure-suite suite) :stream output)))
  28.131+
  28.132+;; this assumes that *test-suite* is re-initialized correctly to the
  28.133+;; correct test-suite object.
  28.134+(defun continue-testing ()
  28.135+  (if-let ((test *testing*))
  28.136+    (throw '%in-test test)
  28.137+    (do-suite *test-suite*)))
  28.138+
  28.139+;; NOTE 2023-09-01: `pushnew' does not return an indication of whether
  28.140+;; place is changed - it returns place. This is functionally sound but
  28.141+;; means that if we want to do something else in the event that place
  28.142+;; is unchanged, we run into some friction,
  28.143+;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure
  28.144+(defun spush (item lst &key (test #'equal))
  28.145+  "Substituting `push'"
  28.146+  (declare (type function test))
  28.147+  (cond
  28.148+    ((null lst) (push item lst))
  28.149+    ((list lst)
  28.150+     (if-let ((found (member item lst
  28.151+			     :test test)))
  28.152+       (progn
  28.153+	 (rplaca found item)
  28.154+	 lst)
  28.155+       (push item lst)))
  28.156+    #|(or nil '(t (cons item lst)))|#))
  28.157+
  28.158+;; FIX 2023-08-31: spush, replace with `add-test' method.
  28.159+;; (declaim (inline normalize-test-name))
  28.160+(defun normalize-test-name (a)
  28.161+  "Return the normalized `test-suite-designator' of A."
  28.162+  (etypecase a
  28.163+    (string a)
  28.164+    (symbol (symbol-name a))
  28.165+    (test-object (test-name a))
  28.166+    (t (format nil "~A" a))))
  28.167+
  28.168+(defun test-name= (a b)
  28.169+  "Return t if A and B are similar `test-suite-designator's."
  28.170+  (let ((a (normalize-test-name a))
  28.171+	(b (normalize-test-name b)))
  28.172+    (string= a b)))
  28.173+
  28.174+;; (declaim (inline assert-suite ensure-suite))
  28.175+(defun ensure-suite (name)
  28.176+  (if-let ((ok (member name *test-suite-list* :test #'test-name=)))
  28.177+    (car ok)
  28.178+    (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*))))
  28.179+
  28.180+(defun check-suite-designator (suite) (check-type suite test-suite-designator))
  28.181+
  28.182+(defun assert-suite (name)
  28.183+  (check-suite-designator name)
  28.184+  (assert (ensure-suite name)))
  28.185+
  28.186+(declaim (inline test-opt-key-p test-opt-valid-p))
  28.187+(defun test-opt-key-p (k)
  28.188+  "Test if K is a `test-opt-key'."
  28.189+  (member k '(:profile :save :stream)))
  28.190+
  28.191+(defun test-opt-valid-p (f)
  28.192+  "Test if F is a valid `test-opt' form. If so, return F else nil."
  28.193+  (when (test-opt-key-p (car f))
  28.194+    f))
  28.195+
  28.196+;;; Conditions
  28.197+(define-condition test-failed (error)
  28.198+  ((reason :accessor fail-reason :initarg :reason :initform "unknown")
  28.199+   (name :accessor fail-name :initarg :name)
  28.200+   (form :accessor fail-form :initarg :form))
  28.201+  (:documentation "Signaled when a test fails.")
  28.202+  (:report (lambda (c s)
  28.203+	     (format s "The following expression failed: ~S~%~A."
  28.204+		     (fail-form c)
  28.205+		     (fail-reason c)))))
  28.206+
  28.207+;;; Protocol
  28.208+(defgeneric eval-test (self)
  28.209+  (:documentation "Eval a `test'."))
  28.210+
  28.211+(defgeneric compile-test (self &key &allow-other-keys)
  28.212+  (:documentation "Compile a `test'."))
  28.213+
  28.214+(defgeneric locked-tests (self)
  28.215+  (:documentation "Return a list of locked tests in `test-suite' object SELF."))
  28.216+
  28.217+(defgeneric push-test (self place)
  28.218+  (:documentation
  28.219+   "Push `test' SELF to the value of slot ':tests' in `test-suite' object PLACE."))
  28.220+
  28.221+(defgeneric pop-test (self)
  28.222+  (:documentation
  28.223+   "Pop the first `test' from the slot-value of ':tests' in `test-suite' object SELF."))
  28.224+
  28.225+(defgeneric push-result (self place)
  28.226+  (:documentation
  28.227+   "Push object SELF to the value of slot ':results' in object PLACE."))
  28.228+
  28.229+(defgeneric pop-result (self)
  28.230+  (:documentation
  28.231+   "Pop the first `test-result' from the slot-value of ':tests' from object SELF."))
  28.232+
  28.233+(defgeneric push-fixture (self place)
  28.234+  (:documentation
  28.235+   "Push object SELF to the value of slot ':results' in object PLACE."))
  28.236+
  28.237+(defgeneric delete-test (self &key &allow-other-keys)
  28.238+  (:documentation "Delete `test' object specified by `test-object' SELF and optional keys."))
  28.239+
  28.240+(defgeneric find-test (self name &key &allow-other-keys)
  28.241+  (:documentation "Find `test' object specified by name and optional keys."))
  28.242+
  28.243+(defgeneric do-test (self &optional test)
  28.244+  (:documentation
  28.245+   "Run `test' SELF, printing results to `*standard-output*'. The second
  28.246+argument is an optional fixture.
  28.247+
  28.248+SELF can also be a `test-suite', in which case the TESTS slot is
  28.249+queried for the value of TEST. If TEST is not provided, pops the car
  28.250+from TESTS."))
  28.251+
  28.252+(defgeneric do-suite (self &key &allow-other-keys)
  28.253+  (:documentation
  28.254+   "Perform actions on `test-suite' object SELF with optional keys."))
  28.255+
  28.256+;;;; Results
  28.257+(deftype result-tag ()
  28.258+  '(or (member :pass :fail :skip) null))
  28.259+
  28.260+(declaim (inline %make-test-result))
  28.261+(defstruct (test-result (:constructor %make-test-result)
  28.262+			(:conc-name  tr-))
  28.263+  (tag nil :type result-tag :read-only t)
  28.264+  (form nil :type form))
  28.265+
  28.266+(defun make-test-result (tag &optional form)
  28.267+  (%make-test-result :tag tag :form form))
  28.268+
  28.269+(defmethod test-pass-p ((res test-result))
  28.270+  (when (eq :pass (tr-tag res)) t))
  28.271+
  28.272+(defmethod test-fail-p ((res test-result))
  28.273+  (when (eq :fail (tr-tag res)) t))
  28.274+
  28.275+(defmethod test-skip-p ((res test-result))
  28.276+  (when (eq :skip (tr-tag res)) t))
  28.277+
  28.278+(defmethod print-object ((self test-result) stream)
  28.279+  (print-unreadable-object (self stream)
  28.280+    (format stream "~A ~A"
  28.281+	    (tr-tag self)
  28.282+	    (tr-form self))))
  28.283+
  28.284+;;; Objects
  28.285+(defclass test-object ()
  28.286+  ((name :initarg :name :initform (required-argument) :type string :accessor test-name)
  28.287+   #+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean))
  28.288+  (:documentation "Super class for all test-related objects."))
  28.289+
  28.290+(defmethod print-object ((self test-object) stream)
  28.291+  "test"
  28.292+  (print-unreadable-object (self stream :type t :identity t)
  28.293+    (format stream "~A"
  28.294+	    (test-name self))))
  28.295+
  28.296+;;;; Tests
  28.297+;; HACK 2023-08-31: inherit sxp?
  28.298+
  28.299+(defclass test (test-object)
  28.300+  ((fn :type symbol :accessor test-fn)
  28.301+   (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench)
  28.302+   (profile :type list :accessor test-profile :initform nil :initarg :profile)
  28.303+   (args :type list :accessor test-args :initform nil :initarg :args)
  28.304+   (decl :type list :accessor test-decl :initform nil :initarg :decl)
  28.305+   (form :initarg :form :initform nil :type function-lambda-expression :accessor test-form)
  28.306+   (doc :initarg :doc :type string :accessor test-doc)
  28.307+   (lock :initarg :lock :type boolean :accessor test-lock-p)
  28.308+   (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p)
  28.309+   (results :initarg :results :type (array test-result) :accessor test-results))
  28.310+  (:documentation "Test class typically made with `deftest'."))
  28.311+
  28.312+(defmethod test-bench-p ((self test))
  28.313+  (when (test-bench self) t))
  28.314+
  28.315+(defmethod get-bench-count ((self test))
  28.316+  (when-let ((v (test-bench self)))
  28.317+    (cond
  28.318+      ((typep v 'fixnum) v)
  28.319+      ((eq v t) *default-bench-count*)
  28.320+      ;; unknown value
  28.321+      (t nil))))
  28.322+
  28.323+(defmethod initialize-instance ((self test) &key name)
  28.324+  ;; (debug! "building test" name)
  28.325+  (setf (test-fn self)
  28.326+	(make-symbol
  28.327+	 (format nil "~A~A"
  28.328+		 name
  28.329+		 (gensym *test-suffix*))))
  28.330+  (setf (test-lock-p self) t)
  28.331+  ;; TODO 2023-09-21: we should count how many checks are in the :form
  28.332+  ;; slot and infer the array dimensions.
  28.333+  (setf (test-results self) (make-array 0 :element-type 'test-result))
  28.334+  (call-next-method))
  28.335+
  28.336+(defmethod print-object ((self test) stream)
  28.337+  (print-unreadable-object (self stream :type t :identity t)
  28.338+    (format stream "~A :fn ~A :args ~A :persist ~A"
  28.339+	    (test-name self)
  28.340+	    (test-fn self)
  28.341+	    (test-args self)
  28.342+	    (test-persist-p self))))
  28.343+
  28.344+;; TODO 2023-09-01: use sxp?
  28.345+;; (defun validate-form (form))
  28.346+
  28.347+(defmethod push-result ((self test-result) (place test))
  28.348+  (with-slots (results) place
  28.349+    (push self results)))
  28.350+
  28.351+(defmethod pop-result ((self test))
  28.352+  (pop (test-results self)))
  28.353+
  28.354+(defmethod eval-test ((self test))
  28.355+  `(progn ,@(test-form self)))
  28.356+
  28.357+(defmethod compile-test ((self test) &key declare &allow-other-keys)
  28.358+  (compile
  28.359+   (test-fn self)
  28.360+   `(lambda ()
  28.361+      ,@(when declare `((declare ,declare)))
  28.362+      ,@(test-form self))))
  28.363+
  28.364+(defun fail! (form &optional fmt &rest args)
  28.365+  (let ((reason (and fmt (apply #'format nil fmt args))))
  28.366+    (with-simple-restart (ignore-fail "Continue testing.")
  28.367+      (error 'test-failed :reason reason :form form))))
  28.368+
  28.369+(defmacro with-test-env (self &body body)
  28.370+  `(catch '%in-test
  28.371+     (setf (test-lock-p ,self) t)
  28.372+     (let* ((*testing* ,self)
  28.373+	    (bail nil)
  28.374+	    r)
  28.375+       (block bail
  28.376+	 ,@body
  28.377+	 (setf (test-lock-p ,self) bail))
  28.378+       r)))
  28.379+
  28.380+(defmethod do-test ((self test) &optional fx)
  28.381+  (declare (ignorable fx))
  28.382+  (with-test-env self
  28.383+    (debug! "running test: " *testing*)
  28.384+    (flet ((%do ()
  28.385+	     (if-let ((opt *compile-tests*))
  28.386+	       ;; RESEARCH 2023-08-31: with-compilation-unit?
  28.387+	       (progn 
  28.388+		 (when (eq opt t) (setq opt *default-test-opts*))
  28.389+		 ;; TODO 2023-09-21: handle failures here
  28.390+		 (funcall (compile-test self :declare opt))
  28.391+		 (setf r (make-test-result :pass (test-fn self))))
  28.392+	       (progn
  28.393+		 (eval-test self)
  28.394+		 (setf r (make-test-result :pass (test-name self)))))))
  28.395+      (if *catch-test-errors*
  28.396+	  (handler-bind
  28.397+	      ((style-warning #'muffle-warning)
  28.398+	       (error 
  28.399+		 #'(lambda (c)
  28.400+		     (setf bail t)
  28.401+		     (setf r (make-test-result :fail c))
  28.402+		     (return-from bail r))))
  28.403+	    (%do))
  28.404+	  (%do)))))
  28.405+
  28.406+(defmacro bench (iter &body body)
  28.407+  `(loop for i from 1 to ,iter
  28.408+	 do ,@body))
  28.409+
  28.410+(defmethod do-bench ((self test) &optional fx)
  28.411+  (declare (ignorable fx))
  28.412+  (with-test-env self
  28.413+    (flet ((%do ()
  28.414+	     (if-let ((opt *compile-tests*))
  28.415+	       (progn 
  28.416+		 (when (eq opt t) (setq opt *default-test-opts*))
  28.417+		 ;; TODO 2023-09-21: handle failures here
  28.418+		 (let ((fn (compile-test self :declare opt)))
  28.419+		   (bench (test-bench self) (funcall fn)))
  28.420+		 (setf r (make-test-result :pass (test-fn self))))
  28.421+	       (progn
  28.422+		 (bench (test-bench self) (eval-test self))
  28.423+		 (setf r (make-test-result :pass (test-name self)))))))
  28.424+      (if *catch-test-errors*
  28.425+	  (handler-bind
  28.426+	      ((style-warning #'muffle-warning)
  28.427+	       (error 
  28.428+		 #'(lambda (c)
  28.429+		     (setf bail t)
  28.430+		     (setf r (make-test-result :fail c))
  28.431+		     (return-from bail r))))
  28.432+	    (%do))
  28.433+	  (%do)))))
  28.434+
  28.435+;;;; Fixtures
  28.436+
  28.437+;; Our fixtures are just closures - with a pandoric environment. You
  28.438+;; might call it a domain-specific object protocol.
  28.439+
  28.440+;; You can build fixtures inside a test or use the push-fixture
  28.441+;; method on a `test-suite' object.
  28.442+
  28.443+(deftype fixture () 'form)
  28.444+
  28.445+(declaim (inline %make-fixture-prototype))
  28.446+(defstruct (fixture-prototype (:constructor %make-fixture-prototype)
  28.447+			      (:conc-name fxp))
  28.448+  (kind :empty :type keyword)
  28.449+  (form nil :type form))
  28.450+
  28.451+(defun make-fixture-prototype (kind form)
  28.452+  (%make-fixture-prototype :kind kind :form form))
  28.453+
  28.454+(defmacro make-fixture (letargs &body ds)
  28.455+  (let ((letargs (let-binding-transform letargs)))
  28.456+    `(let (,@letargs)
  28.457+       (dlambda ,@ds))))
  28.458+
  28.459+(defmacro with-fixture ((var fx) &body body)
  28.460+  `(let ((,var ,fx))
  28.461+     ,@body))
  28.462+
  28.463+;;;; Suites
  28.464+(defclass test-suite (test-object)
  28.465+  ((tests :initarg :set :initform nil :type list :accessor tests
  28.466+	  :documentation "test-suite tests")
  28.467+   (results :initarg :results :initform nil :type list :accessor test-results
  28.468+	    :documentation "test-suite results")
  28.469+   (stream :initarg :stream :initform *standard-output* :type stream :accessor test-stream)
  28.470+   (fixtures :initarg :fixtures :initform nil :type list :accessor test-fixtures))
  28.471+  (:documentation "A class for collections of related `test' objects."))
  28.472+
  28.473+(defmethod print-object ((self test-suite) stream)
  28.474+  (print-unreadable-object (self stream :type t :identity t)
  28.475+    (format stream "~A [~d+~d:~d:~d:~d]"
  28.476+	    (test-name self)
  28.477+	    (count t (map-tests self (lambda (x) (not (test-bench-p x)))))
  28.478+	    (count t (map-tests self #'test-bench-p))
  28.479+	    (count t (map-tests self #'test-lock-p))
  28.480+	    (count t (map-tests self #'test-persist-p))
  28.481+	    (length (test-results self)))))
  28.482+
  28.483+;; (defmethod reinitialize-instance ((self test-suite) &rest initargs &key &allow-other-keys))
  28.484+
  28.485+(deftype test-suite-designator ()
  28.486+  "Either nil, a symbol, a string, or a `test-suite' object."
  28.487+  '(or null symbol string test-suite test keyword))
  28.488+
  28.489+(defmethod map-tests ((self test-suite) function)
  28.490+  (mapcar function (tests self)))
  28.491+
  28.492+(defmethod push-test ((self test) (place test-suite))
  28.493+  (push self (tests place)))
  28.494+
  28.495+(defmethod pop-test ((self test-suite))
  28.496+  (pop (tests self)))
  28.497+
  28.498+(defmethod push-result ((self test-result) (place test-suite))
  28.499+  (with-slots (results) place
  28.500+    (push self results)))
  28.501+
  28.502+(defmethod pop-result ((self test-suite))
  28.503+  (pop (test-results self)))
  28.504+
  28.505+(defmethod find-test ((self test-suite) name &key (test #'test-name=))
  28.506+  (declare (type (or string symbol) name)
  28.507+	   (type function test))
  28.508+  (find name (the list (tests self)) :test test))
  28.509+
  28.510+(defmethod do-test ((self test-suite) &optional test)
  28.511+  (push-result 
  28.512+   (if test
  28.513+       (do-test (find-test self (test-name test)))
  28.514+       (do-test (pop-test self)))
  28.515+   self))
  28.516+
  28.517+;; HACK 2023-09-01: find better method of declaring failures from
  28.518+;; within the body of `deftest'.
  28.519+(defmethod do-suite ((self test-suite) &key stream)
  28.520+  (when stream (setf (test-stream self) stream))
  28.521+  (with-slots (name stream) self
  28.522+    (format stream "in suite ~x with ~A/~A tests:~%"
  28.523+	    name
  28.524+	    (count t (tests self)
  28.525+		   :key (lambda (x) (or (test-lock-p x) (test-persist-p x))))
  28.526+	    (length (tests self)))
  28.527+    ;; loop over each test, calling `do-test' if locked or persistent
  28.528+    (map-tests self 
  28.529+	       (lambda (x)
  28.530+		 (when (or (test-lock-p x) (test-persist-p x))
  28.531+		   (let ((res (do-test x)))
  28.532+		     (push-result res self)
  28.533+		     (format stream "~@[~<~%~:;~:@(~S~) ~>~]~%" res)))))
  28.534+    ;; compare locked vs expected
  28.535+    (let ((locked (remove-if #'null (map-tests self (lambda (x) (when (test-lock-p x) x)))))
  28.536+	  (fails
  28.537+	    ;; collect if locked test not expected
  28.538+	    (loop for r in (test-results self)
  28.539+		  unless (test-pass-p r)
  28.540+		    collect r)))
  28.541+      (if (null locked)
  28.542+	  (format stream "~&No tests failed.~%")
  28.543+	  (progn
  28.544+	    ;;  RESEARCH 2023-09-04: print fails ??
  28.545+	    (format stream "~&~A out of ~A ~
  28.546+                   total tests failed: ~
  28.547+                   ~:@(~{~<~%   ~1:;~S~>~
  28.548+                         ~^, ~}~)."
  28.549+		    (length locked)
  28.550+		    (length (tests self))
  28.551+		    locked)
  28.552+	    (unless (null fails)
  28.553+	      (format stream "~&~A unexpected failures: ~
  28.554+                   ~:@(~{~<~%   ~1:;~S~>~
  28.555+                         ~^, ~}~)."
  28.556+		      (length fails)
  28.557+		      fails))))
  28.558+      ;; close stream
  28.559+      (finish-output stream)
  28.560+      ;; return values (PASS? LOCKED)
  28.561+      (values (not fails) locked))))
  28.562+
  28.563+;;; Checks
  28.564+(flet ((%test (val form)
  28.565+	 (let ((r 
  28.566+		 (if val 
  28.567+		     (make-test-result :pass form)
  28.568+		     (make-test-result :fail form))))
  28.569+	   (debug! r)
  28.570+	   r)))
  28.571+  (defmacro is (test &rest args)
  28.572+    "The DWIM Check.
  28.573+
  28.574+(is (= 1 1) :test 100) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1))
  28.575+If TEST returns a truthy value, return a PASS test-result, else return
  28.576+a FAIL. The TEST is parameterized by ARGS which is a plist or nil.
  28.577+
  28.578+If ARGS is nil, TEST is bound to to the RESULT slot of the test-result
  28.579+and evaluated 'as-is'.
  28.580+
  28.581+(nyi!)
  28.582+ARGS may contain the following keywords followed by a corresponding
  28.583+value:
  28.584+
  28.585+:EXPECTED
  28.586+
  28.587+:TIMEOUT
  28.588+
  28.589+:THEN
  28.590+
  28.591+All other values are treated as let bindings.
  28.592+"
  28.593+    (with-gensyms (form)
  28.594+      `(if ,(null args)
  28.595+	   (if *testing* 
  28.596+	       (push-result (funcall ,#'%test ,test ',test) *testing*)
  28.597+	       (funcall ,#'%test ,test ',test))
  28.598+	   (macrolet ((,form (test) `(let ,,(group args 2) ,,test)))
  28.599+	     ;; TODO 2023-09-21: does this work...
  28.600+	     (if *testing*
  28.601+		 (push-result (funcall ,#'%test (,form ,test) ',test) *testing*)
  28.602+		 (funcall ,#'%test (,form ,test) ',test)))))))
  28.603+
  28.604+(defmacro signals (condition-spec &body body)
  28.605+  "Generates a passing TEST-RESULT if body signals a condition of type
  28.606+CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC
  28.607+is not evaluated."
  28.608+  (let ((block-name (gensym)))
  28.609+    (destructuring-bind (condition &optional reason-control &rest reason-args)
  28.610+        (ensure-list condition-spec)
  28.611+      `(block ,block-name
  28.612+         (handler-bind ((,condition (lambda (c)
  28.613+                                      ;; ok, body threw condition
  28.614+				      ;; TODO 2023-09-05: result collectors
  28.615+                                      ;; (add-result 'test-passed
  28.616+                                      ;;            :test-expr ',condition)
  28.617+                                      (return-from ,block-name (make-test-result :pass ',body)))))
  28.618+           (block nil
  28.619+             ,@body))
  28.620+         (fail!
  28.621+          ',condition
  28.622+          ,@(if reason-control
  28.623+                `(,reason-control ,@reason-args)
  28.624+                `("Failed to signal a ~S" ',condition)))
  28.625+         (return-from ,block-name nil)))))
  28.626+
  28.627+;;; Macros
  28.628+(defmacro deftest (name props &body body)
  28.629+  "Build a test with NAME, parameterized by LAMBDA-LIST and with a test form of BODY."
  28.630+  (destructuring-bind (pr doc dec fn)
  28.631+      (multiple-value-bind (forms dec doc)
  28.632+	  ;; parse body with docstring allowed
  28.633+	  (sb-int:parse-body
  28.634+	   (or body) t)
  28.635+	`(,props ',doc ',dec ',forms))
  28.636+    ;; TODO 2023-09-21: parse plist
  28.637+    `(let ((obj (make-test
  28.638+		 :name ',(format nil "~A" name)
  28.639+		 ;; note: we could leave these unbound if we want,
  28.640+		 ;; personal preference
  28.641+		 :form ,fn
  28.642+		 ,@(when-let ((v (getf pr :persist))) `(:persist ,v))
  28.643+		 ,@(when-let ((v (getf pr :args))) `(:args ,v))
  28.644+		 ,@(when-let ((v (getf pr :bench))) `(:bench ,v))
  28.645+		 ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
  28.646+		 ,@(when doc `(:doc ,doc))
  28.647+		 ,@(when dec `(:decl ,dec)))))
  28.648+       (push-test obj *test-suite*)
  28.649+       obj)))
  28.650+
  28.651+(defmacro defsuite (suite-name &rest props)
  28.652+  "Define a `test-suite' with provided keys. The object returned can be
  28.653+enabled using the `in-suite' macro, similiar to the `defpackage' API."
  28.654+  (check-type suite-name (or symbol string))
  28.655+  `(eval-when (:compile-toplevel :load-toplevel :execute)
  28.656+     (let ((obj (make-suite
  28.657+		 :name (format nil "~A" ',suite-name)
  28.658+		 ,@(when-let ((v (getf props :stream))) `(:stream ,v)))))
  28.659+       (setq *test-suite-list* (spush obj *test-suite-list* :test #'test-name=))
  28.660+       obj)))
  28.661+
  28.662+(defmacro in-suite (name)
  28.663+  "Set `*test-suite*' to the `test-suite' referred to by symbol
  28.664+NAME. Return the `test-suite'."
  28.665+  (assert-suite name)
  28.666+  `(setf *test-suite* (ensure-suite ',name)))
  28.667+
  28.668+(provide :rt)

    29.1--- a/lisp/std/str.lisp	Mon Oct 16 19:33:42 2023 -0400
    29.2+++ b/lisp/std/str.lisp	Mon Oct 16 22:25:50 2023 -0400
    29.3@@ -14,13 +14,12 @@
    29.4 ;;     unicode< unicode> unicode= unicode-equal
    29.5 ;;     unicode<= unicode>=))
    29.6 
    29.7-(defpackage :std/str
    29.8+(uiop:define-package :std/str
    29.9   (:use :cl :uiop/driver :sb-unicode)
   29.10-  (:nicknames :str)
   29.11   (:export
   29.12    #:string-designator))
   29.13 
   29.14-(in-package :str)
   29.15+(in-package :std/str)
   29.16 
   29.17 ;; (mapc (lambda (s) (export s)) sb-unicode-syms)
   29.18 ;; (reexport-from 
   29.19@@ -32,5 +31,3 @@
   29.20 or a character."
   29.21   `(or symbol string character))
   29.22 ;;;  TODO 2023-08-27: camel snake kebab
   29.23-
   29.24-;;; format recipes

    30.1--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    30.2+++ b/lisp/std/sxp.lisp	Mon Oct 16 22:25:50 2023 -0400
    30.3@@ -0,0 +1,159 @@
    30.4+;;; sxp.lisp --- S-eXPressions
    30.5+
    30.6+;; sxp is a unified S-Expression data format
    30.7+
    30.8+;;; Code:
    30.9+(defpackage :std/sxp
   30.10+  (:use :cl :sb-mop :std/sym :std/fu)
   30.11+  (:nicknames :sxp)
   30.12+  (:import-from :uiop :read-file-forms :slurp-stream-forms :with-output-file)
   30.13+  ;; TODO: hot-patch readtables into sxp classes/parsers
   30.14+  (:import-from :named-readtables :defreadtable :in-readtable)
   30.15+  (:export
   30.16+   :sxp-fmt-designator
   30.17+   :form :formp :sxp-error :sxp-fmt-error :sxp-syntax-error :reader :writer :fmt
   30.18+   :wrap :wrap! :wrap-from-string! :unwrap :unwrap! :unwrap-or
   30.19+   :sxpp :build-ast :load-ast :ast
   30.20+   :define-macro :define-fmt :read-sxp-file :write-sxp-file
   30.21+   :read-sxp-string :write-sxp-string :read-sxp-stream :write-sxp-stream
   30.22+   :make-sxp :sxp :formp :form
   30.23+   :wrap-object :unwrap-object))
   30.24+
   30.25+(in-package :std/sxp)
   30.26+
   30.27+(defun formp (form)
   30.28+  (or (consp form) (atom form)))
   30.29+
   30.30+(deftype form ()
   30.31+  '(satisfies formp))
   30.32+
   30.33+;;; Conditions
   30.34+(define-condition sxp-error (error) ())
   30.35+
   30.36+(define-condition sxp-fmt-error (sxp-error)
   30.37+  ((format-control :initarg :format-control :reader format-control)
   30.38+   (format-arguments :initarg :format-arguments :reader format-arguments))
   30.39+  (:report (lambda (c s)
   30.40+             (apply 'format s (format-control c) (format-arguments c)))))
   30.41+
   30.42+(define-condition sxp-syntax-error (sxp-error) ())
   30.43+
   30.44+ ;;; Protocol
   30.45+(defgeneric wrap (self form))
   30.46+(defgeneric wrap! (self form))
   30.47+(defgeneric wrap-from-string! (self str))
   30.48+(defgeneric unwrap (self))
   30.49+(defgeneric unwrap! (self))
   30.50+(defgeneric unwrap-or (self lambda))
   30.51+(defgeneric sxpp (self form))
   30.52+
   30.53+(defgeneric write-sxp-stream (self stream &key pretty case))
   30.54+(defgeneric read-sxp-stream (self stream))
   30.55+
   30.56+(defgeneric build-ast (self &key &allow-other-keys)
   30.57+  (:documentation "build the sxp representation of SELF and store it in the :ast
   30.58+slot. The :ast slot is always ignored."))
   30.59+
   30.60+(defgeneric load-ast (self)
   30.61+  (:documentation "load the object SELF from the :ast slot."))
   30.62+
   30.63+;;; Objects
   30.64+(defclass sxp ()
   30.65+  ((ast :initarg :ast :type form :accessor ast))
   30.66+  (:documentation "Dynamic class representing a SXP form."))
   30.67+
   30.68+(defmethod wrap! ((self sxp) form) (setf (slot-value self 'ast) (ignore-errors form)))
   30.69+
   30.70+(defmethod wrap-from-string! ((self sxp) str) (setf (slot-value self 'ast) (ignore-errors (read str))))
   30.71+
   30.72+(defmethod wrap ((self sxp) form) (setf (slot-value self 'ast) form))
   30.73+
   30.74+(defmethod unwrap ((self sxp)) (slot-value self 'ast))
   30.75+
   30.76+(defmethod unwrap! ((self sxp)) (ignore-errors (slot-value self 'ast)))
   30.77+
   30.78+(defmethod unwrap-or ((self sxp) else-fn)
   30.79+  (if (slot-unbound 'sxp self 'ast)
   30.80+      (slot-value self 'ast)
   30.81+      (if (null (slot-value self 'ast))
   30.82+	  (funcall else-fn))))
   30.83+
   30.84+(defmethod write-sxp-stream ((self sxp) stream &key (pretty *print-pretty*) (case :downcase))
   30.85+  (write (ast self)
   30.86+	 :stream stream
   30.87+	 :pretty pretty
   30.88+	 :case case))
   30.89+
   30.90+(defmethod read-sxp-stream ((self sxp) stream)
   30.91+  (setf (ast self) (slurp-stream-forms stream :count nil)))
   30.92+
   30.93+;; (defsetf unwrap ) (defsetf wrap )
   30.94+
   30.95+;;; Functions
   30.96+(defun read-sxp-file (file)
   30.97+  (make-instance 'sxp :ast (read-file-forms file)))
   30.98+
   30.99+(defun write-sxp-file (sxp file &optional &key if-exists)
  30.100+  (with-output-file (out file) :if-exists if-exists
  30.101+    (write-sxp-stream sxp out)))
  30.102+
  30.103+(defun read-sxp-string (self str) (with-input-from-string (s str) (read-sxp-stream self s)))
  30.104+
  30.105+(defun write-sxp-string (sxp) 
  30.106+  (let ((ast (ast sxp)))
  30.107+    (if (> (length ast) 1)
  30.108+	(write-to-string ast)
  30.109+	(write-to-string (car ast)))))
  30.110+
  30.111+(defun make-sxp (&rest form) (make-instance 'sxp :ast form))
  30.112+
  30.113+(deftype sxp-fmt-designator () '(member :canonical :collapsed)) 
  30.114+
  30.115+(defun unwrap-object (obj &key (slots t) (methods nil)
  30.116+			    (indirect nil) (tag nil)
  30.117+			    (unboundp nil) (nullp nil)
  30.118+			    (exclude nil))
  30.119+  "Build and return a new `form' from OBJ by traversing the class
  30.120+definition. This differs from the generic function `unwrap' which
  30.121+always uses the ast slot as an internal buffer. We can also call this
  30.122+on any class instance (doesn't need to subclass `sxp').
  30.123+
  30.124+SLOTS specifies the slots to be included in the output. If the value
  30.125+is t, all slots are included. The ast slot is not included by default,
  30.126+but this behavior may change in future revisions.
  30.127+
  30.128+When INDIRECT is non-nil, also include methods which indirectly
  30.129+specialize on OBJ.
  30.130+
  30.131+When TAG is non-nil, return a cons where car is TAG and cdr is the
  30.132+output. If TAG is t, use the class-name symbol."
  30.133+  (declare (type standard-object obj)
  30.134+	   (type (or list boolean) slots)
  30.135+	   (type (or list boolean) methods)
  30.136+	   (type boolean indirect)
  30.137+	   (type list exclude))
  30.138+  (unless (or slots methods)
  30.139+    (error "Required one missing key arg: SLOTS or METHODS"))
  30.140+  (let* ((class (class-of obj))
  30.141+	(res (when tag (list (if (eq t tag) (class-name class) tag)))))
  30.142+    (block unwrap
  30.143+      (when-let ((slots (when slots
  30.144+			  (list-class-slots class slots exclude))))
  30.145+	(let ((slot-vals (list-slot-values-using-class class obj (remove-if #'null slots) nullp unboundp)))
  30.146+	  (if methods
  30.147+	      (push slot-vals res)
  30.148+	      (return-from unwrap (push slot-vals res)))))
  30.149+      (when-let ((methods (when methods (list-class-methods class methods indirect))))
  30.150+	(push methods res)))
  30.151+    (flatten res)))
  30.152+
  30.153+(defun wrap-object (class form)
  30.154+  "Given a CLASS prototype and an input FORM, return a new instance of
  30.155+CLASS. FORM is assumed to be the finalized lisp object which has
  30.156+already passed through `read' -- not a string or file-stream for
  30.157+example."
  30.158+  (declare (type class class)
  30.159+	   (type form form)))
  30.160+
  30.161+;; (defmacro define-fmt ())
  30.162+;; (defmacro define-macro ())

    31.1--- a/lisp/std/sym.lisp	Mon Oct 16 19:33:42 2023 -0400
    31.2+++ b/lisp/std/sym.lisp	Mon Oct 16 22:25:50 2023 -0400
    31.3@@ -3,9 +3,8 @@
    31.4 ;; inspired by alexandria/symbols.lisp
    31.5 
    31.6 ;;; Code:
    31.7-(pkg:defpkg :std/sym
    31.8-  (:use :cl :str :sb-int)
    31.9-  (:nicknames :sym)
   31.10+(uiop:define-package :std/sym
   31.11+  (:use :cl :std/str :sb-int)
   31.12   (:export
   31.13    #:ensure-symbol
   31.14    #:format-symbol
   31.15@@ -17,7 +16,7 @@
   31.16    #:with-unique-names
   31.17    #:symbolicate))
   31.18 
   31.19-(in-package :sym)
   31.20+(in-package :std/sym)
   31.21 
   31.22 ;; (reexport-from :sb-int
   31.23 ;; 	       :include '(:with-unique-names :symbolicate :package-symbolicate :keywordicate :gensymify*))

    32.1--- a/lisp/std/tests.lisp	Mon Oct 16 19:33:42 2023 -0400
    32.2+++ b/lisp/std/tests.lisp	Mon Oct 16 22:25:50 2023 -0400
    32.3@@ -5,24 +5,10 @@
    32.4 ;; TODO: fix false positives when using (eval-test)
    32.5 
    32.6 ;;; Code:
    32.7-(defpackage :std/tests
    32.8-  (:use
    32.9-   :cl
   32.10-   :readtables
   32.11-   :str
   32.12-   :fmt
   32.13-   :sym
   32.14-   :list
   32.15-   :cond
   32.16-   :log
   32.17-   :fu
   32.18-   :ana
   32.19-   :pan
   32.20-   :fs
   32.21-   :alien
   32.22-   :thread
   32.23-   :rt))
   32.24-
   32.25+(uiop:define-package :std/tests
   32.26+  (:use :cl :std/all :std/rt)
   32.27+  (:use-reexport :std/tests/sxp))
   32.28+   
   32.29 (in-package :std/tests)
   32.30 
   32.31 (in-readtable :std)
   32.32@@ -49,8 +35,8 @@
   32.33   "Test STD.SYM"
   32.34   ;; gensyms
   32.35   (is (not (equalp (make-gensym 'a) (make-gensym 'a))))
   32.36-  (is (eq (ensure-symbol 'tests :macs.tests) 'tests))
   32.37-  (is (eq 'macs.tests::foo (format-symbol :macs.tests "~A" 'foo)))
   32.38+  (is (eq (ensure-symbol 'tests :std/tests) 'tests))
   32.39+  (is (eq 'std/tests::foo (format-symbol :std/tests "~A" 'foo)))
   32.40   (is (eq (make-keyword 'fizz) :fizz)))
   32.41 
   32.42 ;;;; TODO
   32.43@@ -101,7 +87,7 @@
   32.44 "#))
   32.45 ;; with plist option
   32.46   (is (string= 
   32.47-       #.(fmt:fmt-tree nil '(sk-project :name "foobar" :path "/a/b/c.asd" :vc :hg) :layout :down :plist t)
   32.48+       #.(std/fmt:fmt-tree nil '(sk-project :name "foobar" :path "/a/b/c.asd" :vc :hg) :layout :down :plist t)
   32.49        #"SK-PROJECT
   32.50  ├─ :NAME
   32.51  │   ╰─ "foobar"
   32.52@@ -129,3 +115,62 @@
   32.53       (is (= 0 (funcall p nil)))
   32.54       (is (= 1 (funcall p 1)))
   32.55       (is (= 1 b c)))))
   32.56+
   32.57+;;; RT
   32.58+(defsuite :rt)
   32.59+(in-suite :rt)
   32.60+(deftest rt (:bench 100 :profile t :persist nil)
   32.61+  (is (typep (make-fixture-prototype :empty nil) 'fixture-prototype))
   32.62+  (with-fixture (fx (make-fixture ((a 1) (b 2)) 
   32.63+		      (:+ () (+ (incf a) (incf b)))
   32.64+		      (:- () (- (decf a) (decf b)))
   32.65+		      (t () 0)))
   32.66+    (is (= 5 (funcall fx :+)))
   32.67+    (is (= 7 (funcall fx :+)))
   32.68+    (is (= 5 (funcall fx :-)))
   32.69+    (is (= 0 (funcall fx))))
   32.70+  (signals (error t) (test-form (make-instance 'test-result))))
   32.71+
   32.72+;;; CLI
   32.73+(defsuite :cli)
   32.74+(in-suite :cli)
   32.75+(unless *compile-tests*
   32.76+  (deftest cli-prompt ()
   32.77+    "Test MACS.CLI prompts"
   32.78+    (make-prompt! tpfoo "testing: ")
   32.79+    (defvar tcoll nil)
   32.80+    (defvar thist nil)
   32.81+    (let ((*standard-input* (make-string-input-stream 
   32.82+			     (format nil "~A~%~A~%" "foobar" "foobar"))))
   32.83+      ;; prompts 
   32.84+      (is (string= (tpfoo-prompt) "foobar"))
   32.85+      (is (string= "foobar"
   32.86+		   (cli:completing-read "nothing: " tcoll :history thist :default "foobar"))))))
   32.87+
   32.88+(defparameter *opts* (cli:make-opts (:name foo :global t :description "bar")
   32.89+			    (:name bar :description "foo")))
   32.90+
   32.91+(defparameter *cmd1* (make-cli :cmd :name "holla" :opts *opts* :description "cmd1 description"))
   32.92+(defparameter *cmd2* (make-cli :cmd :name "ayo" :cmds #(*cmd1*) :opts *opts* :description "cmd1 description"))
   32.93+(defparameter *cmds* (cli:make-cmds (:name "baz" :description "baz" :opts *opts*)))
   32.94+
   32.95+(defparameter *cli* (make-cli t :opts *opts* :cmds *cmds* :description "test cli"))
   32.96+
   32.97+(deftest cli ()
   32.98+  "test MACS.CLI OOS."
   32.99+  (let ((cli *cli*))
  32.100+    (is (eq (make-shorty "test") #\t))
  32.101+    (is (equalp (proc-args cli '("-f" "baz" "--bar" "fax")) ;; not eql
  32.102+		(make-cli-ast 
  32.103+		 (list (make-cli-node 'opt (find-short-opt cli #\f))
  32.104+		       (make-cli-node 'cmd (find-cmd cli "baz"))
  32.105+		       (make-cli-node 'opt (find-opt cli "bar"))
  32.106+		       (make-cli-node 'arg "fax")))))
  32.107+    (is (parse-args cli '("--bar" "baz" "-f" "yaks")))
  32.108+    (is (stringp
  32.109+	 (with-output-to-string (s)
  32.110+	   (print-version cli s)
  32.111+	   (print-usage cli s)
  32.112+	   (print-help cli s))))
  32.113+    (is (string= "foobar" (parse-str-opt "foobar")))))
  32.114+

    33.1--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    33.2+++ b/lisp/std/tests/bench.lisp	Mon Oct 16 22:25:50 2023 -0400
    33.3@@ -0,0 +1,49 @@
    33.4+(require :sb-sprof)
    33.5+(defpackage :sxp-bench
    33.6+  (:use :cl :sxp :sb-ext :sb-unix)
    33.7+  (:export :run-bench :*bench-input-file* :*bench-input-string* :*bench-input-object*
    33.8+	   :*bench-output-directory* :*bench-iterations* :*bench-report-file* ;:*bench-flamegraph-file*
    33.9+	   ))
   33.10+(in-package :sxp-bench)
   33.11+(declaim
   33.12+ (type (or string pathname) *bench-input-file* *bench-output-directory* *bench-report-file*)
   33.13+ (type string *bench-input-string*)
   33.14+ (type sxp *bench-input-object*)
   33.15+ (type integer *bench-iterations*))
   33.16+(defparameter *bench-input-file* "tests.sxp")
   33.17+(defparameter *bench-input-string* (uiop:read-file-string *bench-input-file*))
   33.18+(defparameter *bench-input-object* (make-instance 'sxp))
   33.19+(read-sxp-string *bench-input-object* *bench-input-string*)
   33.20+
   33.21+(defparameter *bench-output-directory* "/tmp/sxp-bench")
   33.22+(defparameter *bench-iterations* 1000)
   33.23+(defparameter *bench-report-file* "bench.sxp")
   33.24+;; (defparameter *bench-flamegraph-file* "bench.stack")
   33.25+(defmacro bench (&body body)
   33.26+  `(loop for i from 1 to *bench-iterations*
   33.27+	 do ,@body))
   33.28+
   33.29+(defun rbench (fn input)
   33.30+  (let ((res))
   33.31+    (bench (call-with-timing (lambda (&rest x) (push (cons i x) res)) fn input))
   33.32+    (nreverse res)))
   33.33+
   33.34+(defun wbench (fn)
   33.35+  (let ((res))
   33.36+    (bench (let ((out (make-pathname :name (format nil "~d.sxp" i) :directory *bench-output-directory*)))
   33.37+	     (call-with-timing (lambda (&rest x) (push (cons i x) res)) fn *bench-input-object* out :if-exists :supersede)))
   33.38+    (nreverse res)))
   33.39+
   33.40+(defun run-bench (&optional rpt)
   33.41+  (when (probe-file *bench-output-directory*)
   33.42+    (sb-ext:delete-directory *bench-output-directory* :recursive t))
   33.43+  (sb-unix:unix-mkdir *bench-output-directory* #o777)
   33.44+  (let ((rres (sb-sprof:with-profiling (:sample-interval 0.001) (rbench #'sxp:read-sxp-file *bench-input-file*)))
   33.45+	(wres (sb-sprof:with-profiling (:sample-interval 0.001) (wbench #'sxp:write-sxp-file))))
   33.46+    (if rpt
   33.47+	(progn
   33.48+	  (format t "Writing output to ~s" *bench-report-file*)
   33.49+	  (uiop:with-output-file (out *bench-report-file* :if-exists :supersede :if-does-not-exist :create)
   33.50+	    (print `(,@rres ,@wres) out)))
   33.51+	(print (list rres wres))))
   33.52+  (terpri))

    34.1--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    34.2+++ b/lisp/std/tests/sxp.lisp	Mon Oct 16 22:25:50 2023 -0400
    34.3@@ -0,0 +1,39 @@
    34.4+;;; std/tests/sxp.lisp --- SXP tests
    34.5+(defpackage :std/tests/sxp
    34.6+    (:use :cl :sxp :std/base :std/fu :std/rt)
    34.7+  (:export :*sxp-test-file* :*sxp-test-string*))
    34.8+
    34.9+(in-package :std/tests/sxp)
   34.10+(in-readtable :std)
   34.11+(declaim
   34.12+ (type (or string pathname) *sxp-test-file*)
   34.13+ (type string *sxp-test-string*))
   34.14+(defparameter *sxp-test-file* "tests.sxp")
   34.15+(defparameter *sxp-test-string* "(FOO 'BAR `(\"test\" ,BAZ ,@QUX) 123 0.0123 1/3 `(,A1 ,A2))")
   34.16+
   34.17+(defsuite :sxp)
   34.18+(in-suite :sxp)
   34.19+
   34.20+(deftest forms ()
   34.21+  (is (formp nil))
   34.22+  (is (formp t))
   34.23+  (is (formp 3.14))
   34.24+  (is (formp "string"))
   34.25+  (is (formp (mapc #`(',a1) '(a))))
   34.26+  (is (formp ())))
   34.27+
   34.28+(deftest sxp-file ()
   34.29+  (let ((f (read-sxp-file *sxp-test-file*)))
   34.30+    (is (equal (unwrap f) (unwrap f)))))
   34.31+
   34.32+(deftest sxp-string ()
   34.33+  (let ((f (make-instance 'sxp)))
   34.34+    (is (formp (read-sxp-string f *sxp-test-string*)))
   34.35+    (is (equalp (read-from-string (write-sxp-string f)) (read-from-string *sxp-test-string*)))))
   34.36+
   34.37+(deftest sxp-stream ()
   34.38+  (let ((f (make-instance 'sxp)))
   34.39+    (with-input-from-string (s *sxp-test-string*)
   34.40+      (read-sxp-stream f s))
   34.41+    (with-output-to-string (s)
   34.42+      (is (write-sxp-stream f s)))))

    35.1--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    35.2+++ b/lisp/std/tests/tests.sxp	Mon Oct 16 22:25:50 2023 -0400
    35.3@@ -0,0 +1,42 @@
    35.4+; skip me maybe
    35.5+;; this file does not contain quote characters.
    35.6+(edges-1
    35.7+(
    35.8+(1389.886593 1341.567282)
    35.9+(1383.122623 1339.369530)
   35.10+)
   35.11+(
   35.12+(1383.122623 1339.369530)
   35.13+(1387.706464 1325.261939)
   35.14+)
   35.15+(
   35.16+(1387.706464 1325.261939)
   35.17+(1394.470360 1327.459664)
   35.18+)
   35.19+(
   35.20+(1394.470360 1327.459664)
   35.21+(1389.886593 1341.567282)
   35.22+)
   35.23+) ; edges end
   35.24+
   35.25+(edges-2
   35.26+( ( 1.1 2.2 ) (2.2 3.3) )
   35.27+( ( 2.2 3.3 ) (3.3 3.3) )
   35.28+( ( 3.3 3.3 ) (1.1 2.2) )
   35.29+) ; end edges of triangle room
   35.30+
   35.31+(= 4 4)
   35.32+(= 5 4)
   35.33+(> 4.0 54.0)
   35.34+(= 4 s)
   35.35+(= (= 4 4) (> 5 4))
   35.36+(not (= 3 3))
   35.37+(not 4)
   35.38+(if (= 4 4) 42 666)
   35.39+(if (= 4.0 4.0) (42))
   35.40+(+ 4 4)
   35.41+(+ 5.0 6.5)
   35.42+(- 4 5)
   35.43+(^ 2 3)
   35.44+(^ 3 2)
   35.45+(^ 3 (+ 2 1))