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

haskell: Phase 14 — record update r { field = v } (parser + desugar + eval)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m6s
Details

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

7
lib/haskell/desugar.sx
View File

@@ -142,6 +142,13 @@
(list
:app (hk-desugar (nth node 1))
(hk-desugar (nth node 2))))
((= tag "rec-update")
(list
:rec-update
(hk-desugar (nth node 1))
(map
(fn (p) (list (first p) (hk-desugar (nth p 1))))
(nth node 2))))
((= tag "rec-create")
(let
((cname (nth node 1))

36
lib/haskell/eval.sx
View File

@@ -246,6 +246,42 @@
(hk-apply
(hk-eval (nth node 1) env)
(hk-mk-thunk (nth node 2) env)))
((= tag "rec-update")
(let
((rec-val (hk-force (hk-eval (nth node 1) env)))
(updates (nth node 2)))
(let
((cname (first rec-val))
(args (rest rec-val))
(new-args (list)))
(begin
(let
((i 0))
(for-each
(fn
(a)
(let
((fname-at-i
(cond
((nil? (hk-record-field-names cname)) nil)
(:else
(nth (hk-record-field-names cname) i)))))
(let
((override
(cond
((nil? fname-at-i) nil)
(:else
(hk-find-rec-pair updates fname-at-i)))))
(begin
(append!
new-args
(cond
((nil? override) a)
(:else
(hk-mk-thunk (nth override 1) env))))
(set! i (+ i 1))))))
args))
(cons cname new-args)))))
((= tag "op")
(hk-eval-op (nth node 1) (nth node 2) (nth node 3) env))
((= tag "case") (hk-eval-case (nth node 1) (nth node 2) env))

35
lib/haskell/parser.sx
View File

@@ -208,7 +208,12 @@
((= (get t "type") "char")
(do (hk-advance!) (list :char (get t "value"))))
((= (get t "type") "varid")
(do (hk-advance!) (list :var (get t "value"))))
(do
(hk-advance!)
(cond
((hk-match? "lbrace" nil)
(hk-parse-rec-update (list :var (get t "value"))))
(:else (list :var (get t "value"))))))
((= (get t "type") "conid")
(do
(hk-advance!)
@@ -489,6 +494,34 @@
(hk-rc-loop)
(hk-expect! "rbrace" nil)
(list :rec-create cname fields)))))
(define
hk-parse-rec-update
(fn
(rec-expr)
(begin
(hk-expect! "lbrace" nil)
(let
((fields (list)))
(define
hk-ru-loop
(fn
()
(when
(hk-match? "varid" nil)
(let
((fname (get (hk-advance!) "value")))
(begin
(hk-expect! "reservedop" "=")
(let
((fexpr (hk-parse-expr-inner)))
(begin
(append! fields (list fname fexpr))
(when
(hk-match? "comma" nil)
(begin (hk-advance!) (hk-ru-loop))))))))))
(hk-ru-loop)
(hk-expect! "rbrace" nil)
(list :rec-update rec-expr fields)))))
(define
hk-parse-fexp
(fn