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

ocaml: phase 3 type declarations (+5 tests, 300 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 52s
Details

Browse Source 
Parser: type [PARAMS] NAME = | Ctor [of T1 [* T2]*] | ...
- PARAMS: optional 'a or ('a, 'b) tyvar list
- AST: (:type-def NAME PARAMS CTORS) with each CTOR (NAME ARG-SOURCES)
- Argument types captured as raw source strings (treated opaquely at
  runtime since ctor dispatch is dynamic)

Runtime is a no-op — constructors and pattern matching already work
dynamically. Phase 5 will use these decls to register ctor types for
HM checking.
This commit is contained in:
giles
2026-05-08 12:32:39 +00:00
parent 851e0585cf
commit d8f6250962
4 changed files with 110 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

74
lib/ocaml/parser.sx
View File

@@ -908,6 +908,7 @@
((at-kw? "open") nil)
((at-kw? "include") nil)
((at-kw? "and") nil)
((at-kw? "type") nil)
(else (begin (advance-tok!) (skip-to-boundary!))))))
(define
parse-decl-let
@@ -977,6 +978,77 @@
;; module M = struct DECLS end
;; Parsed by sub-tokenising the body source between `struct` and
;; the matching `end`. Nested modules / sigs increment depth.
;; type [PARAMS] NAME = | Ctor [of T1 [* T2]*] | …
;;
;; PARAMS is `'a` or `('a, 'b)` (single or paren-tuple of tyvars).
;; We parse the structure and emit `(:type-def NAME PARAMS CTORS)`
;; where each CTOR is `(NAME ARG-TYPES)` (ARG-TYPES list of source
;; strings — types are treated opaquely at runtime).
(define
parse-decl-type
(fn ()
(advance-tok!) ;; consume 'type'
(let ((tparams (list)))
(begin
;; Optional type-vars before the type name.
(cond
((= (ocaml-tok-type (peek-tok)) "tyvar")
(begin
(append! tparams (ocaml-tok-value (peek-tok)))
(advance-tok!)))
((at-op? "(")
(begin
(advance-tok!)
(define more
(fn ()
(when (= (ocaml-tok-type (peek-tok)) "tyvar")
(begin
(append! tparams (ocaml-tok-value (peek-tok)))
(advance-tok!)
(when (at-op? ",")
(begin (advance-tok!) (more)))))))
(more)
(consume! "op" ")"))))
(let ((name (ocaml-tok-value (consume! "ident" nil))))
(begin
(consume! "op" "=")
(when (at-op? "|") (advance-tok!))
;; Parse a sum-type: Ctor [of TYPE [* TYPE]*] (| Ctor …)*
(let ((ctors (list)))
(begin
(define one
(fn ()
(let ((cname (ocaml-tok-value (consume! "ctor" nil)))
(arg-srcs (list)))
(begin
(when (at-kw? "of")
(begin
(advance-tok!)
(let ((arg-start (cur-pos)))
(begin
(define skip-type
(fn ()
(cond
((>= idx tok-len) nil)
((= (ocaml-tok-type (peek-tok)) "eof") nil)
((at-op? "|") nil)
((at-op? ";;") nil)
((at-kw? "let") nil)
((at-kw? "type") nil)
((at-kw? "and") nil)
((at-kw? "module") nil)
(else (begin (advance-tok!) (skip-type))))))
(skip-type)
(append! arg-srcs (slice src arg-start (cur-pos)))))))
(append! ctors (cons cname arg-srcs))))))
(one)
(define more
(fn ()
(when (at-op? "|")
(begin (advance-tok!) (one) (more)))))
(more)
(list :type-def name tparams ctors)))))))))
;; open M / include M — collect a path Ctor(.SubCtor)* and emit
;; (:open PATH) or (:include PATH).
(define
@@ -1143,6 +1215,8 @@
(begin (append! decls (parse-decl-open false)) (loop)))
((at-kw? "include")
(begin (append! decls (parse-decl-open true)) (loop)))
((at-kw? "type")
(begin (append! decls (parse-decl-type)) (loop)))
(else (begin (append! decls (parse-decl-expr)) (loop))))))))
(loop)
(cons :program decls)))))