multi: Clojure-style defmulti / defmethod via (std multi)
ober
5524045f95fcbb09ccdd3ee77614d1f5b27645f6
--- a/docs/clojure-remaining.md +++ b/docs/clojure-remaining.md @@ -1156,6 +1156,50 @@ Half a day. ### 4.5 Value-dispatched multimethods (`defmulti` / `defmethod`) +**[landed]** Phase E.2 shipped `(std multi)`. The module exports +`defmulti`, `defmethod`, `multimethod?`, `multimethod-name`, `get-method`, +`remove-method`, and `methods`. Because the prelude already binds +`defmethod` to the struct-typed dispatcher, `(std multi)` is *not* in the +prelude — users import it explicitly and shadow the prelude's +`defmethod`: + +```scheme +(import (except (jerboa prelude) defmethod) + (std multi)) + +(defmulti area (lambda (s) (car s))) +(defmethod area 'circle (c) (* 3.14 (cadr c) (cadr c))) +(defmethod area 'square (s) (let ([side (cadr s)]) (* side side))) +(defmethod area 'default (x) (error 'area "unknown shape" x)) +(area '(circle 3)) ;; => 28.26 +``` + +Dispatch keys are compared with `equal?`, so any hashable value works +(symbols, numbers, strings, lists, pmaps). The sentinel `'default` on +`defmethod` / `remove-method` / `get-method` targets the fallback slot. +Without a default, a miss raises. Concurrency: each multimethod owns a +mutex; dispatch lookup runs under the mutex but the body runs outside, +so methods may recursively invoke the same multimethod without +deadlocking. + +Internally, `defmulti` returns a procedure and registers it in a +module-level `eq?`-hashtable keyed on the procedure identity, so +`defmethod` can look up the underlying record without threading a second +identifier through macro hygiene. + +Tests: `tests/test-multi.ss` — 24 tests covering basic dispatch, default +fallthrough, `multimethod?`/`multimethod-name` introspection, `methods` +alist, `get-method` (found / missing / default), `remove-method` +(drops / idempotent / clears default), no-default raise, redefinition, +equal?-based keys (string / int / list), two-arg dispatch, and error on +non-multimethod procs. + +Advanced Clojure features (`isa?` hierarchies, `prefer-method`, +`derive`/`underive`) are deferred to a follow-up — the current module +implements the 90% case. + +--- + **The gap.** Jerboa has `defmethod` in the prelude, but it dispatches on **struct type** — you write `(defmethod (area (c circle)) ...)` and it registers a method against the `circle` record type. Clojure's @@ -1818,7 +1862,7 @@ in this doc. **[deferred]** items are non-goals. | PersistentQueue | [current] `(std pqueue)` | §4.2 landed | | Sorted-set | [current] `(std sorted-set)` | §4.3 landed | | Metadata (`with-meta`/`meta`) | [gap] | §4.4 | -| `defmulti`/`defmethod` value-dispatch | [gap] | §4.5 | +| `defmulti`/`defmethod` value-dispatch | [landed] `(std multi)` | §4.5 landed | | `defprotocol`/`extend-type` | [gap] | §4.6 | | Atom watches | [current] `(std misc atom)` | §4.7 landed | | Volatiles | [current] `(std misc atom)` | §4.7 landed | new file mode 100644 --- /dev/null +++ b/lib/std/multi.sls @@ -0,0 +1,199 @@ +#!chezscheme +;;; (std multi) — Clojure-style value-dispatched multimethods. +;;; +;;; Jerboa's prelude already ships a `defmethod` that dispatches on +;;; struct type (`(defmethod (area (c circle)) ...)`). Clojure's +;;; `defmulti` / `defmethod` are orthogonal — the user supplies a +;;; dispatch function, and each method is registered against an +;;; arbitrary value returned by that function: +;;; +;;; (defmulti area (lambda (shape) (car shape))) +;;; (defmethod area 'circle (c) (* 3.14 (cadr c) (cadr c))) +;;; (defmethod area 'square (s) (let ([side (cadr s)]) (* side side))) +;;; (defmethod area 'default (x) (error 'area "unknown shape" x)) +;;; (area '(circle 3)) ;; => 28.26 +;;; +;;; This module is NOT in the prelude to avoid shadowing the +;;; struct-typed `defmethod`. Users who want Clojure-style dispatch +;;; import `(std multi)` explicitly and (typically) shadow the +;;; prelude's `defmethod`: +;;; +;;; (import (except (jerboa prelude) defmethod) +;;; (std multi)) +;;; +;;; Dispatch values +;;; --------------- +;;; Keys are compared with `equal?`, so any value is usable: symbols, +;;; numbers, strings, vectors, lists, persistent maps, etc. +;;; +;;; The symbol `'default` is reserved: registering a method with key +;;; `'default` sets the fallback method that fires when no explicit +;;; dispatch value matches (mirrors Clojure's `:default`). Without a +;;; default, a dispatch miss raises. + +(library (std multi) + (export + ;; Core + defmulti defmethod + ;; Introspection / mutation + multimethod? multimethod-name + get-method remove-method methods) + + (import (chezscheme)) + + ;; --- Record ----------------------------------------------- + ;; + ;; The record is internal: user-facing `multimethod?` and + ;; `multimethod-name` operate on the dispatching *procedure* + ;; returned by `defmulti`, not on the record directly. We prefix + ;; the record name to keep the auto-generated accessors out of + ;; the export namespace. + + (define-record-type %mm + (fields (immutable name) + (immutable dispatch-fn) + (immutable methods) ;; hashtable, equal? keys + (mutable default-method) + (immutable lock)) ;; guards methods + default + (sealed #t)) + + (define (%new-multimethod name dispatch-fn) + (make-%mm name dispatch-fn + (make-hashtable equal-hash equal?) + #f + (make-mutex))) + + ;; --- Registry linking procedure -> multimethod ------------ + ;; + ;; `defmulti` installs the dispatching procedure and registers it + ;; in a module-level eq?-hashtable so `defmethod` can look up the + ;; underlying record from the procedure identity. Procedures are + ;; cheaper to compare by eq? than by name, and this sidesteps a + ;; macro-hygiene dance to thread a second identifier around. + + (define %registry (make-eq-hashtable)) + (define %registry-lock (make-mutex)) + + (define (%register! proc mm) + (with-mutex %registry-lock + (eq-hashtable-set! %registry proc mm))) + + (define (%lookup proc) + (with-mutex %registry-lock + (eq-hashtable-ref %registry proc #f))) + + ;; --- Dispatch --------------------------------------------- + + (define (%invoke mm args) + (let* ([k (apply (%mm-dispatch-fn mm) args)] + [mn (with-mutex (%mm-lock mm) + (or (hashtable-ref (%mm-methods mm) k #f) + (%mm-default-method mm)))]) + (cond + [mn (apply mn args)] + [else + (error (%mm-name mm) + "no method for dispatch value" k)]))) + + (define (%install name dispatch-fn) + (let* ([mm (%new-multimethod name dispatch-fn)] + [proc (lambda args (%invoke mm args))]) + (%register! proc mm) + proc)) + + ;; --- Public API ------------------------------------------- + + ;; (defmulti NAME DISPATCH-FN) + ;; + ;; 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. + (define-syntax defmulti + (syntax-rules () + [(_ name dispatch-fn) + (define name (%install 'name dispatch-fn))])) + + ;; (defmethod NAME DISPATCH-VAL (arg ...) body ...) + ;; + ;; Adds a method to the multimethod NAME for the dispatch value + ;; DISPATCH-VAL. If DISPATCH-VAL is the symbol `'default`, sets the + ;; fallback method instead. DISPATCH-VAL is an arbitrary expression + ;; evaluated at definition time — use your own quoting for + ;; symbolic keys (`'circle`, `'square`, etc.). + (define-syntax defmethod + (syntax-rules () + [(_ name dispatch-val (arg ...) body ...) + (%add-method! name dispatch-val (lambda (arg ...) body ...))])) + + (define (%add-method! proc k method) + (let ([mm (%lookup proc)]) + (unless mm + (error 'defmethod "not a multimethod" proc)) + (with-mutex (%mm-lock mm) + (cond + [(eq? k 'default) + (%mm-default-method-set! mm method)] + [else + (hashtable-set! (%mm-methods mm) k method)])) + proc)) + + ;; (multimethod? PROC) — true if PROC was created by `defmulti`. + (define (multimethod? proc) + (and (procedure? proc) (and (%lookup proc) #t))) + + ;; (multimethod-name PROC) — returns the symbol used in defmulti. + (define (multimethod-name proc) + (let ([mm (%lookup proc)]) + (unless mm + (error 'multimethod-name "not a multimethod" proc)) + (%mm-name mm))) + + ;; (get-method NAME DISPATCH-VAL) + ;; + ;; Returns the registered method for DISPATCH-VAL, or #f if none. + ;; The sentinel `'default` returns the default method. + (define (get-method proc k) + (let ([mm (%lookup proc)]) + (unless mm + (error 'get-method "not a multimethod" proc)) + (with-mutex (%mm-lock mm) + (cond + [(eq? k 'default) (%mm-default-method mm)] + [else (hashtable-ref (%mm-methods mm) k #f)])))) + + ;; (remove-method NAME DISPATCH-VAL) + ;; + ;; Removes the method registered for DISPATCH-VAL. Idempotent: + ;; removing a key that isn't present is a no-op. Returns NAME. + (define (remove-method proc k) + (let ([mm (%lookup proc)]) + (unless mm + (error 'remove-method "not a multimethod" proc)) + (with-mutex (%mm-lock mm) + (cond + [(eq? k 'default) + (%mm-default-method-set! mm #f)] + [else + (hashtable-delete! (%mm-methods mm) k)])) + proc)) + + ;; (methods NAME) => alist of (dispatch-value . method-procedure). + ;; Does not include the default method. Use `(get-method name 'default)` + ;; for that. + (define (methods proc) + (let ([mm (%lookup proc)]) + (unless mm + (error 'methods "not a multimethod" proc)) + (with-mutex (%mm-lock mm) + (let-values ([(keys vals) + (hashtable-entries (%mm-methods mm))]) + (let loop ([i 0] [acc '()]) + (cond + [(= i (vector-length keys)) acc] + [else + (loop (+ i 1) + (cons (cons (vector-ref keys i) + (vector-ref vals i)) + acc))])))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-multi.ss @@ -0,0 +1,187 @@ +#!chezscheme +;;; Tests for (std multi) — Clojure-style value-dispatched multimethods. + +(import (except (jerboa prelude) defmethod) + (std multi)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(printf "--- std/multi ---~%~%") + +;;; ---- Basic dispatch (top-level defmulti is the only place +;;; ---- defmulti is allowed; tests below use `describe` as a +;;; ---- shared fixture). + +(defmulti describe (lambda (x) (car x))) +(defmethod describe 'cat (x) (list 'cat (cadr x))) +(defmethod describe 'dog (x) (list 'dog (cadr x))) +(defmethod describe 'default (x) (list 'unknown (car x))) + +(test "dispatch cat" + (describe '(cat "whiskers")) + '(cat "whiskers")) + +(test "dispatch dog" + (describe '(dog "rover")) + '(dog "rover")) + +(test "dispatch falls through to default" + (describe '(fish "nemo")) + '(unknown fish)) + +;;; ---- multimethod predicate and introspection ---- + +(test "multimethod? true for defmulti-created procs" + (multimethod? describe) + #t) + +(test "multimethod? false for normal procedures" + (multimethod? car) + #f) + +(test "multimethod-name" + (multimethod-name describe) + 'describe) + +(test "methods returns alist of registered non-default entries" + (let ([m (methods describe)]) + (list-sort (lambda (a b) + (string<? (symbol->string (car a)) + (symbol->string (car b)))) + (map (lambda (e) (cons (car e) 'proc)) m))) + '((cat . proc) (dog . proc))) + +(test "get-method finds registered key" + (and (get-method describe 'cat) #t) + #t) + +(test "get-method returns #f for missing key" + (get-method describe 'nonexistent) + #f) + +(test "get-method 'default returns the default method" + (and (get-method describe 'default) #t) + #t) + +;;; ---- remove-method ---- + +(defmulti greeting (lambda (x) x)) +(defmethod greeting 'hi (x) "hello") +(defmethod greeting 'bye (x) "goodbye") + +(test "before remove-method 'hi -> hello" + (greeting 'hi) + "hello") + +(test "remove-method drops the method" + (begin + (remove-method greeting 'hi) + (guard (_ [else 'no-method]) + (greeting 'hi))) + 'no-method) + +(test "remove-method idempotent" + (begin + (remove-method greeting 'hi) + (remove-method greeting 'hi) + (greeting 'bye)) + "goodbye") + +(test "remove-method 'default clears the default" + (let () + (defmulti op (lambda (x) x)) + (defmethod op 'default (x) 'fallback) + (let ([before (op 'anything)]) + (remove-method op 'default) + (list before + (guard (_ [else 'missed]) (op 'anything))))) + '(fallback missed)) + +;;; ---- No default => raise ---- + +(defmulti strict (lambda (x) x)) +(defmethod strict 'ok (x) 'good) + +(test "no default raises on miss" + (guard (_ [else 'raised]) + (strict 'missing)) + 'raised) + +(test "no default still dispatches found methods" + (strict 'ok) + 'good) + +;;; ---- Redefining a method replaces ---- + +(defmulti tag (lambda (x) x)) +(defmethod tag 'a (x) 1) + +(test "redefine method replaces" + (begin + (defmethod tag 'a (x) 2) + (tag 'a)) + 2) + +;;; ---- Equal?-based keys: any hashable value ---- + +(defmulti kind (lambda (x) x)) +(defmethod kind "string-key" (x) 'string) +(defmethod kind 42 (x) 'int) +(defmethod kind '(nested key) (x) 'list) + +(test "string dispatch key" + (kind "string-key") + 'string) + +(test "integer dispatch key" + (kind 42) + 'int) + +(test "list dispatch key (equal? not eq?)" + (kind (list 'nested 'key)) + 'list) + +;;; ---- Multi-argument dispatch ---- + +(defmulti encounter + (lambda (a b) (cons (car a) (car b)))) +(defmethod encounter '(cat . mouse) (a b) 'chase) +(defmethod encounter '(dog . cat) (a b) 'chase) +(defmethod encounter 'default (a b) 'ignore) + +(test "two-arg dispatch cat/mouse" + (encounter '(cat whiskers) '(mouse jerry)) + 'chase) + +(test "two-arg dispatch fell through to default" + (encounter '(cow bessie) '(bird tweety)) + 'ignore) + +;;; ---- remove-method / get-method error on non-multimethods ---- + +(test "remove-method on plain proc raises" + (guard (_ [else 'raised]) + (remove-method car 'x)) + 'raised) + +(test "get-method on plain proc raises" + (guard (_ [else 'raised]) + (get-method car 'x)) + 'raised) + +;;; ---- Summary ---- +(printf "~%std/multi: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) (exit 1))