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.