1.1--- a/.hgsubstate Sun Oct 15 01:50:27 2023 -0400
1.2+++ b/.hgsubstate Sun Oct 15 03:20:41 2023 -0400
1.3@@ -1,3 +1,3 @@
1.4-0000000000000000000000000000000000000000 lisp/macs
1.5-080137fb0579395424bb96622252d1ddb3dade5d lisp/organ
1.6-6b7881cc28419cd135ce64216267a42a0960eb10 lisp/skel
1.7+4685181e4be84baada5b21327b51bc5616fc4cae lisp/macs
1.8+0000000000000000000000000000000000000000 lisp/organ
1.9+0000000000000000000000000000000000000000 lisp/skel
2.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
2.2+++ b/lisp/lib/cli.asd Sun Oct 15 03:20:41 2023 -0400
2.3@@ -0,0 +1,9 @@
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 "macs/tests")))
2.12+ :components ((:file "cli")))
3.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
3.2+++ b/lisp/lib/cli/cli.lisp Sun Oct 15 03:20:41 2023 -0400
3.3@@ -0,0 +1,781 @@
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--- /dev/null Thu Jan 01 00:00:00 1970 +0000
4.2+++ b/lisp/lib/rdb.asd Sun Oct 15 03:20:41 2023 -0400
4.3@@ -0,0 +1,20 @@
4.4+;;; rdb.asd --- thin RocksDB ORM
4.5+(defsystem "rdb"
4.6+ :version "0.1.0"
4.7+ :license (:file "LICENSE")
4.8+ :maintainer "ellis <ellis@rwest.io>"
4.9+ :homepage "https://nas-t.net"
4.10+ :bug-tracker "https://lab.rwest.io/comp/core/issues"
4.11+ :depends-on (:macs :rocksdb)
4.12+ :in-order-to ((test-op (test-op "rdb/tests")))
4.13+ :components ((:file "rdb/rdb")))
4.14+
4.15+(defsystem "rdb/tests"
4.16+ :version "0.1.0"
4.17+ :license (:file "LICENSE")
4.18+ :maintainer "ellis <ellis@rwest.io>"
4.19+ :homepage "https://nas-t.net"
4.20+ :bug-tracker "https://lab.rwest.io/comp/core/issues"
4.21+ :depends-on (:rdb :rt)
4.22+ :components ((:file "rdb/tests"))
4.23+ :perform (test-op (op c) (uiop:symbol-call '#:rt '#:do-tests :rdb)))
5.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2+++ b/lisp/lib/rdb/rdb.lisp Sun Oct 15 03:20:41 2023 -0400
5.3@@ -0,0 +1,204 @@
5.4+;;; rdb.lisp --- High-level RocksDB API
5.5+
5.6+;; a thin ORM for working with RocksDB storage.
5.7+
5.8+;; Low-level bindings are in rocksdb.lisp.
5.9+
5.10+;; Commentary:
5.11+
5.12+;; Code:
5.13+(pkg:defpkg :rdb
5.14+ (:use :cl :alien :fu :rocksdb)
5.15+ (:import-from :sb-ext :string-to-octets :octets-to-string)
5.16+ (:reexport :rocksdb)
5.17+ (:export
5.18+ ;; opts
5.19+ :make-rdb-opts
5.20+ :rdb-opts
5.21+ :default-rdb-opts
5.22+ ;; db
5.23+ :open-db
5.24+ :with-open-db
5.25+ ;; iter
5.26+ :create-iter :with-iter
5.27+ :iter-key :iter-key-str
5.28+ :iter-val :iter-val-str
5.29+ ;; err
5.30+ :unable-to-open-db
5.31+ :unable-to-put-key-value-to-db
5.32+ :unable-to-get-value-to-db))
5.33+
5.34+(in-package :rdb)
5.35+
5.36+(defstruct rdb-opts
5.37+ (create-if-missing nil :type boolean)
5.38+ (total-threads 1 :type integer) ;; numcpus is default
5.39+ (max-open-files 10000 :type integer)
5.40+ (use-fsync nil :type boolean)
5.41+ (disable-auto-compations nil :type boolean))
5.42+
5.43+;; unsafe
5.44+(defun bind-rocksdb-opts% (opts)
5.45+ (let ((o (rocksdb-options-create)))
5.46+ (with-slots (create-if-missing total-threads) opts
5.47+ (rocksdb-options-set-create-if-missing o create-if-missing)
5.48+ (rocksdb-options-increase-parallelism o total-threads))
5.49+ o))
5.50+
5.51+(defun default-rdb-opts ()
5.52+ (make-rdb-opts
5.53+ :create-if-missing t
5.54+ :total-threads 4))
5.55+
5.56+(defun default-rocksdb-options% ()
5.57+ (bind-rocksdb-opts% (default-rdb-opts)))
5.58+
5.59+(defmacro with-open-db ((db-var db-path &optional opt) &body body)
5.60+ `(let ((,db-var (open-db ,db-path ,opt)))
5.61+ (unwind-protect (progn ,@body)
5.62+ (rocksdb-close ,db-var))))
5.63+
5.64+(defmacro with-iter ((iter-var db &optional opt) &body body)
5.65+ `(let ((,iter-var (create-iter ,db ,opt)))
5.66+ (unwind-protect (progn ,@body)
5.67+ (rocksdb-iter-destroy ,iter-var))))
5.68+
5.69+;;; Conditions
5.70+(define-condition unable-to-open-db (error)
5.71+ ((db-path :initarg :db-path
5.72+ :reader db-path)
5.73+ (error-message :initarg :error-message
5.74+ :reader error-message)))
5.75+
5.76+(defmethod print-object ((obj unable-to-open-db) stream)
5.77+ (print-unreadable-object (obj stream :type t :identity t)
5.78+ (format stream "error-message=~A" (error-message obj))))
5.79+
5.80+(define-condition unable-to-put-key-value-to-db (error)
5.81+ ((db :initarg :db
5.82+ :reader db)
5.83+ (key :initarg :key
5.84+ :reader key)
5.85+ (val :initarg :val
5.86+ :reader val)
5.87+ (error-message :initarg :error-message
5.88+ :reader error-message)))
5.89+
5.90+(define-condition unable-to-get-value-to-db (error)
5.91+ ((db :initarg :db
5.92+ :reader db)
5.93+ (key :initarg :key
5.94+ :reader key)
5.95+ (error-message :initarg :error-message
5.96+ :reader error-message)))
5.97+
5.98+;;; API
5.99+(defun open-db (db-path &optional opts)
5.100+ (let ((opts (if opts (bind-rocksdb-opts% opts) (default-rocksdb-options%))))
5.101+ (with-alien ((e rocksdb-errptr))
5.102+ (let* ((db-path (if (pathnamep db-path)
5.103+ (namestring db-path)
5.104+ db-path))
5.105+ (db (rocksdb-open opts db-path e)))
5.106+ (if (null-alien e)
5.107+ db
5.108+ (error 'unable-to-open-db
5.109+ :db-path db-path
5.110+ :error-message e))))))
5.111+
5.112+(defun put-kv (db key val &optional opts)
5.113+ (let ((opts (or opts (rocksdb-writeoptions-create)))
5.114+ (klen (length key))
5.115+ (vlen (length val)))
5.116+ (with-alien ((errptr rocksdb-errptr nil)
5.117+ (k (* char) (make-alien char klen))
5.118+ (v (* char) (make-alien char vlen)))
5.119+ (loop for x across key
5.120+ for i from 0 below klen
5.121+ do (setf (deref k i) x))
5.122+ (loop for y across val
5.123+ for i from 0 below vlen
5.124+ do (setf (deref v i) y))
5.125+ (rocksdb-put db
5.126+ opts
5.127+ k
5.128+ klen
5.129+ v
5.130+ vlen
5.131+ errptr)
5.132+ (unless (null-alien errptr)
5.133+ (error 'unable-to-put-key-value-to-db
5.134+ :db db
5.135+ :key key
5.136+ :val val
5.137+ :error-message (alien-sap errptr))))))
5.138+
5.139+(defun put-kv-str (db key val &optional opt)
5.140+ (let ((key-octets (string-to-octets key))
5.141+ (val-octets (string-to-octets val)))
5.142+ (put-kv db key-octets val-octets opt)))
5.143+
5.144+(defun get-kv (db key &optional opt)
5.145+ (let ((opt (or opt (rocksdb-readoptions-create)))
5.146+ (key (string-to-octets key))
5.147+ (klen (length key)))
5.148+ (with-alien ((vlen (* size-t))
5.149+ (errptr rocksdb-errptr nil)
5.150+ (k (* char) (make-alien char klen)))
5.151+ (loop for x across key
5.152+ for i from 0 below klen
5.153+ do (setf (deref k i) x))
5.154+
5.155+ (let* ((val (rocksdb-get db
5.156+ opt
5.157+ k
5.158+ klen
5.159+ vlen
5.160+ errptr))
5.161+ (vlen (deref vlen)))
5.162+ (unless (null-alien errptr)
5.163+ (error 'unable-to-get-value-to-db
5.164+ :db db
5.165+ :key key
5.166+ :error-message (alien-sap errptr)))
5.167+ ;; helps if we know the vlen beforehand, would need a custom
5.168+ ;; C-side function probably.
5.169+ (let ((v (make-array vlen :element-type 'unsigned-byte)))
5.170+ (loop for i from 0 below vlen
5.171+ with x = (deref val i)
5.172+ do (setf (aref v i) x))
5.173+ (map 'vector #'code-char v))))))
5.174+
5.175+ (defun get-kv-str (db key &optional opt)
5.176+ (let ((k (string-to-octets key)))
5.177+ (let ((v (get-kv db k opt)))
5.178+ (when v (print v)))))
5.179+
5.180+(defun create-iter (db &optional opt)
5.181+ (unless opt
5.182+ (setq opt (rocksdb-readoptions-create)))
5.183+ (rocksdb-create-iterator db opt))
5.184+
5.185+(defun iter-key (iter)
5.186+ (with-alien ((klen-ptr (* unsigned-int)))
5.187+ (let* ((key-ptr (rocksdb-iter-key iter klen-ptr))
5.188+ (klen (deref klen-ptr))
5.189+ (k (make-array klen :element-type '(unsigned-byte 8))))
5.190+ (loop for i from 0 below klen with x = (deref key-ptr i) do (setf (aref k i) x))
5.191+ k)))
5.192+
5.193+(defun iter-key-str (iter)
5.194+ (when-let ((k (iter-key iter)))
5.195+ (octets-to-string k)))
5.196+
5.197+ (defun iter-val (iter)
5.198+ (with-alien ((vlen-ptr (* unsigned-int)))
5.199+ (let* ((val-ptr (rocksdb-iter-value iter vlen-ptr))
5.200+ (vlen (deref vlen-ptr))
5.201+ (v (make-array vlen :element-type '(unsigned-byte 8))))
5.202+ (loop for i from 0 below vlen with x = (deref val-ptr i) do (setf (aref v i) x))
5.203+ v)))
5.204+
5.205+ (defun iter-val-str (iter)
5.206+ (when-let ((v (iter-val iter)))
5.207+ (octets-to-string v)))
6.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2+++ b/lisp/lib/rdb/tests.lisp Sun Oct 15 03:20:41 2023 -0400
6.3@@ -0,0 +1,5 @@
6.4+(defpackage :rdb.tests
6.5+ (:use :cl :rt :rdb))
6.6+(in-package :rdb.tests)
6.7+(defsuite :rdb)
6.8+(in-suite :rdb)
7.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2+++ b/lisp/lib/rt.asd Sun Oct 15 03:20:41 2023 -0400
7.3@@ -0,0 +1,9 @@
7.4+(defsystem "rt"
7.5+ :version "0.1.0"
7.6+ :author "ellis <ellis@rwest.io>"
7.7+ :description "regression test framework"
7.8+ :bug-tracker "https://lab.rwest.io/ellis/macs/issues"
7.9+ :source-control (:hg "https://lab.rwest.io/ellis/macs")
7.10+ :depends-on (:macs :sxp)
7.11+ :in-order-to ((test-op (test-op "macs/tests")))
7.12+ :components ((:file "rt")))
8.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2+++ b/lisp/lib/rt/rt.lisp Sun Oct 15 03:20:41 2023 -0400
8.3@@ -0,0 +1,665 @@
8.4+;;; rt.lisp --- regression testing
8.5+
8.6+;; Regression Testing framework. inspired by PCL, the original CMUCL
8.7+;; code, and the SBCL port.
8.8+
8.9+;;; Commentary:
8.10+
8.11+;; - :rt https://www.merl.com/publications/docs/TR91-04.pdf Chapter 1
8.12+;; - :com.gigamonkeys.test https://github.com/gigamonkey/monkeylib-test-framework
8.13+;; - :sb-rt https://github.com/sbcl/sbcl/blob/master/contrib/sb-rt/rt.lisp
8.14+
8.15+;; This package is intended to provide a modernized Lisp testing
8.16+;; library with features found in some of the test frameworks listed
8.17+;; below.
8.18+
8.19+;; - :it.bese.fiveam https://github.com/lispci/fiveam
8.20+;; - :try https://github.com/melisgl/try
8.21+;; - :rove https://github.com/fukamachi/rove
8.22+
8.23+;;; TODO:
8.24+#|
8.25+
8.26+- [ ] benchmark support: do-bench, test-count,
8.27+
8.28+- [ ] fixtures api
8.29+
8.30+- [ ] profiling
8.31+|#
8.32+;;; Code:
8.33+#+x86-64
8.34+(eval-when (:compile-toplevel :load-toplevel :execute)
8.35+ (require 'sb-sprof))
8.36+
8.37+(pkg:defpkg :rt
8.38+ (:use
8.39+ :cl :sxp
8.40+ :sym :list :cond :readtables :fu :fmt :log :ana :pan :sb-aprof
8.41+ #+x86-64 :sb-sprof)
8.42+ (:nicknames :rt)
8.43+ (:export
8.44+ :*default-test-opts*
8.45+ :*compile-tests*
8.46+ :*catch-test-errors*
8.47+ :*test-suffix*
8.48+ :*default-test-suite-name*
8.49+ :*test-suite*
8.50+ :*test-suite-list*
8.51+ ;; TODO 2023-09-04: :*test-profiler-list* not yet
8.52+ :*testing*
8.53+ :test-suite-designator
8.54+ :check-suite-designator
8.55+ :make-test
8.56+ :make-suite
8.57+ :test-name=
8.58+ :do-test
8.59+ :do-tests
8.60+ :continue-testing
8.61+ :with-test-env
8.62+ :ensure-suite
8.63+ :test-fixture
8.64+ :fixture-prototype
8.65+ :make-fixture-prototype
8.66+ :make-fixture
8.67+ :with-fixture
8.68+ :test-result
8.69+ :test-pass-p
8.70+ :test-fail-p
8.71+ :test-skip-p
8.72+ :test-failed
8.73+ :fail!
8.74+ :is
8.75+ :signals
8.76+ :deftest
8.77+ :defsuite
8.78+ :in-suite
8.79+ :eval-test
8.80+ :compile-test
8.81+ :locked-tests
8.82+ :push-test
8.83+ :pop-test
8.84+ :delete-test
8.85+ :find-test
8.86+ :do-suite
8.87+ :test-object
8.88+ :test
8.89+ :test-fixture
8.90+ :test-suite
8.91+ :test-name
8.92+ :tests
8.93+ :test-form
8.94+ :test-results))
8.95+
8.96+(in-package :rt)
8.97+(in-readtable *macs-readtable*)
8.98+
8.99+;;; Vars
8.100+(defvar *default-test-opts* '(optimize sb-c::instrument-consing))
8.101+(defvar *compile-tests* t
8.102+ "When nil do not compile tests. With a value of t, tests are compiled
8.103+with default optimizations else the value is used to configure
8.104+compiler optimizations.")
8.105+(defvar *catch-test-errors* t "When non-nil, cause errors in a test to be caught.")
8.106+(defvar *test-suffix* "-test" "A suffix to append to every `test' defined with `deftest'.")
8.107+(defvar *test-suite-list* nil "List of available `test-suite' objects.")
8.108+(defvar *test-suite* nil "A 'test-suite-designator' which identifies the current `test-suite'.")
8.109+(eval-when (:compile-toplevel :load-toplevel :execute)
8.110+ (defvar *default-test-suite-name* "default"))
8.111+(declaim (type (or stream boolean string) *test-input*))
8.112+(defvar *test-input* nil "When non-nil, specifies an input stream or buffer for `*testing*'.")
8.113+(defvar *default-bench-count* 100 "Default number of iterations to repeat a bench test for. This value is
8.114+used when the slot value of :BENCH is t.")
8.115+(defvar *testing* nil "Testing state var.")
8.116+
8.117+;;; Utils
8.118+(eval-when (:compile-toplevel :load-toplevel :execute)
8.119+ (defun make-test (&rest slots)
8.120+ (apply #'make-instance 'test slots))
8.121+ (defun make-suite (&rest slots)
8.122+ (apply #'make-instance 'test-suite slots)))
8.123+
8.124+;; TODO 2023-09-04: optimize
8.125+(declaim (inline do-tests))
8.126+(defun do-tests (&optional (suite *test-suite*) (output *standard-output*))
8.127+ (if (pathnamep output)
8.128+ (with-open-file (stream output :direction :output)
8.129+ (do-suite (ensure-suite suite) :stream stream))
8.130+ (do-suite (ensure-suite suite) :stream output)))
8.131+
8.132+;; this assumes that *test-suite* is re-initialized correctly to the
8.133+;; correct test-suite object.
8.134+(defun continue-testing ()
8.135+ (if-let ((test *testing*))
8.136+ (throw '%in-test test)
8.137+ (do-suite *test-suite*)))
8.138+
8.139+;; NOTE 2023-09-01: `pushnew' does not return an indication of whether
8.140+;; place is changed - it returns place. This is functionally sound but
8.141+;; means that if we want to do something else in the event that place
8.142+;; is unchanged, we run into some friction,
8.143+;; https://stackoverflow.com/questions/56228832/adapting-common-lisp-pushnew-to-return-success-failure
8.144+(defun spush (item lst &key (test #'equal))
8.145+ "Substituting `push'"
8.146+ (declare (type function test))
8.147+ (cond
8.148+ ((null lst) (push item lst))
8.149+ ((list lst)
8.150+ (if-let ((found (member item lst
8.151+ :test test)))
8.152+ (progn
8.153+ (rplaca found item)
8.154+ lst)
8.155+ (push item lst)))
8.156+ #|(or nil '(t (cons item lst)))|#))
8.157+
8.158+;; FIX 2023-08-31: spush, replace with `add-test' method.
8.159+;; (declaim (inline normalize-test-name))
8.160+(defun normalize-test-name (a)
8.161+ "Return the normalized `test-suite-designator' of A."
8.162+ (etypecase a
8.163+ (string a)
8.164+ (symbol (symbol-name a))
8.165+ (test-object (test-name a))
8.166+ (t (format nil "~A" a))))
8.167+
8.168+(defun test-name= (a b)
8.169+ "Return t if A and B are similar `test-suite-designator's."
8.170+ (let ((a (normalize-test-name a))
8.171+ (b (normalize-test-name b)))
8.172+ (string= a b)))
8.173+
8.174+;; (declaim (inline assert-suite ensure-suite))
8.175+(defun ensure-suite (name)
8.176+ (if-let ((ok (member name *test-suite-list* :test #'test-name=)))
8.177+ (car ok)
8.178+ (when (or (eq name t) (null name)) (make-suite :name *default-test-suite-name*))))
8.179+
8.180+(defun check-suite-designator (suite) (check-type suite test-suite-designator))
8.181+
8.182+(defun assert-suite (name)
8.183+ (check-suite-designator name)
8.184+ (assert (ensure-suite name)))
8.185+
8.186+(declaim (inline test-opt-key-p test-opt-valid-p))
8.187+(defun test-opt-key-p (k)
8.188+ "Test if K is a `test-opt-key'."
8.189+ (member k '(:profile :save :stream)))
8.190+
8.191+(defun test-opt-valid-p (f)
8.192+ "Test if F is a valid `test-opt' form. If so, return F else nil."
8.193+ (when (test-opt-key-p (car f))
8.194+ f))
8.195+
8.196+;;; Conditions
8.197+(define-condition test-failed (error)
8.198+ ((reason :accessor fail-reason :initarg :reason :initform "unknown")
8.199+ (name :accessor fail-name :initarg :name)
8.200+ (form :accessor fail-form :initarg :form))
8.201+ (:documentation "Signaled when a test fails.")
8.202+ (:report (lambda (c s)
8.203+ (format s "The following expression failed: ~S~%~A."
8.204+ (fail-form c)
8.205+ (fail-reason c)))))
8.206+
8.207+;;; Protocol
8.208+(defgeneric eval-test (self)
8.209+ (:documentation "Eval a `test'."))
8.210+
8.211+(defgeneric compile-test (self &key &allow-other-keys)
8.212+ (:documentation "Compile a `test'."))
8.213+
8.214+(defgeneric locked-tests (self)
8.215+ (:documentation "Return a list of locked tests in `test-suite' object SELF."))
8.216+
8.217+(defgeneric push-test (self place)
8.218+ (:documentation
8.219+ "Push `test' SELF to the value of slot ':tests' in `test-suite' object PLACE."))
8.220+
8.221+(defgeneric pop-test (self)
8.222+ (:documentation
8.223+ "Pop the first `test' from the slot-value of ':tests' in `test-suite' object SELF."))
8.224+
8.225+(defgeneric push-result (self place)
8.226+ (:documentation
8.227+ "Push object SELF to the value of slot ':results' in object PLACE."))
8.228+
8.229+(defgeneric pop-result (self)
8.230+ (:documentation
8.231+ "Pop the first `test-result' from the slot-value of ':tests' from object SELF."))
8.232+
8.233+(defgeneric push-fixture (self place)
8.234+ (:documentation
8.235+ "Push object SELF to the value of slot ':results' in object PLACE."))
8.236+
8.237+(defgeneric delete-test (self &key &allow-other-keys)
8.238+ (:documentation "Delete `test' object specified by `test-object' SELF and optional keys."))
8.239+
8.240+(defgeneric find-test (self name &key &allow-other-keys)
8.241+ (:documentation "Find `test' object specified by name and optional keys."))
8.242+
8.243+(defgeneric do-test (self &optional test)
8.244+ (:documentation
8.245+ "Run `test' SELF, printing results to `*standard-output*'. The second
8.246+argument is an optional fixture.
8.247+
8.248+SELF can also be a `test-suite', in which case the TESTS slot is
8.249+queried for the value of TEST. If TEST is not provided, pops the car
8.250+from TESTS."))
8.251+
8.252+(defgeneric do-suite (self &key &allow-other-keys)
8.253+ (:documentation
8.254+ "Perform actions on `test-suite' object SELF with optional keys."))
8.255+
8.256+;;;; Results
8.257+(deftype result-tag ()
8.258+ '(or (member :pass :fail :skip) null))
8.259+
8.260+(declaim (inline %make-test-result))
8.261+(defstruct (test-result (:constructor %make-test-result)
8.262+ (:conc-name tr-))
8.263+ (tag nil :type result-tag :read-only t)
8.264+ (form nil :type form))
8.265+
8.266+(defun make-test-result (tag &optional form)
8.267+ (%make-test-result :tag tag :form form))
8.268+
8.269+(defmethod test-pass-p ((res test-result))
8.270+ (when (eq :pass (tr-tag res)) t))
8.271+
8.272+(defmethod test-fail-p ((res test-result))
8.273+ (when (eq :fail (tr-tag res)) t))
8.274+
8.275+(defmethod test-skip-p ((res test-result))
8.276+ (when (eq :skip (tr-tag res)) t))
8.277+
8.278+(defmethod print-object ((self test-result) stream)
8.279+ (print-unreadable-object (self stream)
8.280+ (format stream "~A ~A"
8.281+ (tr-tag self)
8.282+ (tr-form self))))
8.283+
8.284+;;; Objects
8.285+(defclass test-object ()
8.286+ ((name :initarg :name :initform (required-argument) :type string :accessor test-name)
8.287+ #+nil (cached :initarg :cache :allocation :class :accessor test-cached-p :type boolean))
8.288+ (:documentation "Super class for all test-related objects."))
8.289+
8.290+(defmethod print-object ((self test-object) stream)
8.291+ "test"
8.292+ (print-unreadable-object (self stream :type t :identity t)
8.293+ (format stream "~A"
8.294+ (test-name self))))
8.295+
8.296+;;;; Tests
8.297+;; HACK 2023-08-31: inherit sxp?
8.298+
8.299+(defclass test (test-object)
8.300+ ((fn :type symbol :accessor test-fn)
8.301+ (bench :type (or boolean fixnum) :accessor test-bench :initform nil :initarg :bench)
8.302+ (profile :type list :accessor test-profile :initform nil :initarg :profile)
8.303+ (args :type list :accessor test-args :initform nil :initarg :args)
8.304+ (decl :type list :accessor test-decl :initform nil :initarg :decl)
8.305+ (form :initarg :form :initform nil :type function-lambda-expression :accessor test-form)
8.306+ (doc :initarg :doc :type string :accessor test-doc)
8.307+ (lock :initarg :lock :type boolean :accessor test-lock-p)
8.308+ (persist :initarg :persist :initform nil :type boolean :accessor test-persist-p)
8.309+ (results :initarg :results :type (array test-result) :accessor test-results))
8.310+ (:documentation "Test class typically made with `deftest'."))
8.311+
8.312+(defmethod test-bench-p ((self test))
8.313+ (when (test-bench self) t))
8.314+
8.315+(defmethod get-bench-count ((self test))
8.316+ (when-let ((v (test-bench self)))
8.317+ (cond
8.318+ ((typep v 'fixnum) v)
8.319+ ((eq v t) *default-bench-count*)
8.320+ ;; unknown value
8.321+ (t nil))))
8.322+
8.323+(defmethod initialize-instance ((self test) &key name)
8.324+ ;; (debug! "building test" name)
8.325+ (setf (test-fn self)
8.326+ (make-symbol
8.327+ (format nil "~A~A"
8.328+ name
8.329+ (gensym *test-suffix*))))
8.330+ (setf (test-lock-p self) t)
8.331+ ;; TODO 2023-09-21: we should count how many checks are in the :form
8.332+ ;; slot and infer the array dimensions.
8.333+ (setf (test-results self) (make-array 0 :element-type 'test-result))
8.334+ (call-next-method))
8.335+
8.336+(defmethod print-object ((self test) stream)
8.337+ (print-unreadable-object (self stream :type t :identity t)
8.338+ (format stream "~A :fn ~A :args ~A :persist ~A"
8.339+ (test-name self)
8.340+ (test-fn self)
8.341+ (test-args self)
8.342+ (test-persist-p self))))
8.343+
8.344+;; TODO 2023-09-01: use sxp?
8.345+;; (defun validate-form (form))
8.346+
8.347+(defmethod push-result ((self test-result) (place test))
8.348+ (with-slots (results) place
8.349+ (push self results)))
8.350+
8.351+(defmethod pop-result ((self test))
8.352+ (pop (test-results self)))
8.353+
8.354+(defmethod eval-test ((self test))
8.355+ `(progn ,@(test-form self)))
8.356+
8.357+(defmethod compile-test ((self test) &key declare &allow-other-keys)
8.358+ (compile
8.359+ (test-fn self)
8.360+ `(lambda ()
8.361+ ,@(when declare `((declare ,declare)))
8.362+ ,@(test-form self))))
8.363+
8.364+(defun fail! (form &optional fmt &rest args)
8.365+ (let ((reason (and fmt (apply #'format nil fmt args))))
8.366+ (with-simple-restart (ignore-fail "Continue testing.")
8.367+ (error 'test-failed :reason reason :form form))))
8.368+
8.369+(defmacro with-test-env (self &body body)
8.370+ `(catch '%in-test
8.371+ (setf (test-lock-p ,self) t)
8.372+ (let* ((*testing* ,self)
8.373+ (bail nil)
8.374+ r)
8.375+ (block bail
8.376+ ,@body
8.377+ (setf (test-lock-p ,self) bail))
8.378+ r)))
8.379+
8.380+(defmethod do-test ((self test) &optional fx)
8.381+ (declare (ignorable fx))
8.382+ (with-test-env self
8.383+ (debug! "running test: " *testing*)
8.384+ (flet ((%do ()
8.385+ (if-let ((opt *compile-tests*))
8.386+ ;; RESEARCH 2023-08-31: with-compilation-unit?
8.387+ (progn
8.388+ (when (eq opt t) (setq opt *default-test-opts*))
8.389+ ;; TODO 2023-09-21: handle failures here
8.390+ (funcall (compile-test self :declare opt))
8.391+ (setf r (make-test-result :pass (test-fn self))))
8.392+ (progn
8.393+ (eval-test self)
8.394+ (setf r (make-test-result :pass (test-name self)))))))
8.395+ (if *catch-test-errors*
8.396+ (handler-bind
8.397+ ((style-warning #'muffle-warning)
8.398+ (error
8.399+ #'(lambda (c)
8.400+ (setf bail t)
8.401+ (setf r (make-test-result :fail c))
8.402+ (return-from bail r))))
8.403+ (%do))
8.404+ (%do)))))
8.405+
8.406+(defmacro bench (iter &body body)
8.407+ `(loop for i from 1 to ,iter
8.408+ do ,@body))
8.409+
8.410+(defmethod do-bench ((self test) &optional fx)
8.411+ (declare (ignorable fx))
8.412+ (with-test-env self
8.413+ (flet ((%do ()
8.414+ (if-let ((opt *compile-tests*))
8.415+ (progn
8.416+ (when (eq opt t) (setq opt *default-test-opts*))
8.417+ ;; TODO 2023-09-21: handle failures here
8.418+ (let ((fn (compile-test self :declare opt)))
8.419+ (bench (test-bench self) (funcall fn)))
8.420+ (setf r (make-test-result :pass (test-fn self))))
8.421+ (progn
8.422+ (bench (test-bench self) (eval-test self))
8.423+ (setf r (make-test-result :pass (test-name self)))))))
8.424+ (if *catch-test-errors*
8.425+ (handler-bind
8.426+ ((style-warning #'muffle-warning)
8.427+ (error
8.428+ #'(lambda (c)
8.429+ (setf bail t)
8.430+ (setf r (make-test-result :fail c))
8.431+ (return-from bail r))))
8.432+ (%do))
8.433+ (%do)))))
8.434+
8.435+;;;; Fixtures
8.436+
8.437+;; Our fixtures are just closures - with a pandoric environment. You
8.438+;; might call it a domain-specific object protocol.
8.439+
8.440+;; You can build fixtures inside a test or use the push-fixture
8.441+;; method on a `test-suite' object.
8.442+
8.443+(deftype fixture () 'form)
8.444+
8.445+(declaim (inline %make-fixture-prototype))
8.446+(defstruct (fixture-prototype (:constructor %make-fixture-prototype)
8.447+ (:conc-name fxp))
8.448+ (kind :empty :type keyword)
8.449+ (form nil :type form))
8.450+
8.451+(defun make-fixture-prototype (kind form)
8.452+ (%make-fixture-prototype :kind kind :form form))
8.453+
8.454+(defmacro make-fixture (letargs &body ds)
8.455+ (let ((letargs (let-binding-transform letargs)))
8.456+ `(let (,@letargs)
8.457+ (dlambda ,@ds))))
8.458+
8.459+(defmacro with-fixture ((var fx) &body body)
8.460+ `(let ((,var ,fx))
8.461+ ,@body))
8.462+
8.463+;;;; Suites
8.464+(defclass test-suite (test-object)
8.465+ ((tests :initarg :set :initform nil :type list :accessor tests
8.466+ :documentation "test-suite tests")
8.467+ (results :initarg :results :initform nil :type list :accessor test-results
8.468+ :documentation "test-suite results")
8.469+ (stream :initarg :stream :initform *standard-output* :type stream :accessor test-stream)
8.470+ (fixtures :initarg :fixtures :initform nil :type list :accessor test-fixtures))
8.471+ (:documentation "A class for collections of related `test' objects."))
8.472+
8.473+(defmethod print-object ((self test-suite) stream)
8.474+ (print-unreadable-object (self stream :type t :identity t)
8.475+ (format stream "~A [~d+~d:~d:~d:~d]"
8.476+ (test-name self)
8.477+ (count t (map-tests self (lambda (x) (not (test-bench-p x)))))
8.478+ (count t (map-tests self #'test-bench-p))
8.479+ (count t (map-tests self #'test-lock-p))
8.480+ (count t (map-tests self #'test-persist-p))
8.481+ (length (test-results self)))))
8.482+
8.483+;; (defmethod reinitialize-instance ((self test-suite) &rest initargs &key &allow-other-keys))
8.484+
8.485+(deftype test-suite-designator ()
8.486+ "Either nil, a symbol, a string, or a `test-suite' object."
8.487+ '(or null symbol string test-suite test keyword))
8.488+
8.489+(defmethod map-tests ((self test-suite) function)
8.490+ (mapcar function (tests self)))
8.491+
8.492+(defmethod push-test ((self test) (place test-suite))
8.493+ (push self (tests place)))
8.494+
8.495+(defmethod pop-test ((self test-suite))
8.496+ (pop (tests self)))
8.497+
8.498+(defmethod push-result ((self test-result) (place test-suite))
8.499+ (with-slots (results) place
8.500+ (push self results)))
8.501+
8.502+(defmethod pop-result ((self test-suite))
8.503+ (pop (test-results self)))
8.504+
8.505+(defmethod find-test ((self test-suite) name &key (test #'test-name=))
8.506+ (declare (type (or string symbol) name)
8.507+ (type function test))
8.508+ (find name (the list (tests self)) :test test))
8.509+
8.510+(defmethod do-test ((self test-suite) &optional test)
8.511+ (push-result
8.512+ (if test
8.513+ (do-test (find-test self (test-name test)))
8.514+ (do-test (pop-test self)))
8.515+ self))
8.516+
8.517+;; HACK 2023-09-01: find better method of declaring failures from
8.518+;; within the body of `deftest'.
8.519+(defmethod do-suite ((self test-suite) &key stream)
8.520+ (when stream (setf (test-stream self) stream))
8.521+ (with-slots (name stream) self
8.522+ (format stream "in suite ~x with ~A/~A tests:~%"
8.523+ name
8.524+ (count t (tests self)
8.525+ :key (lambda (x) (or (test-lock-p x) (test-persist-p x))))
8.526+ (length (tests self)))
8.527+ ;; loop over each test, calling `do-test' if locked or persistent
8.528+ (map-tests self
8.529+ (lambda (x)
8.530+ (when (or (test-lock-p x) (test-persist-p x))
8.531+ (let ((res (do-test x)))
8.532+ (push-result res self)
8.533+ (format stream "~@[~<~%~:;~:@(~S~) ~>~]~%" res)))))
8.534+ ;; compare locked vs expected
8.535+ (let ((locked (remove-if #'null (map-tests self (lambda (x) (when (test-lock-p x) x)))))
8.536+ (fails
8.537+ ;; collect if locked test not expected
8.538+ (loop for r in (test-results self)
8.539+ unless (test-pass-p r)
8.540+ collect r)))
8.541+ (if (null locked)
8.542+ (format stream "~&No tests failed.~%")
8.543+ (progn
8.544+ ;; RESEARCH 2023-09-04: print fails ??
8.545+ (format stream "~&~A out of ~A ~
8.546+ total tests failed: ~
8.547+ ~:@(~{~<~% ~1:;~S~>~
8.548+ ~^, ~}~)."
8.549+ (length locked)
8.550+ (length (tests self))
8.551+ locked)
8.552+ (unless (null fails)
8.553+ (format stream "~&~A unexpected failures: ~
8.554+ ~:@(~{~<~% ~1:;~S~>~
8.555+ ~^, ~}~)."
8.556+ (length fails)
8.557+ fails))))
8.558+ ;; close stream
8.559+ (finish-output stream)
8.560+ ;; return values (PASS? LOCKED)
8.561+ (values (not fails) locked))))
8.562+
8.563+;;; Checks
8.564+(flet ((%test (val form)
8.565+ (let ((r
8.566+ (if val
8.567+ (make-test-result :pass form)
8.568+ (make-test-result :fail form))))
8.569+ (debug! r)
8.570+ r)))
8.571+ (defmacro is (test &rest args)
8.572+ "The DWIM Check.
8.573+
8.574+(is (= 1 1) :test 100) ;=> #S(TEST-RESULT :TAG :PASS :FORM (= 1 1))
8.575+If TEST returns a truthy value, return a PASS test-result, else return
8.576+a FAIL. The TEST is parameterized by ARGS which is a plist or nil.
8.577+
8.578+If ARGS is nil, TEST is bound to to the RESULT slot of the test-result
8.579+and evaluated 'as-is'.
8.580+
8.581+(nyi!)
8.582+ARGS may contain the following keywords followed by a corresponding
8.583+value:
8.584+
8.585+:EXPECTED
8.586+
8.587+:TIMEOUT
8.588+
8.589+:THEN
8.590+
8.591+All other values are treated as let bindings.
8.592+"
8.593+ (with-gensyms (form)
8.594+ `(if ,(null args)
8.595+ (if *testing*
8.596+ (push-result (funcall ,#'%test ,test ',test) *testing*)
8.597+ (funcall ,#'%test ,test ',test))
8.598+ (macrolet ((,form (test) `(let ,,(group args 2) ,,test)))
8.599+ ;; TODO 2023-09-21: does this work...
8.600+ (if *testing*
8.601+ (push-result (funcall ,#'%test (,form ,test) ',test) *testing*)
8.602+ (funcall ,#'%test (,form ,test) ',test)))))))
8.603+
8.604+(defmacro signals (condition-spec &body body)
8.605+ "Generates a passing TEST-RESULT if body signals a condition of type
8.606+CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC
8.607+is not evaluated."
8.608+ (let ((block-name (gensym)))
8.609+ (destructuring-bind (condition &optional reason-control &rest reason-args)
8.610+ (ensure-list condition-spec)
8.611+ `(block ,block-name
8.612+ (handler-bind ((,condition (lambda (c)
8.613+ ;; ok, body threw condition
8.614+ ;; TODO 2023-09-05: result collectors
8.615+ ;; (add-result 'test-passed
8.616+ ;; :test-expr ',condition)
8.617+ (return-from ,block-name (make-test-result :pass ',body)))))
8.618+ (block nil
8.619+ ,@body))
8.620+ (fail!
8.621+ ',condition
8.622+ ,@(if reason-control
8.623+ `(,reason-control ,@reason-args)
8.624+ `("Failed to signal a ~S" ',condition)))
8.625+ (return-from ,block-name nil)))))
8.626+
8.627+;;; Macros
8.628+(defmacro deftest (name props &body body)
8.629+ "Build a test with NAME, parameterized by LAMBDA-LIST and with a test form of BODY."
8.630+ (destructuring-bind (pr doc dec fn)
8.631+ (multiple-value-bind (forms dec doc)
8.632+ ;; parse body with docstring allowed
8.633+ (sb-int:parse-body
8.634+ (or body) t)
8.635+ `(,props ',doc ',dec ',forms))
8.636+ ;; TODO 2023-09-21: parse plist
8.637+ `(let ((obj (make-test
8.638+ :name ',(format nil "~A" name)
8.639+ ;; note: we could leave these unbound if we want,
8.640+ ;; personal preference
8.641+ :form ,fn
8.642+ ,@(when-let ((v (getf pr :persist))) `(:persist ,v))
8.643+ ,@(when-let ((v (getf pr :args))) `(:args ,v))
8.644+ ,@(when-let ((v (getf pr :bench))) `(:bench ,v))
8.645+ ,@(when-let ((v (getf pr :profile))) `(:profile ,v))
8.646+ ,@(when doc `(:doc ,doc))
8.647+ ,@(when dec `(:decl ,dec)))))
8.648+ (push-test obj *test-suite*)
8.649+ obj)))
8.650+
8.651+(defmacro defsuite (suite-name &rest props)
8.652+ "Define a `test-suite' with provided keys. The object returned can be
8.653+enabled using the `in-suite' macro, similiar to the `defpackage' API."
8.654+ (check-type suite-name (or symbol string))
8.655+ `(eval-when (:compile-toplevel :load-toplevel :execute)
8.656+ (let ((obj (make-suite
8.657+ :name (format nil "~A" ',suite-name)
8.658+ ,@(when-let ((v (getf props :stream))) `(:stream ,v)))))
8.659+ (setq *test-suite-list* (spush obj *test-suite-list* :test #'test-name=))
8.660+ obj)))
8.661+
8.662+(defmacro in-suite (name)
8.663+ "Set `*test-suite*' to the `test-suite' referred to by symbol
8.664+NAME. Return the `test-suite'."
8.665+ (assert-suite name)
8.666+ `(setf *test-suite* (ensure-suite ',name)))
8.667+
8.668+(provide :rt)
9.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2+++ b/lisp/lib/sxp.asd Sun Oct 15 03:20:41 2023 -0400
9.3@@ -0,0 +1,27 @@
9.4+;;; sxp.asd
9.5+(defsystem "sxp"
9.6+ :version "0.1.0"
9.7+ :author "ellis <ellis@rwest.io>"
9.8+ :maintainer "ellis <ellis@rwest.io>"
9.9+ :depends-on ("macs")
9.10+ :description "S-eXPressions"
9.11+ :homepage "https://rwest.io/sxp"
9.12+ :bug-tracker "https://lab.rwest.io/comp/sxp/issues"
9.13+ :source-control "https://lab.rwest.io/comp/sxp"
9.14+ :license "WTF"
9.15+ :in-order-to ((test-op (test-op :sxp/tests)))
9.16+ :components ((:file "sxp/sxp")))
9.17+
9.18+(defmethod perform :after ((op load-op) (c (eql (find-system :sxp))))
9.19+ (pushnew :sxp *features*))
9.20+
9.21+(defsystem "sxp/tests"
9.22+ :depends-on ("sxp" "rt" "uiop")
9.23+ :components ((:file "sxp/tests"))
9.24+ :perform (test-op (op c)
9.25+ (uiop:symbol-call '#:rt '#:do-tests)))
9.26+
9.27+(defsystem "sxp/bench"
9.28+ :depends-on ("sxp" "uiop" "sb-sprof" "flamegraph")
9.29+ :components ((:file "sxp/bench"))
9.30+ :perform (test-op (op c) (uiop:symbol-call '#:sxp-bench '#:run-bench)))
10.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
10.2+++ b/lisp/lib/sxp/bench.lisp Sun Oct 15 03:20:41 2023 -0400
10.3@@ -0,0 +1,49 @@
10.4+(require :sb-sprof)
10.5+(defpackage :sxp-bench
10.6+ (:use :cl :sxp :sb-ext :sb-unix)
10.7+ (:export :run-bench :*bench-input-file* :*bench-input-string* :*bench-input-object*
10.8+ :*bench-output-directory* :*bench-iterations* :*bench-report-file* ;:*bench-flamegraph-file*
10.9+ ))
10.10+(in-package :sxp-bench)
10.11+(declaim
10.12+ (type (or string pathname) *bench-input-file* *bench-output-directory* *bench-report-file*)
10.13+ (type string *bench-input-string*)
10.14+ (type sxp *bench-input-object*)
10.15+ (type integer *bench-iterations*))
10.16+(defparameter *bench-input-file* "tests.sxp")
10.17+(defparameter *bench-input-string* (uiop:read-file-string *bench-input-file*))
10.18+(defparameter *bench-input-object* (make-instance 'sxp))
10.19+(read-sxp-string *bench-input-object* *bench-input-string*)
10.20+
10.21+(defparameter *bench-output-directory* "/tmp/sxp-bench")
10.22+(defparameter *bench-iterations* 1000)
10.23+(defparameter *bench-report-file* "bench.sxp")
10.24+;; (defparameter *bench-flamegraph-file* "bench.stack")
10.25+(defmacro bench (&body body)
10.26+ `(loop for i from 1 to *bench-iterations*
10.27+ do ,@body))
10.28+
10.29+(defun rbench (fn input)
10.30+ (let ((res))
10.31+ (bench (call-with-timing (lambda (&rest x) (push (cons i x) res)) fn input))
10.32+ (nreverse res)))
10.33+
10.34+(defun wbench (fn)
10.35+ (let ((res))
10.36+ (bench (let ((out (make-pathname :name (format nil "~d.sxp" i) :directory *bench-output-directory*)))
10.37+ (call-with-timing (lambda (&rest x) (push (cons i x) res)) fn *bench-input-object* out :if-exists :supersede)))
10.38+ (nreverse res)))
10.39+
10.40+(defun run-bench (&optional rpt)
10.41+ (when (probe-file *bench-output-directory*)
10.42+ (sb-ext:delete-directory *bench-output-directory* :recursive t))
10.43+ (sb-unix:unix-mkdir *bench-output-directory* #o777)
10.44+ (let ((rres (sb-sprof:with-profiling (:sample-interval 0.001) (rbench #'sxp:read-sxp-file *bench-input-file*)))
10.45+ (wres (sb-sprof:with-profiling (:sample-interval 0.001) (wbench #'sxp:write-sxp-file))))
10.46+ (if rpt
10.47+ (progn
10.48+ (format t "Writing output to ~s" *bench-report-file*)
10.49+ (uiop:with-output-file (out *bench-report-file* :if-exists :supersede :if-does-not-exist :create)
10.50+ (print `(,@rres ,@wres) out)))
10.51+ (print (list rres wres))))
10.52+ (terpri))
11.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
11.2+++ b/lisp/lib/sxp/sxp.lisp Sun Oct 15 03:20:41 2023 -0400
11.3@@ -0,0 +1,158 @@
11.4+;;; sxp.lisp --- S-eXPressions
11.5+
11.6+;; sxp is a unified S-Expression data format
11.7+
11.8+;;; Code:
11.9+(pkg:defpkg :sxp
11.10+ (:use :cl :sb-mop :sym :fu)
11.11+ (:import-from :uiop :read-file-forms :slurp-stream-forms :with-output-file)
11.12+ ;; TODO: hot-patch readtables into sxp classes/parsers
11.13+ (:import-from :readtables :defreadtable :in-readtable)
11.14+ (:export
11.15+ :sxp-fmt-designator
11.16+ :form :formp :sxp-error :sxp-fmt-error :sxp-syntax-error :reader :writer :fmt
11.17+ :wrap :wrap! :wrap-from-string! :unwrap :unwrap! :unwrap-or
11.18+ :sxpp :build-ast :load-ast :ast
11.19+ :define-macro :define-fmt :read-sxp-file :write-sxp-file
11.20+ :read-sxp-string :write-sxp-string :read-sxp-stream :write-sxp-stream
11.21+ :make-sxp :sxp :formp :form
11.22+ :wrap-object :unwrap-object))
11.23+
11.24+(in-package :sxp)
11.25+
11.26+(defun formp (form)
11.27+ (or (consp form) (atom form)))
11.28+
11.29+(deftype form ()
11.30+ '(satisfies formp))
11.31+
11.32+;;; Conditions
11.33+(define-condition sxp-error (error) ())
11.34+
11.35+(define-condition sxp-fmt-error (sxp-error)
11.36+ ((format-control :initarg :format-control :reader format-control)
11.37+ (format-arguments :initarg :format-arguments :reader format-arguments))
11.38+ (:report (lambda (c s)
11.39+ (apply 'format s (format-control c) (format-arguments c)))))
11.40+
11.41+(define-condition sxp-syntax-error (sxp-error) ())
11.42+
11.43+ ;;; Protocol
11.44+(defgeneric wrap (self form))
11.45+(defgeneric wrap! (self form))
11.46+(defgeneric wrap-from-string! (self str))
11.47+(defgeneric unwrap (self))
11.48+(defgeneric unwrap! (self))
11.49+(defgeneric unwrap-or (self lambda))
11.50+(defgeneric sxpp (self form))
11.51+
11.52+(defgeneric write-sxp-stream (self stream &key pretty case))
11.53+(defgeneric read-sxp-stream (self stream))
11.54+
11.55+(defgeneric build-ast (self &key &allow-other-keys)
11.56+ (:documentation "build the sxp representation of SELF and store it in the :ast
11.57+slot. The :ast slot is always ignored."))
11.58+
11.59+(defgeneric load-ast (self)
11.60+ (:documentation "load the object SELF from the :ast slot."))
11.61+
11.62+;;; Objects
11.63+(defclass sxp ()
11.64+ ((ast :initarg :ast :type form :accessor ast))
11.65+ (:documentation "Dynamic class representing a SXP form."))
11.66+
11.67+(defmethod wrap! ((self sxp) form) (setf (slot-value self 'ast) (ignore-errors form)))
11.68+
11.69+(defmethod wrap-from-string! ((self sxp) str) (setf (slot-value self 'ast) (ignore-errors (read str))))
11.70+
11.71+(defmethod wrap ((self sxp) form) (setf (slot-value self 'ast) form))
11.72+
11.73+(defmethod unwrap ((self sxp)) (slot-value self 'ast))
11.74+
11.75+(defmethod unwrap! ((self sxp)) (ignore-errors (slot-value self 'ast)))
11.76+
11.77+(defmethod unwrap-or ((self sxp) else-fn)
11.78+ (if (slot-unbound 'sxp self 'ast)
11.79+ (slot-value self 'ast)
11.80+ (if (null (slot-value self 'ast))
11.81+ (funcall else-fn))))
11.82+
11.83+(defmethod write-sxp-stream ((self sxp) stream &key (pretty *print-pretty*) (case :downcase))
11.84+ (write (ast self)
11.85+ :stream stream
11.86+ :pretty pretty
11.87+ :case case))
11.88+
11.89+(defmethod read-sxp-stream ((self sxp) stream)
11.90+ (setf (ast self) (slurp-stream-forms stream :count nil)))
11.91+
11.92+;; (defsetf unwrap ) (defsetf wrap )
11.93+
11.94+;;; Functions
11.95+(defun read-sxp-file (file)
11.96+ (make-instance 'sxp :ast (read-file-forms file)))
11.97+
11.98+(defun write-sxp-file (sxp file &optional &key if-exists)
11.99+ (with-output-file (out file) :if-exists if-exists
11.100+ (write-sxp-stream sxp out)))
11.101+
11.102+(defun read-sxp-string (self str) (with-input-from-string (s str) (read-sxp-stream self s)))
11.103+
11.104+(defun write-sxp-string (sxp)
11.105+ (let ((ast (ast sxp)))
11.106+ (if (> (length ast) 1)
11.107+ (write-to-string ast)
11.108+ (write-to-string (car ast)))))
11.109+
11.110+(defun make-sxp (&rest form) (make-instance 'sxp :ast form))
11.111+
11.112+(deftype sxp-fmt-designator () '(member :canonical :collapsed))
11.113+
11.114+(defun unwrap-object (obj &key (slots t) (methods nil)
11.115+ (indirect nil) (tag nil)
11.116+ (unboundp nil) (nullp nil)
11.117+ (exclude nil))
11.118+ "Build and return a new `form' from OBJ by traversing the class
11.119+definition. This differs from the generic function `unwrap' which
11.120+always uses the ast slot as an internal buffer. We can also call this
11.121+on any class instance (doesn't need to subclass `sxp').
11.122+
11.123+SLOTS specifies the slots to be included in the output. If the value
11.124+is t, all slots are included. The ast slot is not included by default,
11.125+but this behavior may change in future revisions.
11.126+
11.127+When INDIRECT is non-nil, also include methods which indirectly
11.128+specialize on OBJ.
11.129+
11.130+When TAG is non-nil, return a cons where car is TAG and cdr is the
11.131+output. If TAG is t, use the class-name symbol."
11.132+ (declare (type standard-object obj)
11.133+ (type (or list boolean) slots)
11.134+ (type (or list boolean) methods)
11.135+ (type boolean indirect)
11.136+ (type list exclude))
11.137+ (unless (or slots methods)
11.138+ (error "Required one missing key arg: SLOTS or METHODS"))
11.139+ (let* ((class (class-of obj))
11.140+ (res (when tag (list (if (eq t tag) (class-name class) tag)))))
11.141+ (block unwrap
11.142+ (when-let ((slots (when slots
11.143+ (list-class-slots class slots exclude))))
11.144+ (let ((slot-vals (list-slot-values-using-class class obj (remove-if #'null slots) nullp unboundp)))
11.145+ (if methods
11.146+ (push slot-vals res)
11.147+ (return-from unwrap (push slot-vals res)))))
11.148+ (when-let ((methods (when methods (list-class-methods class methods indirect))))
11.149+ (push methods res)))
11.150+ (flatten res)))
11.151+
11.152+(defun wrap-object (class form)
11.153+ "Given a CLASS prototype and an input FORM, return a new instance of
11.154+CLASS. FORM is assumed to be the finalized lisp object which has
11.155+already passed through `read' -- not a string or file-stream for
11.156+example."
11.157+ (declare (type class class)
11.158+ (type form form)))
11.159+
11.160+;; (defmacro define-fmt ())
11.161+;; (defmacro define-macro ())
12.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
12.2+++ b/lisp/lib/sxp/tests.lisp Sun Oct 15 03:20:41 2023 -0400
12.3@@ -0,0 +1,38 @@
12.4+;;; tests.lisp --- SEXP tests
12.5+(pkg:defpkg :sxp.tests
12.6+ (:use :cl :sxp :macs :rt)
12.7+ (:export :*test-file* :*test-string*))
12.8+
12.9+(in-package :sxp.tests)
12.10+(in-readtable *macs-readtable*)
12.11+(declaim
12.12+ (type (or string pathname) *test-file*)
12.13+ (type string *test-string*))
12.14+(defparameter *test-file* "tests.sxp")
12.15+(defparameter *test-string* "(FOO 'BAR `(\"test\" ,BAZ ,@QUX) 123 0.0123 1/3 `(,A1 ,A2))")
12.16+
12.17+(defsuite :sxp)
12.18+(in-suite :sxp)
12.19+
12.20+(deftest forms ()
12.21+ (is (formp nil))
12.22+ (is (formp t))
12.23+ (is (formp 3.14))
12.24+ (is (formp "string"))
12.25+ (is (formp (mapc #`(',a1) '(a))))
12.26+ (is (formp ())))
12.27+
12.28+(deftest sxp-file ()
12.29+ (let ((f (read-sxp-file *test-file*)))
12.30+ (is (equal (unwrap f) (unwrap f)))))
12.31+
12.32+(deftest sxp-string ()
12.33+ (let ((f (make-instance 'sxp)))
12.34+ (is (formp (read-sxp-string f *test-string*)))
12.35+ (is (equalp (read-from-string (write-sxp-string f)) (read-from-string *test-string*)))))
12.36+
12.37+(deftest sxp-stream ()
12.38+ (let ((f (make-instance 'sxp)))
12.39+ (with-input-from-string (s *test-string*)
12.40+ (read-sxp-stream f s))
12.41+ (is (write-sxp-stream f nil))))
13.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
13.2+++ b/lisp/lib/sxp/tests.sxp Sun Oct 15 03:20:41 2023 -0400
13.3@@ -0,0 +1,42 @@
13.4+; skip me maybe
13.5+;; this file does not contain quote characters.
13.6+(edges-1
13.7+(
13.8+(1389.886593 1341.567282)
13.9+(1383.122623 1339.369530)
13.10+)
13.11+(
13.12+(1383.122623 1339.369530)
13.13+(1387.706464 1325.261939)
13.14+)
13.15+(
13.16+(1387.706464 1325.261939)
13.17+(1394.470360 1327.459664)
13.18+)
13.19+(
13.20+(1394.470360 1327.459664)
13.21+(1389.886593 1341.567282)
13.22+)
13.23+) ; edges end
13.24+
13.25+(edges-2
13.26+( ( 1.1 2.2 ) (2.2 3.3) )
13.27+( ( 2.2 3.3 ) (3.3 3.3) )
13.28+( ( 3.3 3.3 ) (1.1 2.2) )
13.29+) ; end edges of triangle room
13.30+
13.31+(= 4 4)
13.32+(= 5 4)
13.33+(> 4.0 54.0)
13.34+(= 4 s)
13.35+(= (= 4 4) (> 5 4))
13.36+(not (= 3 3))
13.37+(not 4)
13.38+(if (= 4 4) 42 666)
13.39+(if (= 4.0 4.0) (42))
13.40+(+ 4 4)
13.41+(+ 5.0 6.5)
13.42+(- 4 5)
13.43+(^ 2 3)
13.44+(^ 3 2)
13.45+(^ 3 (+ 2 1))
14.1--- a/lisp/rdb.asd Sun Oct 15 01:50:27 2023 -0400
14.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
14.3@@ -1,20 +0,0 @@
14.4-;;; rdb.asd --- thin RocksDB ORM
14.5-(defsystem "rdb"
14.6- :version "0.1.0"
14.7- :license (:file "LICENSE")
14.8- :maintainer "ellis <ellis@rwest.io>"
14.9- :homepage "https://nas-t.net"
14.10- :bug-tracker "https://lab.rwest.io/comp/core/issues"
14.11- :depends-on (:macs :rocksdb)
14.12- :in-order-to ((test-op (test-op "rdb/tests")))
14.13- :components ((:file "rdb/rdb")))
14.14-
14.15-(defsystem "rdb/tests"
14.16- :version "0.1.0"
14.17- :license (:file "LICENSE")
14.18- :maintainer "ellis <ellis@rwest.io>"
14.19- :homepage "https://nas-t.net"
14.20- :bug-tracker "https://lab.rwest.io/comp/core/issues"
14.21- :depends-on (:rdb :rt)
14.22- :components ((:file "rdb/tests"))
14.23- :perform (test-op (op c) (uiop:symbol-call '#:rt '#:do-tests :rdb)))
15.1--- a/lisp/rdb/rdb.lisp Sun Oct 15 01:50:27 2023 -0400
15.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
15.3@@ -1,204 +0,0 @@
15.4-;;; rdb.lisp --- High-level RocksDB API
15.5-
15.6-;; a thin ORM for working with RocksDB storage.
15.7-
15.8-;; Low-level bindings are in rocksdb.lisp.
15.9-
15.10-;; Commentary:
15.11-
15.12-;; Code:
15.13-(pkg:defpkg :rdb
15.14- (:use :cl :alien :fu :rocksdb)
15.15- (:import-from :sb-ext :string-to-octets :octets-to-string)
15.16- (:reexport :rocksdb)
15.17- (:export
15.18- ;; opts
15.19- :make-rdb-opts
15.20- :rdb-opts
15.21- :default-rdb-opts
15.22- ;; db
15.23- :open-db
15.24- :with-open-db
15.25- ;; iter
15.26- :create-iter :with-iter
15.27- :iter-key :iter-key-str
15.28- :iter-val :iter-val-str
15.29- ;; err
15.30- :unable-to-open-db
15.31- :unable-to-put-key-value-to-db
15.32- :unable-to-get-value-to-db))
15.33-
15.34-(in-package :rdb)
15.35-
15.36-(defstruct rdb-opts
15.37- (create-if-missing nil :type boolean)
15.38- (total-threads 1 :type integer) ;; numcpus is default
15.39- (max-open-files 10000 :type integer)
15.40- (use-fsync nil :type boolean)
15.41- (disable-auto-compations nil :type boolean))
15.42-
15.43-;; unsafe
15.44-(defun bind-rocksdb-opts% (opts)
15.45- (let ((o (rocksdb-options-create)))
15.46- (with-slots (create-if-missing total-threads) opts
15.47- (rocksdb-options-set-create-if-missing o create-if-missing)
15.48- (rocksdb-options-increase-parallelism o total-threads))
15.49- o))
15.50-
15.51-(defun default-rdb-opts ()
15.52- (make-rdb-opts
15.53- :create-if-missing t
15.54- :total-threads 4))
15.55-
15.56-(defun default-rocksdb-options% ()
15.57- (bind-rocksdb-opts% (default-rdb-opts)))
15.58-
15.59-(defmacro with-open-db ((db-var db-path &optional opt) &body body)
15.60- `(let ((,db-var (open-db ,db-path ,opt)))
15.61- (unwind-protect (progn ,@body)
15.62- (rocksdb-close ,db-var))))
15.63-
15.64-(defmacro with-iter ((iter-var db &optional opt) &body body)
15.65- `(let ((,iter-var (create-iter ,db ,opt)))
15.66- (unwind-protect (progn ,@body)
15.67- (rocksdb-iter-destroy ,iter-var))))
15.68-
15.69-;;; Conditions
15.70-(define-condition unable-to-open-db (error)
15.71- ((db-path :initarg :db-path
15.72- :reader db-path)
15.73- (error-message :initarg :error-message
15.74- :reader error-message)))
15.75-
15.76-(defmethod print-object ((obj unable-to-open-db) stream)
15.77- (print-unreadable-object (obj stream :type t :identity t)
15.78- (format stream "error-message=~A" (error-message obj))))
15.79-
15.80-(define-condition unable-to-put-key-value-to-db (error)
15.81- ((db :initarg :db
15.82- :reader db)
15.83- (key :initarg :key
15.84- :reader key)
15.85- (val :initarg :val
15.86- :reader val)
15.87- (error-message :initarg :error-message
15.88- :reader error-message)))
15.89-
15.90-(define-condition unable-to-get-value-to-db (error)
15.91- ((db :initarg :db
15.92- :reader db)
15.93- (key :initarg :key
15.94- :reader key)
15.95- (error-message :initarg :error-message
15.96- :reader error-message)))
15.97-
15.98-;;; API
15.99-(defun open-db (db-path &optional opts)
15.100- (let ((opts (if opts (bind-rocksdb-opts% opts) (default-rocksdb-options%))))
15.101- (with-alien ((e rocksdb-errptr))
15.102- (let* ((db-path (if (pathnamep db-path)
15.103- (namestring db-path)
15.104- db-path))
15.105- (db (rocksdb-open opts db-path e)))
15.106- (if (null-alien e)
15.107- db
15.108- (error 'unable-to-open-db
15.109- :db-path db-path
15.110- :error-message e))))))
15.111-
15.112-(defun put-kv (db key val &optional opts)
15.113- (let ((opts (or opts (rocksdb-writeoptions-create)))
15.114- (klen (length key))
15.115- (vlen (length val)))
15.116- (with-alien ((errptr rocksdb-errptr nil)
15.117- (k (* char) (make-alien char klen))
15.118- (v (* char) (make-alien char vlen)))
15.119- (loop for x across key
15.120- for i from 0 below klen
15.121- do (setf (deref k i) x))
15.122- (loop for y across val
15.123- for i from 0 below vlen
15.124- do (setf (deref v i) y))
15.125- (rocksdb-put db
15.126- opts
15.127- k
15.128- klen
15.129- v
15.130- vlen
15.131- errptr)
15.132- (unless (null-alien errptr)
15.133- (error 'unable-to-put-key-value-to-db
15.134- :db db
15.135- :key key
15.136- :val val
15.137- :error-message (alien-sap errptr))))))
15.138-
15.139-(defun put-kv-str (db key val &optional opt)
15.140- (let ((key-octets (string-to-octets key))
15.141- (val-octets (string-to-octets val)))
15.142- (put-kv db key-octets val-octets opt)))
15.143-
15.144-(defun get-kv (db key &optional opt)
15.145- (let ((opt (or opt (rocksdb-readoptions-create)))
15.146- (key (string-to-octets key))
15.147- (klen (length key)))
15.148- (with-alien ((vlen (* size-t))
15.149- (errptr rocksdb-errptr nil)
15.150- (k (* char) (make-alien char klen)))
15.151- (loop for x across key
15.152- for i from 0 below klen
15.153- do (setf (deref k i) x))
15.154-
15.155- (let* ((val (rocksdb-get db
15.156- opt
15.157- k
15.158- klen
15.159- vlen
15.160- errptr))
15.161- (vlen (deref vlen)))
15.162- (unless (null-alien errptr)
15.163- (error 'unable-to-get-value-to-db
15.164- :db db
15.165- :key key
15.166- :error-message (alien-sap errptr)))
15.167- ;; helps if we know the vlen beforehand, would need a custom
15.168- ;; C-side function probably.
15.169- (let ((v (make-array vlen :element-type 'unsigned-byte)))
15.170- (loop for i from 0 below vlen
15.171- with x = (deref val i)
15.172- do (setf (aref v i) x))
15.173- (map 'vector #'code-char v))))))
15.174-
15.175- (defun get-kv-str (db key &optional opt)
15.176- (let ((k (string-to-octets key)))
15.177- (let ((v (get-kv db k opt)))
15.178- (when v (print v)))))
15.179-
15.180-(defun create-iter (db &optional opt)
15.181- (unless opt
15.182- (setq opt (rocksdb-readoptions-create)))
15.183- (rocksdb-create-iterator db opt))
15.184-
15.185-(defun iter-key (iter)
15.186- (with-alien ((klen-ptr (* unsigned-int)))
15.187- (let* ((key-ptr (rocksdb-iter-key iter klen-ptr))
15.188- (klen (deref klen-ptr))
15.189- (k (make-array klen :element-type '(unsigned-byte 8))))
15.190- (loop for i from 0 below klen with x = (deref key-ptr i) do (setf (aref k i) x))
15.191- k)))
15.192-
15.193-(defun iter-key-str (iter)
15.194- (when-let ((k (iter-key iter)))
15.195- (octets-to-string k)))
15.196-
15.197- (defun iter-val (iter)
15.198- (with-alien ((vlen-ptr (* unsigned-int)))
15.199- (let* ((val-ptr (rocksdb-iter-value iter vlen-ptr))
15.200- (vlen (deref vlen-ptr))
15.201- (v (make-array vlen :element-type '(unsigned-byte 8))))
15.202- (loop for i from 0 below vlen with x = (deref val-ptr i) do (setf (aref v i) x))
15.203- v)))
15.204-
15.205- (defun iter-val-str (iter)
15.206- (when-let ((v (iter-val iter)))
15.207- (octets-to-string v)))
16.1--- a/lisp/rdb/tests.lisp Sun Oct 15 01:50:27 2023 -0400
16.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
16.3@@ -1,5 +0,0 @@
16.4-(defpackage :rdb.tests
16.5- (:use :cl :rt :rdb))
16.6-(in-package :rdb.tests)
16.7-(defsuite :rdb)
16.8-(in-suite :rdb)
17.1--- a/lisp/sxp.asd Sun Oct 15 01:50:27 2023 -0400
17.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
17.3@@ -1,27 +0,0 @@
17.4-;;; sxp.asd
17.5-(defsystem "sxp"
17.6- :version "0.1.0"
17.7- :author "ellis <ellis@rwest.io>"
17.8- :maintainer "ellis <ellis@rwest.io>"
17.9- :depends-on ("macs")
17.10- :description "S-eXPressions"
17.11- :homepage "https://rwest.io/sxp"
17.12- :bug-tracker "https://lab.rwest.io/comp/sxp/issues"
17.13- :source-control "https://lab.rwest.io/comp/sxp"
17.14- :license "WTF"
17.15- :in-order-to ((test-op (test-op :sxp/tests)))
17.16- :components ((:file "sxp/sxp")))
17.17-
17.18-(defmethod perform :after ((op load-op) (c (eql (find-system :sxp))))
17.19- (pushnew :sxp *features*))
17.20-
17.21-(defsystem "sxp/tests"
17.22- :depends-on ("sxp" "rt" "uiop")
17.23- :components ((:file "sxp/tests"))
17.24- :perform (test-op (op c)
17.25- (uiop:symbol-call '#:rt '#:do-tests)))
17.26-
17.27-(defsystem "sxp/bench"
17.28- :depends-on ("sxp" "uiop" "sb-sprof" "flamegraph")
17.29- :components ((:file "sxp/bench"))
17.30- :perform (test-op (op c) (uiop:symbol-call '#:sxp-bench '#:run-bench)))
18.1--- a/lisp/sxp/bench.lisp Sun Oct 15 01:50:27 2023 -0400
18.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
18.3@@ -1,49 +0,0 @@
18.4-(require :sb-sprof)
18.5-(defpackage :sxp-bench
18.6- (:use :cl :sxp :sb-ext :sb-unix)
18.7- (:export :run-bench :*bench-input-file* :*bench-input-string* :*bench-input-object*
18.8- :*bench-output-directory* :*bench-iterations* :*bench-report-file* ;:*bench-flamegraph-file*
18.9- ))
18.10-(in-package :sxp-bench)
18.11-(declaim
18.12- (type (or string pathname) *bench-input-file* *bench-output-directory* *bench-report-file*)
18.13- (type string *bench-input-string*)
18.14- (type sxp *bench-input-object*)
18.15- (type integer *bench-iterations*))
18.16-(defparameter *bench-input-file* "tests.sxp")
18.17-(defparameter *bench-input-string* (uiop:read-file-string *bench-input-file*))
18.18-(defparameter *bench-input-object* (make-instance 'sxp))
18.19-(read-sxp-string *bench-input-object* *bench-input-string*)
18.20-
18.21-(defparameter *bench-output-directory* "/tmp/sxp-bench")
18.22-(defparameter *bench-iterations* 1000)
18.23-(defparameter *bench-report-file* "bench.sxp")
18.24-;; (defparameter *bench-flamegraph-file* "bench.stack")
18.25-(defmacro bench (&body body)
18.26- `(loop for i from 1 to *bench-iterations*
18.27- do ,@body))
18.28-
18.29-(defun rbench (fn input)
18.30- (let ((res))
18.31- (bench (call-with-timing (lambda (&rest x) (push (cons i x) res)) fn input))
18.32- (nreverse res)))
18.33-
18.34-(defun wbench (fn)
18.35- (let ((res))
18.36- (bench (let ((out (make-pathname :name (format nil "~d.sxp" i) :directory *bench-output-directory*)))
18.37- (call-with-timing (lambda (&rest x) (push (cons i x) res)) fn *bench-input-object* out :if-exists :supersede)))
18.38- (nreverse res)))
18.39-
18.40-(defun run-bench (&optional rpt)
18.41- (when (probe-file *bench-output-directory*)
18.42- (sb-ext:delete-directory *bench-output-directory* :recursive t))
18.43- (sb-unix:unix-mkdir *bench-output-directory* #o777)
18.44- (let ((rres (sb-sprof:with-profiling (:sample-interval 0.001) (rbench #'sxp:read-sxp-file *bench-input-file*)))
18.45- (wres (sb-sprof:with-profiling (:sample-interval 0.001) (wbench #'sxp:write-sxp-file))))
18.46- (if rpt
18.47- (progn
18.48- (format t "Writing output to ~s" *bench-report-file*)
18.49- (uiop:with-output-file (out *bench-report-file* :if-exists :supersede :if-does-not-exist :create)
18.50- (print `(,@rres ,@wres) out)))
18.51- (print (list rres wres))))
18.52- (terpri))
19.1--- a/lisp/sxp/sxp.lisp Sun Oct 15 01:50:27 2023 -0400
19.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
19.3@@ -1,158 +0,0 @@
19.4-;;; sxp.lisp --- S-eXPressions
19.5-
19.6-;; sxp is a unified S-Expression data format
19.7-
19.8-;;; Code:
19.9-(defpackage :sxp
19.10- (:use :cl :sb-mop :sym :fu :reexport)
19.11- (:import-from :uiop :read-file-forms :slurp-stream-forms :with-output-file)
19.12- ;; TODO: hot-patch readtables into sxp classes/parsers
19.13- (:import-from :readtables :defreadtable :in-readtable)
19.14- (:export
19.15- :sxp-fmt-designator
19.16- :form :formp :sxp-error :sxp-fmt-error :sxp-syntax-error :reader :writer :fmt
19.17- :wrap :wrap! :wrap-from-string! :unwrap :unwrap! :unwrap-or
19.18- :sxpp :build-ast :load-ast :ast
19.19- :define-macro :define-fmt :read-sxp-file :write-sxp-file
19.20- :read-sxp-string :write-sxp-string :read-sxp-stream :write-sxp-stream
19.21- :make-sxp :sxp :formp :form
19.22- :wrap-object :unwrap-object))
19.23-
19.24-(in-package :sxp)
19.25-
19.26-(defun formp (form)
19.27- (or (consp form) (atom form)))
19.28-
19.29-(deftype form ()
19.30- '(satisfies formp))
19.31-
19.32-;;; Conditions
19.33-(define-condition sxp-error (error) ())
19.34-
19.35-(define-condition sxp-fmt-error (sxp-error)
19.36- ((format-control :initarg :format-control :reader format-control)
19.37- (format-arguments :initarg :format-arguments :reader format-arguments))
19.38- (:report (lambda (c s)
19.39- (apply 'format s (format-control c) (format-arguments c)))))
19.40-
19.41-(define-condition sxp-syntax-error (sxp-error) ())
19.42-
19.43- ;;; Protocol
19.44-(defgeneric wrap (self form))
19.45-(defgeneric wrap! (self form))
19.46-(defgeneric wrap-from-string! (self str))
19.47-(defgeneric unwrap (self))
19.48-(defgeneric unwrap! (self))
19.49-(defgeneric unwrap-or (self lambda))
19.50-(defgeneric sxpp (self form))
19.51-
19.52-(defgeneric write-sxp-stream (self stream &key pretty case))
19.53-(defgeneric read-sxp-stream (self stream))
19.54-
19.55-(defgeneric build-ast (self &key &allow-other-keys)
19.56- (:documentation "build the sxp representation of SELF and store it in the :ast
19.57-slot. The :ast slot is always ignored."))
19.58-
19.59-(defgeneric load-ast (self)
19.60- (:documentation "load the object SELF from the :ast slot."))
19.61-
19.62-;;; Objects
19.63-(defclass sxp ()
19.64- ((ast :initarg :ast :type form :accessor ast))
19.65- (:documentation "Dynamic class representing a SXP form."))
19.66-
19.67-(defmethod wrap! ((self sxp) form) (setf (slot-value self 'ast) (ignore-errors form)))
19.68-
19.69-(defmethod wrap-from-string! ((self sxp) str) (setf (slot-value self 'ast) (ignore-errors (read str))))
19.70-
19.71-(defmethod wrap ((self sxp) form) (setf (slot-value self 'ast) form))
19.72-
19.73-(defmethod unwrap ((self sxp)) (slot-value self 'ast))
19.74-
19.75-(defmethod unwrap! ((self sxp)) (ignore-errors (slot-value self 'ast)))
19.76-
19.77-(defmethod unwrap-or ((self sxp) else-fn)
19.78- (if (slot-unbound 'sxp self 'ast)
19.79- (slot-value self 'ast)
19.80- (if (null (slot-value self 'ast))
19.81- (funcall else-fn))))
19.82-
19.83-(defmethod write-sxp-stream ((self sxp) stream &key (pretty *print-pretty*) (case :downcase))
19.84- (write (ast self)
19.85- :stream stream
19.86- :pretty pretty
19.87- :case case))
19.88-
19.89-(defmethod read-sxp-stream ((self sxp) stream)
19.90- (setf (ast self) (slurp-stream-forms stream :count nil)))
19.91-
19.92-;; (defsetf unwrap ) (defsetf wrap )
19.93-
19.94-;;; Functions
19.95-(defun read-sxp-file (file)
19.96- (make-instance 'sxp :ast (read-file-forms file)))
19.97-
19.98-(defun write-sxp-file (sxp file &optional &key if-exists)
19.99- (with-output-file (out file) :if-exists if-exists
19.100- (write-sxp-stream sxp out)))
19.101-
19.102-(defun read-sxp-string (self str) (with-input-from-string (s str) (read-sxp-stream self s)))
19.103-
19.104-(defun write-sxp-string (sxp)
19.105- (let ((ast (ast sxp)))
19.106- (if (> (length ast) 1)
19.107- (write-to-string ast)
19.108- (write-to-string (car ast)))))
19.109-
19.110-(defun make-sxp (&rest form) (make-instance 'sxp :ast form))
19.111-
19.112-(deftype sxp-fmt-designator () '(member :canonical :collapsed))
19.113-
19.114-(defun unwrap-object (obj &key (slots t) (methods nil)
19.115- (indirect nil) (tag nil)
19.116- (unboundp nil) (nullp nil)
19.117- (exclude nil))
19.118- "Build and return a new `form' from OBJ by traversing the class
19.119-definition. This differs from the generic function `unwrap' which
19.120-always uses the ast slot as an internal buffer. We can also call this
19.121-on any class instance (doesn't need to subclass `sxp').
19.122-
19.123-SLOTS specifies the slots to be included in the output. If the value
19.124-is t, all slots are included. The ast slot is not included by default,
19.125-but this behavior may change in future revisions.
19.126-
19.127-When INDIRECT is non-nil, also include methods which indirectly
19.128-specialize on OBJ.
19.129-
19.130-When TAG is non-nil, return a cons where car is TAG and cdr is the
19.131-output. If TAG is t, use the class-name symbol."
19.132- (declare (type standard-object obj)
19.133- (type (or list boolean) slots)
19.134- (type (or list boolean) methods)
19.135- (type boolean indirect)
19.136- (type list exclude))
19.137- (unless (or slots methods)
19.138- (error "Required one missing key arg: SLOTS or METHODS"))
19.139- (let* ((class (class-of obj))
19.140- (res (when tag (list (if (eq t tag) (class-name class) tag)))))
19.141- (block unwrap
19.142- (when-let ((slots (when slots
19.143- (list-class-slots class slots exclude))))
19.144- (let ((slot-vals (list-slot-values-using-class class obj (remove-if #'null slots) nullp unboundp)))
19.145- (if methods
19.146- (push slot-vals res)
19.147- (return-from unwrap (push slot-vals res)))))
19.148- (when-let ((methods (when methods (list-class-methods class methods indirect))))
19.149- (push methods res)))
19.150- (flatten res)))
19.151-
19.152-(defun wrap-object (class form)
19.153- "Given a CLASS prototype and an input FORM, return a new instance of
19.154-CLASS. FORM is assumed to be the finalized lisp object which has
19.155-already passed through `read' -- not a string or file-stream for
19.156-example."
19.157- (declare (type class class)
19.158- (type form form)))
19.159-
19.160-;; (defmacro define-fmt ())
19.161-;; (defmacro define-macro ())
20.1--- a/lisp/sxp/tests.lisp Sun Oct 15 01:50:27 2023 -0400
20.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
20.3@@ -1,38 +0,0 @@
20.4-;;; tests.lisp --- SEXP tests
20.5-;; TODO 2023-09-01: refactor to macs.rt
20.6-(defpackage :sxp-tests
20.7- (:use :cl :sxp :macs :rt)
20.8- (:export #:run-tests))
20.9-(in-package :sxp-tests)
20.10-(in-readtable *macs-readtable*)
20.11-(declaim
20.12- (type (or string pathname) *test-file*)
20.13- (type string *test-string*))
20.14-(defparameter *test-file* "tests.sxp")
20.15-(defparameter *test-string* "(FOO 'BAR `(\"test\" ,BAZ ,@QUX) 123 0.0123 1/3 `(,A1 ,A2))")
20.16-
20.17-(defsuite :sxp)
20.18-(in-suite :sxp)
20.19-
20.20-(deftest forms ()
20.21- (is (formp nil))
20.22- (is (formp t))
20.23- (is (formp 3.14))
20.24- (is (formp "string"))
20.25- (is (formp (mapc #`(',a1) '(a))))
20.26- (is (formp ())))
20.27-
20.28-(deftest sxp-file ()
20.29- (let ((f (read-sxp-file *test-file*)))
20.30- (is (equal (unwrap f) (unwrap f)))))
20.31-
20.32-(deftest sxp-string ()
20.33- (let ((f (make-instance 'sxp)))
20.34- (is (formp (read-sxp-string f *test-string*)))
20.35- (is (equalp (read-from-string (write-sxp-string f)) (read-from-string *test-string*)))))
20.36-
20.37-(deftest sxp-stream ()
20.38- (let ((f (make-instance 'sxp)))
20.39- (with-input-from-string (s *test-string*)
20.40- (read-sxp-stream f s))
20.41- (is (write-sxp-stream f nil))))
21.1--- a/lisp/sxp/tests.sxp Sun Oct 15 01:50:27 2023 -0400
21.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
21.3@@ -1,42 +0,0 @@
21.4-; skip me maybe
21.5-;; this file does not contain quote characters.
21.6-(edges-1
21.7-(
21.8-(1389.886593 1341.567282)
21.9-(1383.122623 1339.369530)
21.10-)
21.11-(
21.12-(1383.122623 1339.369530)
21.13-(1387.706464 1325.261939)
21.14-)
21.15-(
21.16-(1387.706464 1325.261939)
21.17-(1394.470360 1327.459664)
21.18-)
21.19-(
21.20-(1394.470360 1327.459664)
21.21-(1389.886593 1341.567282)
21.22-)
21.23-) ; edges end
21.24-
21.25-(edges-2
21.26-( ( 1.1 2.2 ) (2.2 3.3) )
21.27-( ( 2.2 3.3 ) (3.3 3.3) )
21.28-( ( 3.3 3.3 ) (1.1 2.2) )
21.29-) ; end edges of triangle room
21.30-
21.31-(= 4 4)
21.32-(= 5 4)
21.33-(> 4.0 54.0)
21.34-(= 4 s)
21.35-(= (= 4 4) (> 5 4))
21.36-(not (= 3 3))
21.37-(not 4)
21.38-(if (= 4 4) 42 666)
21.39-(if (= 4.0 4.0) (42))
21.40-(+ 4 4)
21.41-(+ 5.0 6.5)
21.42-(- 4 5)
21.43-(^ 2 3)
21.44-(^ 3 2)
21.45-(^ 3 (+ 2 1))
22.1--- a/readme.org Sun Oct 15 01:50:27 2023 -0400
22.2+++ b/readme.org Sun Oct 15 03:20:41 2023 -0400
22.3@@ -1,29 +1,363 @@
22.4 #+TITLE: comp/core
22.5 * rust
22.6-** btrfs
22.7-** btrfsutil
22.8+** ffi
22.9+*** btrfs
22.10+*** btrfsutil
22.11 * lisp
22.12 #+begin_src lisp :results silent
22.13- (let ((asds '("lisp/rdb.asd" "lisp/sxp.asd"
22.14- "lisp/organ/organ.asd" "lisp/macs/macs.asd" "lisp/skel/skel.asd"
22.15+ (let ((asds '("lisp/macs/macs.asd"
22.16+ "lisp/lib/rdb.asd" "lisp/lib/sxp.asd" "lisp/lib/organ/organ.asd" "lisp/lib/skel/skel.asd"
22.17 "lisp/ffi/rocksdb.asd" "lisp/ffi/btrfs.asd")))
22.18 (mapc (lambda (x) (asdf:load-asd x)) asds))
22.19 #+end_src
22.20-** rdb
22.21+** macs
22.22 *** tests
22.23 #+begin_src lisp :package rdb.tests :results output replace :exports results
22.24+ (asdf:load-system :cli)
22.25+ (asdf:load-system :macs/tests)
22.26+ (in-package :macs.tests)
22.27+ (load "lisp/macs/tests.lisp")
22.28+ (setq *log-level* :debug)
22.29+ (rt:do-tests :macs)
22.30+#+end_src
22.31+#+RESULTS:
22.32+#+begin_example
22.33+in suite MACS with 11/11 tests:
22.34+:DEBUG @ 10521.106
22.35+; running test:
22.36+; #<TEST PAN :fn PAN-test1353 :args NIL :persist NIL {100445A003}>
22.37+:DEBUG @ 10521.113
22.38+; #<PASS (= 0 (FUNCALL P NIL))>
22.39+:DEBUG @ 10521.113
22.40+; #<PASS (= 1 (FUNCALL P 1))>
22.41+:DEBUG @ 10521.113
22.42+; #<PASS (= 1 B C)>
22.43+#<PASS PAN-TEST1353>
22.44+:DEBUG @ 10521.113
22.45+; running test:
22.46+; #<TEST ANA :fn ANA-test1352 :args NIL :persist NIL {10043B24C3}>
22.47+:DEBUG @ 10521.117
22.48+; #<PASS (= 8 (AIF (+ 2 2) (+ IT IT)))>
22.49+#<PASS ANA-TEST1352>
22.50+:DEBUG @ 10521.117
22.51+; running test:
22.52+; #<TEST FMT :fn FMT-test1351 :args NIL :persist NIL {1003D5F413}>
22.53+:DEBUG @ 10521.12
22.54+; #<PASS (STRING= (FORMAT NIL | 1 | 2 | 3 |~%) (FMT-ROW '(1 2 3)))>
22.55+:DEBUG @ 10521.12
22.56+; #<PASS (STRING= (FMT-SXHASH (SXHASH T)) (FMT-SXHASH (SXHASH T)))>
22.57+:DEBUG @ 10521.12
22.58+; #<PASS (STRING= FOOBAR
22.59+ ├─ :A
22.60+ ├─ :B
22.61+ ├─ C
22.62+ ╰─ D
22.63+
22.64+ FOOBAR
22.65+ ├─ :A
22.66+ ├─ :B
22.67+ ├─ C
22.68+ ╰─ D
22.69+)>
22.70+:DEBUG @ 10521.12
22.71+; #<PASS (STRING= SK-PROJECT
22.72+ ├─ :NAME
22.73+ │ ╰─ "foobar"
22.74+ ├─ :PATH
22.75+ │ ╰─ "/a/b/c.asd"
22.76+ ╰─ :VC
22.77+ ╰─ :HG
22.78+
22.79+ SK-PROJECT
22.80+ ├─ :NAME
22.81+ │ ╰─ "foobar"
22.82+ ├─ :PATH
22.83+ │ ╰─ "/a/b/c.asd"
22.84+ ╰─ :VC
22.85+ ╰─ :HG
22.86+)>
22.87+#<PASS FMT-TEST1351>
22.88+:DEBUG @ 10521.12
22.89+; running test:
22.90+; #<TEST ALIEN :fn ALIEN-test1350 :args NIL :persist NIL {1003D5D903}>
22.91+:DEBUG @ 10521.123
22.92+; #<PASS (= 0 (FOREIGN-INT-TO-INTEGER 0 4))>
22.93+:DEBUG @ 10521.123
22.94+; #<PASS (= 1 (BOOL-TO-FOREIGN-INT T))>
22.95+#<PASS ALIEN-TEST1350>
22.96+:DEBUG @ 10521.123
22.97+; running test:
22.98+; #<TEST THREAD :fn THREAD-test1349 :args NIL :persist NIL {1003D5BB43}>
22.99+:DEBUG @ 10521.127
22.100+; #<PASS (STRINGP (PRINT-THREAD-INFO NIL))>
22.101+#<PASS THREAD-TEST1349>
22.102+:DEBUG @ 10521.127
22.103+; running test:
22.104+; #<TEST REEXPORT :fn REEXPORT-test1348 :args NIL :persist NIL {1003D5A633}>
22.105+#<PASS REEXPORT-TEST1348>
22.106+:DEBUG @ 10521.127
22.107+; running test:
22.108+; #<TEST COND :fn COND-test1347 :args NIL :persist NIL {1003D59383}>
22.109+#<PASS COND-TEST1347>
22.110+:DEBUG @ 10521.127
22.111+; running test:
22.112+; #<TEST LOG :fn LOG-test1346 :args NIL :persist NIL {1003D580A3}>
22.113+:DEBUG @ 10521.127
22.114+; test
22.115+; DEBUG
22.116+:DEBUG @ 10521.127
22.117+; test
22.118+; DEBUG
22.119+:DEBUG @ 10521.13
22.120+; test
22.121+; DEBUG
22.122+:DEBUG @ 10521.13
22.123+; #<PASS (DEBUG! test *LOG-LEVEL*)>
22.124+#<PASS LOG-TEST1346>
22.125+:DEBUG @ 10521.13
22.126+; running test:
22.127+; #<TEST LIST :fn LIST-test1345 :args NIL :persist NIL {1003CD8E43}>
22.128+:DEBUG @ 10521.134
22.129+; #<PASS (EQ (ENSURE-CAR '(0)) (ENSURE-CAR 0))>
22.130+:DEBUG @ 10521.134
22.131+; #<PASS (EQ (ENSURE-CAR '(NIL)) (ENSURE-CAR NIL))>
22.132+:DEBUG @ 10521.134
22.133+; #<PASS (NOT (EQ (ENSURE-CONS 0) (ENSURE-CONS 0)))>
22.134+:DEBUG @ 10521.134
22.135+; #<PASS (EQUAL (ENSURE-CONS 0) (ENSURE-CONS 0))>
22.136+#<PASS LIST-TEST1345>
22.137+:DEBUG @ 10521.134
22.138+; running test:
22.139+; #<TEST STR :fn STR-test1344 :args NIL :persist NIL {1003BADEE3}>
22.140+:DEBUG @ 10521.14
22.141+; #<PASS (TYPEP test 'STRING-DESIGNATOR)>
22.142+:DEBUG @ 10521.14
22.143+; #<PASS (TYPEP 'TEST 'STRING-DESIGNATOR)>
22.144+:DEBUG @ 10521.14
22.145+; #<PASS (TYPEP C 'STRING-DESIGNATOR)>
22.146+:DEBUG @ 10521.14
22.147+; #<PASS (NOT (TYPEP 0 'STRING-DESIGNATOR))>
22.148+#<PASS STR-TEST1344>
22.149+:DEBUG @ 10521.14
22.150+; running test:
22.151+; #<TEST SYM :fn SYM-test1343 :args NIL :persist NIL {10037F7453}>
22.152+:DEBUG @ 10521.144
22.153+; #<PASS (NOT (EQUALP (MAKE-GENSYM 'A) (MAKE-GENSYM 'A)))>
22.154+:DEBUG @ 10521.144
22.155+; #<PASS (EQ (ENSURE-SYMBOL 'TESTS MACS.TESTS) 'TESTS)>
22.156+:DEBUG @ 10521.144
22.157+; #<PASS (EQ 'FOO (FORMAT-SYMBOL MACS.TESTS ~A 'FOO))>
22.158+:DEBUG @ 10521.144
22.159+; #<PASS (EQ (MAKE-KEYWORD 'FIZZ) FIZZ)>
22.160+#<PASS SYM-TEST1343>
22.161+No tests failed.
22.162+#+end_example
22.163+** lib
22.164+*** cli
22.165+#+begin_src lisp :package rdb.tests :results output replace :exports results
22.166+ (asdf:load-system :cli)
22.167+ (asdf:load-system :cli/tests)
22.168+ (in-package :cli.tests)
22.169+ (load "lisp/lib/cli/tests.lisp")
22.170+ (setq *log-level* :debug)
22.171+ (rt:do-tests :cli)
22.172+#+end_src
22.173+*** rt
22.174+#+begin_src lisp :package rt.tests :results output replace :exports results
22.175+ (asdf:load-system :rt/tests)
22.176+ (in-package :rt.tests)
22.177+ (load "lisp/lib/cli/tests.lisp")
22.178+ (setq *log-level* :debug)
22.179+ (do-tests :rt)
22.180+#+end_src
22.181+*** rdb
22.182+**** tests
22.183+#+begin_src lisp :package rdb.tests :results output replace :exports results
22.184 (asdf:load-system :rdb/tests)
22.185 (in-package :rdb.tests)
22.186- (load "lisp/rdb/tests.lisp")
22.187- (setq log:*log-level* :debug)
22.188- (rt:do-tests :rdb)
22.189+ (load "lisp/lib/rdb/tests.lisp")
22.190+ (setq *log-level* :debug)
22.191+ (do-tests :rdb)
22.192 #+end_src
22.193-
22.194 #+RESULTS:
22.195 : in suite RDB with 0/0 tests:
22.196 : No tests failed.
22.197+*** sxp
22.198+**** tests
22.199+#+begin_src lisp :package sxp.tests :results output replace :exports results
22.200+ (asdf:load-system :sxp/tests)
22.201+ (load "lisp/lib/sxp/tests.lisp")
22.202+ (in-package :sxp.tests)
22.203+ (let ((*default-pathname-defaults* #.#P"./lisp/lib/sxp/")
22.204+ (log:*log-level* :debug))
22.205+ (do-tests :sxp))
22.206+#+end_src
22.207+#+RESULTS:
22.208+#+begin_example
22.209+in suite SXP with 4/4 tests:
22.210+:DEBUG @ 10905.557
22.211+; running test:
22.212+; #<TEST SXP-STREAM :fn SXP-STREAM-test1461 :args NIL :persist NIL {1002F41C33}>
22.213+((foo 'bar `("test" ,baz ,@qux) 123 0.0123 1/3 `(,a1 ,a2))):DEBUG @ 10905.563
22.214+; #<PASS (WRITE-SXP-STREAM F NIL)>
22.215+#<PASS SXP-STREAM-TEST1461>
22.216+:DEBUG @ 10905.563
22.217+; running test:
22.218+; #<TEST SXP-STRING :fn SXP-STRING-test1460 :args NIL :persist NIL {1002DEF703}>
22.219+:DEBUG @ 10905.566
22.220+; #<PASS (FORMP (READ-SXP-STRING F *TEST-STRING*))>
22.221+:DEBUG @ 10905.566
22.222+; #<PASS (EQUALP (READ-FROM-STRING (WRITE-SXP-STRING F))
22.223+ (READ-FROM-STRING *TEST-STRING*))>
22.224+#<PASS SXP-STRING-TEST1460>
22.225+:DEBUG @ 10905.566
22.226+; running test:
22.227+; #<TEST SXP-FILE :fn SXP-FILE-test1459 :args NIL :persist NIL {1002DEDBF3}>
22.228+:DEBUG @ 10905.57
22.229+; #<PASS (EQUAL (UNWRAP F) (UNWRAP F))>
22.230+#<PASS SXP-FILE-TEST1459>
22.231+:DEBUG @ 10905.57
22.232+; running test:
22.233+; #<TEST FORMS :fn FORMS-test1458 :args NIL :persist NIL {1002DEC3C3}>
22.234+:DEBUG @ 10905.577
22.235+; #<PASS (FORMP NIL)>
22.236+:DEBUG @ 10905.577
22.237+; #<PASS (FORMP T)>
22.238+:DEBUG @ 10905.577
22.239+; #<PASS (FORMP 3.14)>
22.240+:DEBUG @ 10905.577
22.241+; #<PASS (FORMP string)>
22.242+:DEBUG @ 10905.577
22.243+; #<PASS (FORMP (MAPC (LAMBDA (A1) `(',A1)) '(A)))>
22.244+:DEBUG @ 10905.577
22.245+; #<PASS (FORMP NIL)>
22.246+#<PASS FORMS-TEST1458>
22.247+No tests failed.
22.248+#+end_example
22.249+*** organ
22.250+**** tests
22.251+#+begin_src lisp :package organ.tests :results output replace :exports results
22.252+ (asdf:load-system :organ/tests)
22.253+ (in-package :organ.tests)
22.254+ (setq log:*log-level* :debug)
22.255+ (load "lisp/lib/organ/tests.lisp")
22.256+ (rt:do-tests :organ)
22.257+#+end_src
22.258+#+RESULTS:
22.259+#+begin_example
22.260+in suite ORGAN with 3/3 tests:
22.261+:DEBUG @ 12527.026
22.262+; running test:
22.263+; #<TEST ORG-HEADLINE :fn ORG-HEADLINE-test18308 :args NIL :persist NIL {1005FBD213}>
22.264+:DEBUG @ 12527.037
22.265+; #<PASS (= (LEVEL (ORG-PARSE (MAKE-ORG-HEADLINE S))) 2)>
22.266+:DEBUG @ 12527.04
22.267+; #<PASS (STRING= (TITLE (ORG-PARSE (MAKE-ORG-HEADLINE S))) DONE testing stuff )>
22.268+:DEBUG @ 12527.04
22.269+; #<PASS (= (LENGTH (TAGS (ORG-PARSE (MAKE-ORG-HEADLINE S)))) 2)>
22.270+#<PASS ORG-HEADLINE-TEST18308>
22.271+:DEBUG @ 12527.04
22.272+; running test:
22.273+; #<TEST ORG-LINES :fn ORG-LINES-test18307 :args NIL :persist NIL {1005FBAEE3}>
22.274+:DEBUG @ 12527.043
22.275+; #<PASS (READ-ORG-LINES (OPEN *TEST-FILE*))>
22.276+:DEBUG @ 12527.043
22.277+; #<PASS (READ-ORG-LINES-FROM-STRING S)>
22.278+#<PASS ORG-LINES-TEST18307>
22.279+:DEBUG @ 12527.043
22.280+; running test:
22.281+; #<TEST ORG-FILE :fn ORG-FILE-test18306 :args NIL :persist NIL {1005FB96E3}>
22.282+:DEBUG @ 12527.047
22.283+; #<PASS (READ-ORG-FILE *TEST-FILE*)>
22.284+#<PASS ORG-FILE-TEST18306>
22.285+No tests failed.
22.286+#+end_example
22.287+*** skel
22.288+**** tests
22.289+#+begin_src lisp :package skel.tests :results output replace :exports results
22.290+ (asdf:load-system :skel/tests)
22.291+ (in-package :skel.tests)
22.292+ (load "lisp/lib/skel/tests.lisp")
22.293+ (setq *log-level* :debug)
22.294+ (rt:do-tests :skel)
22.295+#+end_src
22.296+#+RESULTS:
22.297+#+begin_example
22.298+; compiling file "/home/ellis/dev/skel/tests.lisp" (written 15 OCT 2023 03:10:25 AM):
22.299
22.300-** sxp
22.301+; wrote /home/ellis/.cache/common-lisp/sbcl-2.3.8.18.master.74-8cf7faf9a-linux-x64/home/ellis/dev/skel/tests-tmpR8PK79V8.fasl
22.302+; compilation finished in 0:00:00.006
22.303+in suite SKEL with 6/6 tests:
22.304+:DEBUG @ 12500.617
22.305+; running test:
22.306+; #<TEST VM :fn VM-test17295 :args NIL :persist NIL {100713BF53}>
22.307+:DEBUG @ 12500.623
22.308+; #<PASS (LET ((VM (MAKE-SK-VM C9)))
22.309+ (DOTIMES (I C8) (SKS-POP VM))
22.310+ T)>
22.311+:DEBUG @ 12500.623
22.312+; #<PASS (SKS-POP VM)>
22.313+#<PASS VM-TEST17295>
22.314+:DEBUG @ 12500.623
22.315+; running test:
22.316+; #<TEST MAKEFILE :fn MAKEFILE-test17294 :args NIL :persist NIL {100713A443}>
22.317+:DEBUG @ 12500.646
22.318+; #<PASS (NULL (SK-WRITE-FILE (MK) IF-EXISTS SUPERSEDE PATH (TMP-PATH mk)))>
22.319+:DEBUG @ 12500.646
22.320+; #<PASS (PUSH-RULE R1 MK1)>
22.321+:DEBUG @ 12500.646
22.322+; #<PASS (PUSH-RULE R2 MK1)>
22.323+:DEBUG @ 12500.646
22.324+; #<PASS (PUSH-DIRECTIVE
22.325+ (CMD ifeq ($(DEBUG),1) echo foo
22.326+endif)
22.327+ MK1)>
22.328+:DEBUG @ 12500.646
22.329+; #<PASS (PUSH-VAR '(A B) MK1)>
22.330+:DEBUG @ 12500.646
22.331+; #<PASS (PUSH-VAR '(B C) MK1)>
22.332+#<PASS MAKEFILE-TEST17294>
22.333+:DEBUG @ 12500.646
22.334+; running test:
22.335+; #<TEST SKELRC :fn SKELRC-test17293 :args NIL :persist NIL {1006FD6AF3}>
22.336+#<PASS SKELRC-TEST17293>
22.337+:DEBUG @ 12500.65
22.338+; running test:
22.339+; #<TEST SKELFILE :fn SKELFILE-test17292 :args NIL :persist NIL {1006FD5843}>
22.340+:DEBUG @ 12500.663
22.341+; #<PASS (SK-WRITE-FILE (MAKE-INSTANCE 'SK-PROJECT NAME nada PATH %TMP) PATH
22.342+ %TMP IF-EXISTS SUPERSEDE)>
22.343+:DEBUG @ 12500.663
22.344+; #<FAIL (INIT-SKELFILE %TMP)>
22.345+:DEBUG @ 12500.663
22.346+; #<PASS (LOAD-SKELFILE %TMP)>
22.347+:DEBUG @ 12500.663
22.348+; #<PASS (BUILD-AST (SK-READ-FILE (MAKE-INSTANCE 'SK-PROJECT) %TMP))>
22.349+#<PASS SKELFILE-TEST17292>
22.350+:DEBUG @ 12500.663
22.351+; running test:
22.352+; #<TEST HEADER-COMMENTS :fn HEADER-COMMENTS-test17291 :args NIL :persist NIL {1006FD3893}>
22.353+:DEBUG @ 12500.667
22.354+; #<PASS (EQ
22.355+ (TYPE-OF (MAKE-SHEBANG-FILE-HEADER (MAKE-SHEBANG-COMMENT /dev/null)))
22.356+ 'FILE-HEADER)>
22.357+:DEBUG @ 12500.667
22.358+; #<PASS (EQ
22.359+ (TYPE-OF
22.360+ (MAKE-SOURCE-FILE-HEADER
22.361+ (MAKE-SOURCE-HEADER-COMMENT foo-test TIMESTAMP T DESCRIPTION
22.362+ nothing to see here OPTS
22.363+ '(Definitely-Not_Emacs: T;))))
22.364+ 'FILE-HEADER)>
22.365+#<PASS HEADER-COMMENTS-TEST17291>
22.366+:DEBUG @ 12500.667
22.367+; running test:
22.368+; #<TEST SANITY :fn SANITY-test17290 :args NIL :persist NIL {1006FD1D83}>
22.369+:DEBUG @ 12500.67
22.370+; #<PASS (EQ T (APPLY #'/= (SKELS 3E8)))>
22.371+#<PASS SANITY-TEST17290>
22.372+No tests failed.
22.373+#+end_example
22.374 ** ffi
22.375 *** btrfs
22.376 **** tests
22.377@@ -34,11 +368,9 @@
22.378 (setq log:*log-level* :debug)
22.379 (rt:do-tests :btrfs)
22.380 #+end_src
22.381-
22.382 #+RESULTS:
22.383 : in suite BTRFS with 0/0 tests:
22.384 : No tests failed.
22.385-
22.386 *** rocksdb
22.387 **** tests
22.388 #+begin_src lisp :package rocksdb.tests :results output replace :exports results
22.389@@ -48,7 +380,6 @@
22.390 (setq log:*log-level* :debug)
22.391 (rt:do-tests :rocksdb)
22.392 #+end_src
22.393-
22.394 #+RESULTS:
22.395 #+begin_example
22.396 in suite ROCKSDB with 2/2 tests:
