[typer] factor out `make_extension_type`

src/typing/typeload.ml

@@ -207,6 +207,33 @@ let generate_value_meta com co fadd args =
 		| [] -> ()
 		| _ -> fadd (Meta.Value,[EObjectDecl values,null_pos],null_pos)
 
+let is_redefined ctx cf1 fields p =
+	try
+		let cf2 = PMap.find cf1.cf_name fields in
+		let st = s_type (print_context()) in
+		if not (type_iseq cf1.cf_type cf2.cf_type) then begin
+			display_error ctx ("Cannot redefine field " ^ cf1.cf_name ^ " with different type") p;
+			display_error ctx ("First type was " ^ (st cf1.cf_type)) cf1.cf_pos;
+			error ("Second type was " ^ (st cf2.cf_type)) cf2.cf_pos
+		end else
+			true
+	with Not_found ->
+		false
+
+let make_extension_type ctx tl p =
+	let mk_extension fields t = match follow t with
+		| TAnon a ->
+			PMap.fold (fun cf fields ->
+				if not (is_redefined ctx cf fields p) then PMap.add cf.cf_name cf fields
+				else fields
+			) a.a_fields fields
+		| _ ->
+			error "Can only extend structures" p
+	in
+	let fields = List.fold_left mk_extension PMap.empty tl in
+	let ta = TAnon { a_fields = fields; a_status = ref (Extend tl); } in
+	ta
+
 (* build an instance from a full type *)
 let rec load_instance' ctx (t,p) allow_no_params =
 	let t = try
@@ -332,19 +359,6 @@ and load_instance ctx ?(allow_display=false) (t,pn) allow_no_params =
 	build an instance from a complex type
 *)
 and load_complex_type' ctx allow_display (t,p) =
-	let is_redefined cf1 fields =
-		try
-			let cf2 = PMap.find cf1.cf_name fields in
-			let st = s_type (print_context()) in
-			if not (type_iseq cf1.cf_type cf2.cf_type) then begin
-				display_error ctx ("Cannot redefine field " ^ cf1.cf_name ^ " with different type") p;
-				display_error ctx ("First type was " ^ (st cf1.cf_type)) cf1.cf_pos;
-				error ("Second type was " ^ (st cf2.cf_type)) cf2.cf_pos
-			end else
-				true
-		with Not_found ->
-			false
-	in
 	match t with
 	| CTParent t -> load_complex_type ctx allow_display t
 	| CTPath t -> load_instance ~allow_display ctx (t,p) false
@@ -365,17 +379,7 @@ and load_complex_type' ctx allow_display (t,p) =
 		let t = TMono tr in
 		let r = exc_protect ctx (fun r ->
 			r := lazy_processing (fun() -> t);
-			let mk_extension fields t = match follow t with
-				| TAnon a ->
-					PMap.fold (fun cf fields ->
-						if not (is_redefined cf fields) then PMap.add cf.cf_name cf fields
-						else fields
-					) a.a_fields fields
-				| _ ->
-					error "Can only extend structures" p
-			in
-			let fields = List.fold_left mk_extension PMap.empty tl in
-			let ta = TAnon { a_fields = fields; a_status = ref (Extend tl); } in
+			let ta = make_extension_type ctx tl p in
 			tr := Some ta;
 			ta
 		) "constraint" in
@@ -390,14 +394,14 @@ and load_complex_type' ctx allow_display (t,p) =
 				| TMono _ ->
 					error "Loop found in cascading signatures definitions. Please change order/import" p
 				| TAnon a2 ->
-					PMap.iter (fun _ cf -> ignore(is_redefined cf a2.a_fields)) a.a_fields;
+					PMap.iter (fun _ cf -> ignore(is_redefined ctx cf a2.a_fields p)) a.a_fields;
 					TAnon { a_fields = (PMap.foldi PMap.add a.a_fields a2.a_fields); a_status = ref (Extend [t]); }
 				| _ -> error "Can only extend structures" p
 			in
 			let loop t = match follow t with
 				| TAnon a2 ->
 					PMap.iter (fun f cf ->
-						if not (is_redefined cf a.a_fields) then
+						if not (is_redefined ctx cf a.a_fields p) then
 							a.a_fields <- PMap.add f cf a.a_fields
 					) a2.a_fields
 				| _ ->