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

haskell: Phase 14 — record patterns Foo { f = b } in case + fun-clauses
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 49s
Details

Browse Source 
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-07 17:18:08 +00:00
parent 76d141737a
commit a4fd57cff1
3 changed files with 88 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

25
lib/haskell/desugar.sx
View File

@@ -142,6 +142,27 @@
(list
:app (hk-desugar (nth node 1))
(hk-desugar (nth node 2))))
((= tag "p-rec")
(let
((cname (nth node 1))
(field-pats (nth node 2))
(field-order (hk-record-field-names cname)))
(cond
((nil? field-order)
(raise (str "p-rec: no record info for " cname)))
(:else
(list
:p-con
cname
(map
(fn
(fname)
(let
((p (hk-find-rec-pair field-pats fname)))
(cond
((nil? p) (list :p-wild))
(:else (hk-desugar (nth p 1))))))
field-order))))))
((= tag "rec-update")
(list
:rec-update
@@ -217,7 +238,7 @@
:case (hk-desugar (nth node 1))
(map hk-desugar (nth node 2))))
((= tag "alt")
(list :alt (nth node 1) (hk-desugar (nth node 2))))
(list :alt (hk-desugar (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))))
@@ -234,7 +255,7 @@
((= tag "fun-clause")
(list
:fun-clause (nth node 1)
(nth node 2)
(map hk-desugar (nth node 2))
(hk-desugar (nth node 3))))
((= tag "instance-decl")
(list

63
lib/haskell/parser.sx
View File

@@ -522,6 +522,34 @@
(hk-ru-loop)
(hk-expect! "rbrace" nil)
(list :rec-update rec-expr fields)))))
(define
hk-parse-rec-pat
(fn
(cname)
(begin
(hk-expect! "lbrace" nil)
(let
((field-pats (list)))
(define
hk-rp-loop
(fn
()
(when
(hk-match? "varid" nil)
(let
((fname (get (hk-advance!) "value")))
(begin
(hk-expect! "reservedop" "=")
(let
((fpat (hk-parse-pat)))
(begin
(append! field-pats (list fname fpat))
(when
(hk-match? "comma" nil)
(begin (hk-advance!) (hk-rp-loop))))))))))
(hk-rp-loop)
(hk-expect! "rbrace" nil)
(list :p-rec cname field-pats)))))
(define
hk-parse-fexp
(fn
@@ -762,7 +790,12 @@
(:else
(do (hk-advance!) (list :p-var (get t "value")))))))
((= (get t "type") "conid")
(do (hk-advance!) (list :p-con (get t "value") (list))))
(do
(hk-advance!)
(cond
((hk-match? "lbrace" nil)
(hk-parse-rec-pat (get t "value")))
(:else (list :p-con (get t "value") (list))))))
((= (get t "type") "qconid")
(do (hk-advance!) (list :p-con (get t "value") (list))))
((= (get t "type") "lparen") (hk-parse-paren-pat))
@@ -828,16 +861,24 @@
(cond
((and (not (nil? t)) (or (= (get t "type") "conid") (= (get t "type") "qconid")))
(let
((name (get (hk-advance!) "value")) (args (list)))
(define
hk-pca-loop
(fn
()
(when
(hk-apat-start? (hk-peek))
(do (append! args (hk-parse-apat)) (hk-pca-loop)))))
(hk-pca-loop)
(list :p-con name args)))
((name (get (hk-advance!) "value")))
(cond
((hk-match? "lbrace" nil)
(hk-parse-rec-pat name))
(:else
(let
((args (list)))
(define
hk-pca-loop
(fn
()
(when
(hk-apat-start? (hk-peek))
(do
(append! args (hk-parse-apat))
(hk-pca-loop)))))
(hk-pca-loop)
(list :p-con name args))))))
(:else (hk-parse-apat))))))
(define
hk-parse-pat