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

ocaml: phase 5 HM with user type declarations (+6 tests, 363 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
Details

Browse Source 
ocaml-hm-ctors is now a mutable list cell; user type-defs register
their constructors via ocaml-hm-register-type-def!. New
ocaml-type-of-program processes top-level decls in order:
- type-def: register ctors with the scheme inferred from PARAMS+CTORS
- def/def-rec: generalize and bind in the type env
- exception-def: no-op for typing
- expr: return inferred type

Examples:
  type color = Red | Green | Blue;; Red : color
  type shape = Circle of int | Square of int;;
  let area s = match s with
    | Circle r -> r * r
    | Square s -> s * s;;
  area : shape -> Int

Caveat: ctor arg types parsed as raw source strings; registry defaults
to int for any single-arg ctor. Proper type-source parsing pending.
This commit is contained in:
giles
2026-05-08 13:12:07 +00:00
parent 5bc7895ce0
commit 756d5fba64
3 changed files with 141 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files

108
lib/ocaml/infer.sx
View File

@@ -228,8 +228,8 @@
(define ocaml-infer-pcon
(fn (name arg-pats env counter)
(cond
((has-key? ocaml-hm-ctors name)
(let ((ctor-type (hm-instantiate (get ocaml-hm-ctors name) counter))
((ocaml-hm-ctor-has? name)
(let ((ctor-type (hm-instantiate (ocaml-hm-ctor-lookup name) counter))
(env-cur env) (subst {}))
(let ((cur-type (list nil)))
(begin
@@ -388,21 +388,60 @@
{:subst subst
:type (ocaml-hm-list (hm-apply subst elem-tv))}))))))
(define ocaml-hm-ctors (ocaml-hm-ctor-env))
;; Mutable cell so user `type` declarations can extend the registry.
(define ocaml-hm-ctors (list (ocaml-hm-ctor-env)))
(define ocaml-hm-ctor-lookup
(fn (name) (get (nth ocaml-hm-ctors 0) name)))
(define ocaml-hm-ctor-has?
(fn (name) (has-key? (nth ocaml-hm-ctors 0) name)))
(define ocaml-hm-ctor-register!
(fn (name scheme)
(set-nth! ocaml-hm-ctors 0
(merge (nth ocaml-hm-ctors 0) (dict name scheme)))))
;; Process a :type-def AST. For each ctor, build its scheme:
;; nullary `A` → scheme [] (con NAME [param-tvs...])
;; ctor `B of int` → scheme [] (int -> (con NAME [...]))
;; Argument types are ignored for now (they're raw source strings) — we
;; assume `int`. A future iteration parses arg types properly.
(define ocaml-hm-register-type-def!
(fn (type-def)
(let ((name (nth type-def 1))
(params (nth type-def 2))
(ctors (nth type-def 3)))
(let ((param-tvs (map hm-tv params)))
(let ((self-type (hm-con name param-tvs)))
(begin
(define register-ctor
(fn (ctor)
(let ((cname (first ctor))
(arg-srcs (rest ctor)))
(cond
((= (len arg-srcs) 0)
(ocaml-hm-ctor-register! cname
(hm-scheme params self-type)))
(else
;; Single-arg ctor with arg type `int` (placeholder).
;; Multi-arg or other-typed ctors fall back to int.
(ocaml-hm-ctor-register! cname
(hm-scheme params
(hm-arrow (hm-int) self-type))))))))
(for-each register-ctor ctors)))))))
(set! ocaml-infer
(fn (expr env counter)
(let ((tag (nth expr 0)))
(cond
((= tag "con")
;; (:con NAME) — look up constructor type, instantiate fresh.
(let ((name (nth expr 1)))
(cond
((has-key? ocaml-hm-ctors name)
((ocaml-hm-ctor-has? name)
{:subst {}
:type (hm-instantiate (get ocaml-hm-ctors name) counter)})
:type (hm-instantiate (ocaml-hm-ctor-lookup name) counter)})
(else
;; Unknown ctor — treat as a fresh polymorphic type.
{:subst {} :type (hm-fresh-tv counter)}))))
((= tag "int") {:subst {} :type (hm-int)})
((= tag "float") {:subst {} :type (hm-int)}) ;; treat float as int for now
@@ -448,6 +487,61 @@
(let ((r (ocaml-infer expr env counter)))
(ocaml-hm-format-type (hm-apply (get r :subst) (get r :type)))))))
;; Program-level type inference: process decls in order, registering
;; type-defs with the ctor registry, threading let-bindings into the
;; env, and returning the type of the last expression-level form.
(define ocaml-type-of-program
(fn (src)
(let ((prog (ocaml-parse-program src))
(env (ocaml-hm-builtin-env))
(counter (ocaml-hm-counter))
(last-type (hm-tv "?")))
(begin
(define run-decl
(fn (decl)
(let ((tag (nth decl 0)))
(cond
((= tag "type-def") (ocaml-hm-register-type-def! decl))
((= tag "exception-def") nil)
((= tag "def")
(let ((nm (nth decl 1)) (ps (nth decl 2)) (rh (nth decl 3)))
(let ((rhs-expr (cond
((= (len ps) 0) rh)
(else (list :fun ps rh)))))
(let ((r (ocaml-infer rhs-expr env counter)))
(let ((s (get r :subst)) (t (get r :type)))
(let ((env2 (hm-apply-env s env)))
(let ((scheme (hm-generalize t env2)))
(begin
(set! env (assoc env2 nm scheme))
(set! last-type t)))))))))
((= tag "def-rec")
(let ((nm (nth decl 1)) (ps (nth decl 2)) (rh (nth decl 3)))
(let ((rec-tv (hm-fresh-tv counter)))
(let ((env-rec (assoc env nm (hm-monotype rec-tv)))
(rhs-expr (cond
((= (len ps) 0) rh)
(else (list :fun ps rh)))))
(let ((r (ocaml-infer rhs-expr env-rec counter)))
(let ((s (get r :subst)) (t (get r :type)))
(let ((s2 (ocaml-hm-unify (hm-apply s rec-tv) t s)))
(let ((env2 (hm-apply-env s2 env)))
(let ((scheme (hm-generalize (hm-apply s2 t) env2)))
(begin
(set! env (assoc env2 nm scheme))
(set! last-type t)))))))))))
((= tag "expr")
(let ((r (ocaml-infer (nth decl 1) env counter)))
(set! last-type
(hm-apply (get r :subst) (get r :type)))))
(else nil)))))
(define loop
(fn (xs)
(when (not (= xs (list)))
(begin (run-decl (first xs)) (loop (rest xs))))))
(loop (rest prog))
(ocaml-hm-format-type last-type)))))
;; Pretty-print a type as an OCaml-style string for testing. Only handles
;; the constructors we use: Int / Bool / String / Unit / -> / type-vars.
(define ocaml-hm-format-type