From 5a8c25bec7f62b7c0c8ad174f4f9eb4ea5197120 Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 7 May 2026 12:39:46 +0000 Subject: [PATCH] =?UTF-8?q?haskell:=20Phase=2013=20=E2=80=94=20class=20def?= =?UTF-8?q?ault=20method=20registration=20+=20dispatch=20fallback?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored-By: Claude Sonnet 4.6 --- lib/haskell/eval.sx | 72 ++++++++++++++++++++++++++++------- plans/haskell-completeness.md | 14 ++++++- 2 files changed, 71 insertions(+), 15 deletions(-) diff --git a/lib/haskell/eval.sx b/lib/haskell/eval.sx index 1692cc20..beae9eca 100644 --- a/lib/haskell/eval.sx +++ b/lib/haskell/eval.sx @@ -1258,15 +1258,66 @@ ((key (str "dict" cls "_" (hk-runtime-type tv)))) (if (has-key? env key) - (hk-apply (get (get env key) mname) x) - (raise - (str - "No instance " - cls - " for " - (hk-runtime-type tv))))))) + (let + ((inst (get env key))) + (if + (has-key? inst mname) + (hk-apply (get inst mname) x) + (if + (has-key? + env + (str "__default__" cls "_" mname)) + (hk-apply + (get + env + (str + "__default__" + cls + "_" + mname)) + x) + (raise + (str + "No method " + mname + " in instance " + cls + " for " + (hk-runtime-type tv)))))) + (if + (has-key? + env + (str "__default__" cls "_" mname)) + (hk-apply + (get + env + (str "__default__" cls "_" mname)) + x) + (raise + (str + "No instance " + cls + " for " + (hk-runtime-type tv)))))))) 1))) (nth m 1)))) + method-decls) + (for-each + (fn + (m) + (when + (= (first m) "fun-clause") + (let + ((mname (nth m 1)) + (pats (nth m 2)) + (body (nth m 3))) + (dict-set! + env + (str "__default__" cls "_" mname) + (if + (empty? pats) + (hk-eval body env) + (hk-eval (list "lambda" pats body) env)))))) method-decls))) ((= (first d) "instance-decl") (let @@ -1363,12 +1414,7 @@ (let ((modname (nth d 2)) (as-name (nth d 3))) (let - ((alias - (cond - ((not (nil? as-name)) as-name) - ((= modname "Data.Map") "Map") - ((= modname "Data.Set") "Set") - (:else modname)))) + ((alias (cond ((not (nil? as-name)) as-name) ((= modname "Data.Map") "Map") ((= modname "Data.Set") "Set") (:else modname)))) (cond ((= modname "Data.Map") (hk-bind-data-map! env alias)) ((= modname "Data.Set") (hk-bind-data-set! env alias)) diff --git a/plans/haskell-completeness.md b/plans/haskell-completeness.md index 7d1905dd..0d66fde4 100644 --- a/plans/haskell-completeness.md +++ b/plans/haskell-completeness.md @@ -223,10 +223,10 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. - [x] Verify `where`-clauses in `instance` bodies desugar correctly. The `hk-bind-decls!` instance arm must call the same where-lifting logic as top-level function clauses. Write a targeted test to confirm. -- [ ] Class declarations may include default method implementations. Parser: +- [x] Class declarations may include default method implementations. Parser: `hk-parse-class` collects method decls; eval registers defaults under `"__default__ClassName_method"` in the class dict. -- [ ] Instance method lookup: when the instance dict lacks a method, fall back +- [x] Instance method lookup: when the instance dict lacks a method, fall back to the default. Wire this into the dictionary-passing dispatch. - [ ] `Eq` default: `(/=) x y = not (x == y)`. Verify it works without an explicit `/=` in every Eq instance. @@ -307,6 +307,16 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. _Newest first._ +**2026-05-07** — Phase 13 default method implementations + dispatch fallback: +- class-decl handler now also registers fun-clause method bodies under + `__default__ClassName_method` (paralleling the type-sig dispatcher pass). +- Dispatcher rewritten as nested `if`s: instance dict has the method → + use it; else look up default → use it; else raise. Earlier attempt with + `cond + and` infinite-looped — switched to plain `if` form which works. +- Both regular dispatch (`describe x = "a boolean"` instance) and default + fallback (`hello x = "hi"` default with empty instance body) verified. + No regressions in class/deriving/instance-where/eval suites. + **2026-05-07** — Phase 13 `where`-clauses in `instance` bodies: - Bug discovered: `hk-desugar` didn't recurse into `instance-decl` method bodies, so a `where`-form in an instance method survived to eval and hit