ocaml: phase 4 modules + field access (+11 tests, 215 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 54s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 54s
module M = struct DECLS end parsed by sub-tokenising the body source between struct and the matching end (nesting tracked via struct/begin/ sig/end). Field access is a postfix layer above parse-atom, binding tighter than application: f r.x -> (:app f (:field r "x")). Eval (:module-def NAME DECLS) builds a dict via ocaml-eval-module running decls in a sub-env. (:field EXPR NAME) looks up dict fields, treating (:con NAME) heads as module-name lookups instead of nullary ctors so M.x works with M as a module. Phase 4 LOC so far: ~110 lines (well under 2000 budget).
This commit is contained in:
@@ -314,6 +314,23 @@
|
|||||||
;; matches its argument against the clauses.
|
;; matches its argument against the clauses.
|
||||||
(let ((clauses (nth ast 1)) (captured env))
|
(let ((clauses (nth ast 1)) (captured env))
|
||||||
(fn (arg) (ocaml-match-clauses arg clauses captured))))
|
(fn (arg) (ocaml-match-clauses arg clauses captured))))
|
||||||
|
((= tag "field")
|
||||||
|
;; `e.name` — evaluate e, expect a dict (record/module), get name.
|
||||||
|
;; Special case: `(:field (:con "M") "x")` looks up M as a module
|
||||||
|
;; binding rather than evaluating it as a nullary ctor.
|
||||||
|
(let ((target-ast (nth ast 1)) (fname (nth ast 2)))
|
||||||
|
(let ((target
|
||||||
|
(cond
|
||||||
|
((= (ocaml-tag-of target-ast) "con")
|
||||||
|
(cond
|
||||||
|
((ocaml-env-has? env (nth target-ast 1))
|
||||||
|
(ocaml-env-lookup env (nth target-ast 1)))
|
||||||
|
(else (list (nth target-ast 1)))))
|
||||||
|
(else (ocaml-eval target-ast env)))))
|
||||||
|
(cond
|
||||||
|
((dict? target) (get target fname))
|
||||||
|
(else (error
|
||||||
|
(str "ocaml-eval: not a record/module on .field: " target)))))))
|
||||||
((= tag "for")
|
((= tag "for")
|
||||||
;; (:for NAME LO HI DIR BODY) — DIR is "ascend" or "descend".
|
;; (:for NAME LO HI DIR BODY) — DIR is "ascend" or "descend".
|
||||||
(let ((name (nth ast 1))
|
(let ((name (nth ast 1))
|
||||||
@@ -417,6 +434,64 @@
|
|||||||
(else (error
|
(else (error
|
||||||
(str "ocaml-eval: unknown AST tag " tag)))))))
|
(str "ocaml-eval: unknown AST tag " tag)))))))
|
||||||
|
|
||||||
|
;; ocaml-eval-module — evaluate a list of decls in a fresh sub-env layered
|
||||||
|
;; on top of the parent. Returns a dict mapping each declared name to its
|
||||||
|
;; value. Used by `module M = struct DECLS end`.
|
||||||
|
(define ocaml-eval-module
|
||||||
|
(fn (decls parent-env)
|
||||||
|
(let ((env parent-env) (result {}))
|
||||||
|
(begin
|
||||||
|
(define run-decl
|
||||||
|
(fn (decl)
|
||||||
|
(let ((tag (ocaml-tag-of decl)))
|
||||||
|
(cond
|
||||||
|
((= tag "def")
|
||||||
|
(let ((name (nth decl 1)) (params (nth decl 2)) (rhs (nth decl 3)))
|
||||||
|
(let ((v (if (= (len params) 0)
|
||||||
|
(ocaml-eval rhs env)
|
||||||
|
(ocaml-make-curried params rhs env))))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env name v))
|
||||||
|
(set! result (merge result (dict name v)))))))
|
||||||
|
((= tag "def-rec")
|
||||||
|
(let ((name (nth decl 1)) (params (nth decl 2)) (rhs (nth decl 3)))
|
||||||
|
(let ((rhs-fn?
|
||||||
|
(or (> (len params) 0)
|
||||||
|
(= (ocaml-tag-of rhs) "fun")
|
||||||
|
(= (ocaml-tag-of rhs) "function"))))
|
||||||
|
(cond
|
||||||
|
(rhs-fn?
|
||||||
|
(let ((cell (list nil)))
|
||||||
|
(let ((env2 (ocaml-env-extend env name
|
||||||
|
(fn (arg) ((nth cell 0) arg)))))
|
||||||
|
(let ((v (if (= (len params) 0)
|
||||||
|
(ocaml-eval rhs env2)
|
||||||
|
(ocaml-make-curried params rhs env2))))
|
||||||
|
(begin
|
||||||
|
(set-nth! cell 0 v)
|
||||||
|
(set! env env2)
|
||||||
|
(set! result (merge result (dict name v))))))))
|
||||||
|
(else
|
||||||
|
(let ((v (ocaml-eval rhs env)))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env name v))
|
||||||
|
(set! result (merge result (dict name v))))))))))
|
||||||
|
((= tag "expr")
|
||||||
|
(ocaml-eval (nth decl 1) env))
|
||||||
|
((= tag "module-def")
|
||||||
|
(let ((mname (nth decl 1)) (mdecls (nth decl 2)))
|
||||||
|
(let ((mod-val (ocaml-eval-module mdecls env)))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env mname mod-val))
|
||||||
|
(set! result (merge result (dict mname mod-val)))))))
|
||||||
|
(else (error (str "ocaml-eval-module: bad decl " tag)))))))
|
||||||
|
(define loop
|
||||||
|
(fn (xs)
|
||||||
|
(when (not (= xs (list)))
|
||||||
|
(begin (run-decl (first xs)) (loop (rest xs))))))
|
||||||
|
(loop decls)
|
||||||
|
result))))
|
||||||
|
|
||||||
;; ocaml-run — convenience wrapper: parse + eval.
|
;; ocaml-run — convenience wrapper: parse + eval.
|
||||||
(define ocaml-run
|
(define ocaml-run
|
||||||
(fn (src)
|
(fn (src)
|
||||||
@@ -466,6 +541,16 @@
|
|||||||
(set! last v))))))))
|
(set! last v))))))))
|
||||||
((= tag "expr")
|
((= tag "expr")
|
||||||
(set! last (ocaml-eval (nth decl 1) env)))
|
(set! last (ocaml-eval (nth decl 1) env)))
|
||||||
|
((= tag "module-def")
|
||||||
|
;; module M = struct DECLS end — evaluate the inner
|
||||||
|
;; decls in a fresh sub-env layered on the current
|
||||||
|
;; one, then collect the new bindings into a dict that
|
||||||
|
;; we bind under M.
|
||||||
|
(let ((mname (nth decl 1)) (mdecls (nth decl 2)))
|
||||||
|
(let ((mod-val (ocaml-eval-module mdecls env)))
|
||||||
|
(begin
|
||||||
|
(set! env (ocaml-env-extend env mname mod-val))
|
||||||
|
(set! last mod-val)))))
|
||||||
(else (error (str "ocaml-run-program: bad decl " tag)))))))
|
(else (error (str "ocaml-run-program: bad decl " tag)))))))
|
||||||
(define loop
|
(define loop
|
||||||
(fn (xs)
|
(fn (xs)
|
||||||
|
|||||||
@@ -377,12 +377,32 @@
|
|||||||
true)
|
true)
|
||||||
((and (= tt "op") (or (= tv "(") (= tv "["))) true)
|
((and (= tt "op") (or (= tv "(") (= tv "["))) true)
|
||||||
(else false)))))
|
(else false)))))
|
||||||
|
(define parse-atom-postfix
|
||||||
|
(fn ()
|
||||||
|
;; After a primary atom, consume `.field` chains. Field name
|
||||||
|
;; may be lower (record field, module value) or upper (module
|
||||||
|
;; or constructor reference). Note: `M.x.y` is left-assoc:
|
||||||
|
;; `(:field (:field M "x") "y")`.
|
||||||
|
(let ((head (parse-atom)))
|
||||||
|
(begin
|
||||||
|
(define loop
|
||||||
|
(fn ()
|
||||||
|
(when (at-op? ".")
|
||||||
|
(begin
|
||||||
|
(advance-tok!)
|
||||||
|
(let ((tok (peek-tok)))
|
||||||
|
(begin
|
||||||
|
(advance-tok!)
|
||||||
|
(set! head (list :field head (ocaml-tok-value tok)))
|
||||||
|
(loop)))))))
|
||||||
|
(loop)
|
||||||
|
head))))
|
||||||
(set!
|
(set!
|
||||||
parse-app
|
parse-app
|
||||||
(fn
|
(fn
|
||||||
()
|
()
|
||||||
(let
|
(let
|
||||||
((head (parse-atom)))
|
((head (parse-atom-postfix)))
|
||||||
(begin
|
(begin
|
||||||
(define
|
(define
|
||||||
loop
|
loop
|
||||||
@@ -391,7 +411,7 @@
|
|||||||
(when
|
(when
|
||||||
(at-app-start?)
|
(at-app-start?)
|
||||||
(let
|
(let
|
||||||
((arg (parse-atom)))
|
((arg (parse-atom-postfix)))
|
||||||
(begin (set! head (list :app head arg)) (loop))))))
|
(begin (set! head (list :app head arg)) (loop))))))
|
||||||
(loop)
|
(loop)
|
||||||
head))))
|
head))))
|
||||||
@@ -767,6 +787,7 @@
|
|||||||
((= (ocaml-tok-type (peek-tok)) "eof") nil)
|
((= (ocaml-tok-type (peek-tok)) "eof") nil)
|
||||||
((at-op? ";;") nil)
|
((at-op? ";;") nil)
|
||||||
((at-kw? "let") nil)
|
((at-kw? "let") nil)
|
||||||
|
((at-kw? "module") nil)
|
||||||
(else (begin (advance-tok!) (skip-to-boundary!))))))
|
(else (begin (advance-tok!) (skip-to-boundary!))))))
|
||||||
(define
|
(define
|
||||||
parse-decl-let
|
parse-decl-let
|
||||||
@@ -818,6 +839,43 @@
|
|||||||
(let
|
(let
|
||||||
((expr-src (slice src expr-start (cur-pos))))
|
((expr-src (slice src expr-start (cur-pos))))
|
||||||
(let ((expr (ocaml-parse expr-src))) (list :expr expr)))))))
|
(let ((expr (ocaml-parse expr-src))) (list :expr expr)))))))
|
||||||
|
;; module M = struct DECLS end
|
||||||
|
;; Parsed by sub-tokenising the body source between `struct` and
|
||||||
|
;; the matching `end`. Nested modules / sigs increment depth.
|
||||||
|
(define
|
||||||
|
parse-decl-module
|
||||||
|
(fn ()
|
||||||
|
(advance-tok!)
|
||||||
|
(let ((name (ocaml-tok-value (consume! "ctor" nil))))
|
||||||
|
(begin
|
||||||
|
(consume! "op" "=")
|
||||||
|
(consume! "keyword" "struct")
|
||||||
|
(let ((body-start (cur-pos)) (depth 1))
|
||||||
|
(begin
|
||||||
|
(define skip
|
||||||
|
(fn ()
|
||||||
|
(cond
|
||||||
|
((>= idx tok-len) nil)
|
||||||
|
((= (ocaml-tok-type (peek-tok)) "eof") nil)
|
||||||
|
((at-kw? "struct")
|
||||||
|
(begin (set! depth (+ depth 1)) (advance-tok!) (skip)))
|
||||||
|
((at-kw? "begin")
|
||||||
|
(begin (set! depth (+ depth 1)) (advance-tok!) (skip)))
|
||||||
|
((at-kw? "sig")
|
||||||
|
(begin (set! depth (+ depth 1)) (advance-tok!) (skip)))
|
||||||
|
((at-kw? "end")
|
||||||
|
(cond
|
||||||
|
((= depth 1) nil)
|
||||||
|
(else
|
||||||
|
(begin (set! depth (- depth 1)) (advance-tok!) (skip)))))
|
||||||
|
(else (begin (advance-tok!) (skip))))))
|
||||||
|
(skip)
|
||||||
|
(let ((body-end (cur-pos)))
|
||||||
|
(begin
|
||||||
|
(consume! "keyword" "end")
|
||||||
|
(let ((body-src (slice src body-start body-end)))
|
||||||
|
(let ((body-prog (ocaml-parse-program body-src)))
|
||||||
|
(list :module-def name (rest body-prog))))))))))))
|
||||||
(define
|
(define
|
||||||
loop
|
loop
|
||||||
(fn
|
(fn
|
||||||
@@ -830,6 +888,8 @@
|
|||||||
((= (ocaml-tok-type (peek-tok)) "eof") nil)
|
((= (ocaml-tok-type (peek-tok)) "eof") nil)
|
||||||
((at-kw? "let")
|
((at-kw? "let")
|
||||||
(begin (append! decls (parse-decl-let)) (loop)))
|
(begin (append! decls (parse-decl-let)) (loop)))
|
||||||
|
((at-kw? "module")
|
||||||
|
(begin (append! decls (parse-decl-module)) (loop)))
|
||||||
(else (begin (append! decls (parse-decl-expr)) (loop))))))))
|
(else (begin (append! decls (parse-decl-expr)) (loop))))))))
|
||||||
(loop)
|
(loop)
|
||||||
(cons :program decls)))))
|
(cons :program decls)))))
|
||||||
|
|||||||
@@ -531,6 +531,30 @@ cat > "$TMPFILE" << 'EPOCHS'
|
|||||||
(epoch 665)
|
(epoch 665)
|
||||||
(eval "(ocaml-run \"let f x = if x < 0 then raise (NegArg x) else x * 2 in try f (-5) with | NegArg n -> n\")")
|
(eval "(ocaml-run \"let f x = if x < 0 then raise (NegArg x) else x * 2 in try f (-5) with | NegArg n -> n\")")
|
||||||
|
|
||||||
|
;; ── Phase 4: Modules + field access ────────────────────────────
|
||||||
|
(epoch 700)
|
||||||
|
(eval "(ocaml-parse \"M.x\")")
|
||||||
|
(epoch 701)
|
||||||
|
(eval "(ocaml-parse \"r.field\")")
|
||||||
|
(epoch 702)
|
||||||
|
(eval "(ocaml-parse \"M.M2.x\")")
|
||||||
|
(epoch 703)
|
||||||
|
(eval "(ocaml-parse \"f r.x\")")
|
||||||
|
(epoch 710)
|
||||||
|
(eval "(ocaml-run-program \"module M = struct let x = 42 end ;; M.x\")")
|
||||||
|
(epoch 711)
|
||||||
|
(eval "(ocaml-run-program \"module M = struct let f x = x + 1 end ;; M.f 41\")")
|
||||||
|
(epoch 712)
|
||||||
|
(eval "(ocaml-run-program \"module M = struct let x = 1 let y = 2 end ;; M.x + M.y\")")
|
||||||
|
(epoch 713)
|
||||||
|
(eval "(ocaml-run-program \"module Math = struct let pi = 3.14 let square x = x * x end ;; Math.square 5\")")
|
||||||
|
(epoch 714)
|
||||||
|
(eval "(ocaml-run-program \"module Outer = struct module Inner = struct let v = 99 end end ;; Outer.Inner.v\")")
|
||||||
|
(epoch 715)
|
||||||
|
(eval "(ocaml-run-program \"module M = struct let rec fact n = if n = 0 then 1 else n * fact (n - 1) end ;; M.fact 5\")")
|
||||||
|
(epoch 716)
|
||||||
|
(eval "(ocaml-run-program \"module Pair = struct let make a b = (a, b) let swap p = match p with | (x, y) -> (y, x) end ;; Pair.swap (Pair.make 1 2)\")")
|
||||||
|
|
||||||
EPOCHS
|
EPOCHS
|
||||||
|
|
||||||
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
|
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
|
||||||
@@ -846,6 +870,19 @@ check 663 "try failwith" '"oops"'
|
|||||||
check 664 "try sequence raises" '101'
|
check 664 "try sequence raises" '101'
|
||||||
check 665 "raise from function" '-5'
|
check 665 "raise from function" '-5'
|
||||||
|
|
||||||
|
# ── Phase 4: Modules + field access ─────────────────────────────
|
||||||
|
check 700 "parse M.x" '("field" ("con" "M") "x")'
|
||||||
|
check 701 "parse r.field" '("field" ("var" "r") "field")'
|
||||||
|
check 702 "parse M.M2.x left-assoc" '("field" ("field" ("con" "M") "M2") "x")'
|
||||||
|
check 703 "parse f r.x bind tighter" '("app" ("var" "f") ("field" ("var" "r") "x"))'
|
||||||
|
check 710 "module M.x = 42" '42'
|
||||||
|
check 711 "module M.f 41 = 42" '42'
|
||||||
|
check 712 "module two values" '3'
|
||||||
|
check 713 "module fn: square 5" '25'
|
||||||
|
check 714 "nested module Outer.Inner" '99'
|
||||||
|
check 715 "module rec fact 5" '120'
|
||||||
|
check 716 "module Pair.swap" '("tuple" 2 1)'
|
||||||
|
|
||||||
TOTAL=$((PASS + FAIL))
|
TOTAL=$((PASS + FAIL))
|
||||||
if [ $FAIL -eq 0 ]; then
|
if [ $FAIL -eq 0 ]; then
|
||||||
echo "ok $PASS/$TOTAL OCaml-on-SX tests passed"
|
echo "ok $PASS/$TOTAL OCaml-on-SX tests passed"
|
||||||
|
|||||||
@@ -179,7 +179,8 @@ SX CEK evaluator (both JS and OCaml hosts)
|
|||||||
|
|
||||||
### Phase 4 — Modules + functors
|
### Phase 4 — Modules + functors
|
||||||
|
|
||||||
- [ ] `module M = struct let x = 1 let f y = x + y end` → SX dict `{:x 1 :f <fn>}`.
|
- [x] `module M = struct let x = 1 let f y = x + y end` → SX dict
|
||||||
|
`{"x" 1 "f" <fn>}`.
|
||||||
- [ ] `module type S = sig val x : int val f : int -> int end` → interface record
|
- [ ] `module type S = sig val x : int val f : int -> int end` → interface record
|
||||||
(runtime stub; typed checking in Phase 5).
|
(runtime stub; typed checking in Phase 5).
|
||||||
- [ ] `module M : S = struct ... end` — coercive sealing (runtime: pass-through).
|
- [ ] `module M : S = struct ... end` — coercive sealing (runtime: pass-through).
|
||||||
@@ -187,7 +188,7 @@ SX CEK evaluator (both JS and OCaml hosts)
|
|||||||
- [ ] `module F = Functor(Base)` — functor application.
|
- [ ] `module F = Functor(Base)` — functor application.
|
||||||
- [ ] `open M` — merge M's dict into current env (`env-merge`).
|
- [ ] `open M` — merge M's dict into current env (`env-merge`).
|
||||||
- [ ] `include M` — same as open at structure level.
|
- [ ] `include M` — same as open at structure level.
|
||||||
- [ ] `M.name` — dict get via `:name` key.
|
- [x] `M.name` — dict get via field access.
|
||||||
- [ ] First-class modules (pack/unpack) — deferred to Phase 5.
|
- [ ] First-class modules (pack/unpack) — deferred to Phase 5.
|
||||||
- [ ] Standard module hierarchy: `List`, `Option`, `Result`, `String`, `Char`,
|
- [ ] Standard module hierarchy: `List`, `Option`, `Result`, `String`, `Char`,
|
||||||
`Int`, `Float`, `Bool`, `Unit`, `Printf`, `Format` (stubs, filled in Phase 6).
|
`Int`, `Float`, `Bool`, `Unit`, `Printf`, `Format` (stubs, filled in Phase 6).
|
||||||
@@ -321,6 +322,18 @@ the "mother tongue" closure: OCaml → SX → OCaml. This means:
|
|||||||
|
|
||||||
_Newest first._
|
_Newest first._
|
||||||
|
|
||||||
|
- 2026-05-08 Phase 4 — modules + field access (+11 tests, 215 total). Parser:
|
||||||
|
`module M = struct DECLS end` decl in `ocaml-parse-program`. Body parsed
|
||||||
|
by sub-tokenising the source between `struct` and the matching `end`,
|
||||||
|
tracking nesting via `struct`/`begin`/`sig`/`end`. Field access added
|
||||||
|
as a postfix layer above `parse-atom`, binding tighter than application:
|
||||||
|
`f r.x` → `(:app f (:field r "x"))`. Eval: `(:module-def NAME DECLS)`
|
||||||
|
builds a dict via new `ocaml-eval-module` that runs decls in a sub-env;
|
||||||
|
`(:field EXPR NAME)` looks up the field, with the special case that
|
||||||
|
`(:con NAME)` heads are interpreted as module-name lookups instead of
|
||||||
|
nullary ctors. Tested: simple module, multi-decl module, nested modules
|
||||||
|
(`Outer.Inner.v`), `let rec` inside a module, module containing tuple
|
||||||
|
pattern match. Phase 4 LOC: ~110 (well under 2000 budget).
|
||||||
- 2026-05-08 Phase 2 — `try`/`with` + `raise` builtin. Parser produces
|
- 2026-05-08 Phase 2 — `try`/`with` + `raise` builtin. Parser produces
|
||||||
`(:try EXPR CLAUSES)`; eval delegates to SX `guard` with `else`
|
`(:try EXPR CLAUSES)`; eval delegates to SX `guard` with `else`
|
||||||
matching the raised value against clause patterns and re-raising on
|
matching the raised value against clause patterns and re-raising on
|
||||||
|
|||||||
Reference in New Issue
Block a user