coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ocaml: phase 4 functors + module aliases (+5 tests, 225 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 53s
Details

Browse Source 
Parser: module F (M) (N) ... = struct DECLS end -> (:functor-def NAME
PARAMS DECLS). module N = expr (non-struct) -> (:module-alias NAME
BODY-SRC). Functor params accept (P) or (P : Sig) — signatures
parsed-and-skipped via skip-optional-sig.

Eval: ocaml-make-functor builds curried host-SX closures from module
dicts to a module dict. ocaml-resolve-module-path extended for :app so
F(A), F(A)(B), and Outer.Inner all resolve to dicts.

Phase 4 LOC ~290 cumulative (still well under 2000).
This commit is contained in:
giles
2026-05-08 08:44:54 +00:00
parent d45e653a87
commit 5603ecc3a6
4 changed files with 211 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files

129
lib/ocaml/parser.sx
View File

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