protocol: Clojure-style open-world protocols via (std protocol)
ober
3196011f5b4ba43b0f830327c32a30fb3f927104
--- a/docs/clojure-remaining.md +++ b/docs/clojure-remaining.md @@ -1292,6 +1292,66 @@ tests. Half a day for the basic version; another half-day for hierarchies. ### 4.6 Protocols (`defprotocol` / `extend-protocol` / `extend-type`) +**[landed]** Phase E.3 shipped `(std protocol)`. The module exports +`defprotocol`, `extend-type`, `extend-protocol`, `satisfies?`, +`protocol?`, `protocol-name`, and `protocol-methods`. + +```scheme +(import (jerboa prelude) (std protocol)) + +(defprotocol Shape + (area (self)) + (perimeter (self))) + +(defstruct circle (r)) +(extend-type circle::t Shape + (area (c) (* 314/100 (circle-r c) (circle-r c))) + (perimeter (c) (* 2 314/100 (circle-r c)))) + +(extend-protocol Shape + ('string (area (s) (string-length s)) + (perimeter (s) (* 4 (string-length s)))) + ('pair (area (p) (length p)) + (perimeter (p) (* 2 (length p))))) + +(area (make-circle 10)) ;; => 314 +(area "hello") ;; => 5 +(satisfies? Shape "foo") ;; => #t +``` + +Type keys are either record type descriptors (rtds) for records or +symbols for built-ins (`'string`, `'vector`, `'pair`, `'null`, +`'number`, `'symbol`, `'boolean`, `'char`, `'procedure`, `'hashtable`, +`'bytevector`, `'eof`). The sentinel `'any` acts as a universal +fallback. `defstruct` users pass `name::t`; `define-record-type` users +pass `(record-type-descriptor name)`. + +Rather than layering over `(std clos)` as the design doc originally +sketched, the implementation uses a direct two-level eq?-hashtable +(`type-key → method-sym → procedure`) guarded by a single mutex. This +keeps dispatch overhead to one hashtable lookup per call and avoids +the CLOS method-resolution machinery entirely — protocols don't need +class hierarchies, they need open-world type dispatch, and the table +lookup gives us that with minimal moving parts. Method bodies run +outside the dispatch lock so a method can recursively invoke other +protocol methods without deadlocking. + +`satisfies?` checks for a type-specific implementation — an `'any` +fallback does NOT count, matching Clojure's semantics where +`Object`-level methods are separate from protocol participation. + +Tests: `tests/test-protocol.ss` — 32 tests covering basic dispatch +(string / pair / record), `extend-protocol` bulk form, `satisfies?` +(positive / negative / partial / non-protocol), `'any` fallback +interaction with type-specific methods, method redefinition replaces, +multi-argument dispatch on first arg, and introspection. + +Deferred features: `isa?` hierarchies (Clojure's multimethod hierarchy +system), `prefer-method`, and classifier-style dispatch. These can +layer on top of the current implementation without breaking changes. + +--- + **The gap.** Clojure protocols are open-world method sets. You define the set of methods a protocol requires, then any number of types can opt in by providing implementations: @@ -1863,7 +1923,7 @@ in this doc. **[deferred]** items are non-goals. | Sorted-set | [current] `(std sorted-set)` | §4.3 landed | | Metadata (`with-meta`/`meta`) | [gap] | §4.4 | | `defmulti`/`defmethod` value-dispatch | [landed] `(std multi)` | §4.5 landed | -| `defprotocol`/`extend-type` | [gap] | §4.6 | +| `defprotocol`/`extend-type` | [landed] `(std protocol)` | §4.6 landed | | Atom watches | [current] `(std misc atom)` | §4.7 landed | | Volatiles | [current] `(std misc atom)` | §4.7 landed | | Agents | [gap] | §4.8 | new file mode 100644 --- /dev/null +++ b/lib/std/protocol.sls @@ -0,0 +1,223 @@ +#!chezscheme +;;; (std protocol) — Clojure-style protocols. +;;; +;;; A protocol is a named bundle of method names. Each method is a +;;; procedure that dispatches on the *type* of its first argument. +;;; Any number of types can opt in by providing method implementations; +;;; types do not need to know about the protocol up front. +;;; +;;; (defprotocol Shape +;;; (area (self)) +;;; (perimeter (self))) +;;; +;;; (defstruct circle (r)) +;;; (extend-type circle::t Shape +;;; (area (c) (* 3.14 (circle-r c) (circle-r c))) +;;; (perimeter (c) (* 2 3.14 (circle-r c)))) +;;; +;;; (extend-protocol Shape +;;; ('string (area (s) (string-length s)) +;;; (perimeter (s) (* 4 (string-length s)))) +;;; ('pair (area (p) (length p)) +;;; (perimeter (p) (* 2 (length p))))) +;;; +;;; (area (make-circle 3)) ;; => 28.26 +;;; (area "hello") ;; => 5 +;;; +;;; Type keys +;;; --------- +;;; A "type key" identifies the type for dispatch: +;;; +;;; - For records (`defstruct` / `define-record-type`), use the rtd: +;;; `point::t` for defstruct forms (they bind the rtd as `name::t`) +;;; `(record-type-descriptor point)` for define-record-type. +;;; - For built-in types, use a symbol: `'string`, `'vector`, `'pair`, +;;; `'null`, `'number`, `'symbol`, `'boolean`, `'char`, `'procedure`, +;;; `'hashtable`, `'bytevector`, `'eof`. +;;; - The sentinel `'any` is the universal fallback. A method with an +;;; 'any implementation fires when no type-specific method exists. +;;; +;;; Method body syntax +;;; ------------------ +;;; Each method is written like a plain lambda: +;;; +;;; (area (c) (* 3.14 (circle-r c) (circle-r c))) +;;; +;;; The first parameter is always the dispatch value (traditionally +;;; `self` in Clojure), but any name works. +;;; +;;; Unlike (std multi), `defprotocol` shares namespace with the rest +;;; of your code: each method name is defined as a top-level procedure. +;;; This is safe to import into the prelude because the method names +;;; are user-chosen and don't collide with built-ins. +;;; +;;; Thread safety +;;; ------------- +;;; Protocol dispatch is backed by a global registry guarded by a +;;; single mutex. Method lookup takes the lock; method *bodies* run +;;; outside the lock, so a method may call the same protocol on a +;;; different type without deadlocking. + +(library (std protocol) + (export + defprotocol extend-type extend-protocol + protocol? protocol-name protocol-methods + satisfies?) + + (import (chezscheme)) + + ;; --- Type key ----------------------------------------------- + + (define (%type-of x) + (cond + [(record? x) (record-rtd x)] + [(pair? x) 'pair] + [(null? x) 'null] + [(string? x) 'string] + [(vector? x) 'vector] + [(symbol? x) 'symbol] + [(number? x) 'number] + [(boolean? x) 'boolean] + [(char? x) 'char] + [(procedure? x) 'procedure] + [(hashtable? x) 'hashtable] + [(bytevector? x) 'bytevector] + [(eof-object? x) 'eof] + [else 'any])) + + ;; --- Dispatch table ----------------------------------------- + ;; + ;; The dispatch table is a two-level `eq?`-hashtable: + ;; + ;; type-key -> (eq-hashtable method-sym -> procedure) + ;; + ;; Both keys are always `eq?`-comparable: + ;; - method-sym is a symbol + ;; - type-key is either a symbol (for built-ins) or an rtd (records). + ;; Record type descriptors compare by identity in Chez. + + (define %dispatch (make-eq-hashtable)) + (define %dispatch-lock (make-mutex)) + + (define (%register-impl! method-sym type-key proc) + (with-mutex %dispatch-lock + (let ([inner (eq-hashtable-ref %dispatch type-key #f)]) + (cond + [inner (eq-hashtable-set! inner method-sym proc)] + [else + (let ([new-inner (make-eq-hashtable)]) + (eq-hashtable-set! new-inner method-sym proc) + (eq-hashtable-set! %dispatch type-key new-inner))])))) + + (define (%lookup-impl method-sym obj) + (let ([type-key (%type-of obj)]) + (with-mutex %dispatch-lock + (let ([inner (eq-hashtable-ref %dispatch type-key #f)]) + (or (and inner (eq-hashtable-ref inner method-sym #f)) + (let ([any-inner (eq-hashtable-ref %dispatch 'any #f)]) + (and any-inner + (eq-hashtable-ref any-inner method-sym #f)))))))) + + (define (%has-impl-for? method-sym type-key) + (with-mutex %dispatch-lock + (let ([inner (eq-hashtable-ref %dispatch type-key #f)]) + (and inner + (and (eq-hashtable-ref inner method-sym #f) #t))))) + + (define (%make-dispatcher method-sym) + (lambda args + (when (null? args) + (error method-sym + "protocol method called with no arguments")) + (let ([impl (%lookup-impl method-sym (car args))]) + (cond + [impl (apply impl args)] + [else + (error method-sym + "no implementation for type" + (%type-of (car args)))])))) + + ;; --- Protocol record ---------------------------------------- + + (define-record-type %protocol + (fields (immutable name) + (immutable methods)) ;; list of method name symbols + (sealed #t)) + + (define (protocol? x) (%protocol? x)) + (define (protocol-name p) + (unless (%protocol? p) + (error 'protocol-name "not a protocol" p)) + (%protocol-name p)) + (define (protocol-methods p) + (unless (%protocol? p) + (error 'protocol-methods "not a protocol" p)) + (%protocol-methods p)) + + ;; --- Public macros ------------------------------------------ + + ;; (defprotocol NAME + ;; (method-name (self arg ...)) ...) + ;; + ;; Binds NAME to a protocol handle and introduces each method-name + ;; as a top-level procedure that dispatches on the first argument's + ;; type. The formals list after each method-name is documentation — + ;; individual implementations may have any arity. + (define-syntax defprotocol + (syntax-rules () + [(_ name (method-name formals) ...) + (begin + (define method-name (%make-dispatcher 'method-name)) ... + (define name + (make-%protocol 'name '(method-name ...))))])) + + ;; (extend-type TYPE-EXPR PROTOCOL + ;; (method-name (self arg ...) body ...) ...) + ;; + ;; Registers method implementations for TYPE-EXPR against PROTOCOL. + ;; TYPE-EXPR is evaluated and must be either a record type + ;; descriptor (rtd) or a symbol identifying a built-in type. + ;; PROTOCOL is referenced for documentation only — the actual + ;; registration is keyed on method name + type key. + (define-syntax extend-type + (syntax-rules () + [(_ type-expr protocol-name + (method-name (arg ...) body ...) ...) + (let ([%tk type-expr]) + (%register-impl! 'method-name %tk + (lambda (arg ...) body ...)) + ... + %tk)])) + + ;; (extend-protocol PROTOCOL + ;; (TYPE-EXPR + ;; (method-name (self arg ...) body ...) ...) ...) + ;; + ;; Shorthand for registering multiple types against a single + ;; protocol. Each (TYPE-EXPR ...) group produces one `extend-type` + ;; expansion. + (define-syntax extend-protocol + (syntax-rules () + [(_ protocol-name + (type-expr (method-name (arg ...) body ...) ...) ...) + (begin + (extend-type type-expr protocol-name + (method-name (arg ...) body ...) ...) + ...)])) + + ;; (satisfies? PROTOCOL OBJ) + ;; + ;; Returns #t iff every method in PROTOCOL has an explicit + ;; implementation for the object's type. An 'any fallback does + ;; NOT count as satisfying the protocol — matches Clojure's + ;; behaviour where `Object` methods are separate from type-specific + ;; ones. + (define (satisfies? p x) + (unless (%protocol? p) + (error 'satisfies? "not a protocol" p)) + (let ([type-key (%type-of x)]) + (for-all + (lambda (name) (%has-impl-for? name type-key)) + (%protocol-methods p)))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-protocol.ss @@ -0,0 +1,261 @@ +#!chezscheme +;;; Tests for (std protocol) — Clojure-style protocols. + +(import (jerboa prelude) + (std protocol)) + +(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/protocol ---~%~%") + +;;; ---- defprotocol basics ---------------------------------------- + +(defprotocol Shape + (area (self)) + (perimeter (self))) + +(test "protocol? true for defprotocol result" + (protocol? Shape) + #t) + +(test "protocol? false for non-protocols" + (list (protocol? 42) (protocol? '()) (protocol? "str")) + '(#f #f #f)) + +(test "protocol-name" + (protocol-name Shape) + 'Shape) + +(test "protocol-methods" + (list-sort (lambda (a b) + (string<? (symbol->string a) (symbol->string b))) + (protocol-methods Shape)) + '(area perimeter)) + +;;; ---- extend-type on built-in types ----------------------------- + +(extend-type 'string Shape + (area (s) (string-length s)) + (perimeter (s) (* 4 (string-length s)))) + +(extend-type 'pair Shape + (area (p) (length p)) + (perimeter (p) (* 2 (length p)))) + +(test "dispatch on string" + (area "hello") + 5) + +(test "perimeter on string" + (perimeter "hello") + 20) + +(test "dispatch on pair" + (area '(a b c d)) + 4) + +(test "perimeter on pair" + (perimeter '(a b c)) + 6) + +;;; ---- No implementation => raise -------------------------------- + +(test "calling method on unsupported type raises" + (guard (_ [else 'raised]) + (area 42)) + 'raised) + +;;; ---- satisfies? ------------------------------------------------ + +(test "satisfies? true when all methods implemented for type" + (satisfies? Shape "foo") + #t) + +(test "satisfies? false for unsupported type" + (satisfies? Shape 42) + #f) + +(test "satisfies? false when type has only some methods" + (let () + (defprotocol Partial + (m1 (self)) + (m2 (self))) + (extend-type 'number Partial + (m1 (n) n)) + (satisfies? Partial 42)) + #f) + +(test "satisfies? error on non-protocol" + (guard (_ [else 'raised]) + (satisfies? "not-a-protocol" 42)) + 'raised) + +;;; ---- extend-protocol (bulk) ------------------------------------ + +(defprotocol Describable + (describe (self))) + +(extend-protocol Describable + ('string + (describe (s) (list 'string (string-length s)))) + ('number + (describe (n) (list 'number n))) + ('symbol + (describe (s) (list 'symbol s)))) + +(test "extend-protocol string" + (describe "abc") + '(string 3)) + +(test "extend-protocol number" + (describe 42) + '(number 42)) + +(test "extend-protocol symbol" + (describe 'hi) + '(symbol hi)) + +;;; ---- Records via defstruct ------------------------------------- + +(defstruct point (x y)) +(defstruct circle (r)) + +(defprotocol Geom + (center-of-mass (self)) + (shape-name (self))) + +(extend-type point::t Geom + (center-of-mass (p) (list (point-x p) (point-y p))) + (shape-name (p) 'point)) + +(extend-type circle::t Geom + (center-of-mass (c) (list 0 0)) + (shape-name (c) 'circle)) + +(test "dispatch on defstruct point" + (center-of-mass (make-point 3 4)) + '(3 4)) + +(test "dispatch on defstruct circle" + (center-of-mass (make-circle 5)) + '(0 0)) + +(test "shape-name point" + (shape-name (make-point 1 2)) + 'point) + +(test "shape-name circle" + (shape-name (make-circle 7)) + 'circle) + +(test "satisfies? works on records" + (list (satisfies? Geom (make-point 1 2)) + (satisfies? Geom (make-circle 3)) + (satisfies? Geom "not-a-record")) + '(#t #t #f)) + +;;; ---- 'any fallback --------------------------------------------- + +(defprotocol Greetable + (greet (self))) + +(extend-type 'any Greetable + (greet (x) (list 'hi x))) + +(test "'any fallback fires when no type-specific method" + (greet 42) + '(hi 42)) + +(test "'any fallback also works for strings" + (greet "world") + '(hi "world")) + +(test "type-specific override beats 'any" + (begin + (extend-type 'string Greetable + (greet (s) (list 'hello-string s))) + (greet "world")) + '(hello-string "world")) + +(test "'any fallback still works for number after string override" + (greet 99) + '(hi 99)) + +(test "satisfies? does NOT count 'any fallback" + (let () + (defprotocol OnlyAny + (foo (self))) + (extend-type 'any OnlyAny + (foo (x) x)) + (satisfies? OnlyAny 42)) + #f) + +;;; ---- Method redefinition replaces ------------------------------ + +(defprotocol Counter + (n (self))) + +(extend-type 'number Counter + (n (x) (* 2 x))) + +(test "first extend-type" + (n 21) + 42) + +(extend-type 'number Counter + (n (x) (* 3 x))) + +(test "re-extend-type replaces" + (n 21) + 63) + +;;; ---- Multi-argument methods ------------------------------------ + +(defprotocol Mixer + (mix (self other))) + +(extend-type 'number Mixer + (mix (a b) (+ a b))) + +(extend-type 'string Mixer + (mix (a b) (string-append a (if (string? b) b (format "~a" b))))) + +(test "multi-arg dispatch number" + (mix 3 4) + 7) + +(test "multi-arg dispatch string" + (mix "hello " "world") + "hello world") + +(test "dispatch uses first arg only" + (mix "x=" 42) + "x=42") + +;;; ---- protocol-methods returns list ----------------------------- + +(test "protocol-methods order matches defprotocol" + (let () + (defprotocol Three + (a (self)) + (b (self)) + (c (self))) + (protocol-methods Three)) + '(a b c)) + +;;; ---- Summary --------------------------------------------------- +(printf "~%std/protocol: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) (exit 1))