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

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

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

View File

@@ -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

View File

@@ -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")

View File

@@ -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