|
|
|
@ -25,15 +25,9 @@ module Make
|
|
|
|
|
type tevar =
|
|
|
|
|
X.tevar
|
|
|
|
|
|
|
|
|
|
type svar =
|
|
|
|
|
int
|
|
|
|
|
|
|
|
|
|
module TeVarMap =
|
|
|
|
|
Map.Make(struct include X type t = tevar end)
|
|
|
|
|
|
|
|
|
|
module SVMap =
|
|
|
|
|
Map.Make(Int)
|
|
|
|
|
|
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
|
|
|
|
|
|
(* The type variables that appear in constraints are immutable: they
|
|
|
|
@ -45,9 +39,6 @@ type variable =
|
|
|
|
|
let fresh : unit -> variable =
|
|
|
|
|
Utils.gensym()
|
|
|
|
|
|
|
|
|
|
let fresh_svar : unit -> svar =
|
|
|
|
|
Utils.gensym()
|
|
|
|
|
|
|
|
|
|
module VarTable = Hashtbl.Make(struct
|
|
|
|
|
type t = variable
|
|
|
|
|
let hash = Hashtbl.hash
|
|
|
|
@ -105,8 +96,6 @@ type _ co =
|
|
|
|
|
term variable [x]. Its result is a list of types that indicates
|
|
|
|
|
how the type scheme was instantiated. *)
|
|
|
|
|
|
|
|
|
|
| CInstance' : svar * variable -> O.ty list co
|
|
|
|
|
|
|
|
|
|
| CDef : tevar * variable * 'a co -> 'a co
|
|
|
|
|
(**The constraint [CDef (x, v, c)] binds the term variable [x] to
|
|
|
|
|
the trivial (monomorphic) type scheme [v] in the constraint [c]. *)
|
|
|
|
@ -129,7 +118,7 @@ type _ co =
|
|
|
|
|
- the value [a2] produced by solving the constraint [c2].
|
|
|
|
|
*)
|
|
|
|
|
|
|
|
|
|
| CLetRigid : variable list * variable * 'a co * svar * 'b co ->
|
|
|
|
|
| CLetRigid : variable list * variable * 'a co * tevar * 'b co ->
|
|
|
|
|
(O.tyvar list * 'a * 'b) co
|
|
|
|
|
|
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
@ -197,7 +186,7 @@ module Printer = struct
|
|
|
|
|
next c1 ^^
|
|
|
|
|
string " in")) ^/^
|
|
|
|
|
self c2 ^^
|
|
|
|
|
string " : " ^^ var s
|
|
|
|
|
string " : " ^^ tevar s
|
|
|
|
|
| _ ->
|
|
|
|
|
next c
|
|
|
|
|
|
|
|
|
@ -229,8 +218,6 @@ module Printer = struct
|
|
|
|
|
separate space [var v1; string "="; var v2]
|
|
|
|
|
| CInstance (x, v) ->
|
|
|
|
|
tevar x ^^ utf8string " ≤ " ^^ var v
|
|
|
|
|
| CInstance'(sv, w) ->
|
|
|
|
|
var sv ^^ utf8string " ≤ " ^^ var w
|
|
|
|
|
| CExist _
|
|
|
|
|
| CDef _
|
|
|
|
|
| CLet _
|
|
|
|
@ -457,7 +444,6 @@ let rec ok : type a . a co -> bool =
|
|
|
|
|
| CExist _
|
|
|
|
|
| CWitness _
|
|
|
|
|
| CInstance _
|
|
|
|
|
| CInstance' _
|
|
|
|
|
| CDef _ ->
|
|
|
|
|
(* These forms are not [ok], as they involve (free or binding
|
|
|
|
|
occurrences of) type variables. *)
|
|
|
|
@ -509,25 +495,25 @@ let solve ~(rectypes : bool) (type a) (c : a co) : a =
|
|
|
|
|
range (the range annotation that was most recently encountered on the
|
|
|
|
|
way down). *)
|
|
|
|
|
|
|
|
|
|
let rec solve : type a . env -> 'b SVMap.t -> range -> a co -> a on_sol =
|
|
|
|
|
fun env senv range c -> match c with
|
|
|
|
|
let rec solve : type a . env -> range -> a co -> a on_sol =
|
|
|
|
|
fun env range c -> match c with
|
|
|
|
|
| CRange (range, c) ->
|
|
|
|
|
solve env senv range c
|
|
|
|
|
solve env range c
|
|
|
|
|
| CTrue ->
|
|
|
|
|
On_sol (fun () -> ())
|
|
|
|
|
| CMap (c, f) ->
|
|
|
|
|
let (On_sol r) = solve env senv range c in
|
|
|
|
|
let (On_sol r) = solve env range c in
|
|
|
|
|
On_sol (fun () -> f (r ()))
|
|
|
|
|
| CConj (c1, c2) ->
|
|
|
|
|
let (On_sol r1) = solve env senv range c1 in
|
|
|
|
|
let (On_sol r2) = solve env senv range c2 in
|
|
|
|
|
let (On_sol r1) = solve env range c1 in
|
|
|
|
|
let (On_sol r2) = solve env range c2 in
|
|
|
|
|
On_sol (fun () -> (r1 (), r2 ()))
|
|
|
|
|
| CEq (v, w) ->
|
|
|
|
|
unify range (uvar v) (uvar w);
|
|
|
|
|
On_sol (fun () -> ())
|
|
|
|
|
| CExist (v, s, c) ->
|
|
|
|
|
ignore (ubind v s);
|
|
|
|
|
solve env senv range c
|
|
|
|
|
solve env range c
|
|
|
|
|
| CWitness v ->
|
|
|
|
|
On_sol (fun () -> decode (uvar v))
|
|
|
|
|
| CInstance (x, w) ->
|
|
|
|
@ -539,14 +525,9 @@ let solve ~(rectypes : bool) (type a) (c : a co) : a =
|
|
|
|
|
let witnesses, v = G.instantiate state s in
|
|
|
|
|
unify range v (uvar w);
|
|
|
|
|
On_sol (fun () -> List.map decode witnesses)
|
|
|
|
|
| CInstance' (sv, w) ->
|
|
|
|
|
let s = SVMap.find sv senv in
|
|
|
|
|
let witnesses, v = G.instantiate state s in
|
|
|
|
|
unify range v (uvar w);
|
|
|
|
|
On_sol (fun () -> List.map decode witnesses)
|
|
|
|
|
| CDef (x, v, c) ->
|
|
|
|
|
let env = Env.bind x (G.trivial (uvar v)) env in
|
|
|
|
|
solve env senv range c
|
|
|
|
|
solve env range c
|
|
|
|
|
| CLet (xvs, c1, c2) ->
|
|
|
|
|
(* Warn the generalization engine that we are entering the left-hand
|
|
|
|
|
side of a [let] construct. *)
|
|
|
|
@ -556,7 +537,7 @@ let solve ~(rectypes : bool) (type a) (c : a co) : a =
|
|
|
|
|
basically, but they also serve as named entry points. *)
|
|
|
|
|
let vs = List.map (fun (_, v) -> ubind v None) xvs in
|
|
|
|
|
(* Solve the constraint [c1]. *)
|
|
|
|
|
let (On_sol r1) = solve env senv range c1 in
|
|
|
|
|
let (On_sol r1) = solve env range c1 in
|
|
|
|
|
(* Ask the generalization engine to perform an occurs check, to adjust
|
|
|
|
|
the ranks of the type variables in the young generation (i.e., all
|
|
|
|
|
of the type variables that were registered since the call to
|
|
|
|
@ -572,7 +553,7 @@ let solve ~(rectypes : bool) (type a) (c : a co) : a =
|
|
|
|
|
) xvs ss (env, [])
|
|
|
|
|
in
|
|
|
|
|
(* Proceed to solve [c2] in the extended environment. *)
|
|
|
|
|
let (On_sol r2) = solve env senv range c2 in
|
|
|
|
|
let (On_sol r2) = solve env range c2 in
|
|
|
|
|
On_sol (fun () ->
|
|
|
|
|
List.map decode_variable generalizable,
|
|
|
|
|
List.map (fun (x, s) -> (x, decode_scheme decode s)) xss,
|
|
|
|
@ -582,10 +563,10 @@ let solve ~(rectypes : bool) (type a) (c : a co) : a =
|
|
|
|
|
G.enter state;
|
|
|
|
|
let vs = List.map (fun v -> ubind_rigid v None) vs in
|
|
|
|
|
let z = ubind z None in
|
|
|
|
|
let (On_sol r1) = solve env senv range c1 in
|
|
|
|
|
let (On_sol r1) = solve env range c1 in
|
|
|
|
|
let s = exit_rigid range ~rectypes state z in
|
|
|
|
|
let senv = SVMap.add sv s senv in
|
|
|
|
|
let (On_sol r2) = solve env senv range c2 in
|
|
|
|
|
let env = Env.bind sv s env in
|
|
|
|
|
let (On_sol r2) = solve env range c2 in
|
|
|
|
|
On_sol (fun () ->
|
|
|
|
|
List.map decode_variable vs,
|
|
|
|
|
r1 (),
|
|
|
|
@ -593,10 +574,9 @@ let solve ~(rectypes : bool) (type a) (c : a co) : a =
|
|
|
|
|
in
|
|
|
|
|
|
|
|
|
|
let env = Env.empty
|
|
|
|
|
and senv = SVMap.empty
|
|
|
|
|
and range = Lexing.(dummy_pos, dummy_pos) in
|
|
|
|
|
(* Phase 1: solve the constraint. *)
|
|
|
|
|
let (On_sol r) = solve env senv range c in
|
|
|
|
|
let (On_sol r) = solve env range c in
|
|
|
|
|
(* Phase 2: elaborate. *)
|
|
|
|
|
r()
|
|
|
|
|
|
|
|
|
@ -738,9 +718,6 @@ let instance x v =
|
|
|
|
|
|
|
|
|
|
let instance_ x v =
|
|
|
|
|
CMap (instance x v, ignore)
|
|
|
|
|
|
|
|
|
|
let instance' sv v =
|
|
|
|
|
CInstance' (sv, v)
|
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
|
|
|
|
|
|
(* Constraint abstractions. *)
|
|
|
|
@ -797,17 +774,16 @@ let let0 c1 =
|
|
|
|
|
|
|
|
|
|
let letr1
|
|
|
|
|
: 'tyvar list
|
|
|
|
|
-> tevar
|
|
|
|
|
-> (('tyvar * variable) list -> variable -> 'a co)
|
|
|
|
|
-> (svar -> 'b co)
|
|
|
|
|
-> 'b co
|
|
|
|
|
-> (O.tyvar list * 'a * 'b) co
|
|
|
|
|
= fun alphas f1 f2 ->
|
|
|
|
|
= fun alphas sv f1 c2 ->
|
|
|
|
|
let xvss = List.map (fun a ->
|
|
|
|
|
a, fresh ()
|
|
|
|
|
) alphas in
|
|
|
|
|
let z = fresh () in
|
|
|
|
|
let c1 = f1 xvss z in
|
|
|
|
|
let sv = fresh_svar () in
|
|
|
|
|
let c2 = f2 sv in
|
|
|
|
|
CLetRigid (List.map snd xvss, z, c1, sv, c2)
|
|
|
|
|
|
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
|