diff --git a/lib/haskell/desugar.sx b/lib/haskell/desugar.sx index 65ab5c6f..c2b5ebdc 100644 --- a/lib/haskell/desugar.sx +++ b/lib/haskell/desugar.sx @@ -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 diff --git a/lib/haskell/parser.sx b/lib/haskell/parser.sx index d61916f5..3642d979 100644 --- a/lib/haskell/parser.sx +++ b/lib/haskell/parser.sx @@ -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 diff --git a/plans/haskell-completeness.md b/plans/haskell-completeness.md index e6d9733b..cb7d53d4 100644 --- a/plans/haskell-completeness.md +++ b/plans/haskell-completeness.md @@ -259,7 +259,7 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. tagged list. Field → index mapping stored in `hk-constructors` at registration. _Field map lives in `hk-record-fields` (desugar.sx) for load-order reasons, not `hk-constructors`._ -- [ ] Exhaustive record patterns: `Foo { bar = b }` in case binds `b`, +- [x] Exhaustive record patterns: `Foo { bar = b }` in case binds `b`, wildcards remaining fields. - [ ] Tests in `lib/haskell/tests/records.sx` (≥ 12 tests: creation, accessor, update one field, update two fields, record pattern, `deriving Show` on @@ -315,6 +315,18 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. _Newest first._ +**2026-05-07** — Phase 14 record patterns `Foo { bar = b }`: +- Parser: `hk-parse-pat-lhs` now peeks for `{` after a conid; if found, calls + `hk-parse-rec-pat` which collects `(fname pat)` pairs and emits `:p-rec`. +- Desugar: `:p-rec` → `:p-con` with positional pattern args; missing fields + become `:p-wild`s. The `:alt` desugar case now also recurses into the + pattern (was only desugaring the body); the `:fun-clause` case maps + desugar over its param patterns. Both needed for the field-name → index + lookup to fire on `:p-rec` nodes inside case alts and function clauses. +- Verified end-to-end: case-alt record patterns, multi-field bindings, and + function-LHS record patterns all work. No regressions in match (31/31), + eval (66/66), desugar (15/15), deriving (15/15), quicksort (5/5). + **2026-05-07** — Phase 14 record-update syntax `r { field = v }`: - Parser: `varid {` after a primary expression now triggers `hk-parse-rec-update` returning `(:rec-update record-expr [(fname expr) …])`.