From c821e21f943344826e592e79b5308c2c80e05204 Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 7 May 2026 12:18:21 +0000 Subject: [PATCH] =?UTF-8?q?haskell:=20Phase=2013=20=E2=80=94=20where-claus?= =?UTF-8?q?es=20in=20instance=20bodies=20(desugar=20fix,=20+4=20tests)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored-By: Claude Sonnet 4.6 --- lib/haskell/desugar.sx | 80 +++++++++-------------------- lib/haskell/tests/instance-where.sx | 31 +++++++++++ plans/haskell-completeness.md | 14 ++++- 3 files changed, 67 insertions(+), 58 deletions(-) create mode 100644 lib/haskell/tests/instance-where.sx diff --git a/lib/haskell/desugar.sx b/lib/haskell/desugar.sx index b61a9453..fb5af2cd 100644 --- a/lib/haskell/desugar.sx +++ b/lib/haskell/desugar.sx @@ -131,112 +131,78 @@ (let ((tag (first node))) (cond - ;; Transformations ((= tag "where") (list - :let - (map hk-desugar (nth node 2)) + :let (map hk-desugar (nth node 2)) (hk-desugar (nth node 1)))) ((= tag "guarded") (hk-guards-to-if (nth node 1))) ((= tag "list-comp") - (hk-lc-desugar - (hk-desugar (nth node 1)) - (nth node 2))) - - ;; Expression nodes + (hk-lc-desugar (hk-desugar (nth node 1)) (nth node 2))) ((= tag "app") (list - :app - (hk-desugar (nth node 1)) + :app (hk-desugar (nth node 1)) (hk-desugar (nth node 2)))) ((= tag "op") (list - :op - (nth node 1) + :op (nth node 1) (hk-desugar (nth node 2)) (hk-desugar (nth node 3)))) ((= tag "neg") (list :neg (hk-desugar (nth node 1)))) ((= tag "if") (list - :if - (hk-desugar (nth node 1)) + :if (hk-desugar (nth node 1)) (hk-desugar (nth node 2)) (hk-desugar (nth node 3)))) - ((= tag "tuple") - (list :tuple (map hk-desugar (nth node 1)))) - ((= tag "list") - (list :list (map hk-desugar (nth node 1)))) + ((= tag "tuple") (list :tuple (map hk-desugar (nth node 1)))) + ((= tag "list") (list :list (map hk-desugar (nth node 1)))) ((= tag "range") (list - :range - (hk-desugar (nth node 1)) + :range (hk-desugar (nth node 1)) (hk-desugar (nth node 2)))) ((= tag "range-step") (list - :range-step - (hk-desugar (nth node 1)) + :range-step (hk-desugar (nth node 1)) (hk-desugar (nth node 2)) (hk-desugar (nth node 3)))) ((= tag "lambda") - (list - :lambda - (nth node 1) - (hk-desugar (nth node 2)))) + (list :lambda (nth node 1) (hk-desugar (nth node 2)))) ((= tag "let") (list - :let - (map hk-desugar (nth node 1)) + :let (map hk-desugar (nth node 1)) (hk-desugar (nth node 2)))) ((= tag "case") (list - :case - (hk-desugar (nth node 1)) + :case (hk-desugar (nth node 1)) (map hk-desugar (nth node 2)))) ((= tag "alt") (list :alt (nth node 1) (hk-desugar (nth node 2)))) ((= tag "do") (hk-desugar-do (nth node 1))) ((= tag "sect-left") - (list - :sect-left - (nth node 1) - (hk-desugar (nth node 2)))) + (list :sect-left (nth node 1) (hk-desugar (nth node 2)))) ((= tag "sect-right") - (list - :sect-right - (nth node 1) - (hk-desugar (nth node 2)))) - - ;; Top-level + (list :sect-right (nth node 1) (hk-desugar (nth node 2)))) ((= tag "program") (list :program (map hk-desugar (nth node 1)))) ((= tag "module") (list - :module - (nth node 1) + :module (nth node 1) (nth node 2) (nth node 3) (map hk-desugar (nth node 4)))) - - ;; Decls carrying a body ((= tag "fun-clause") (list - :fun-clause - (nth node 1) + :fun-clause (nth node 1) (nth node 2) (hk-desugar (nth node 3)))) + ((= tag "instance-decl") + (list + :instance-decl (nth node 1) + (nth node 2) + (map hk-desugar (nth node 3)))) ((= tag "pat-bind") - (list - :pat-bind - (nth node 1) - (hk-desugar (nth node 2)))) + (list :pat-bind (nth node 1) (hk-desugar (nth node 2)))) ((= tag "bind") - (list - :bind - (nth node 1) - (hk-desugar (nth node 2)))) - - ;; Everything else: leaf literals, vars, cons, patterns, - ;; types, imports, type-sigs, data / newtype / fixity, … + (list :bind (nth node 1) (hk-desugar (nth node 2)))) (:else node))))))) ;; Convenience — tokenize + layout + parse + desugar. diff --git a/lib/haskell/tests/instance-where.sx b/lib/haskell/tests/instance-where.sx new file mode 100644 index 00000000..96613969 --- /dev/null +++ b/lib/haskell/tests/instance-where.sx @@ -0,0 +1,31 @@ +;; instance-where.sx — Phase 13: where-clauses inside instance bodies. + +(hk-test + "instance method body with where-helper (Bool)" + (hk-deep-force + (hk-run + "class Greet a where\n greet :: a -> String\ninstance Greet Bool where\n greet x = mkMsg x\n where mkMsg True = \"yes\"\n mkMsg False = \"no\"\nmain = greet True")) + "yes") + +(hk-test + "instance method body with where-helper (False branch)" + (hk-deep-force + (hk-run + "class Greet a where\n greet :: a -> String\ninstance Greet Bool where\n greet x = mkMsg x\n where mkMsg True = \"yes\"\n mkMsg False = \"no\"\nmain = greet False")) + "no") + +(hk-test + "instance method body with where-binding referenced multiple times" + (hk-deep-force + (hk-run + "class Twice a where\n twice :: a -> Int\ninstance Twice Int where\n twice x = h + h\n where h = x + 1\nmain = twice 5")) + 12) + +(hk-test + "instance method body with multi-binding where" + (hk-deep-force + (hk-run + "class Calc a where\n calc :: a -> Int\ninstance Calc Int where\n calc x = a + b\n where a = x * 2\n b = x + 1\nmain = calc 3")) + 10) + +{:fails hk-test-fails :pass hk-test-pass :fail hk-test-fail} diff --git a/plans/haskell-completeness.md b/plans/haskell-completeness.md index dac15562..7d1905dd 100644 --- a/plans/haskell-completeness.md +++ b/plans/haskell-completeness.md @@ -220,7 +220,7 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. ### Phase 13 — `where` in typeclass instances + default methods -- [ ] Verify `where`-clauses in `instance` bodies desugar correctly. The +- [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: @@ -307,6 +307,18 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. _Newest first._ +**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 + `eval: unknown node tag 'where'`. Fix: added an `instance-decl` case to + the desugarer that maps `hk-desugar` over the method-decls list. The + existing `fun-clause` branch then desugars each method body, including + the where → let lifting. +- 4 tests in new `tests/instance-where.sx`: where-helper with literal + pattern matching, references reused multiple times, and multi-binding + where. Verified no regression in class.sx (14/14), deriving.sx (15/15), + desugar.sx (15/15). + **2026-05-07** — Phase 12 conformance: uniquewords.hs (4/4) + setops.hs (8/8) → Phase 12 complete: - `program-uniquewords.sx`: `foldl Set.insert` over a word list, then check `Set.size`/`member`. 4/4.