diff --git a/lib/ocaml/eval.sx b/lib/ocaml/eval.sx index 1066bc70..873b391f 100644 --- a/lib/ocaml/eval.sx +++ b/lib/ocaml/eval.sx @@ -67,9 +67,11 @@ (fn (env name val) (cons (list name val) env))) -;; Resolve a module path like `M` or `M.Sub` to a dict. Mirrors the -;; field-access escape hatch where `(:con NAME)` is treated as an env -;; lookup rather than a nullary ctor. +;; Resolve a module path / functor-application expression to a module dict. +;; Mirrors the field-access escape hatch where `(:con NAME)` is treated as +;; an env lookup rather than a nullary ctor; also handles `(:app FN ARG)` +;; for functor applications, `(:field …)` for sub-modules, and `(:var …)` +;; for lower-case bindings. (define ocaml-resolve-module-path (fn (path-expr env) (let ((tag (ocaml-tag-of path-expr))) @@ -79,12 +81,22 @@ ((ocaml-env-has? env (nth path-expr 1)) (ocaml-env-lookup env (nth path-expr 1))) (else (error (str "ocaml-eval: unknown module " (nth path-expr 1)))))) + ((= tag "var") + (cond + ((ocaml-env-has? env (nth path-expr 1)) + (ocaml-env-lookup env (nth path-expr 1))) + (else (error (str "ocaml-eval: unknown module-var " (nth path-expr 1)))))) ((= tag "field") (let ((parent (ocaml-resolve-module-path (nth path-expr 1) env))) (cond ((dict? parent) (get parent (nth path-expr 2))) (else (error (str "ocaml-eval: not a module on path: " parent)))))) + ((= tag "app") + (let ((fn-val (ocaml-resolve-module-path (nth path-expr 1) env)) + (arg-val (ocaml-resolve-module-path (nth path-expr 2) env))) + (fn-val arg-val))) + ((= tag "unit") {}) (else (ocaml-eval path-expr env)))))) ;; Merge a dict's bindings into an env (used by `open`/`include`). @@ -470,6 +482,21 @@ (else (error (str "ocaml-eval: unknown AST tag " tag))))))) +;; ocaml-make-functor — build a curried host-SX closure that accepts +;; argument modules (one per param) and returns the resulting module dict +;; produced by evaluating the functor's body. +(define ocaml-make-functor + (fn (params decls captured-env) + (cond + ((= (len params) 1) + (fn (arg-mod) + (ocaml-eval-module decls + (ocaml-env-extend captured-env (first params) arg-mod)))) + (else + (fn (arg-mod) + (ocaml-make-functor (rest params) decls + (ocaml-env-extend captured-env (first params) arg-mod))))))) + ;; 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`. @@ -520,6 +547,21 @@ (begin (set! env (ocaml-env-extend env mname mod-val)) (set! result (merge result (dict mname mod-val))))))) + ((= tag "functor-def") + (let ((mname (nth decl 1)) + (mparams (nth decl 2)) + (mdecls (nth decl 3))) + (let ((fn-val (ocaml-make-functor mparams mdecls env))) + (begin + (set! env (ocaml-env-extend env mname fn-val)) + (set! result (merge result (dict mname fn-val))))))) + ((= tag "module-alias") + (let ((mname (nth decl 1)) (body-src (nth decl 2))) + (let ((body-expr (ocaml-parse body-src))) + (let ((mod-val (ocaml-resolve-module-path body-expr env))) + (begin + (set! env (ocaml-env-extend env mname mod-val)) + (set! result (merge result (dict mname mod-val)))))))) ((= tag "open") (let ((mod-val (ocaml-resolve-module-path (nth decl 1) env))) (cond @@ -605,6 +647,26 @@ (begin (set! env (ocaml-env-extend env mname mod-val)) (set! last mod-val))))) + ((= tag "functor-def") + ;; module F (M1) (M2) ... = struct DECLS end — bind F + ;; to a curried function from module dicts to a module + ;; dict. + (let ((mname (nth decl 1)) + (mparams (nth decl 2)) + (mdecls (nth decl 3))) + (let ((functor-val + (ocaml-make-functor mparams mdecls env))) + (begin + (set! env (ocaml-env-extend env mname functor-val)) + (set! last functor-val))))) + ((= tag "module-alias") + ;; module N = M / module N = F(A) / module N = M.Sub + (let ((mname (nth decl 1)) (body-src (nth decl 2))) + (let ((body-expr (ocaml-parse body-src))) + (let ((mod-val (ocaml-resolve-module-path body-expr env))) + (begin + (set! env (ocaml-env-extend env mname mod-val)) + (set! last mod-val)))))) ((or (= tag "open") (= tag "include")) ;; open M / include M — bring M's bindings into scope. (let ((mod-val (ocaml-resolve-module-path (nth decl 1) env))) diff --git a/lib/ocaml/parser.sx b/lib/ocaml/parser.sx index f905711d..cbe834d8 100644 --- a/lib/ocaml/parser.sx +++ b/lib/ocaml/parser.sx @@ -867,40 +867,131 @@ (if include? (list :include path-expr) (list :open path-expr)))))))) + ;; Parse a `struct DECLS end` body and return the decls list. (define - parse-decl-module + parse-struct-body (fn () - (advance-tok!) - (let ((name (ocaml-tok-value (consume! "ctor" nil)))) + (consume! "keyword" "struct") + (let ((body-start (cur-pos)) (depth 1)) (begin - (consume! "op" "=") - (consume! "keyword" "struct") - (let ((body-start (cur-pos)) (depth 1)) + (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))) + (rest body-prog))))))))) + + ;; Skip an optional `: Sig` constraint (parens-balanced; we + ;; ignore signatures in this iteration). + (define + skip-optional-sig + (fn () + (when (at-op? ":") + (begin + (advance-tok!) + (let ((depth 0)) (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") + ((and (= depth 0) (at-op? ")")) nil) + ((and (= depth 0) (at-op? "=")) nil) + ((at-op? "(") (begin (set! depth (+ depth 1)) (advance-tok!) (skip))) ((at-kw? "sig") (begin (set! depth (+ depth 1)) (advance-tok!) (skip))) + ((at-op? ")") + (begin (set! depth (- depth 1)) (advance-tok!) (skip))) ((at-kw? "end") - (cond - ((= depth 1) nil) - (else - (begin (set! depth (- depth 1)) (advance-tok!) (skip))))) + (begin (set! depth (- depth 1)) (advance-tok!) (skip))) (else (begin (advance-tok!) (skip)))))) - (skip) - (let ((body-end (cur-pos))) + (skip))))))) + + (define + parse-decl-module + (fn () + (advance-tok!) + (let ((name (ocaml-tok-value (consume! "ctor" nil))) + (params (list))) + (begin + ;; Functor parameters: `(P)` or `(P : Sig)`, repeated. + (define collect-params + (fn () + (when (at-op? "(") (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)))))))))))) + (advance-tok!) + (when (= (ocaml-tok-type (peek-tok)) "ctor") + (begin + (append! params (ocaml-tok-value (peek-tok))) + (advance-tok!))) + (skip-optional-sig) + (consume! "op" ")") + (collect-params))))) + (collect-params) + (skip-optional-sig) + (consume! "op" "=") + (cond + ;; Body is `struct DECLS end` — possibly a functor body. + ((at-kw? "struct") + (let ((decls (parse-struct-body))) + (cond + ((= (len params) 0) (list :module-def name decls)) + (else (list :functor-def name params decls))))) + ;; Body is a path possibly applied: `M`, `M.Sub`, `F(A)`, `F(A)(B)`. + (else + (let ((body-start (cur-pos))) + (begin + (define skip-path-app + (fn () + (cond + ((>= idx tok-len) nil) + ((= (ocaml-tok-type (peek-tok)) "ctor") + (begin (advance-tok!) (skip-path-app))) + ((at-op? ".") + (begin (advance-tok!) (skip-path-app))) + ((at-op? "(") + ;; Paren-balanced argument list. + (let ((d 1)) + (begin + (advance-tok!) + (define skip-args + (fn () + (cond + ((>= idx tok-len) nil) + ((= (ocaml-tok-type (peek-tok)) "eof") nil) + ((at-op? "(") + (begin (set! d (+ d 1)) (advance-tok!) (skip-args))) + ((at-op? ")") + (cond + ((= d 1) (begin (advance-tok!) nil)) + (else (begin (set! d (- d 1)) (advance-tok!) (skip-args))))) + (else (begin (advance-tok!) (skip-args)))))) + (skip-args) + (skip-path-app)))) + (else nil)))) + (skip-path-app) + (let ((body-src (slice src body-start (cur-pos)))) + (list :module-alias name body-src)))))))))) (define loop (fn diff --git a/lib/ocaml/test.sh b/lib/ocaml/test.sh index dff83522..98937c07 100755 --- a/lib/ocaml/test.sh +++ b/lib/ocaml/test.sh @@ -567,6 +567,18 @@ cat > "$TMPFILE" << 'EPOCHS' (epoch 734) (eval "(ocaml-run-program \"module M = struct let x = 1 let y = 2 end ;; module N = struct include M let z = x + y end ;; N.z\")") +;; ── Functors ─────────────────────────────────────────────────── +(epoch 750) +(eval "(ocaml-run-program \"module Add (M) = struct let add x = x + M.n end ;; module Five = struct let n = 5 end ;; module AddFive = Add(Five) ;; AddFive.add 10\")") +(epoch 751) +(eval "(ocaml-run-program \"module M = struct let x = 1 end ;; module N = M ;; N.x\")") +(epoch 752) +(eval "(ocaml-run-program \"module Outer = struct module Inner = struct let v = 42 end end ;; module Alias = Outer.Inner ;; Alias.v\")") +(epoch 753) +(eval "(ocaml-run-program \"module Pair (A) (B) = struct let mk = (A.x, B.x) end ;; module One = struct let x = 1 end ;; module Two = struct let x = 2 end ;; module P = Pair(One)(Two) ;; P.mk\")") +(epoch 754) +(eval "(ocaml-run-program \"module Identity (M) = struct include M end ;; module Base = struct let v = 99 end ;; module Same = Identity(Base) ;; Same.v\")") + EPOCHS OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null) @@ -902,6 +914,13 @@ check 732 "module open inside" '11' check 733 "Sphere.pi via include" '3' check 734 "include M; N.z = x+y" '3' +# ── Functors ──────────────────────────────────────────────────── +check 750 "functor app Add(Five).add 10" '15' +check 751 "module alias N = M" '1' +check 752 "submodule alias" '42' +check 753 "multi-param functor" '("tuple" 1 2)' +check 754 "Identity functor + include" '99' + TOTAL=$((PASS + FAIL)) if [ $FAIL -eq 0 ]; then echo "ok $PASS/$TOTAL OCaml-on-SX tests passed" diff --git a/plans/ocaml-on-sx.md b/plans/ocaml-on-sx.md index f6255ee3..8e428a17 100644 --- a/plans/ocaml-on-sx.md +++ b/plans/ocaml-on-sx.md @@ -181,11 +181,13 @@ SX CEK evaluator (both JS and OCaml hosts) - [x] `module M = struct let x = 1 let f y = x + y end` → SX dict `{"x" 1 "f" }`. -- [ ] `module type S = sig val x : int val f : int -> int end` → interface record - (runtime stub; typed checking in Phase 5). -- [ ] `module M : S = struct ... end` — coercive sealing (runtime: pass-through). -- [ ] `functor (M : S) -> struct ... end` → SX `(fn (M) ...)`. -- [ ] `module F = Functor(Base)` — functor application. +- [~] `module type S = sig val x : int val f : int -> int end` — signature + annotations are parsed-and-skipped (`skip-optional-sig`); typed + checking deferred to Phase 5. +- [x] `module M : S = struct ... end` — coercive sealing (signature ignored). +- [x] `functor (M : S) -> struct ... end` via shorthand `module F (M) = …`. +- [x] `module F = Functor(Base)` — functor application; multi-param via + `module P = F(A)(B)`. - [x] `open M` — merge M's dict into current env (via `ocaml-env-merge-dict`). Module path `M.Sub` resolves via `ocaml-resolve-module-path`. @@ -325,6 +327,16 @@ the "mother tongue" closure: OCaml → SX → OCaml. This means: _Newest first._ +- 2026-05-08 Phase 4 — functors + module aliases (+5 tests, 225 total). + Parser: `module F (M) = struct DECLS end` → `(:functor-def NAME PARAMS + DECLS)`. `module N = expr` (where expr isn't `struct`) → `(:module-alias + NAME BODY-SRC)`. Functor params accept `(P)` or `(P : Sig)` (signatures + parsed-and-skipped). Eval: `ocaml-make-functor` builds a curried + host-SX closure that takes module dicts and returns a module dict; + `ocaml-resolve-module-path` extended for `:app` so `F(A)`, `F(A)(B)`, + `Outer.Inner` all resolve to dicts. Tested: 1-arg functor, 2-arg + curried `Pair(One)(Two)`, module alias, submodule alias, identity + functor with include. Phase 4 LOC ~290 (still well under 2000). - 2026-05-08 Phase 4 — `open M` / `include M` (+5 tests, 220 total). Parser: top-level `open Path` / `include Path` decls; path is `Ctor (. Ctor)*`. Eval resolves the path via `ocaml-resolve-module-path` (the