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

haskell: Phase 14 — record creation Foo { f = e, … } (parser + desugar)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m0s
Details

Browse Source 
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-07 16:11:23 +00:00
parent b89e321007
commit 9307437679
4 changed files with 137 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files

78
lib/haskell/desugar.sx
View File

@@ -142,6 +142,41 @@
(list
:app (hk-desugar (nth node 1))
(hk-desugar (nth node 2))))
((= tag "rec-create")
(let
((cname (nth node 1))
(field-pairs (nth node 2))
(field-order (hk-record-field-names cname)))
(cond
((nil? field-order)
(raise (str "rec-create: no record info for " cname)))
(:else
(let
((acc (list :con cname)))
(begin
(for-each
(fn
(fname)
(let
((pair
(hk-find-rec-pair field-pairs fname)))
(cond
((nil? pair)
(raise
(str
"rec-create: missing field "
fname
" for "
cname)))
(:else
(set!
acc
(list
:app
acc
(hk-desugar (nth pair 1))))))))
field-order)
acc))))))
((= tag "op")
(list
:op (nth node 1)
@@ -206,6 +241,46 @@
(:else node)))))))
;; Convenience — tokenize + layout + parse + desugar.
(define hk-record-fields (dict))
(define
hk-register-record-fields!
(fn (cname fields) (dict-set! hk-record-fields cname fields)))
(define
hk-record-field-names
(fn
(cname)
(if (has-key? hk-record-fields cname) (get hk-record-fields cname) nil)))
(define
hk-record-field-index
(fn
(cname fname)
(let
((fields (hk-record-field-names cname)))
(cond
((nil? fields) -1)
(:else
(let
((i 0) (idx -1))
(begin
(for-each
(fn
(f)
(begin (when (= f fname) (set! idx i)) (set! i (+ i 1))))
fields)
idx)))))))
(define
hk-find-rec-pair
(fn
(pairs name)
(cond
((empty? pairs) nil)
((= (first (first pairs)) name) (first pairs))
(:else (hk-find-rec-pair (rest pairs) name)))))
(define
hk-record-accessors
(fn
@@ -277,6 +352,9 @@
(let
((cname (nth c 1)) (rec-fields (nth c 2)))
(begin
(hk-register-record-fields!
cname
(map (fn (f) (first f)) rec-fields))
(append!
new-cons
(list