# HG changeset patch # User Richard Westhaver # Date 1726105201 14400 # Node ID 74e563ed453702c0ad9ca7dc2223cb0fefbd6a0c # Parent 95fd920af398014206f8782e56d437ac8419b7b8 cli and rt/fuzz diff -r 95fd920af398 -r 74e563ed4537 lisp/bin/organ.lisp --- a/lisp/bin/organ.lisp Wed Sep 11 18:08:29 2024 -0400 +++ b/lisp/bin/organ.lisp Wed Sep 11 21:40:01 2024 -0400 @@ -57,7 +57,7 @@ (defun run () (let ((*log-level* :info)) - (with-cli (opts cmds args) *cli* + (with-cli (*cli* opts cmds args) () (do-cmd *cli*) (debug-opts *cli*)))) diff -r 95fd920af398 -r 74e563ed4537 lisp/bin/skel.lisp --- a/lisp/bin/skel.lisp Wed Sep 11 18:08:29 2024 -0400 +++ b/lisp/bin/skel.lisp Wed Sep 11 21:40:01 2024 -0400 @@ -4,8 +4,8 @@ ;; level. :INPUT :WAIT :OUTPUT (in-package :std-user) (defpkg :bin/skel - (:use :cl :std :cli/clap :cli/clap/vars - :vc :sb-ext :skel :log + (:use :cl :std :cli + :vc :sb-ext :skel :log :cli/clap/util :dat/sxp #+tools :skel/tools/viz) (:import-from :cli/shell :*shell-input* :*shell-directory*) (:use :cli/tools/sbcl) @@ -344,12 +344,12 @@ (in-package :sk-user) (let ((*log-level* :info)) (in-readtable :shell) - (with-cli (opts cmds) *cli* + (with-cli (*cli* opts cmds) (cli:args) (debug-opts *cli*) (init-skel-vars) (when-let ((project (find-skelfile #P"."))) (let ((*default-pathname-defaults* (pathname (directory-namestring project)))) (setq *skel-project* (load-skelfile project)) - (setq *skel-shell* (sk-src *skel-project*)) + (setq *skel-path* (sk-src *skel-project*)) (setq *shell-directory* (sk-src *skel-project*)))) (do-cmd *cli*)))) diff -r 95fd920af398 -r 74e563ed4537 lisp/lib/cli/clap/cli.lisp --- a/lisp/lib/cli/clap/cli.lisp Wed Sep 11 18:08:29 2024 -0400 +++ b/lisp/lib/cli/clap/cli.lisp Wed Sep 11 21:40:01 2024 -0400 @@ -56,13 +56,13 @@ (defun make-cmds (cmds) "Make a vector of CLI-CMDs based on CMDS." (map 'vector - (lambda (x) - (etypecase x - (cli-cmd x) - (string (make-cli :cmd :name x)) - (list (apply #'make-cli :cmd x)) - (t (make-cli :cmd :name (format nil "~(~A~)" x))))) - cmds)) + (lambda (x) + (etypecase x + (cli-cmd x) + (string (make-cli :cmd :name x)) + (list (apply #'make-cli :cmd x)) + (t (make-cli :cmd :name (format nil "~(~A~)" x))))) + cmds)) (defclass cli (cli-cmd) ;; name slot defaults to *package*, must be string @@ -70,7 +70,7 @@ (version :initarg :version :initform "0.1.0" :accessor cli-version :type string) ;; TODO 2023-10-11: look into pushd popd - cd-stack? (cd :initarg :cd :initform (sb-posix:getcwd) :type string :accessor cli-cd - :documentation "working directory of the top-level CLI.")) + :documentation "working directory of the top-level CLI.")) (:documentation "CLI")) (defmethod print-usage ((self cli) &optional stream) @@ -114,15 +114,16 @@ (loop for opt across (active-opts self global) do (do-opt opt))) -(defmacro with-cli (slots cli &body body) +(defmacro with-cli ((cli &rest slots) args &body body) "Like with-slots with some extra bindings. SLOTS is a list passed to WITH-SLOTS. -CLI is updated based on the current environment and dynamically bound to -*CLI*." +CLI is updated based on the current environment and dynamically bound +to *CLI*. ARGS is a list of CLI args, defaults to *POSIX-ARGV* at +runtime if nil." `(progn - (setq *cli* ,cli) - (setf (cli-cd ,cli) (sb-posix:getcwd)) - (with-slots ,slots (parse-args ,cli (args) :compile t) - ,@body))) + (let ((*cli* ,cli)) + (setf (cli-cd *cli*) *default-pathname-defaults*) + (with-slots ,slots (parse-args *cli* ,args :compile t) + ,@body)))) diff -r 95fd920af398 -r 74e563ed4537 lisp/lib/cli/clap/cmd.lisp --- a/lisp/lib/cli/clap/cmd.lisp Wed Sep 11 18:08:29 2024 -0400 +++ b/lisp/lib/cli/clap/cmd.lisp Wed Sep 11 21:40:01 2024 -0400 @@ -96,9 +96,8 @@ (when-let ((c (find name (cli-cmds self) :key #'cli-name :test #'string=))) (if active ;; maybe issue warning here? report to user - (if (cli-lock-p c) - c - (clap-simple-error "inactive (unlocked) cmd: ~A" c)) + (when (cli-lock-p c) + c) c))) (defmethod active-cmds ((self cli-cmd)) @@ -143,16 +142,12 @@ "Bind restarts 'use-as-arg' and 'discard-arg' for duration of BODY." `(restart-case ,condition (use-as-arg () () (make-cli-node 'arg ,arg)) - (discard-arg () () nil))) + (discard-arg () () (setf ,arg nil)))) (defmethod proc-args ((self cli-cmd) args) "Process ARGS into an ast. Each element of the ast is a node with a :kind slot, indicating the type of node and a :form slot which stores -a value. - -For now we parse group separators '--' and insert a nil into the tree, -this will likely change to generating a new branch in the ast as it -should be." +a value." (make-cli-ast (let ((holes)) ;; list of arg indexes which can be skipped since they're ;; consumed by an opt diff -r 95fd920af398 -r 74e563ed4537 lisp/lib/cli/tests.lisp --- a/lisp/lib/cli/tests.lisp Wed Sep 11 18:08:29 2024 -0400 +++ b/lisp/lib/cli/tests.lisp Wed Sep 11 21:40:01 2024 -0400 @@ -218,7 +218,7 @@ (is (string= "foobar" (completing-read "nothing: " tcoll :history thist :default "foobar"))))) -(defparameter *opts* '((:name "foo" :global t :description "bar") +(defparameter *opts* '((:name "foo" :global t :description "bar" :kind string) (:name "bar" :description "foo" :kind string))) (defparameter *cmd1* (make-cli :cmd :name "holla" :opts *opts* :description "cmd1 description")) @@ -683,13 +683,12 @@ (proc-args *cli* '("--log" "default" "--foo=11")))) (defmain (:exit nil :export nil) - (with-cli () *cli* + (with-cli (*cli*) () (log:trace! "defmain is OK") t)) (deftest clap-main () - (let ((sb-ext:*posix-argv* nil)) - (is (null (funcall #'main))))) + (is (null (funcall #'main)))) (deftest sbcl-tools () (with-sbcl (:noinform t :quit t) diff -r 95fd920af398 -r 74e563ed4537 lisp/lib/rt/fuzz.lisp --- a/lisp/lib/rt/fuzz.lisp Wed Sep 11 18:08:29 2024 -0400 +++ b/lisp/lib/rt/fuzz.lisp Wed Sep 11 21:40:01 2024 -0400 @@ -48,4 +48,8 @@ (let ((ret (make-hash-table))) (dotimes (i count ret) (destructuring-bind (k v) (funcall generator state) - (setf (gethash k ret) v)))))) + (setf (gethash k ret) v))))) + (:method ((state random-state) (generator function) &key (count 1)) + (let ((ret)) + (dotimes (i count ret) + (push (funcall generator state) ret))))) diff -r 95fd920af398 -r 74e563ed4537 lisp/lib/rt/tests.lisp --- a/lisp/lib/rt/tests.lisp Wed Sep 11 18:08:29 2024 -0400 +++ b/lisp/lib/rt/tests.lisp Wed Sep 11 21:40:01 2024 -0400 @@ -1,5 +1,5 @@ (defpackage :rt/tests - (:use :cl :std :rt :sb-sprof :rt/flamegraph :rt/tracing :rt/cover :rt/bench)) + (:use :cl :std :rt :sb-sprof :rt/flamegraph :rt/tracing :rt/cover :rt/bench :rt/fuzz)) (in-package :rt/tests) @@ -44,7 +44,7 @@ (deftest tmp () (is (null (with-tmp-directory ()))) - (is (null (with-tmp-file ()))) + (is (null (with-tmp-file (file)))) (is (with-tmp-file (f1 :name "temporary-file") (is (probe-file *tmp*)) (write-string "1 2 3 4" f1) @@ -52,4 +52,9 @@ (is (= 7 (file-length f1))))) (is (with-tmp-directory ("foobar") (is (directory-path-p (probe-file *tmp*)))))) - + +(deftest fuzz () + (defclass foo-fuzz (fuzzer) ()) + (is (integerp + (fuzz (make-instance 'foo-fuzz)))) + (is (= 100 (length (fuzz* (make-random-state) (fuzz-generator (make-instance 'foo-fuzz)) :count 100))))) diff -r 95fd920af398 -r 74e563ed4537 lisp/lib/skel/pkg.lisp --- a/lisp/lib/skel/pkg.lisp Wed Sep 11 18:08:29 2024 -0400 +++ b/lisp/lib/skel/pkg.lisp Wed Sep 11 21:40:01 2024 -0400 @@ -47,5 +47,5 @@ (:use-reexport :skel/core :skel/comp)) (pkg:defpkg :sk-user - (:use :cl :std :std-user :cl-user :log :sb-debug :sb-ext :net/proto/dns :net/fetch :cli/tools/sbcl :pod) + (:use :cl :std :std-user :cl-user :log :sb-debug :sb-ext :net/proto/dns :net/fetch :cli/tools/sbcl :pod :cli/clap) (:use :skel :skel/core :skel/comp)) diff -r 95fd920af398 -r 74e563ed4537 skelfile --- a/skelfile Wed Sep 11 18:08:29 2024 -0400 +++ b/skelfile Wed Sep 11 21:40:01 2024 -0400 @@ -31,24 +31,32 @@ alien.c -o ../../../.stash/libtree-sitter-alien.so$#) (:install () #$cp .stash/libtree-sitter-alien.so /usr/local/lib/$#)) (psl.dat (%stash) - (download "https://publicsuffix.org/list/public_suffix_list.dat" :output ".stash/psl.dat")) + (download "https://publicsuffix.org/list/public_suffix_list.dat" + :output (merge-pathnames + ".stash/psl.dat" + *skel-path*))) (rgb.txt (%stash) - (download "https://packy.compiler.company/data/rgb.txt" :output ".stash/rgb.txt")) + (download "https://packy.compiler.company/data/rgb.txt" + :output (merge-pathnames + ".stash/rgb.txt" + *skel-path*))) (x11.lisp (rgb.txt) - (color::parse-x11-color-definitions :input ".stash/rgb.txt" :output "color/x11.lisp")) + (color::parse-x11-color-definitions + :input ".stash/rgb.txt" + :output (merge-pathnames "color/x11.lisp" *skel-path*))) (parquet.thrift (%stash) (download "https://raw.githubusercontent.com/apache/parquet-format/master/src/main/thrift/parquet.thrift" - :output ".stash/parquet.thrift") + :output (merge-pathnames ".stash/parquet.thrift" *skel-path*)) #$thrift --gen json -out .stash .stash/parquet.thrift$#) (parquet.json (%stash) (download "https://packy.compiler.company/data/parquet.json" - :output ".stash/parquet.json")) + :output (merge-pathnames ".stash/parquet.json" *skel-path*))) (freedesktop.org.xml (%stash) (download "https://packy.compiler.company/data/freedesktop.org.xml" - :output ".stash/freedesktop.org.xml")) + :output (merge-pathnames ".stash/freedesktop.org.xml" *skel-path*))) (parquet-test-data (%stash) (download "https://packy.compiler.company/data/test/alltypes_plain.parquet" - :output ".stash/alltypes_plain.parquet")) + :output (merge-pathnames ".stash/alltypes_plain.parquet" *skel-path*))) ;; lisp (%stash () #$mkdir -pv .stash$#) (rdb (%stash)