Round 7: sleep-ms prelude helper, defmulti :hierarchy, s-defn
ober
f2be3b3a08fe5d9358043c65b80e44a20850dfd0
--- a/lib/jerboa/prelude.sls +++ b/lib/jerboa/prelude.sls @@ -237,6 +237,9 @@ get-in assoc-in update-in assoc-in! update-in! nested-get nested-empty-like + ;; ---- Timing helpers ---- + sleep-ms + ;; ---- AI compatibility aliases ---- ;; Common names LLMs hallucinate from Racket/Gerbil/Gambit/CL training data. ;; These are thin aliases so AI-generated code works on the first try. @@ -299,7 +302,11 @@ (std misc atom) (std misc meta) (std misc shared) - (std misc nested)) + (std misc nested) + ;; Private access to Chez's make-time (shadowed above) so we can + ;; build a time-duration record for the sleep-ms wrapper. + (rename (only (chezscheme) make-time) + (make-time %chez-make-time))) ;; ---- System ---- (define cpu-count platform-cpu-count) @@ -328,4 +335,16 @@ (define (regex-replace pat str rep) (re-replace pat str rep)) (define (regex-replace-all pat str rep) (re-replace-all pat str rep)) + ;; ---- Timing helpers ---- + ;; (sleep-ms ms) sleeps for MS milliseconds. Wraps Chez's + ;; `(sleep (make-time 'time-duration ns sec))` so users never have + ;; to reach for `make-time` (which the prelude shadows with a + ;; date-style constructor). MS must be a non-negative integer. + (define (sleep-ms ms) + (unless (and (integer? ms) (>= ms 0)) + (error 'sleep-ms "ms must be a non-negative integer" ms)) + (let ([sec (quotient ms 1000)] + [ns (* (remainder ms 1000) 1000000)]) + (sleep (%chez-make-time 'time-duration ns sec)))) + ) ;; end library --- a/lib/std/multi.sls +++ b/lib/std/multi.sls @@ -44,7 +44,9 @@ parents ancestors descendants isa? prefer-method preferred-methods - global-hierarchy) + global-hierarchy + ;; Auxiliary keyword for (defmulti name dispatch :hierarchy h) + :hierarchy) (import (chezscheme)) @@ -204,11 +206,13 @@ (immutable lock)) ;; guards methods + default + prefs (sealed #t)) - (define (%new-multimethod name dispatch-fn) + (define (%new-multimethod name dispatch-fn hierarchy) + (unless (%hierarchy? hierarchy) + (error 'defmulti "not a hierarchy" hierarchy)) (make-%mm name dispatch-fn (make-hashtable equal-hash equal?) #f - global-hierarchy + hierarchy '() (make-mutex))) @@ -316,23 +320,41 @@ (let ([v (f (car xs))]) (loop (cdr xs) (if v (cons v acc) acc)))]))) - (define (%install name dispatch-fn) - (let* ([mm (%new-multimethod name dispatch-fn)] + (define (%install name dispatch-fn hierarchy) + (let* ([mm (%new-multimethod name dispatch-fn hierarchy)] [proc (lambda args (%invoke mm args))]) (%register! proc mm) proc)) ;; --- Public API ------------------------------------------- + ;; Auxiliary keyword used by defmulti. Exported so that a literal + ;; `:hierarchy` at a use site refers to the same binding as the + ;; literal in this library (R6RS `syntax-rules` literal matching + ;; requires matching bindings across library boundaries). + (define-syntax :hierarchy + (lambda (x) + (syntax-violation ':hierarchy + "misplaced auxiliary keyword" x))) + ;; (defmulti NAME DISPATCH-FN) + ;; (defmulti NAME DISPATCH-FN :hierarchy HIERARCHY-EXPR) ;; ;; Binds NAME to a procedure that, when called, applies DISPATCH-FN ;; to its arguments, looks up the resulting key in the multimethod's ;; methods table, and invokes the registered method. + ;; + ;; When the optional `:hierarchy` form is supplied, HIERARCHY-EXPR + ;; must evaluate to a hierarchy (from `make-hierarchy`) and is used + ;; for ancestor-walk dispatch. Otherwise the multimethod uses + ;; `global-hierarchy`. This is the moral equivalent of Clojure's + ;; `(defmulti name dispatch-fn :hierarchy #'my-h)`. (define-syntax defmulti - (syntax-rules () + (syntax-rules (:hierarchy) [(_ name dispatch-fn) - (define name (%install 'name dispatch-fn))])) + (define name (%install 'name dispatch-fn global-hierarchy))] + [(_ name dispatch-fn :hierarchy h-expr) + (define name (%install 'name dispatch-fn h-expr))])) ;; (defmethod NAME DISPATCH-VAL (arg ...) body ...) ;; --- a/lib/std/prelude.sls +++ b/lib/std/prelude.sls @@ -171,7 +171,10 @@ ;; ---- FFI ---- c-lambda define-c-lambda - begin-ffi c-declare) + begin-ffi c-declare + + ;; ---- Timing helpers ---- + sleep-ms) (import (except (chezscheme) @@ -183,6 +186,10 @@ iota 1+ 1- partition make-date make-time) + ;; Private access to Chez's make-time (shadowed above) so we can + ;; build a time-duration record for the sleep-ms wrapper. + (rename (only (chezscheme) make-time) + (make-time %chez-make-time)) (only (jerboa core) def def* defrule defrules defstruct defclass defmethod @@ -213,4 +220,16 @@ (std debug pp) (std csv)) + ;; ---- Timing helpers ---- + ;; (sleep-ms ms) sleeps for MS milliseconds. Wraps Chez's + ;; `(sleep (make-time 'time-duration ns sec))` so users never have + ;; to reach for `make-time` (which the prelude shadows with a + ;; date-style constructor). MS must be a non-negative integer. + (define (sleep-ms ms) + (unless (and (integer? ms) (>= ms 0)) + (error 'sleep-ms "ms must be a non-negative integer" ms)) + (let ([sec (quotient ms 1000)] + [ns (* (remainder ms 1000) 1000000)]) + (sleep (%chez-make-time 'time-duration ns sec)))) + ) ;; end library --- a/lib/std/spec.sls +++ b/lib/std/spec.sls @@ -33,6 +33,8 @@ s-valid? s-conform s-explain s-explain-str s-assert ;; Function specs s-fdef s-check-fn + ;; Script-safe speced define (Round 7 §42) + s-defn ;; Instrumentation (Round 5 §36) s-instrument s-unstrument s-instrumented? ;; Generation (basic) @@ -375,6 +377,100 @@ (%fspec-set! 'name 'key spec) (s-fdef name rest ...))]))) + ;; s-defn — a `define` that embeds arg/ret validation into the body. + ;; + ;; Why this exists: `s-instrument` rewires the top-level binding of a + ;; name after definition, which works in a REPL but loses the race in + ;; `--script` programs where the speced name has already been closed + ;; over by other top-level code by the time `s-instrument` runs. + ;; `s-defn` sidesteps the indirection by baking the validation into + ;; the function body at expansion time, so validation fires no matter + ;; how the binding is resolved. The function is also registered with + ;; `s-fdef` so `s-check-fn` still works. + ;; + ;; Forms: + ;; (s-defn name (args ...) body ...) + ;; (s-defn name (args ...) :args args-spec body ...) + ;; (s-defn name (args ...) :ret ret-spec body ...) + ;; (s-defn name (args ...) :args args-spec :ret ret-spec body ...) + ;; (s-defn name (args ...) :ret ret-spec :args args-spec body ...) + ;; + ;; args-spec is validated against the list of argument values. + ;; ret-spec is validated against the return value. + (define-syntax s-defn + (lambda (stx) + (syntax-case stx () + [(_ name (arg ...) form0 form1 ...) + (identifier? #'name) + (let loop ([rest #'(form0 form1 ...)] + [args-spec #f] + [ret-spec #f]) + (syntax-case rest () + [(kw spec-expr more ...) + (and (identifier? #'kw) + (memq (syntax->datum #'kw) '(:args :ret))) + (case (syntax->datum #'kw) + [(:args) + (when args-spec + (syntax-violation 's-defn ":args supplied twice" stx)) + (loop #'(more ...) #'spec-expr ret-spec)] + [(:ret) + (when ret-spec + (syntax-violation 's-defn ":ret supplied twice" stx)) + (loop #'(more ...) args-spec #'spec-expr)])] + [(body0 body1 ...) + (with-syntax + ([(arg* ...) #'(arg ...)] + [(body ...) rest] + [as-expr (or args-spec #'#f)] + [rs-expr (or ret-spec #'#f)] + [args? (if args-spec #t #f)] + [ret? (if ret-spec #t #f)]) + #'(%s-defn-emit name (arg* ...) + args? as-expr ret? rs-expr + (body ...)))] + [() + (syntax-violation 's-defn "s-defn requires a body" stx)]))]))) + + ;; Internal helper that emits the final `define`. Separated so the + ;; outer macro can pick a simple syntax-rules dispatch on the + ;; args?/ret? booleans. + (define-syntax %s-defn-emit + (syntax-rules () + [(_ name (arg ...) #f _as #f _rs (body ...)) + (define (name arg ...) body ...)] + [(_ name (arg ...) #t as #f _rs (body ...)) + (begin + (s-fdef name :args as) + (define (name arg ...) + (let ([%args (list arg ...)]) + (unless (s-valid? as %args) + (error 'name "args don't conform" + (s-explain-str as %args)))) + body ...))] + [(_ name (arg ...) #f _as #t rs (body ...)) + (begin + (s-fdef name :ret rs) + (define (name arg ...) + (let ([%ret (begin body ...)]) + (unless (s-valid? rs %ret) + (error 'name "return doesn't conform" + (s-explain-str rs %ret))) + %ret)))] + [(_ name (arg ...) #t as #t rs (body ...)) + (begin + (s-fdef name :args as :ret rs) + (define (name arg ...) + (let ([%args (list arg ...)]) + (unless (s-valid? as %args) + (error 'name "args don't conform" + (s-explain-str as %args)))) + (let ([%ret (begin body ...)]) + (unless (s-valid? rs %ret) + (error 'name "return doesn't conform" + (s-explain-str rs %ret))) + %ret)))])) + ;; s-check-fn — validate a function against its fspec (define (s-check-fn name f sample-args) (let ([fspec (hashtable-ref *fspec-registry* name #f)]) --- a/tests/test-multi.ss +++ b/tests/test-multi.ss @@ -322,6 +322,40 @@ (prefer-method describe 'flyer 'swimmer)) 'raised) +;;; ---- :hierarchy keyword on defmulti ----------------------- + +;; defmulti can take a custom hierarchy so tests/libraries don't +;; have to mutate the shared global-hierarchy. + +(def hh (make-hierarchy)) +(derive hh 'goldfish 'fish) +(derive hh 'fish 'aquatic) + +(defmulti swim (lambda (x) x) :hierarchy hh) +(defmethod swim 'aquatic (x) 'splash) +(defmethod swim 'fish (x) 'swim!) + +(prefer-method swim 'fish 'aquatic) + +(test ":hierarchy dispatch: goldfish -> fish" + (swim 'goldfish) + 'swim!) + +;; Separate defmulti using default (global) hierarchy knows +;; nothing about 'goldfish — confirming hh is isolated. +(defmulti swim-g (lambda (x) x)) +(defmethod swim-g 'default (x) 'unknown) + +(test ":hierarchy dispatch is isolated from global-hierarchy" + (swim-g 'goldfish) + 'unknown) + +(test ":hierarchy rejects non-hierarchy value" + (guard (_ [else 'raised]) + (eval '(defmulti bad-mm (lambda (x) x) :hierarchy 42) + (interaction-environment))) + 'raised) + ;;; ---- Summary ---- (printf "~%std/multi: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1)) --- a/tests/test-prelude.ss +++ b/tests/test-prelude.ss @@ -71,6 +71,17 @@ (defn (double [x number?]) (* x 2)) (chk (double 5) => 10) +;; sleep-ms — arg validation +(chk + (guard (_ [else 'rejected]) (sleep-ms -1)) + => 'rejected) +(chk + (guard (_ [else 'rejected]) (sleep-ms "not-a-number")) + => 'rejected) +;; Zero-ms is a valid no-op +(sleep-ms 0) +(chk #t => #t) + ;; Summary (newline) (display "prelude: ") --- a/tests/test-spec.ss +++ b/tests/test-spec.ss @@ -254,6 +254,67 @@ (s-instrument 'nonexistent-fn)) 'caught) +;;; ---- s-defn — script-safe speced define ------------------------ + +(s-defn sd-both (x y) + :args (s-cat ':x integer? ':y integer?) + :ret integer? + (+ x y)) + +(test "s-defn :args+:ret accepts valid call" + (sd-both 2 3) + 5) + +(test "s-defn :args rejects bad args" + (guard (exn [else 'caught]) + (sd-both "bad" 3)) + 'caught) + +(s-defn sd-ret-bad (x) :ret integer? "not-an-int") + +(test "s-defn :ret rejects bad return" + (guard (exn [else 'caught]) + (sd-ret-bad 1)) + 'caught) + +(s-defn sd-args-only (x) + :args (s-cat ':x string?) + (string-upcase x)) + +(test "s-defn :args only passes valid" + (sd-args-only "hi") + "HI") + +(test "s-defn :args only rejects invalid" + (guard (exn [else 'caught]) + (sd-args-only 99)) + 'caught) + +(s-defn sd-ret-only (x) :ret symbol? (string->symbol x)) + +(test "s-defn :ret only passes valid" + (sd-ret-only "sym") + 'sym) + +(s-defn sd-bare (x y) (* x y)) + +(test "s-defn with no specs behaves like def" + (sd-bare 4 5) + 20) + +(s-defn sd-reverse (x) + :ret symbol? + :args (s-cat ':x string?) + (string->symbol x)) + +(test "s-defn accepts :ret before :args" + (sd-reverse "ok") + 'ok) + +(test "s-defn registers s-fdef for s-check-fn" + (s-check-fn 'sd-both sd-both '(10 20)) + 30) + ;;; ---- Summary ---- (printf "~%std/spec: ~a passed, ~a failed~%" pass fail)