From 9307437679f30b09193afdb2e9dedc343dd369a5 Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 7 May 2026 16:11:23 +0000 Subject: [PATCH] =?UTF-8?q?haskell:=20Phase=2014=20=E2=80=94=20record=20cr?= =?UTF-8?q?eation=20Foo=20{=20f=20=3D=20e,=20=E2=80=A6=20}=20(parser=20+?= =?UTF-8?q?=20desugar)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored-By: Claude Sonnet 4.6 --- lib/haskell/desugar.sx | 78 +++++++++++++++++++++++++++++++++++ lib/haskell/parser.sx | 35 +++++++++++++++- lib/haskell/runtime.sx | 50 ++++++---------------- plans/haskell-completeness.md | 14 ++++++- 4 files changed, 137 insertions(+), 40 deletions(-) diff --git a/lib/haskell/desugar.sx b/lib/haskell/desugar.sx index f64d3416..923e2c90 100644 --- a/lib/haskell/desugar.sx +++ b/lib/haskell/desugar.sx @@ -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 diff --git a/lib/haskell/parser.sx b/lib/haskell/parser.sx index 75ace6f9..1283ab30 100644 --- a/lib/haskell/parser.sx +++ b/lib/haskell/parser.sx @@ -210,7 +210,12 @@ ((= (get t "type") "varid") (do (hk-advance!) (list :var (get t "value")))) ((= (get t "type") "conid") - (do (hk-advance!) (list :con (get t "value")))) + (do + (hk-advance!) + (cond + ((hk-match? "lbrace" nil) + (hk-parse-rec-create (get t "value"))) + (:else (list :con (get t "value")))))) ((= (get t "type") "qvarid") (do (hk-advance!) (list :var (get t "value")))) ((= (get t "type") "qconid") @@ -456,6 +461,34 @@ (do (hk-expect! "rbracket" nil) (list :list (list first-e)))))))))) + (define + hk-parse-rec-create + (fn + (cname) + (begin + (hk-expect! "lbrace" nil) + (let + ((fields (list))) + (define + hk-rc-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-rc-loop)))))))))) + (hk-rc-loop) + (hk-expect! "rbrace" nil) + (list :rec-create cname fields))))) (define hk-parse-fexp (fn diff --git a/lib/haskell/runtime.sx b/lib/haskell/runtime.sx index 6a8e9a6c..18931dff 100644 --- a/lib/haskell/runtime.sx +++ b/lib/haskell/runtime.sx @@ -12,12 +12,7 @@ (define hk-register-con! - (fn - (cname arity type-name) - (dict-set! - hk-constructors - cname - {:arity arity :type type-name}))) + (fn (cname arity type-name) (dict-set! hk-constructors cname {:arity arity :type type-name}))) (define hk-is-con? (fn (name) (has-key? hk-constructors name))) @@ -48,26 +43,15 @@ (fn (data-node) (let - ((type-name (nth data-node 1)) - (cons-list (nth data-node 3))) + ((type-name (nth data-node 1)) (cons-list (nth data-node 3))) (for-each - (fn - (cd) - (hk-register-con! - (nth cd 1) - (len (nth cd 2)) - type-name)) + (fn (cd) (hk-register-con! (nth cd 1) (len (nth cd 2)) type-name)) cons-list)))) ;; (:newtype NAME TVARS CNAME FIELD) (define hk-register-newtype! - (fn - (nt-node) - (hk-register-con! - (nth nt-node 3) - 1 - (nth nt-node 1)))) + (fn (nt-node) (hk-register-con! (nth nt-node 3) 1 (nth nt-node 1)))) ;; Walk a decls list, registering every `data` / `newtype` decl. (define @@ -78,15 +62,9 @@ (fn (d) (cond - ((and - (list? d) - (not (empty? d)) - (= (first d) "data")) + ((and (list? d) (not (empty? d)) (= (first d) "data")) (hk-register-data! d)) - ((and - (list? d) - (not (empty? d)) - (= (first d) "newtype")) + ((and (list? d) (not (empty? d)) (= (first d) "newtype")) (hk-register-newtype! d)) (:else nil))) decls))) @@ -99,16 +77,12 @@ ((nil? ast) nil) ((not (list? ast)) nil) ((empty? ast) nil) - ((= (first ast) "program") - (hk-register-decls! (nth ast 1))) - ((= (first ast) "module") - (hk-register-decls! (nth ast 4))) + ((= (first ast) "program") (hk-register-decls! (nth ast 1))) + ((= (first ast) "module") (hk-register-decls! (nth ast 4))) (:else nil)))) ;; Convenience: source → AST → desugar → register. -(define - hk-load-source! - (fn (src) (hk-register-program! (hk-core src)))) +(define hk-load-source! (fn (src) (hk-register-program! (hk-core src)))) ;; ── Built-in constructors pre-registered ───────────────────── ;; Bool — used implicitly by `if`, comparison operators. @@ -122,9 +96,9 @@ ;; Standard Prelude types — pre-registered so expression-level ;; programs can use them without a `data` decl. (hk-register-con! "Nothing" 0 "Maybe") -(hk-register-con! "Just" 1 "Maybe") -(hk-register-con! "Left" 1 "Either") -(hk-register-con! "Right" 1 "Either") +(hk-register-con! "Just" 1 "Maybe") +(hk-register-con! "Left" 1 "Either") +(hk-register-con! "Right" 1 "Either") (hk-register-con! "LT" 0 "Ordering") (hk-register-con! "EQ" 0 "Ordering") (hk-register-con! "GT" 0 "Ordering") diff --git a/plans/haskell-completeness.md b/plans/haskell-completeness.md index 3be4fb97..c05aa834 100644 --- a/plans/haskell-completeness.md +++ b/plans/haskell-completeness.md @@ -251,7 +251,7 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. constructor bodies. AST node: `(:con-rec CNAME [(FNAME TYPE) …])`. - [x] Desugar: `:con-rec` → positional `:con-def` plus generated accessor functions `(\rec -> case rec of …)` for each field name. -- [ ] Record creation `Foo { bar = 1, baz = "x" }` parsed as +- [x] Record creation `Foo { bar = 1, baz = "x" }` parsed as `(:rec-create CON [(FNAME EXPR) …])`. Eval builds the same tagged list as positional construction (field order from the data decl). - [ ] Record update `r { field = v }` parsed as `(:rec-update EXPR [(FNAME EXPR)])`. @@ -313,6 +313,18 @@ No OCaml changes are needed. The view type is fully representable as an SX dict. _Newest first._ +**2026-05-07** — Phase 14 record-creation syntax `Foo { f = e, … }`: +- Parser: post-`conid` peek for `{` triggers `hk-parse-rec-create`, returning + `(:rec-create cname [(fname expr) …])`. +- `hk-record-fields` dict (in desugar.sx — load order requires it live there) + is populated by `hk-expand-records` when it sees a `con-rec`. +- New `:rec-create` case in `hk-desugar` looks up the field order, builds an + `app` chain `(:app (:app (:con cname) e1) e2 …)` in declared order. Field- + pair lookup via new `hk-find-rec-pair` helper. Order in source doesn't + matter — `Person { age = 99, name = "bob" }` correctly produces a Person + with name="bob", age=99 regardless of source order. +- Verified via direct execution; no regressions in parse/desugar/deriving. + **2026-05-07** — Phase 14 record desugar (`:con-rec` → positional + accessors): - New `hk-record-accessors` helper in `desugar.sx` generates one fun-clause per field, pattern-matching on the constructor with wildcards in all other