summaryrefslogtreecommitdiff
path: root/typing/typeclass.ml
diff options
context:
space:
mode:
Diffstat (limited to 'typing/typeclass.ml')
-rw-r--r--typing/typeclass.ml126
1 files changed, 76 insertions, 50 deletions
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index a0f9dd64ec..7301b1f9c6 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -88,9 +88,10 @@ let rec generalize_class_type =
Tcty_constr (_, params, cty) ->
List.iter Ctype.generalize params;
generalize_class_type cty
- | Tcty_signature {cty_self = sty; cty_vars = vars } ->
+ | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
Ctype.generalize sty;
- Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars
+ Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars;
+ List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
| Tcty_fun (_, ty, cty) ->
Ctype.generalize ty;
generalize_class_type cty
@@ -172,7 +173,9 @@ let rec limited_generalize rv =
| Tcty_signature sign ->
Ctype.limited_generalize rv sign.cty_self;
Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
- sign.cty_vars
+ sign.cty_vars;
+ List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
+ sign.cty_inher
| Tcty_fun (_, ty, cty) ->
Ctype.limited_generalize rv ty;
limited_generalize rv cty
@@ -272,10 +275,15 @@ let make_method cl_num expr =
(*******************************)
-let rec class_type_field env self_type meths (val_sig, concr_meths) =
+let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
function
Pctf_inher sparent ->
let parent = class_type env sparent in
+ let inher =
+ match parent with
+ Tcty_constr (p, tl, _) -> (p, tl) :: inher
+ | _ -> inher
+ in
let (cl_sig, concr_meths, _) =
inheritance self_type env concr_meths Concr.empty sparent.pcty_loc
parent
@@ -285,7 +293,7 @@ let rec class_type_field env self_type meths (val_sig, concr_meths) =
(fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig)
cl_sig.cty_vars val_sig
in
- (val_sig, concr_meths)
+ (val_sig, concr_meths, inher)
| Pctf_val (lab, mut, sty_opt, loc) ->
let (mut, ty) =
@@ -299,19 +307,19 @@ let rec class_type_field env self_type meths (val_sig, concr_meths) =
| Some sty ->
mut, transl_simple_type env false sty
in
- (Vars.add lab (mut, ty) val_sig, concr_meths)
+ (Vars.add lab (mut, ty) val_sig, concr_meths, inher)
| Pctf_virt (lab, priv, sty, loc) ->
declare_method env meths self_type lab priv sty loc;
- (val_sig, concr_meths)
+ (val_sig, concr_meths, inher)
| Pctf_meth (lab, priv, sty, loc) ->
declare_method env meths self_type lab priv sty loc;
- (val_sig, Concr.add lab concr_meths)
+ (val_sig, Concr.add lab concr_meths, inher)
| Pctf_cstr (sty, sty', loc) ->
type_constraint env sty sty' loc;
- (val_sig, concr_meths)
+ (val_sig, concr_meths, inher)
and class_signature env sty sign =
let meths = ref Meths.empty in
@@ -328,15 +336,16 @@ and class_signature env sty sign =
end;
(* Class type fields *)
- let (val_sig, concr_meths) =
+ let (val_sig, concr_meths, inher) =
List.fold_left (class_type_field env self_type meths)
- (Vars.empty, Concr.empty)
+ (Vars.empty, Concr.empty, [])
sign
in
{cty_self = self_type;
cty_vars = val_sig;
- cty_concr = concr_meths }
+ cty_concr = concr_meths;
+ cty_inher = inher}
and class_type env scty =
match scty.pcty_desc with
@@ -350,7 +359,6 @@ and class_type env scty =
let (params, clty) =
Ctype.instance_class decl.clty_params decl.clty_type
in
- let sty = Ctype.self_type clty in
if List.length params <> List.length styl then
raise(Error(scty.pcty_loc,
Parameter_arity_mismatch (lid, List.length params,
@@ -376,10 +384,16 @@ and class_type env scty =
module StringSet = Set.Make(struct type t = string let compare = compare end)
let rec class_field cl_num self_type meths vars
- (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals) =
+ (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+ inh_vals, inher) =
function
Pcf_inher (sparent, super) ->
let parent = class_expr cl_num val_env par_env sparent in
+ let inher =
+ match parent.cl_type with
+ Tcty_constr (p, tl, _) -> (p, tl) :: inher
+ | _ -> inher
+ in
let (cl_sig, concr_meths, warn_meths) =
inheritance self_type val_env concr_meths warn_meths sparent.pcl_loc
parent.cl_type
@@ -417,7 +431,7 @@ let rec class_field cl_num self_type meths vars
in
(val_env, met_env, par_env,
lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
- concr_meths, warn_meths, inh_vals)
+ concr_meths, warn_meths, inh_vals, inher)
| Pcf_val (lab, mut, sexp, loc) ->
if StringSet.mem lab inh_vals then
@@ -435,12 +449,13 @@ let rec class_field cl_num self_type meths vars
enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
in
(val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
- concr_meths, warn_meths, inh_vals)
+ concr_meths, warn_meths, inh_vals, inher)
| Pcf_virt (lab, priv, sty, loc) ->
virtual_method val_env meths self_type lab priv sty loc;
let warn_meths = Concr.remove lab warn_meths in
- (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
+ (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+ inh_vals, inher)
| Pcf_meth (lab, priv, expr, loc) ->
let (_, ty) =
@@ -483,11 +498,12 @@ let rec class_field cl_num self_type meths vars
Cf_meth (lab, texp)
end in
(val_env, met_env, par_env, field::fields,
- Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals)
+ Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher)
| Pcf_cstr (sty, sty', loc) ->
type_constraint val_env sty sty' loc;
- (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
+ (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+ inh_vals, inher)
| Pcf_let (rec_flag, sdefs, loc) ->
let (defs, val_env) =
@@ -517,7 +533,7 @@ let rec class_field cl_num self_type meths vars
([], met_env, par_env)
in
(val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
- concr_meths, warn_meths, inh_vals)
+ concr_meths, warn_meths, inh_vals, inher)
| Pcf_init expr ->
let expr = make_method cl_num expr in
@@ -534,22 +550,24 @@ let rec class_field cl_num self_type meths vars
Cf_init texp
end in
(val_env, met_env, par_env, field::fields,
- concr_meths, warn_meths, inh_vals)
+ concr_meths, warn_meths, inh_vals, inher)
and class_structure cl_num final val_env met_env loc (spat, str) =
(* Environment for substructures *)
let par_env = met_env in
- (* Private self type more method access, with a dummy method preventing
- it from being closed/escaped. *)
+ (* Self type, with a dummy method preventing it from being closed/escaped. *)
let self_type = Ctype.newvar () in
Ctype.unify val_env
(Ctype.filter_method val_env dummy_method Private self_type)
(Ctype.newty (Ttuple []));
+ (* Private self is used for private method calls *)
+ let private_self = if final then Ctype.newvar () else self_type in
+
(* Self binder *)
let (pat, meths, vars, val_env, meth_env, par_env) =
- type_self_pattern cl_num self_type val_env met_env par_env spat
+ type_self_pattern cl_num private_self val_env met_env par_env spat
in
let public_self = pat.pat_type in
@@ -568,30 +586,33 @@ and class_structure cl_num final val_env met_env loc (spat, str) =
(* Copy known information to still empty self_type *)
List.iter
(fun (lab,kind,ty) ->
+ let k =
+ if Btype.field_kind_repr kind = Fpresent then Public else Private in
try Ctype.unify val_env ty
- (Ctype.filter_method val_env lab Public self_type)
+ (Ctype.filter_method val_env lab k self_type)
with _ -> assert false)
(get_methods public_self)
end;
(* Typing of class fields *)
- let (_, _, _, fields, concr_meths, _, _) =
+ let (_, _, _, fields, concr_meths, _, _, inher) =
List.fold_left (class_field cl_num self_type meths vars)
(val_env, meth_env, par_env, [], Concr.empty, Concr.empty,
- StringSet.empty)
+ StringSet.empty, [])
str
in
Ctype.unify val_env self_type (Ctype.newvar ());
let sign =
{cty_self = public_self;
cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
- cty_concr = concr_meths } in
+ cty_concr = concr_meths;
+ cty_inher = inher} in
let methods = get_methods self_type in
let priv_meths =
List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
methods in
if final then begin
- (* Unify public_self and a copy of self_type. self_type will not
+ (* Unify private_self and a copy of self_type. self_type will not
be modified after this point *)
Ctype.close_object self_type;
let mets = virtual_methods {sign with cty_self = self_type} in
@@ -599,11 +620,18 @@ and class_structure cl_num final val_env met_env loc (spat, str) =
let self_methods =
List.fold_right
(fun (lab,kind,ty) rem ->
- if lab = dummy_method then rem else
- Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
+ if lab = dummy_method then
+ (* allow public self and private self to be unified *)
+ match Btype.field_kind_repr kind with
+ Fvar r -> Btype.set_kind r Fabsent; rem
+ | _ -> rem
+ else
+ Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
methods (Ctype.newty Tnil) in
- begin try Ctype.unify val_env public_self
- (Ctype.newty (Tobject(self_methods, ref None)))
+ begin try
+ Ctype.unify val_env private_self
+ (Ctype.newty (Tobject(self_methods, ref None)));
+ Ctype.unify val_env public_self self_type
with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace))
end;
end;
@@ -625,12 +653,7 @@ and class_structure cl_num final val_env met_env loc (spat, str) =
let l1 = names priv_meths and l2 = names pub_meths' in
let added = List.filter (fun x -> List.mem x l1) l2 in
if added <> [] then
- Location.prerr_warning loc
- (Warnings.Other
- (String.concat " "
- ("the following private methods were made public implicitly:\n "
- :: added)));
-
+ Location.prerr_warning loc (Warnings.Implicit_public_methods added);
{cl_field = fields; cl_meths = meths}, sign
and class_expr cl_num val_env met_env scl =
@@ -735,7 +758,7 @@ and class_expr cl_num val_env met_env scl =
Ctype.end_def ();
if Btype.is_optional l && all_labeled cl.cl_type then
Location.prerr_warning pat.pat_loc
- (Warnings.Other "This optional argument cannot be erased");
+ Warnings.Unerasable_optional_argument;
rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
cl_loc = scl.pcl_loc;
cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type);
@@ -948,10 +971,12 @@ let rec initial_env define_class approx
Tcty_signature
{ cty_self = Ctype.newvar ();
cty_vars = Vars.empty;
- cty_concr = Concr.empty }
+ cty_concr = Concr.empty;
+ cty_inher = [] }
in
let dummy_class =
{cty_params = []; (* Dummy value *)
+ cty_variance = [];
cty_type = dummy_cty; (* Dummy value *)
cty_path = unbound_class;
cty_new =
@@ -962,6 +987,7 @@ let rec initial_env define_class approx
let env =
Env.add_cltype ty_id
{clty_params = []; (* Dummy value *)
+ clty_variance = [];
clty_type = dummy_cty; (* Dummy value *)
clty_path = unbound_class} (
if define_class then
@@ -1076,11 +1102,14 @@ let class_infos define_class kind
end;
(* Class and class type temporary definitions *)
+ let cty_variance = List.map (fun _ -> true, true) params in
let cltydef =
{clty_params = params; clty_type = class_body typ;
+ clty_variance = cty_variance;
clty_path = Path.Pident obj_id}
and clty =
{cty_params = params; cty_type = typ;
+ cty_variance = cty_variance;
cty_path = Path.Pident obj_id;
cty_new =
match cl.pci_virt with
@@ -1112,9 +1141,11 @@ let class_infos define_class kind
let (params', typ') = Ctype.instance_class params typ in
let cltydef =
{clty_params = params'; clty_type = class_body typ';
+ clty_variance = cty_variance;
clty_path = Path.Pident obj_id}
and clty =
{cty_params = params'; cty_type = typ';
+ cty_variance = cty_variance;
cty_path = Path.Pident obj_id;
cty_new =
match cl.pci_virt with
@@ -1193,16 +1224,11 @@ let final_decl env define_class
let extract_type_decls
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, coe, expr, required) decls =
- ((obj_id, obj_abbr), required) :: ((cl_id, cl_abbr), required) :: decls
-
-let rec compact = function
- [] -> []
- | a :: b :: l -> (a,b) :: compact l
- | _ -> fatal_error "Typeclass.compact"
+ (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls
let merge_type_decls
- (id, clty, ty_id, cltydef, _obj_id, _obj_abbr, _cl_id, _cl_abbr,
- arity, pub_meths, coe, expr, req) ((obj_id, obj_abbr), (cl_id, cl_abbr)) =
+ (id, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr,
+ arity, pub_meths, coe, expr, req) (obj_abbr, cl_abbr, clty, cltydef) =
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, coe, expr)
@@ -1268,7 +1294,7 @@ let type_classes define_class approx kind env cls =
let res = List.rev_map (final_decl env define_class) res in
let decls = List.fold_right extract_type_decls res [] in
let decls = Typedecl.compute_variance_decls env decls in
- let res = List.map2 merge_type_decls res (compact decls) in
+ let res = List.map2 merge_type_decls res decls in
let env = List.fold_left (final_env define_class) env res in
let res = List.map (check_coercions env) res in
(res, env)
View Lorry Controller Status