2
0
Эх сурвалжийг харах

use for type parameter constraints

Simon Krajewski 3 жил өмнө
parent
commit
99f2c87500

+ 34 - 15
src/core/tFunctions.ml

@@ -689,21 +689,29 @@ let rec raw_class_field build_type c tl i =
 				| [] ->
 					raise Not_found
 				| t :: ctl ->
-					match follow t with
-					| TAnon a ->
-						(try
-							let f = PMap.find i a.a_fields in
-							None, build_type f, f
-						with
-							Not_found -> loop ctl)
-					| TInst (c,tl) ->
-						(try
-							let c2, t , f = raw_class_field build_type c (List.map apply tl) i in
-							c2, apply_params c.cl_params tl t, f
-						with
-							Not_found -> loop ctl)
-					| _ ->
-						loop ctl
+					let rec loop2 t = match follow t with
+						| TAnon a ->
+							(try
+								let f = PMap.find i a.a_fields in
+								None, build_type f, f
+							with
+								Not_found -> loop ctl)
+						| TInst (c,tl) ->
+							(try
+								let c2, t , f = raw_class_field build_type c (List.map apply tl) i in
+								c2, apply_params c.cl_params tl t, f
+							with
+								Not_found -> loop ctl)
+						| TIntersection(t1,t2) ->
+							begin try
+								loop2 t1
+							with Not_found ->
+								loop2 t2
+							end
+						| _ ->
+							loop ctl
+					in
+					loop2 t
 			in
 			loop tl
 		| _ ->
@@ -805,6 +813,17 @@ let type_has_meta t m =
 		| TType ({ t_meta = metadata }, _)
 		| TAbstract ({ a_meta = metadata }, _) -> has_meta m metadata
 
+let intersection_of_tl tl =
+	let rec loop t1 tl = match tl with
+		| [] -> die "" __LOC__
+		| [t2] -> TIntersection(t1,t2)
+		| t2 :: tl -> loop (TIntersection(t1,t2)) tl
+	in
+	match tl with
+	| [] -> die "" __LOC__
+	| [t1] -> t1
+	| t1 :: tl -> loop t1 tl
+
 (* tvar *)
 
 let var_extra params e = {

+ 14 - 1
src/core/tUnification.ml

@@ -82,7 +82,7 @@ module Monomorph = struct
 		| MMono (m2,s) -> m2.tm_up_constraints <- (TMono m,s) :: m.tm_up_constraints
 		| _ -> ()
 
-	let constraint_of_type name t = match follow t with
+	let rec constraint_of_type name t = match follow t with
 		| TMono m2 ->
 			[MMono(m2,name)]
 		| TAnon an when not (PMap.is_empty an.a_fields) ->
@@ -91,6 +91,8 @@ module Monomorph = struct
 			) an.a_fields []
 		| TAnon _ ->
 			[MEmptyStructure]
+		| TIntersection(t1,t2) ->
+			(constraint_of_type name t1) @ (constraint_of_type name t2)
 		| _ ->
 			[MType(t,name)]
 
@@ -342,6 +344,8 @@ let fast_eq_check type_param_check a b =
 		c1 == c2 && List.for_all2 type_param_check l1 l2
 	| TAbstract (a1,l1), TAbstract (a2,l2) ->
 		a1 == a2 && List.for_all2 type_param_check l1 l2
+	| TIntersection(t1,t2),TIntersection(t1',t2') ->
+		t1 == t1' && t2 == t2'
 	| _ , _ ->
 		false
 
@@ -585,6 +589,9 @@ let rec type_eq uctx a b =
 			) a2.a_fields;
 		with
 			Unify_error l -> error (cannot_unify a b :: l))
+	| TIntersection(t1,t2),TIntersection(t1',t2') ->
+		type_eq uctx t1 t1';
+		type_eq uctx t2 t2';
 	| _ , _ ->
 		error [cannot_unify a b]
 
@@ -889,6 +896,9 @@ let rec unify (uctx : unification_context) a b =
 		) ctl) then unify_from uctx a b bb tl
 	| _, TAbstract (bb,tl) ->
 		unify_from uctx a b bb tl
+	| _,TIntersection(t1,t2) ->
+		unify uctx a t1;
+		unify uctx a t2;
 	| _ , _ ->
 		error [cannot_unify a b]
 
@@ -1075,6 +1085,9 @@ and unify_with_variance uctx f t1 t2 =
 	| TFun(al1,r1),TFun(al2,r2) when List.length al1 = List.length al2 ->
 		List.iter2 (fun (_,_,t1) (_,_,t2) -> unify_nested t1 t2) al1 al2;
 		unify_nested r1 r2;
+	| TIntersection(t1,t2),TIntersection(t1',t2') ->
+		unify_nested t1 t1';
+		unify_nested t2 t2';
 	| _ ->
 		fail()
 

+ 6 - 0
src/typing/fields.ml

@@ -314,6 +314,12 @@ let type_field cfg ctx e i p mode (with_type : WithType.t) =
 		let field_access = field_access e in
 		match t with
 		| TType (td,tl) -> type_field_by_typedef type_field_by_type e td tl
+		| TIntersection(t1,t2) ->
+			begin try
+				type_field_by_type e t1
+			with Not_found ->
+				type_field_by_type e t2
+			end
 		| TInst (c,tl) ->
 			(try
 				snd (class_field_with_access e c tl)

+ 4 - 1
src/typing/typeload.ml

@@ -795,7 +795,10 @@ let rec type_type_param ?(enum_constructor=false) ctx path get_params p tp =
 			r := lazy_processing (fun() -> t);
 			let ctx = { ctx with type_params = ctx.type_params @ get_params() } in
 			let constr = match fst th with
-				| CTIntersection tl -> List.map (load_complex_type ctx true) tl
+				| CTIntersection ctl ->
+					let tl = List.map (load_complex_type ctx true) ctl in
+					let t = intersection_of_tl tl in
+					[t]
 				| _ -> [load_complex_type ctx true th]
 			in
 			(* check against direct recursion *)