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

ocaml: phase 5 HM let-rec + cons / append op types (+6 tests, 357 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
Details

Browse Source 
ocaml-infer-let-rec pre-binds the function name to a fresh tv before
inferring rhs (which may recursively call the name), unifies the
inferred rhs type with the tv, generalizes, then infers body.

Builtin env types :: : 'a -> 'a list -> 'a list and @ : 'a list ->
'a list -> 'a list — needed because :op compiles to (:app (:app (:var
OP) L) R) and previously these var lookups failed.

Examples now infer:
  let rec fact n = if ... in fact : Int -> Int
  let rec len lst = ... in len    : 'a list -> Int
  let rec map f xs = ... in map   : ('a -> 'b) -> 'a list -> 'b list
  1 :: [2; 3]                      : Int list
  let rec sum lst = ... in sum [1;2;3] : Int

Scoreboard refreshed: 358/358 across 14 suites.
This commit is contained in:
giles
2026-05-08 13:08:51 +00:00
parent 81247eb6ea
commit 5bc7895ce0
5 changed files with 86 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

38
lib/ocaml/infer.sx
View File

@@ -49,7 +49,19 @@
(hm-arrow a (hm-arrow a (hm-bool))))))
(a->a
(let ((a (hm-tv "a")))
(hm-scheme (list "a") (hm-arrow a a)))))
(hm-scheme (list "a") (hm-arrow a a))))
(cons-type
(let ((a (hm-tv "a")))
(hm-scheme (list "a")
(hm-arrow a
(hm-arrow (hm-con "list" (list a))
(hm-con "list" (list a)))))))
(concat-type
(let ((a (hm-tv "a")))
(hm-scheme (list "a")
(hm-arrow (hm-con "list" (list a))
(hm-arrow (hm-con "list" (list a))
(hm-con "list" (list a))))))))
{"+" (hm-monotype int-int-int)
"-" (hm-monotype int-int-int)
"*" (hm-monotype int-int-int)
@@ -66,6 +78,8 @@
"&&" (hm-monotype bool-bool-bool)
"||" (hm-monotype bool-bool-bool)
"^" (hm-monotype str-str-str)
"::" cons-type
"@" concat-type
"not" (hm-monotype (hm-arrow (hm-bool) (hm-bool)))
"succ" (hm-monotype (hm-arrow (hm-int) (hm-int)))
"pred" (hm-monotype (hm-arrow (hm-int) (hm-int)))
@@ -142,6 +156,26 @@
(let ((s2 (get r2 :subst)) (t2 (get r2 :type)))
{:subst (hm-compose s2 s1) :type t2}))))))))))
;; let-rec name params = rhs in body — bind name to a fresh tv before
;; inferring rhs, then unify the inferred rhs type with the tv. This
;; lets rhs reference name (recursive call). Generalize after.
(define ocaml-infer-let-rec
(fn (name params rhs body env counter)
(let ((rhs-expr (cond
((= (len params) 0) rhs)
(else (list :fun params rhs))))
(rec-tv (hm-fresh-tv counter)))
(let ((env-rec (assoc env name (hm-monotype rec-tv))))
(let ((r1 (ocaml-infer rhs-expr env-rec counter)))
(let ((s1 (get r1 :subst)) (t1 (get r1 :type)))
(let ((s2 (ocaml-hm-unify (hm-apply s1 rec-tv) t1 s1)))
(let ((env2 (hm-apply-env s2 env)))
(let ((scheme (hm-generalize (hm-apply s2 t1) env2)))
(let ((env3 (assoc env2 name scheme)))
(let ((r2 (ocaml-infer body env3 counter)))
(let ((s3 (get r2 :subst)) (t2 (get r2 :type)))
{:subst (hm-compose s3 s2) :type t2}))))))))))))
(define ocaml-infer-if
(fn (c-ast t-ast e-ast env counter)
(let ((rc (ocaml-infer c-ast env counter)))
@@ -381,6 +415,8 @@
((= tag "app") (ocaml-infer-app (nth expr 1) (nth expr 2) env counter))
((= tag "let") (ocaml-infer-let (nth expr 1) (nth expr 2)
(nth expr 3) (nth expr 4) env counter))
((= tag "let-rec") (ocaml-infer-let-rec (nth expr 1) (nth expr 2)
(nth expr 3) (nth expr 4) env counter))
((= tag "if") (ocaml-infer-if (nth expr 1) (nth expr 2)
(nth expr 3) env counter))
((= tag "tuple") (ocaml-infer-tuple (rest expr) env counter))