coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

haskell: Phase 13 — where-clauses in instance bodies (desugar fix, +4 tests)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 50s
Details

Browse Source 
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-07 12:18:21 +00:00
parent 5605fe1cc2
commit c821e21f94
3 changed files with 67 additions and 58 deletions
Download Patch File Download Diff File Expand all files Collapse all files

80
lib/haskell/desugar.sx
View File

@@ -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.

31
lib/haskell/tests/instance-where.sx Normal file
View File

@@ -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}