haskell: Phase 14 — record creation Foo { f = e, … } (parser + desugar)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m0s
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:
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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")
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user