From f30a517cf7f515d01ca23f83e962fe4cb7536320 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Mon, 22 Jun 2026 18:30:44 -0400 Subject: [PATCH] Conformance: reify falls back to a protocol's default extension (jolt-az9a) A reify that doesn't implement a given protocol method now dispatches to that protocol's extended impls over the reify's host tags (e.g. an Object/default extension) instead of erroring 'No reified method'. This is malli's pattern: it reifies some protocols and relies on RegexSchema's default for the rest. A method with neither a reify impl nor a default still errors. --- host/chez/records.ss | 11 ++++++++++- test/chez/unit.edn | 2 ++ 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/host/chez/records.ss b/host/chez/records.ss index 352f7c6..c357cb8 100644 --- a/host/chez/records.ss +++ b/host/chez/records.ss @@ -240,7 +240,16 @@ ((reified-methods obj) => (lambda (rm) (let ((f (hashtable-ref rm method-name #f))) (if f (apply jolt-invoke f obj rest) - (error #f (string-append "No reified method " method-name)))))) + ;; not implemented on the reify — fall back to the + ;; protocol's extended impls over the reify's host tags + ;; (e.g. an Object/default extension). malli reifies some + ;; protocols and relies on a protocol's default for the + ;; rest (jolt-az9a). + (let loop ((tags (value-host-tags obj))) + (cond ((null? tags) (error #f (string-append "No reified method " method-name))) + ((find-protocol-method (car tags) proto-name method-name) + => (lambda (g) (apply jolt-invoke g obj rest))) + (else (loop (cdr tags))))))))) (else (let loop ((tags (value-host-tags obj))) (cond ((null? tags) (error #f (string-append "No method " method-name " in " proto-name))) diff --git a/test/chez/unit.edn b/test/chez/unit.edn index 1e741aa..64fcdf4 100644 --- a/test/chez/unit.edn +++ b/test/chez/unit.edn @@ -113,6 +113,8 @@ {:suite "hostctor" :expr "[(.getProtocol (java.net.URL. \"file:/tmp/x\")) (.getFile (java.net.URL. \"http://h/p\")) (.getProtocol (java.net.URL. \"http://h/p\"))]" :expected "[file http://h/p http]"} {:suite "hostobj" :expr "(try (throw (ex-info \"x\" {})) (catch Throwable e [(.getNextException e) (vec (.getStackTrace e))]))" :expected "[nil []]"} {:suite "hostobj" :expr "[(some? (ClassLoader/getSystemClassLoader)) (some? (.getContextClassLoader (Thread/currentThread)))]" :expected "[true true]"} + {:suite "reify" :expr "(do (defprotocol P (pm [_])) (defprotocol Q (qm [_])) (extend-protocol Q java.lang.Object (qm [_] :q-default)) (qm (reify P (pm [_] :p))))" :expected ":q-default"} + {:suite "reify" :expr "(do (defprotocol Q (qa [_]) (qb [_])) (extend-protocol Q java.lang.Object (qa [_] :da) (qb [_] :db)) (def r (reify Q (qa [_] :ra))) [(qa r) (qb r)])" :expected "[:ra :db]"} {:suite "dotform" :expr "(.equals \"a\" \"a\")" :expected "true"} {:suite "dotform" :expr "(.equals \"a\" \"b\")" :expected "false"} {:suite "dotform" :expr "(. {:value 41 :describe (fn [self] (str \"v=\" (:value self)))} describe)" :expected "v=41"}