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

haskell: Phase 14 — record desugar (con-rec → con-def + accessor fun-clauses)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 57s
Details

Browse Source 
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-07 15:38:40 +00:00
parent ca9e12fc57
commit b89e321007
2 changed files with 108 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

101
lib/haskell/desugar.sx
View File

@@ -182,13 +182,13 @@
((= tag "sect-right")
(list :sect-right (nth node 1) (hk-desugar (nth node 2))))
((= tag "program")
(list :program (map hk-desugar (nth node 1))))
(list :program (map hk-desugar (hk-expand-records (nth node 1)))))
((= tag "module")
(list
:module (nth node 1)
(nth node 2)
(nth node 3)
(map hk-desugar (nth node 4))))
(map hk-desugar (hk-expand-records (nth node 4)))))
((= tag "fun-clause")
(list
:fun-clause (nth node 1)
@@ -207,9 +207,98 @@
;; Convenience — tokenize + layout + parse + desugar.
(define
hk-core
(fn (src) (hk-desugar (hk-parse-top src))))
hk-record-accessors
(fn
(cname rec-fields)
(let
((n (len rec-fields)) (i 0) (out (list)))
(define
hk-ra-loop
(fn
()
(when
(< i n)
(let
((field (nth rec-fields i)))
(let
((fname (first field)) (j 0) (pats (list)))
(define
hk-pat-loop
(fn
()
(when
(< j n)
(begin
(append!
pats
(if
(= j i)
(list "p-var" "__rec_field")
(list "p-wild")))
(set! j (+ j 1))
(hk-pat-loop)))))
(hk-pat-loop)
(append!
out
(list
"fun-clause"
fname
(list (list "p-con" cname pats))
(list "var" "__rec_field")))
(set! i (+ i 1))
(hk-ra-loop))))))
(hk-ra-loop)
out)))
(define
hk-core-expr
(fn (src) (hk-desugar (hk-parse src))))
hk-expand-records
(fn
(decls)
(let
((out (list)))
(for-each
(fn
(d)
(cond
((and (list? d) (= (first d) "data"))
(let
((dname (nth d 1))
(tvars (nth d 2))
(cons-list (nth d 3))
(deriving (if (> (len d) 4) (nth d 4) (list)))
(new-cons (list))
(accessors (list)))
(begin
(for-each
(fn
(c)
(cond
((= (first c) "con-rec")
(let
((cname (nth c 1)) (rec-fields (nth c 2)))
(begin
(append!
new-cons
(list
"con-def"
cname
(map (fn (f) (nth f 1)) rec-fields)))
(for-each
(fn (a) (append! accessors a))
(hk-record-accessors cname rec-fields)))))
(:else (append! new-cons c))))
cons-list)
(append!
out
(if
(empty? deriving)
(list "data" dname tvars new-cons)
(list "data" dname tvars new-cons deriving)))
(for-each (fn (a) (append! out a)) accessors))))
(:else (append! out d))))
decls)
out)))
(define hk-core (fn (src) (hk-desugar (hk-parse-top src))))
(define hk-core-expr (fn (src) (hk-desugar (hk-parse src))))