1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* Typechecking for the core language *)
17
18 open Misc
19 open Asttypes
20 open Parsetree
21 open Types
22 open Typedtree
23 open Btype
24 open Ctype
25
26 type type_forcing_context =
27 | If_conditional
28 | If_no_else_branch
29 | While_loop_conditional
30 | While_loop_body
31 | For_loop_start_index
32 | For_loop_stop_index
33 | For_loop_body
34 | Assert_condition
35 | Sequence_left_hand_side
36 | When_guard
37
38 type type_expected = {
39 ty: type_expr;
40 explanation: type_forcing_context option;
41 }
42
43 type existential_restriction =
44 | At_toplevel (** no existential types at the toplevel *)
45 | In_group (** nor with let ... and ... *)
46 | In_rec (** or recursive definition *)
47 | With_attributes (** or let[@any_attribute] = ... *)
48 | In_class_args (** or in class arguments *)
49 | In_class_def (** or in [class c = let ... in ...] *)
50 | In_self_pattern (** or in self pattern *)
51
52 type error =
53 | Constructor_arity_mismatch of Longident.t * int * int
54 | Label_mismatch of Longident.t * Ctype.Unification_trace.t
55 | Pattern_type_clash of Ctype.Unification_trace.t * pattern_desc option
56 | Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t
57 | Multiply_bound_variable of string
58 | Orpat_vars of Ident.t * Ident.t list
59 | Expr_type_clash of
60 Ctype.Unification_trace.t * type_forcing_context option
61 * expression_desc option
62 | Apply_non_function of type_expr
63 | Apply_wrong_label of arg_label * type_expr
64 | Label_multiply_defined of string
65 | Label_missing of Ident.t list
66 | Label_not_mutable of Longident.t
67 | Wrong_name of
68 string * type_expected * string * Path.t * string * string list
69 | Name_type_mismatch of
70 string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
71 | Invalid_format of string
72 | Undefined_method of type_expr * string * string list option
73 | Undefined_inherited_method of string * string list
74 | Virtual_class of Longident.t
75 | Private_type of type_expr
76 | Private_label of Longident.t * type_expr
77 | Private_constructor of constructor_description * type_expr
78 | Unbound_instance_variable of string * string list
79 | Instance_variable_not_mutable of string
80 | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t
81 | Outside_class
82 | Value_multiply_overridden of string
83 | Coercion_failure of
84 type_expr * type_expr * Ctype.Unification_trace.t * bool
85 | Too_many_arguments of bool * type_expr * type_forcing_context option
86 | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option
87 | Scoping_let_module of string * type_expr
88 | Not_a_variant_type of Longident.t
89 | Incoherent_label_order
90 | Less_general of string * Ctype.Unification_trace.t
91 | Modules_not_allowed
92 | Cannot_infer_signature
93 | Not_a_packed_module of type_expr
94 | Unexpected_existential of existential_restriction * string * string list
95 | Invalid_interval
96 | Invalid_for_loop_index
97 | No_value_clauses
98 | Exception_pattern_disallowed
99 | Mixed_value_and_exception_patterns_under_guard
100 | Inlined_record_escape
101 | Inlined_record_expected
102 | Unrefuted_pattern of pattern
103 | Invalid_extension_constructor_payload
104 | Not_an_extension_constructor
105 | Literal_overflow of string
106 | Unknown_literal of string * char
107 | Illegal_letrec_pat
108 | Illegal_letrec_expr
109 | Illegal_class_expr
110 | Empty_pattern
111 | Letop_type_clash of string * Ctype.Unification_trace.t
112 | Andop_type_clash of string * Ctype.Unification_trace.t
113 | Bindings_type_clash of Ctype.Unification_trace.t
114
115 exception Error of Location.t * Env.t * error
116 exception Error_forward of Location.error
117
118 (* Forward declaration, to be filled in by Typemod.type_module *)
119
120 let type_module =
121 ref ((fun _env _md -> assert false) :
122 Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
123
124 (* Forward declaration, to be filled in by Typemod.type_open *)
125
126 let type_open :
127 (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
128 Longident.t loc -> Path.t * Env.t)
129 ref =
130 ref (fun ?used_slot:_ _ -> assert false)
131
132 let type_open_decl :
133 (?used_slot:bool ref -> Env.t -> Parsetree.open_declaration
134 -> open_declaration * Types.signature * Env.t)
135 ref =
136 ref (fun ?used_slot:_ _ -> assert false)
137
138 (* Forward declaration, to be filled in by Typemod.type_package *)
139
140 let type_package =
141 ref (fun _ -> assert false)
142
143 (* Forward declaration, to be filled in by Typeclass.class_structure *)
144 let type_object =
145 ref (fun _env _s -> assert false :
146 Env.t -> Location.t -> Parsetree.class_structure ->
147 Typedtree.class_structure * Types.class_signature * string list)
148
149 (*
150 Saving and outputting type information.
151 We keep these function names short, because they have to be
152 called each time we create a record of type [Typedtree.expression]
153 or [Typedtree.pattern] that will end up in the typed AST.
154 *)
155 let re node =
156 Cmt_format.add_saved_type (Cmt_format.Partial_expression node);
157 Stypes.record (Stypes.Ti_expr node);
158 node
159 ;;
160 let rp node =
161 Cmt_format.add_saved_type (Cmt_format.Partial_pattern node);
162 Stypes.record (Stypes.Ti_pat node);
163 node
164 ;;
165
166
167 type recarg =
168 | Allowed
169 | Required
170 | Rejected
171
172
173 let mk_expected ?explanation ty = { ty; explanation; }
174
175 let case lhs rhs =
176 {c_lhs = lhs; c_guard = None; c_rhs = rhs}
177
178 (* Typing of constants *)
179
180 let type_constant = function
181 Const_int _ -> instance Predef.type_int
182 | Const_char _ -> instance Predef.type_char
183 | Const_string _ -> instance Predef.type_string
184 | Const_float _ -> instance Predef.type_float
185 | Const_int32 _ -> instance Predef.type_int32
186 | Const_int64 _ -> instance Predef.type_int64
187 | Const_nativeint _ -> instance Predef.type_nativeint
188
189 let constant : Parsetree.constant -> (Asttypes.constant, error) result =
190 function
191 | Pconst_integer (i,None) ->
192 begin
193 try Ok (Const_int (Misc.Int_literal_converter.int i))
194 with Failure _ -> Error (Literal_overflow "int")
195 end
196 | Pconst_integer (i,Some 'l') ->
197 begin
198 try Ok (Const_int32 (Misc.Int_literal_converter.int32 i))
199 with Failure _ -> Error (Literal_overflow "int32")
200 end
201 | Pconst_integer (i,Some 'L') ->
202 begin
203 try Ok (Const_int64 (Misc.Int_literal_converter.int64 i))
204 with Failure _ -> Error (Literal_overflow "int64")
205 end
206 | Pconst_integer (i,Some 'n') ->
207 begin
208 try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i))
209 with Failure _ -> Error (Literal_overflow "nativeint")
210 end
211 | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c))
212 | Pconst_char c -> Ok (Const_char c)
213 | Pconst_string (s,d) -> Ok (Const_string (s,d))
214 | Pconst_float (f,None)-> Ok (Const_float f)
215 | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c))
216
217 let constant_or_raise env loc cst =
218 match constant cst with
219 | Ok c -> c
220 | Error err -> raise (Error (loc, env, err))
221
222 (* Specific version of type_option, using newty rather than newgenty *)
223
224 let type_option ty =
225 newty (Tconstr(Predef.path_option,[ty], ref Mnil))
226
227 let mkexp exp_desc exp_type exp_loc exp_env =
228 { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }
229
230 let option_none env ty loc =
231 let lid = Longident.Lident "None" in
232 let cnone = Env.find_ident_constructor Predef.ident_none env in
233 mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env
234
235 let option_some env texp =
236 let lid = Longident.Lident "Some" in
237 let csome = Env.find_ident_constructor Predef.ident_some env in
238 mkexp ( Texp_construct(mknoloc lid , csome, [texp]) )
239 (type_option texp.exp_type) texp.exp_loc texp.exp_env
240
241 let extract_option_type env ty =
242 match expand_head env ty with {desc = Tconstr(path, [ty], _)}
243 when Path.same path Predef.path_option -> ty
244 | _ -> assert false
245
246 let extract_concrete_record env ty =
247 match extract_concrete_typedecl env ty with
248 (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
249 | _ -> raise Not_found
250
251 let extract_concrete_variant env ty =
252 match extract_concrete_typedecl env ty with
253 (p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs)
254 | (p0, p, {type_kind=Type_open}) -> (p0, p, [])
255 | _ -> raise Not_found
256
257 let extract_label_names env ty =
258 try
259 let (_, _,fields) = extract_concrete_record env ty in
260 List.map (fun l -> l.Types.ld_id) fields
261 with Not_found ->
262 assert false
263
264 (* Typing of patterns *)
265
266 (* unification inside type_exp and type_expect *)
267 let unify_exp_types loc env ty expected_ty =
268 (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
269 Printtyp.raw_type_expr expected_ty; *)
270 try
271 unify env ty expected_ty
272 with
273 Unify trace ->
274 raise(Error(loc, env, Expr_type_clash(trace, None, None)))
275 | Tags(l1,l2) ->
276 raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
277
278 (* level at which to create the local type declarations *)
279 let gadt_equations_level = ref None
280 let get_gadt_equations_level () =
281 match !gadt_equations_level with
282 Some y -> y
283 | None -> assert false
284
285 (* unification inside type_pat*)
286 let unify_pat_types ?(refine=false) loc env ty ty' =
287 try
288 if refine then
289 unify_gadt ~equations_level:(get_gadt_equations_level ()) env ty ty'
290 else
291 unify !env ty ty'
292 with
293 | Unify trace ->
294 raise(Error(loc, !env, Pattern_type_clash(trace, None)))
295 | Tags(l1,l2) ->
296 raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
297
298 let unify_pat ?refine env pat expected_ty =
299 try unify_pat_types ?refine pat.pat_loc env pat.pat_type expected_ty
300 with Error (loc, env, Pattern_type_clash(trace, None)) ->
301 raise(Error(loc, env, Pattern_type_clash(trace, Some pat.pat_desc)))
302
303 (* Creating new conjunctive types is not allowed when typing patterns *)
304 (* make all Reither present in open variants *)
305 let finalize_variant pat =
306 match pat.pat_desc with
307 Tpat_variant(tag, opat, r) ->
308 let row =
309 match expand_head pat.pat_env pat.pat_type with
310 {desc = Tvariant row} -> r := row; row_repr row
311 | _ -> assert false
312 in
313 begin match row_field tag row with
314 | Rabsent -> () (* assert false *)
315 | Reither (true, [], _, e) when not row.row_closed ->
316 set_row_field e (Rpresent None)
317 | Reither (false, ty::tl, _, e) when not row.row_closed ->
318 set_row_field e (Rpresent (Some ty));
319 begin match opat with None -> assert false
320 | Some pat ->
321 let env = ref pat.pat_env in
322 List.iter (unify_pat env pat) (ty::tl)
323 end
324 | Reither (c, _l, true, e) when not (row_fixed row) ->
325 set_row_field e (Reither (c, [], false, ref None))
326 | _ -> ()
327 end;
328 (* Force check of well-formedness WHY? *)
329 (* unify_pat pat.pat_env pat
330 (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
331 row_bound=(); row_fixed=false; row_name=None})); *)
332 | _ -> ()
333
334 let has_variants p =
335 exists_pattern
336 (function {pat_desc=Tpat_variant _} -> true | _ -> false)
337 p
338
339 (* pattern environment *)
340 type pattern_variable =
341 {
342 pv_id: Ident.t;
343 pv_type: type_expr;
344 pv_loc: Location.t;
345 pv_as_var: bool;
346 pv_attributes: attributes;
347 }
348
349 type module_variable =
350 string loc * Location.t
351
352 let pattern_variables = ref ([] : pattern_variable list)
353 let pattern_force = ref ([] : (unit -> unit) list)
354 let pattern_scope = ref (None : Annot.ident option);;
355 let allow_modules = ref false
356 let module_variables = ref ([] : module_variable list)
357 let reset_pattern scope allow =
358 pattern_variables := [];
359 pattern_force := [];
360 pattern_scope := scope;
361 allow_modules := allow;
362 module_variables := [];
363 ;;
364
365 let maybe_add_pattern_variables_ghost loc_let env pv =
366 List.fold_right
367 (fun {pv_id; _} env ->
368 let name = Ident.name pv_id in
369 if Env.bound_value name env then env
370 else begin
371 Env.enter_unbound_value name
372 (Val_unbound_ghost_recursive loc_let) env
373 end
374 ) pv env
375
376 let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty
377 attrs =
378 if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt)
379 !pattern_variables
380 then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
381 let id = Ident.create_local name.txt in
382 pattern_variables :=
383 {pv_id = id;
384 pv_type = ty;
385 pv_loc = loc;
386 pv_as_var = is_as_variable;
387 pv_attributes = attrs} :: !pattern_variables;
388 if is_module then begin
389 (* Note: unpack patterns enter a variable of the same name *)
390 if not !allow_modules then
391 raise (Error (loc, Env.empty, Modules_not_allowed));
392 module_variables := (name, loc) :: !module_variables
393 end else begin
394 (* moved to genannot *)
395 Option.iter
396 (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s)))
397 !pattern_scope
398 end;
399 id
400
401 let sort_pattern_variables vs =
402 List.sort
403 (fun {pv_id = x; _} {pv_id = y; _} ->
404 Stdlib.compare (Ident.name x) (Ident.name y))
405 vs
406
407 let enter_orpat_variables loc env p1_vs p2_vs =
408 (* unify_vars operate on sorted lists *)
409
410 let p1_vs = sort_pattern_variables p1_vs
411 and p2_vs = sort_pattern_variables p2_vs in
412
413 let rec unify_vars p1_vs p2_vs =
414 let vars vs = List.map (fun {pv_id; _} -> pv_id) vs in
415 match p1_vs, p2_vs with
416 | {pv_id = x1; pv_type = t1; _}::rem1, {pv_id = x2; pv_type = t2; _}::rem2
417 when Ident.equal x1 x2 ->
418 if x1==x2 then
419 unify_vars rem1 rem2
420 else begin
421 begin try
422 unify_var env (newvar ()) t1;
423 unify env t1 t2
424 with
425 | Unify trace ->
426 raise(Error(loc, env, Or_pattern_type_clash(x1, trace)))
427 end;
428 (x2,x1)::unify_vars rem1 rem2
429 end
430 | [],[] -> []
431 | {pv_id; _}::_, [] | [],{pv_id; _}::_ ->
432 raise (Error (loc, env, Orpat_vars (pv_id, [])))
433 | {pv_id = x; _}::_, {pv_id = y; _}::_ ->
434 let err =
435 if Ident.name x < Ident.name y
436 then Orpat_vars (x, vars p2_vs)
437 else Orpat_vars (y, vars p1_vs) in
438 raise (Error (loc, env, err)) in
439 unify_vars p1_vs p2_vs
440
441 let rec build_as_type env p =
442 match p.pat_desc with
443 Tpat_alias(p1,_, _) -> build_as_type env p1
444 | Tpat_tuple pl ->
445 let tyl = List.map (build_as_type env) pl in
446 newty (Ttuple tyl)
447 | Tpat_construct(_, cstr, pl) ->
448 let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
449 if keep then p.pat_type else
450 let tyl = List.map (build_as_type env) pl in
451 let ty_args, ty_res = instance_constructor cstr in
452 List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
453 (List.combine pl tyl) ty_args;
454 ty_res
455 | Tpat_variant(l, p', _) ->
456 let ty = Option.map (build_as_type env) p' in
457 newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
458 row_bound=(); row_name=None;
459 row_fixed=None; row_closed=false})
460 | Tpat_record (lpl,_) ->
461 let lbl = snd3 (List.hd lpl) in
462 if lbl.lbl_private = Private then p.pat_type else
463 let ty = newvar () in
464 let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in
465 let do_label lbl =
466 let _, ty_arg, ty_res = instance_label false lbl in
467 unify_pat env {p with pat_type = ty} ty_res;
468 let refinable =
469 lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl &&
470 match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in
471 if refinable then begin
472 let arg = List.assoc lbl.lbl_pos ppl in
473 unify_pat env {arg with pat_type = build_as_type env arg} ty_arg
474 end else begin
475 let _, ty_arg', ty_res' = instance_label false lbl in
476 unify !env ty_arg ty_arg';
477 unify_pat env p ty_res'
478 end in
479 Array.iter do_label lbl.lbl_all;
480 ty
481 | Tpat_or(p1, p2, row) ->
482 begin match row with
483 None ->
484 let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in
485 unify_pat env {p2 with pat_type = ty2} ty1;
486 ty1
487 | Some row ->
488 let row = row_repr row in
489 newty (Tvariant{row with row_closed=false; row_more=newvar()})
490 end
491 | Tpat_any | Tpat_var _ | Tpat_constant _
492 | Tpat_array _ | Tpat_lazy _ | Tpat_exception _ -> p.pat_type
493
494 let build_or_pat env loc lid =
495 let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in
496 let tyl = List.map (fun _ -> newvar()) decl.type_params in
497 let row0 =
498 let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
499 match ty.desc with
500 Tvariant row when static_row row -> row
501 | _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
502 in
503 let pats, fields =
504 List.fold_left
505 (fun (pats,fields) (l,f) ->
506 match row_field_repr f with
507 Rpresent None ->
508 (l,None) :: pats,
509 (l, Reither(true,[], true, ref None)) :: fields
510 | Rpresent (Some ty) ->
511 (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
512 pat_type=ty; pat_extra=[]; pat_attributes=[]})
513 :: pats,
514 (l, Reither(false, [ty], true, ref None)) :: fields
515 | _ -> pats, fields)
516 ([],[]) (row_repr row0).row_fields in
517 let row =
518 { row_fields = List.rev fields; row_more = newvar(); row_bound = ();
519 row_closed = false; row_fixed = None; row_name = Some (path, tyl) }
520 in
521 let ty = newty (Tvariant row) in
522 let gloc = {loc with Location.loc_ghost=true} in
523 let row' = ref {row with row_more=newvar()} in
524 let pats =
525 List.map
526 (fun (l,p) ->
527 {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;
528 pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})
529 pats
530 in
531 match pats with
532 [] ->
533 (* empty polymorphic variants: not possible with the concrete language
534 but valid at the ast level *)
535 raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
536 | pat :: pats ->
537 let r =
538 List.fold_left
539 (fun pat pat0 ->
540 {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
541 pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})
542 pat pats in
543 (path, rp { r with pat_loc = loc },ty)
544
545 let split_cases env cases =
546 let add_case lst case = function
547 | None -> lst
548 | Some c_lhs -> { case with c_lhs } :: lst
549 in
550 List.fold_right (fun ({ c_lhs; c_guard } as case) (vals, exns) ->
551 match split_pattern c_lhs with
552 | Some _, Some _ when c_guard <> None ->
553 raise (Error (c_lhs.pat_loc, env,
554 Mixed_value_and_exception_patterns_under_guard))
555 | vp, ep -> add_case vals case vp, add_case exns case ep
556 ) cases ([], [])
557
558 (* Type paths *)
559
560 let rec expand_path env p =
561 let decl =
562 try Some (Env.find_type p env) with Not_found -> None
563 in
564 match decl with
565 Some {type_manifest = Some ty} ->
566 begin match repr ty with
567 {desc=Tconstr(p,_,_)} -> expand_path env p
568 | _ -> assert false
569 end
570 | _ ->
571 let p' = Env.normalize_type_path None env p in
572 if Path.same p p' then p else expand_path env p'
573
574 let compare_type_path env tpath1 tpath2 =
575 Path.same (expand_path env tpath1) (expand_path env tpath2)
576
577 (* Records *)
578 let label_of_kind kind =
579 if kind = "record" then "field" else "constructor"
580
581 module NameChoice(Name : sig
582 type t
583 type usage
584 val type_kind: string
585 val get_name: t -> string
586 val get_type: t -> type_expr
587 val lookup_all_from_type:
588 Location.t -> usage -> Path.t -> Env.t -> (t * (unit -> unit)) list
589 val in_env: t -> bool
590 end) = struct
591 open Name
592
593 let get_type_path d =
594 match (repr (get_type d)).desc with
595 | Tconstr(p, _, _) -> p
596 | _ -> assert false
597
598 let lookup_from_type env tpath usage lid =
599 let descrs = lookup_all_from_type lid.loc usage tpath env in
600 match lid.txt with
601 | Longident.Lident s -> begin
602 match
603 List.find (fun (nd, _) -> get_name nd = s) descrs
604 with
605 | descr, use ->
606 use ();
607 descr
608 | exception Not_found ->
609 let names = List.map (fun (nd, _) -> get_name nd) descrs in
610 raise (Error (lid.loc, env,
611 Wrong_name ("", mk_expected (newvar ()),
612 type_kind, tpath, s, names)))
613 end
614 | _ -> raise Not_found
615
616 let rec unique eq acc = function
617 [] -> List.rev acc
618 | x :: rem ->
619 if List.exists (eq x) acc then unique eq acc rem
620 else unique eq (x :: acc) rem
621
622 let ambiguous_types env lbl others =
623 let tpath = get_type_path lbl in
624 let others =
625 List.map (fun (lbl, _) -> get_type_path lbl) others in
626 let tpaths = unique (compare_type_path env) [tpath] others in
627 match tpaths with
628 [_] -> []
629 | _ -> let open Printtyp in
630 wrap_printing_env ~error:true env (fun () ->
631 reset(); strings_of_paths Type tpaths)
632
633 let disambiguate_by_type env tpath lbls =
634 match lbls with
635 | (Error _ : _ result) -> raise Not_found
636 | Ok lbls ->
637 let check_type (lbl, _) =
638 let lbl_tpath = get_type_path lbl in
639 compare_type_path env tpath lbl_tpath
640 in
641 List.find check_type lbls
642
643 let disambiguate ?(warn=Location.prerr_warning) ?scope
644 usage lid env opath lbls =
645 let scope = match scope with None -> lbls | Some l -> l in
646 let lbl = match opath with
647 None ->
648 begin match lbls with
649 | (Error(loc', env', err) : _ result) ->
650 Env.lookup_error loc' env' err
651 | Ok [] -> assert false
652 | Ok((lbl, use) :: rest) ->
653 use ();
654 Printtyp.Conflicts.reset ();
655 let paths = ambiguous_types env lbl rest in
656 let expansion =
657 Format.asprintf "%t" Printtyp.Conflicts.print_explanations in
658 if paths <> [] then
659 warn lid.loc
660 (Warnings.Ambiguous_name ([Longident.last lid.txt],
661 paths, false, expansion));
662 lbl
663 end
664 | Some(tpath0, tpath, pr) ->
665 let warn_pr () =
666 let label = label_of_kind type_kind in
667 warn lid.loc
668 (Warnings.Not_principal
669 ("this type-based " ^ label ^ " disambiguation"))
670 in
671 try
672 let lbl, use = disambiguate_by_type env tpath scope in
673 use ();
674 if not pr then begin
675 (* Check if non-principal type is affecting result *)
676 match lbls with
677 | (Error _ : _ result) | Ok [] -> warn_pr ()
678 | Ok ((lbl', _use') :: rest) ->
679 let lbl_tpath = get_type_path lbl' in
680 if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
681 else
682 Printtyp.Conflicts.reset ();
683 let paths = ambiguous_types env lbl rest in
684 let expansion =
685 Format.asprintf "%t"
686 Printtyp.Conflicts.print_explanations in
687 if paths <> [] then
688 warn lid.loc
689 (Warnings.Ambiguous_name ([Longident.last lid.txt],
690 paths, false, expansion))
691 end;
692 lbl
693 with Not_found -> try
694 let lbl = lookup_from_type env tpath usage lid in
695 if in_env lbl then
696 begin
697 let s =
698 Printtyp.wrap_printing_env ~error:true env
699 (fun () -> Printtyp.string_of_path tpath) in
700 warn lid.loc
701 (Warnings.Name_out_of_scope (s, [Longident.last lid.txt], false));
702 end;
703 if not pr then warn_pr ();
704 lbl
705 with Not_found ->
706 match lbls with
707 | (Error(loc', env', err) : _ result) ->
708 Env.lookup_error loc' env' err
709 | Ok lbls ->
710 let tp = (tpath0, expand_path env tpath) in
711 let tpl =
712 List.map
713 (fun (lbl, _) ->
714 let tp0 = get_type_path lbl in
715 let tp = expand_path env tp0 in
716 (tp0, tp))
717 lbls
718 in
719 raise (Error (lid.loc, env,
720 Name_type_mismatch (type_kind, lid.txt, tp, tpl)))
721 in
722 if in_env lbl then
723 begin match scope with
724 | Ok ((lab1,_)::_) when lab1 == lbl -> ()
725 | _ ->
726 Location.prerr_warning lid.loc
727 (Warnings.Disambiguated_name(get_name lbl))
728 end;
729 lbl
730 end
731
732 let wrap_disambiguate kind ty f x =
733 try f x with Error (loc, env, Wrong_name ("",_,tk,tp,name,valid_names)) ->
734 raise (Error (loc, env, Wrong_name (kind,ty,tk,tp,name,valid_names)))
735
736 module Label = NameChoice (struct
737 type t = label_description
738 type usage = unit
739 let type_kind = "record"
740 let get_name lbl = lbl.lbl_name
741 let get_type lbl = lbl.lbl_res
742 let lookup_all_from_type loc () path env =
743 Env.lookup_all_labels_from_type ~loc path env
744 let in_env lbl =
745 match lbl.lbl_repres with
746 | Record_regular | Record_float | Record_unboxed false -> true
747 | Record_unboxed true | Record_inlined _ | Record_extension _ -> false
748 end)
749
750 let disambiguate_label_by_ids keep closed ids labels =
751 let check_ids (lbl, _) =
752 let lbls = Hashtbl.create 8 in
753 Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
754 List.for_all (Hashtbl.mem lbls) ids
755 and check_closed (lbl, _) =
756 (not closed || List.length ids = Array.length lbl.lbl_all)
757 in
758 let labels' = List.filter check_ids labels in
759 if keep && labels' = [] then (false, labels) else
760 let labels'' = List.filter check_closed labels' in
761 if keep && labels'' = [] then (false, labels') else (true, labels'')
762
763 (* Only issue warnings once per record constructor/pattern *)
764 let disambiguate_lid_a_list loc closed env opath lid_a_list =
765 let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
766 let w_pr = ref false and w_amb = ref []
767 and w_scope = ref [] and w_scope_ty = ref "" in
768 let warn loc msg =
769 let open Warnings in
770 match msg with
771 | Not_principal _ -> w_pr := true
772 | Ambiguous_name([s], l, _, ex) -> w_amb := (s, l, ex) :: !w_amb
773 | Name_out_of_scope(ty, [s], _) ->
774 w_scope := s :: !w_scope; w_scope_ty := ty
775 | _ -> Location.prerr_warning loc msg
776 in
777 let process_label lid =
778 (* Strategy for each field:
779 * collect all the labels in scope for that name
780 * if the type is known and principal, just eventually warn
781 if the real label was not in scope
782 * fail if there is no known type and no label found
783 * otherwise use other fields to reduce the list of candidates
784 * if there is no known type reduce it incrementally, so that
785 there is still at least one candidate (for error message)
786 * if the reduced list is valid, call Label.disambiguate
787 *)
788 let scope = Env.lookup_all_labels ~loc:lid.loc lid.txt env in
789 match opath, scope with
790 | None, Error(loc, env, err) ->
791 Env.lookup_error loc env err
792 | Some _, Error _ ->
793 Label.disambiguate () lid env opath scope ~warn ~scope
794 | _, Ok lbls ->
795 let (ok, lbls) =
796 match opath with
797 | Some (_, _, true) ->
798 (true, lbls) (* disambiguate only checks scope *)
799 | _ -> disambiguate_label_by_ids (opath=None) closed ids lbls
800 in
801 if ok then Label.disambiguate () lid env opath (Ok lbls) ~warn ~scope
802 else fst (List.hd lbls) (* will fail later *)
803 in
804 let lbl_a_list =
805 List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
806 if !w_pr then
807 Location.prerr_warning loc
808 (Warnings.Not_principal "this type-based record disambiguation")
809 else begin
810 match List.rev !w_amb with
811 (_,types,ex)::_ as amb ->
812 let paths =
813 List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
814 let path = List.hd paths in
815 let fst3 (x,_,_) = x in
816 if List.for_all (compare_type_path env path) (List.tl paths) then
817 Location.prerr_warning loc
818 (Warnings.Ambiguous_name (List.map fst3 amb, types, true, ex))
819 else
820 List.iter
821 (fun (s,l,ex) -> Location.prerr_warning loc
822 (Warnings.Ambiguous_name ([s],l,false, ex)))
823 amb
824 | _ -> ()
825 end;
826 if !w_scope <> [] then
827 Location.prerr_warning loc
828 (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true));
829 lbl_a_list
830
831 let rec find_record_qual = function
832 | [] -> None
833 | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
834 | _ :: rest -> find_record_qual rest
835
836 let map_fold_cont f xs k =
837 List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys)))
838 xs (fun ys -> k (List.rev ys)) []
839
840 let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list k =
841 let lbl_a_list =
842 match lid_a_list, labels with
843 ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
844 (* Special case for rebuilt syntax trees *)
845 List.map
846 (function lid, a -> match lid.txt with
847 Longident.Lident s -> lid, Hashtbl.find labels s, a
848 | _ -> assert false)
849 lid_a_list
850 | _ ->
851 let lid_a_list =
852 match find_record_qual lid_a_list with
853 None -> lid_a_list
854 | Some modname ->
855 List.map
856 (fun (lid, a as lid_a) ->
857 match lid.txt with Longident.Lident s ->
858 {lid with txt=Longident.Ldot (modname, s)}, a
859 | _ -> lid_a)
860 lid_a_list
861 in
862 disambiguate_lid_a_list loc closed env opath lid_a_list
863 in
864 (* Invariant: records are sorted in the typed tree *)
865 let lbl_a_list =
866 List.sort
867 (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
868 lbl_a_list
869 in
870 map_fold_cont type_lbl_a lbl_a_list k
871 ;;
872
873 (* Checks over the labels mentioned in a record pattern:
874 no duplicate definitions (error); properly closed (warning) *)
875
876 let check_recordpat_labels loc lbl_pat_list closed =
877 match lbl_pat_list with
878 | [] -> () (* should not happen *)
879 | (_, label1, _) :: _ ->
880 let all = label1.lbl_all in
881 let defined = Array.make (Array.length all) false in
882 let check_defined (_, label, _) =
883 if defined.(label.lbl_pos)
884 then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name))
885 else defined.(label.lbl_pos) <- true in
886 List.iter check_defined lbl_pat_list;
887 if closed = Closed
888 && Warnings.is_active (Warnings.Non_closed_record_pattern "")
889 then begin
890 let undefined = ref [] in
891 for i = 0 to Array.length all - 1 do
892 if not defined.(i) then undefined := all.(i).lbl_name :: !undefined
893 done;
894 if !undefined <> [] then begin
895 let u = String.concat ", " (List.rev !undefined) in
896 Location.prerr_warning loc (Warnings.Non_closed_record_pattern u)
897 end
898 end
899
900 (* Constructors *)
901
902 module Constructor = NameChoice (struct
903 type t = constructor_description
904 type usage = Env.constructor_usage
905 let type_kind = "variant"
906 let get_name cstr = cstr.cstr_name
907 let get_type cstr = cstr.cstr_res
908 let lookup_all_from_type loc usage path env =
909 Env.lookup_all_constructors_from_type ~loc usage path env
910 let in_env _ = true
911 end)
912
913 (* unification of a type with a tconstr with
914 freshly created arguments *)
915 let unify_head_only ~refine loc env ty constr =
916 let (_, ty_res) = instance_constructor constr in
917 let ty_res = repr ty_res in
918 match ty_res.desc with
919 | Tconstr(p,args,m) ->
920 ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m);
921 enforce_constraints !env ty_res;
922 unify_pat_types ~refine loc env ty_res ty
923 | _ -> assert false
924
925 (* Typing of patterns *)
926
927 (* "half typed" cases are produced in [type_cases] when we've just typechecked
928 the pattern but haven't type-checked the body yet.
929 At this point we might have added some type equalities to the environment,
930 but haven't yet added identifiers bound by the pattern. *)
931 type half_typed_case =
932 { typed_pat: pattern;
933 pat_type_for_unif: type_expr;
934 untyped_case: Parsetree.case;
935 branch_env: Env.t;
936 pat_vars: pattern_variable list;
937 unpacks: module_variable list;
938 contains_gadt: bool; }
939
940 let rec has_literal_pattern p = match p.ppat_desc with
941 | Ppat_constant _
942 | Ppat_interval _ ->
943 true
944 | Ppat_any
945 | Ppat_variant (_, None)
946 | Ppat_construct (_, None)
947 | Ppat_type _
948 | Ppat_var _
949 | Ppat_unpack _
950 | Ppat_extension _ ->
951 false
952 | Ppat_exception p
953 | Ppat_variant (_, Some p)
954 | Ppat_construct (_, Some p)
955 | Ppat_constraint (p, _)
956 | Ppat_alias (p, _)
957 | Ppat_lazy p
958 | Ppat_open (_, p) ->
959 has_literal_pattern p
960 | Ppat_tuple ps
961 | Ppat_array ps ->
962 List.exists has_literal_pattern ps
963 | Ppat_record (ps, _) ->
964 List.exists (fun (_,p) -> has_literal_pattern p) ps
965 | Ppat_or (p, q) ->
966 has_literal_pattern p || has_literal_pattern q
967
968 let check_scope_escape loc env level ty =
969 try Ctype.check_scope_escape env level ty
970 with Unify trace ->
971 raise(Error(loc, env, Pattern_type_clash(trace, None)))
972
973 type pattern_checking_mode =
974 | Normal
975 (** We are checking user code. *)
976 | Counter_example of counter_example_checking_info
977 (** In [Counter_example] mode, we are checking a counter-example
978 candidate produced by Parmatch. This is a syntactic pattern that
979 represents a set of values by using or-patterns (p_1 | ... | p_n)
980 to enumerate all alternatives in the counter-example
981 search. These or-patterns occur at every choice point, possibly
982 deep inside the pattern.
983
984 Parmatch does not use type information, so this pattern may
985 exhibit two issues:
986 - some parts of the pattern may be ill-typed due to GADTs, and
987 - some wildcard patterns may not match any values: their type is
988 empty.
989
990 The aim of [type_pat] in the [Counter_example] mode is to refine
991 this syntactic pattern into a well-typed pattern, and ensure
992 that it matches at least one concrete value.
993 - It filters ill-typed branches of or-patterns.
994 (see {!splitting_mode} below)
995 - It tries to check that wildcard patterns are non-empty.
996 (see {!explosion_fuel})
997 *)
998
999 and counter_example_checking_info = {
1000 explosion_fuel: int;
1001 splitting_mode: splitting_mode;
1002 constrs: (string, Types.constructor_description) Hashtbl.t;
1003 labels: (string, Types.label_description) Hashtbl.t;
1004 }
1005 (**
1006 [explosion_fuel] controls the checking of wildcard patterns. We
1007 eliminate potentially-empty wildcard patterns by exploding them
1008 into concrete sub-patterns, for example (K1 _ | K2 _) or
1009 { l1: _; l2: _ }. [explosion_fuel] is the depth limit on wildcard
1010 explosion. Such depth limit is required to avoid non-termination
1011 and compilation-time blowups.
1012
1013 [splitting_mode] controls the handling of or-patterns. In
1014 [Counter_example] mode, we only need to select one branch that
1015 leads to a well-typed pattern. Checking all branches is expensive,
1016 we use different search strategies (see {!splitting_mode}) to
1017 reduce the number of explored alternatives.
1018
1019 [constrs] and [labels] contain metadata produced by [Parmatch] to
1020 type-check the given syntactic pattern. [Parmatch] produces
1021 counter-examples by turning typed patterns into
1022 [Parsetree.pattern]. In this process, constructor and label paths
1023 are lost, and are replaced by generated strings. [constrs] and
1024 [labels] map those synthetic names back to the typed descriptions
1025 of the original names.
1026 *)
1027
1028 (** Due to GADT constraints, an or-pattern produced within
1029 a counter-example may have ill-typed branches. Consider for example
1030
1031 type _ tag = Int : int tag | Bool : bool tag
1032
1033 then [Parmatch] will propose the or-pattern [Int | Bool] whenever
1034 a pattern of type [tag] is required to form a counter-example. For
1035 example, a function expects a (int tag option) and only [None] is
1036 handled by the user-written pattern. [Some (Int | Bool)] is not
1037 well-typed in this context, only the sub-pattern [Some Int] is.
1038 In this example, the expected type coming from the context
1039 suffices to know which or-pattern branch must be chosen.
1040
1041 In the general case, choosing a branch can have non-local effects
1042 on the typability of the term. For example, consider a tuple type
1043 ['a tag * ...'a...], where the first component is a GADT. All
1044 constructor choices for this GADT lead to a well-typed branch in
1045 isolation (['a] is unconstrained), but choosing one of them adds
1046 a constraint on ['a] that may make the other tuple elements
1047 ill-typed.
1048
1049 In general, after choosing each possible branch of the or-pattern,
1050 [type_pat] has to check the rest of the pattern to tell if this
1051 choice leads to a well-typed term. This may lead to an explosion
1052 of typing/search work -- the rest of the term may in turn contain
1053 alternatives.
1054
1055 We use careful strategies to try to limit counterexample-checking
1056 time; [splitting_mode] represents those strategies.
1057 *)
1058 and splitting_mode =
1059 | Backtrack_or
1060 (** Always backtrack in or-patterns.
1061
1062 [Backtrack_or] selects a single alternative from an or-pattern
1063 by using backtracking, trying to choose each branch in turn, and
1064 to complete it into a valid sub-pattern. We call this
1065 "splitting" the or-pattern.
1066
1067 We use this mode when looking for unused patterns or sub-patterns,
1068 in particular to check a refutation clause (p -> .).
1069 *)
1070 | Refine_or of { inside_nonsplit_or: bool; }
1071 (** Only backtrack when needed.
1072
1073 [Refine_or] tries another approach for refining or-pattern.
1074
1075 Instead of always splitting each or-pattern, It first attempts to
1076 find branches that do not introduce new constraints (because they
1077 do not contain GADT constructors). Those branches are such that,
1078 if they fail, all other branches will fail.
1079
1080 If we find one such branch, we attempt to complete the subpattern
1081 (checking what's outside the or-pattern), ignoring other
1082 branches -- we never consider another branch choice again. If all
1083 branches are constrained, it falls back to splitting the
1084 or-pattern.
1085
1086 We use this mode when checking exhaustivity of pattern matching.
1087 *)
1088
1089 (** This exception is only used internally within [type_pat_aux], to jump
1090 back to the parent or-pattern in the [Refine_or] strategy.
1091
1092 Such a parent exists precisely when [inside_nonsplit_or = true];
1093 it's an invariant that we always setup an exception handler for
1094 [Need_backtrack] when we set this flag. *)
1095 exception Need_backtrack
1096
1097 (** Remember current typing state for backtracking.
1098 No variable information, as we only backtrack on
1099 patterns without variables (cf. assert statements). *)
1100 type state =
1101 { snapshot: Btype.snapshot;
1102 levels: Ctype.levels;
1103 env: Env.t; }
1104 let save_state env =
1105 { snapshot = Btype.snapshot ();
1106 levels = Ctype.save_levels ();
1107 env = !env; }
1108 let set_state s env =
1109 Btype.backtrack s.snapshot;
1110 Ctype.set_levels s.levels;
1111 env := s.env
1112
1113 (** Find the first alternative in the tree of or-patterns for which
1114 [f] does not raise an error. If all fail, the last error is
1115 propagated *)
1116 let rec find_valid_alternative f pat =
1117 match pat.ppat_desc with
1118 | Ppat_or(p1,p2) ->
1119 (try find_valid_alternative f p1
1120 with Error _ -> find_valid_alternative f p2)
1121 | _ -> f pat
1122
1123 let no_explosion = function
1124 | Normal -> Normal
1125 | Counter_example info ->
1126 Counter_example { info with explosion_fuel = 0 }
1127
1128 let get_splitting_mode = function
1129 | Normal -> None
1130 | Counter_example {splitting_mode} -> Some splitting_mode
1131
1132 let enter_nonsplit_or mode = match mode with
1133 | Normal -> Normal
1134 | Counter_example info ->
1135 let splitting_mode = match info.splitting_mode with
1136 | Backtrack_or ->
1137 (* in Backtrack_or mode, or-patterns are always split *)
1138 assert false
1139 | Refine_or _ ->
1140 Refine_or {inside_nonsplit_or = true}
1141 in Counter_example { info with splitting_mode }
1142
1143 let rec type_pat ?(exception_allowed=false) ~no_existentials ~mode
1144 ~env sp expected_ty k =
1145 Builtin_attributes.warning_scope sp.ppat_attributes
1146 (fun () ->
1147 type_pat_aux ~exception_allowed ~no_existentials ~mode
1148 ~env sp expected_ty k
1149 )
1150
1151 and type_pat_aux ~exception_allowed ~no_existentials ~mode
1152 ~env sp expected_ty k =
1153 let type_pat ?(exception_allowed=false) ?(mode=mode) ?(env=env) =
1154 type_pat ~exception_allowed ~no_existentials ~mode ~env
1155 in
1156 let loc = sp.ppat_loc in
1157 let refine = match mode with Normal -> false | Counter_example _ -> true in
1158 let rup k x =
1159 if mode = Normal then (ignore (rp x));
1160 unify_pat ~refine env x (instance expected_ty);
1161 k x
1162 in
1163 let rp k x : pattern = if mode = Normal then k (rp x) else k x in
1164 let construction_not_used_in_counterexamples = (mode = Normal) in
1165 let must_backtrack_on_gadt = match get_splitting_mode mode with
1166 | None -> false
1167 | Some Backtrack_or -> false
1168 | Some (Refine_or {inside_nonsplit_or}) -> inside_nonsplit_or
1169 in
1170 match sp.ppat_desc with
1171 Ppat_any ->
1172 let k' d = rp k {
1173 pat_desc = d;
1174 pat_loc = loc; pat_extra=[];
1175 pat_type = instance expected_ty;
1176 pat_attributes = sp.ppat_attributes;
1177 pat_env = !env }
1178 in
1179 begin match mode with
1180 | Normal -> k' Tpat_any
1181 | Counter_example {explosion_fuel; _} when explosion_fuel <= 0 ->
1182 k' Tpat_any
1183 | Counter_example ({explosion_fuel; _} as info) ->
1184 begin match Parmatch.ppat_of_type !env expected_ty with
1185 | exception Parmatch.Empty -> raise (Error (loc, !env, Empty_pattern))
1186 | (sp, constrs, labels) ->
1187 if sp.ppat_desc = Parsetree.Ppat_any then k' Tpat_any else
1188 if must_backtrack_on_gadt then raise Need_backtrack else
1189 let explosion_fuel =
1190 match sp.ppat_desc with
1191 Parsetree.Ppat_or _ -> explosion_fuel - 5
1192 | _ -> explosion_fuel - 1
1193 in
1194 let mode =
1195 Counter_example { info with explosion_fuel; constrs; labels }
1196 in
1197 type_pat ~mode sp expected_ty k
1198 end
1199 end
1200 | Ppat_var name ->
1201 let ty = instance expected_ty in
1202 let id = (* PR#7330 *)
1203 if name.txt = "*extension*" then
1204 Ident.create_local name.txt
1205 else
1206 enter_variable loc name ty sp.ppat_attributes
1207 in
1208 rp k {
1209 pat_desc = Tpat_var (id, name);
1210 pat_loc = loc; pat_extra=[];
1211 pat_type = ty;
1212 pat_attributes = sp.ppat_attributes;
1213 pat_env = !env }
1214 | Ppat_unpack name ->
1215 assert construction_not_used_in_counterexamples;
1216 let t = instance expected_ty in
1217 begin match name.txt with
1218 | None ->
1219 rp k {
1220 pat_desc = Tpat_any;
1221 pat_loc = sp.ppat_loc;
1222 pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes];
1223 pat_type = t;
1224 pat_attributes = [];
1225 pat_env = !env }
1226 | Some s ->
1227 let v = { name with txt = s } in
1228 let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in
1229 rp k {
1230 pat_desc = Tpat_var (id, v);
1231 pat_loc = sp.ppat_loc;
1232 pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
1233 pat_type = t;
1234 pat_attributes = [];
1235 pat_env = !env }
1236 end
1237 | Ppat_constraint(
1238 {ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs},
1239 ({ptyp_desc=Ptyp_poly _} as sty)) ->
1240 (* explicitly polymorphic type *)
1241 assert construction_not_used_in_counterexamples;
1242 let cty, force = Typetexp.transl_simple_type_delayed !env sty in
1243 let ty = cty.ctyp_type in
1244 unify_pat_types ~refine lloc env ty (instance expected_ty);
1245 pattern_force := force :: !pattern_force;
1246 begin match ty.desc with
1247 | Tpoly (body, tyl) ->
1248 begin_def ();
1249 let _, ty' = instance_poly ~keep_names:true false tyl body in
1250 end_def ();
1251 generalize ty';
1252 let id = enter_variable lloc name ty' attrs in
1253 rp k {
1254 pat_desc = Tpat_var (id, name);
1255 pat_loc = lloc;
1256 pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
1257 pat_type = ty;
1258 pat_attributes = [];
1259 pat_env = !env
1260 }
1261 | _ -> assert false
1262 end
1263 | Ppat_alias(sq, name) ->
1264 assert construction_not_used_in_counterexamples;
1265 type_pat sq expected_ty (fun q ->
1266 begin_def ();
1267 let ty_var = build_as_type env q in
1268 end_def ();
1269 generalize ty_var;
1270 let id =
1271 enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes
1272 in
1273 rp k {
1274 pat_desc = Tpat_alias(q, id, name);
1275 pat_loc = loc; pat_extra=[];
1276 pat_type = q.pat_type;
1277 pat_attributes = sp.ppat_attributes;
1278 pat_env = !env })
1279 | Ppat_constant cst ->
1280 let cst = constant_or_raise !env loc cst in
1281 rup k {
1282 pat_desc = Tpat_constant cst;
1283 pat_loc = loc; pat_extra=[];
1284 pat_type = type_constant cst;
1285 pat_attributes = sp.ppat_attributes;
1286 pat_env = !env }
1287 | Ppat_interval (Pconst_char c1, Pconst_char c2) ->
1288 let open Ast_helper.Pat in
1289 let gloc = {loc with Location.loc_ghost=true} in
1290 let rec loop c1 c2 =
1291 if c1 = c2 then constant ~loc:gloc (Pconst_char c1)
1292 else
1293 or_ ~loc:gloc
1294 (constant ~loc:gloc (Pconst_char c1))
1295 (loop (Char.chr(Char.code c1 + 1)) c2)
1296 in
1297 let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
1298 let p = {p with ppat_loc=loc} in
1299 type_pat ~mode:(no_explosion mode) p expected_ty k
1300 (* TODO: record 'extra' to remember about interval *)
1301 | Ppat_interval _ ->
1302 raise (Error (loc, !env, Invalid_interval))
1303 | Ppat_tuple spl ->
1304 assert (List.length spl >= 2);
1305 let spl_ann = List.map (fun p -> (p,newgenvar ())) spl in
1306 let ty = newgenty (Ttuple(List.map snd spl_ann)) in
1307 begin_def ();
1308 let expected_ty = instance expected_ty in
1309 end_def ();
1310 generalize_structure expected_ty;
1311 unify_pat_types ~refine loc env ty expected_ty;
1312 map_fold_cont (fun (p,t) -> type_pat p t) spl_ann (fun pl ->
1313 rp k {
1314 pat_desc = Tpat_tuple pl;
1315 pat_loc = loc; pat_extra=[];
1316 pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
1317 pat_attributes = sp.ppat_attributes;
1318 pat_env = !env })
1319 | Ppat_construct(lid, sarg) ->
1320 let opath =
1321 try
1322 let (p0, p, _) = extract_concrete_variant !env expected_ty in
1323 Some (p0, p, true)
1324 with Not_found -> None
1325 in
1326 let constr =
1327 match lid.txt, mode with
1328 | Longident.Lident s, Counter_example {constrs; _} ->
1329 (* assert: cf. {!counter_example_checking_info} documentation *)
1330 assert (Hashtbl.mem constrs s);
1331 Hashtbl.find constrs s
1332 | _ ->
1333 let candidates =
1334 Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env in
1335 wrap_disambiguate "This variant pattern is expected to have"
1336 (mk_expected expected_ty)
1337 (Constructor.disambiguate Env.Pattern lid !env opath) candidates
1338 in
1339 if constr.cstr_generalized && must_backtrack_on_gadt then
1340 raise Need_backtrack;
1341 begin match no_existentials, constr.cstr_existentials with
1342 | None, _ | _, [] -> ()
1343 | Some r, (_ :: _ as exs) ->
1344 let exs = List.map (Ctype.existential_name constr) exs in
1345 let name = constr.cstr_name in
1346 raise (Error (loc, !env, Unexpected_existential (r,name, exs)))
1347 end;
1348 (* if constructor is gadt, we must verify that the expected type has the
1349 correct head *)
1350 if constr.cstr_generalized then
1351 unify_head_only ~refine loc env (instance expected_ty) constr;
1352 let sargs =
1353 match sarg with
1354 None -> []
1355 | Some {ppat_desc = Ppat_tuple spl} when
1356 constr.cstr_arity > 1 ||
1357 Builtin_attributes.explicit_arity sp.ppat_attributes
1358 -> spl
1359 | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 ->
1360 if constr.cstr_arity = 0 then
1361 Location.prerr_warning sp.ppat_loc
1362 Warnings.Wildcard_arg_to_constant_constr;
1363 replicate_list sp constr.cstr_arity
1364 | Some sp -> [sp] in
1365 if Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes then
1366 begin match List.filter has_literal_pattern sargs with
1367 | sp :: _ ->
1368 Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern
1369 | _ -> ()
1370 end;
1371 if List.length sargs <> constr.cstr_arity then
1372 raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
1373 constr.cstr_arity, List.length sargs)));
1374 begin_def ();
1375 let (ty_args, ty_res) =
1376 instance_constructor ~in_pattern:(env, get_gadt_equations_level ())
1377 constr
1378 in
1379 let expected_ty = instance expected_ty in
1380 (* PR#7214: do not use gadt unification for toplevel lets *)
1381 unify_pat_types loc env ty_res expected_ty
1382 ~refine:(refine || constr.cstr_generalized && no_existentials = None);
1383 end_def ();
1384 generalize_structure expected_ty;
1385 generalize_structure ty_res;
1386 List.iter generalize_structure ty_args;
1387
1388 let rec check_non_escaping p =
1389 match p.ppat_desc with
1390 | Ppat_or (p1, p2) ->
1391 check_non_escaping p1;
1392 check_non_escaping p2
1393 | Ppat_alias (p, _) ->
1394 check_non_escaping p
1395 | Ppat_constraint _ ->
1396 raise (Error (p.ppat_loc, !env, Inlined_record_escape))
1397 | _ ->
1398 ()
1399 in
1400 if constr.cstr_inlined <> None then List.iter check_non_escaping sargs;
1401
1402 map_fold_cont (fun (p,t) -> type_pat p t) (List.combine sargs ty_args)
1403 (fun args ->
1404 rp k {
1405 pat_desc=Tpat_construct(lid, constr, args);
1406 pat_loc = loc; pat_extra=[];
1407 pat_type = instance expected_ty;
1408 pat_attributes = sp.ppat_attributes;
1409 pat_env = !env })
1410 | Ppat_variant(l, sarg) ->
1411 let arg_type = match sarg with None -> [] | Some _ -> [newgenvar()] in
1412 let row = { row_fields =
1413 [l, Reither(sarg = None, arg_type, true, ref None)];
1414 row_bound = ();
1415 row_closed = false;
1416 row_more = newgenvar ();
1417 row_fixed = None;
1418 row_name = None } in
1419 begin_def ();
1420 let expected_ty = instance expected_ty in
1421 end_def ();
1422 generalize_structure expected_ty;
1423 (* PR#7404: allow some_private_tag blindly, as it would not unify with
1424 the abstract row variable *)
1425 if l = Parmatch.some_private_tag
1426 then assert (match mode with Normal -> false | Counter_example _ -> true)
1427 else unify_pat_types ~refine loc env (newgenty(Tvariant row)) expected_ty;
1428 let k arg =
1429 rp k {
1430 pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
1431 pat_loc = loc; pat_extra=[];
1432 pat_type = instance expected_ty;
1433 pat_attributes = sp.ppat_attributes;
1434 pat_env = !env }
1435 in begin
1436 (* PR#6235: propagate type information *)
1437 match sarg, arg_type with
1438 Some p, [ty] -> type_pat p ty (fun p -> k (Some p))
1439 | _ -> k None
1440 end
1441 | Ppat_record(lid_sp_list, closed) ->
1442 assert (lid_sp_list <> []);
1443 let opath, record_ty =
1444 try
1445 let (p0, p,_) = extract_concrete_record !env expected_ty in
1446 begin_def ();
1447 let ty = instance expected_ty in
1448 end_def ();
1449 generalize_structure ty;
1450 Some (p0, p, true), ty
1451 with Not_found -> None, newvar ()
1452 in
1453 let type_label_pat (label_lid, label, sarg) k =
1454 begin_def ();
1455 let (_, ty_arg, ty_res) = instance_label false label in
1456 begin try
1457 unify_pat_types ~refine loc env ty_res (instance record_ty)
1458 with Error(_loc, _env, Pattern_type_clash(trace, _)) ->
1459 raise(Error(label_lid.loc, !env,
1460 Label_mismatch(label_lid.txt, trace)))
1461 end;
1462 end_def ();
1463 generalize_structure ty_res;
1464 generalize_structure ty_arg;
1465 type_pat sarg ty_arg (fun arg ->
1466 k (label_lid, label, arg))
1467 in
1468 let k' k lbl_pat_list =
1469 check_recordpat_labels loc lbl_pat_list closed;
1470 rup k {
1471 pat_desc = Tpat_record (lbl_pat_list, closed);
1472 pat_loc = loc; pat_extra=[];
1473 pat_type = instance record_ty;
1474 pat_attributes = sp.ppat_attributes;
1475 pat_env = !env }
1476 in
1477 begin match mode with
1478 | Normal ->
1479 k (wrap_disambiguate "This record pattern is expected to have"
1480 (mk_expected expected_ty)
1481 (type_label_a_list loc false !env type_label_pat opath
1482 lid_sp_list)
1483 (k' (fun x -> x)))
1484 | Counter_example {labels; _} ->
1485 type_label_a_list ~labels loc false !env type_label_pat opath
1486 lid_sp_list (k' k)
1487 end
1488 | Ppat_array spl ->
1489 let ty_elt = newgenvar() in
1490 begin_def ();
1491 let expected_ty = instance expected_ty in
1492 end_def ();
1493 generalize_structure expected_ty;
1494 unify_pat_types ~refine
1495 loc env (Predef.type_array ty_elt) expected_ty;
1496 map_fold_cont (fun p -> type_pat p ty_elt) spl (fun pl ->
1497 rp k {
1498 pat_desc = Tpat_array pl;
1499 pat_loc = loc; pat_extra=[];
1500 pat_type = instance expected_ty;
1501 pat_attributes = sp.ppat_attributes;
1502 pat_env = !env })
1503 | Ppat_or(sp1, sp2) ->
1504 let may_split, must_split =
1505 match get_splitting_mode mode with
1506 | None -> false, false
1507 | Some Backtrack_or -> true, true
1508 | Some (Refine_or _) -> true, false in
1509 let state = save_state env in
1510 let split_or sp =
1511 assert may_split;
1512 let typ pat = type_pat ~exception_allowed pat expected_ty k in
1513 find_valid_alternative (fun pat -> set_state state env; typ pat) sp in
1514 if must_split then split_or sp else begin
1515 let initial_pattern_variables = !pattern_variables in
1516 let initial_module_variables = !module_variables in
1517 let equation_level = !gadt_equations_level in
1518 let outter_lev = get_current_level () in
1519 (* introduce a new scope *)
1520 begin_def ();
1521 let lev = get_current_level () in
1522 gadt_equations_level := Some lev;
1523 let env1 = ref !env in
1524 let inside_or = enter_nonsplit_or mode in
1525 let p1 =
1526 try Some (type_pat ~exception_allowed ~mode:inside_or
1527 sp1 expected_ty ~env:env1 (fun x -> x))
1528 with Need_backtrack -> None in
1529 let p1_variables = !pattern_variables in
1530 let p1_module_variables = !module_variables in
1531 pattern_variables := initial_pattern_variables;
1532 module_variables := initial_module_variables;
1533 let env2 = ref !env in
1534 let p2 =
1535 try Some (type_pat ~exception_allowed ~mode:inside_or
1536 sp2 expected_ty ~env:env2 (fun x -> x))
1537 with Need_backtrack -> None in
1538 end_def ();
1539 gadt_equations_level := equation_level;
1540 let p2_variables = !pattern_variables in
1541 (* Make sure no variable with an ambiguous type gets added to the
1542 environment. *)
1543 List.iter (fun { pv_type; pv_loc; _ } ->
1544 check_scope_escape pv_loc !env1 outter_lev pv_type
1545 ) p1_variables;
1546 List.iter (fun { pv_type; pv_loc; _ } ->
1547 check_scope_escape pv_loc !env2 outter_lev pv_type
1548 ) p2_variables;
1549 begin match p1, p2 with
1550 | None, None ->
1551 let inside_nonsplit_or =
1552 match get_splitting_mode mode with
1553 | None | Some Backtrack_or -> false
1554 | Some (Refine_or {inside_nonsplit_or}) -> inside_nonsplit_or in
1555 if inside_nonsplit_or
1556 then raise Need_backtrack
1557 else split_or sp
1558 | Some p, None | None, Some p -> rp k p (* no variables in this case *)
1559 | Some p1, Some p2 ->
1560 let alpha_env =
1561 enter_orpat_variables loc !env p1_variables p2_variables in
1562 pattern_variables := p1_variables;
1563 module_variables := p1_module_variables;
1564 rp k { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
1565 pat_loc = loc;
1566 pat_extra=[];
1567 pat_type = instance expected_ty;
1568 pat_attributes = sp.ppat_attributes;
1569 pat_env = !env }
1570 end
1571 end
1572 | Ppat_lazy sp1 ->
1573 let nv = newgenvar () in
1574 unify_pat_types ~refine loc env (Predef.type_lazy_t nv) expected_ty;
1575 (* do not explode under lazy: PR#7421 *)
1576 type_pat ~mode:(no_explosion mode) sp1 nv (fun p1 ->
1577 rp k {
1578 pat_desc = Tpat_lazy p1;
1579 pat_loc = loc; pat_extra=[];
1580 pat_type = instance expected_ty;
1581 pat_attributes = sp.ppat_attributes;
1582 pat_env = !env })
1583 | Ppat_constraint(sp, sty) ->
1584 (* Pretend separate = true *)
1585 begin_def();
1586 let cty, force = Typetexp.transl_simple_type_delayed !env sty in
1587 let ty = cty.ctyp_type in
1588 end_def();
1589 generalize_structure ty;
1590 let ty, expected_ty' = instance ty, ty in
1591 unify_pat_types ~refine loc env ty (instance expected_ty);
1592 type_pat ~exception_allowed sp expected_ty' (fun p ->
1593 (*Format.printf "%a@.%a@."
1594 Printtyp.raw_type_expr ty
1595 Printtyp.raw_type_expr p.pat_type;*)
1596 pattern_force := force :: !pattern_force;
1597 let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
1598 let p =
1599 match p.pat_desc with
1600 Tpat_var (id,s) ->
1601 {p with pat_type = ty;
1602 pat_desc = Tpat_alias
1603 ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
1604 pat_extra = [extra];
1605 }
1606 | _ -> {p with pat_type = ty;
1607 pat_extra = extra :: p.pat_extra}
1608 in k p)
1609 | Ppat_type lid ->
1610 let (path, p,ty) = build_or_pat !env loc lid in
1611 unify_pat_types ~refine loc env ty (instance expected_ty);
1612 k { p with pat_extra =
1613 (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
1614 | Ppat_open (lid,p) ->
1615 let path, new_env =
1616 !type_open Asttypes.Fresh !env sp.ppat_loc lid in
1617 let new_env = ref new_env in
1618 type_pat ~exception_allowed ~env:new_env p expected_ty ( fun p ->
1619 env := Env.copy_local !env ~from:!new_env;
1620 k { p with pat_extra =( Tpat_open (path,lid,!new_env),
1621 loc, sp.ppat_attributes) :: p.pat_extra }
1622 )
1623 | Ppat_exception p ->
1624 if not exception_allowed then
1625 raise (Error (loc, !env, Exception_pattern_disallowed))
1626 else begin
1627 type_pat p Predef.type_exn (fun p_exn ->
1628 rp k {
1629 pat_desc = Tpat_exception p_exn;
1630 pat_loc = sp.ppat_loc;
1631 pat_extra = [];
1632 pat_type = expected_ty;
1633 pat_env = !env;
1634 pat_attributes = sp.ppat_attributes;
1635 })
1636 end
1637 | Ppat_extension ext ->
1638 raise (Error_forward (Builtin_attributes.error_of_extension ext))
1639
1640 let type_pat ?exception_allowed ?no_existentials ?(mode=Normal)
1641 ?(lev=get_current_level()) env sp expected_ty =
1642 Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () ->
1643 let r =
1644 type_pat ?exception_allowed ~no_existentials ~mode
1645 ~env sp expected_ty (fun x -> x)
1646 in
1647 iter_pattern (fun p -> p.pat_env <- !env) r;
1648 r
1649 )
1650
1651 (* this function is passed to Partial.parmatch
1652 to type check gadt nonexhaustiveness *)
1653 let partial_pred ~lev ~splitting_mode ?(explode=0)
1654 env expected_ty constrs labels p =
1655 let env = ref env in
1656 let state = save_state env in
1657 let mode =
1658 Counter_example {
1659 splitting_mode;
1660 explosion_fuel = explode;
1661 constrs; labels;
1662 } in
1663 try
1664 reset_pattern None true;
1665 let typed_p =
1666 Ctype.with_passive_variants (type_pat ~lev ~mode env p) expected_ty
1667 in
1668 set_state state env;
1669 (* types are invalidated but we don't need them here *)
1670 Some typed_p
1671 with Error _ ->
1672 set_state state env;
1673 None
1674
1675 let check_partial ?(lev=get_current_level ()) env expected_ty loc cases =
1676 let explode = match cases with [_] -> 5 | _ -> 0 in
1677 let splitting_mode = Refine_or {inside_nonsplit_or = false} in
1678 Parmatch.check_partial
1679 (partial_pred ~lev ~splitting_mode ~explode env expected_ty) loc cases
1680
1681 let check_unused ?(lev=get_current_level ()) env expected_ty cases =
1682 Parmatch.check_unused
1683 (fun refute constrs labels spat ->
1684 match
1685 partial_pred ~lev ~splitting_mode:Backtrack_or ~explode:5
1686 env expected_ty constrs labels spat
1687 with
1688 Some pat when refute ->
1689 raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat))
1690 | r -> r)
1691 cases
1692
1693 let iter_pattern_variables_type f : pattern_variable list -> unit =
1694 List.iter (fun {pv_type; _} -> f pv_type)
1695
1696 let add_pattern_variables ?check ?check_as env pv =
1697 List.fold_right
1698 (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env ->
1699 let check = if pv_as_var then check_as else check in
1700 Env.add_value ?check pv_id
1701 {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc;
1702 val_attributes = pv_attributes;
1703 } env
1704 )
1705 pv env
1706
1707 let type_pattern ?exception_allowed ~lev env spat scope expected_ty =
1708 reset_pattern scope true;
1709 let new_env = ref env in
1710 let pat = type_pat ?exception_allowed ~lev new_env spat expected_ty in
1711 let pvs = get_ref pattern_variables in
1712 let unpacks = get_ref module_variables in
1713 (pat, !new_env, get_ref pattern_force, pvs, unpacks)
1714
1715 let type_pattern_list no_existentials env spatl scope expected_tys allow =
1716 reset_pattern scope allow;
1717 let new_env = ref env in
1718 let type_pat (attrs, pat) ty =
1719 Builtin_attributes.warning_scope ~ppwarning:false attrs
1720 (fun () ->
1721 type_pat ~no_existentials new_env pat ty
1722 )
1723 in
1724 let patl = List.map2 type_pat spatl expected_tys in
1725 let pvs = get_ref pattern_variables in
1726 let unpacks = get_ref module_variables in
1727 let new_env = add_pattern_variables !new_env pvs in
1728 (patl, new_env, get_ref pattern_force, pvs, unpacks)
1729
1730 let type_class_arg_pattern cl_num val_env met_env l spat =
1731 reset_pattern None false;
1732 let nv = newvar () in
1733 let pat = type_pat ~no_existentials:In_class_args (ref val_env) spat nv in
1734 if has_variants pat then begin
1735 Parmatch.pressure_variants val_env [pat];
1736 iter_pattern finalize_variant pat
1737 end;
1738 List.iter (fun f -> f()) (get_ref pattern_force);
1739 if is_optional l then unify_pat (ref val_env) pat (type_option (newvar ()));
1740 let (pv, met_env) =
1741 List.fold_right
1742 (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} (pv, env) ->
1743 let check s =
1744 if pv_as_var then Warnings.Unused_var s
1745 else Warnings.Unused_var_strict s in
1746 let id' = Ident.create_local (Ident.name pv_id) in
1747 ((id', pv_id, pv_type)::pv,
1748 Env.add_value id' {val_type = pv_type;
1749 val_kind = Val_ivar (Immutable, cl_num);
1750 val_attributes = pv_attributes;
1751 Types.val_loc = pv_loc;
1752 } ~check
1753 env))
1754 !pattern_variables ([], met_env)
1755 in
1756 let val_env = add_pattern_variables val_env (get_ref pattern_variables) in
1757 (pat, pv, val_env, met_env)
1758
1759 let type_self_pattern cl_num privty val_env met_env par_env spat =
1760 let open Ast_helper in
1761 let spat =
1762 Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")),
1763 mknoloc ("selfpat-" ^ cl_num)))
1764 in
1765 reset_pattern None false;
1766 let nv = newvar() in
1767 let pat = type_pat ~no_existentials:In_self_pattern (ref val_env) spat nv in
1768 List.iter (fun f -> f()) (get_ref pattern_force);
1769 let meths = ref Meths.empty in
1770 let vars = ref Vars.empty in
1771 let pv = !pattern_variables in
1772 pattern_variables := [];
1773 let (val_env, met_env, par_env) =
1774 List.fold_right
1775 (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
1776 (val_env, met_env, par_env) ->
1777 let name = Ident.name pv_id in
1778 (Env.enter_unbound_value name Val_unbound_self val_env,
1779 Env.add_value pv_id {val_type = pv_type;
1780 val_kind =
1781 Val_self (meths, vars, cl_num, privty);
1782 val_attributes = pv_attributes;
1783 Types.val_loc = pv_loc;
1784 }
1785 ~check:(fun s -> if pv_as_var then Warnings.Unused_var s
1786 else Warnings.Unused_var_strict s)
1787 met_env,
1788 Env.enter_unbound_value name Val_unbound_self par_env))
1789 pv (val_env, met_env, par_env)
1790 in
1791 (pat, meths, vars, val_env, met_env, par_env)
1792
1793 let delayed_checks = ref []
1794 let reset_delayed_checks () = delayed_checks := []
1795 let add_delayed_check f =
1796 delayed_checks := (f, Warnings.backup ()) :: !delayed_checks
1797
1798 let force_delayed_checks () =
1799 (* checks may change type levels *)
1800 let snap = Btype.snapshot () in
1801 let w_old = Warnings.backup () in
1802 List.iter
1803 (fun (f, w) -> Warnings.restore w; f ())
1804 (List.rev !delayed_checks);
1805 Warnings.restore w_old;
1806 reset_delayed_checks ();
1807 Btype.backtrack snap
1808
1809 let rec final_subexpression exp =
1810 match exp.exp_desc with
1811 Texp_let (_, _, e)
1812 | Texp_sequence (_, e)
1813 | Texp_try (e, _)
1814 | Texp_ifthenelse (_, e, _)
1815 | Texp_match (_, {c_rhs=e} :: _, _)
1816 | Texp_letmodule (_, _, _, _, e)
1817 | Texp_letexception (_, e)
1818 | Texp_open (_, e)
1819 -> final_subexpression e
1820 | _ -> exp
1821
1822 (* Generalization criterion for expressions *)
1823
1824 let rec is_nonexpansive exp =
1825 match exp.exp_desc with
1826 | Texp_ident _
1827 | Texp_constant _
1828 | Texp_unreachable
1829 | Texp_function _
1830 | Texp_array [] -> true
1831 | Texp_let(_rec_flag, pat_exp_list, body) ->
1832 List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
1833 is_nonexpansive body
1834 | Texp_apply(e, (_,None)::el) ->
1835 is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el)
1836 | Texp_match(e, cases, _) ->
1837 (* Not sure this is necessary, if [e] is nonexpansive then we shouldn't
1838 care if there are exception patterns. But the previous version enforced
1839 that there be none, so... *)
1840 let contains_exception_pat p =
1841 let res = ref false in
1842 iter_pattern (fun p ->
1843 match p.pat_desc with
1844 | Tpat_exception _ -> res := true
1845 | _ -> ()
1846 ) p;
1847 !res
1848 in
1849 is_nonexpansive e &&
1850 List.for_all
1851 (fun {c_lhs; c_guard; c_rhs} ->
1852 is_nonexpansive_opt c_guard && is_nonexpansive c_rhs
1853 && not (contains_exception_pat c_lhs)
1854 ) cases
1855 | Texp_tuple el ->
1856 List.for_all is_nonexpansive el
1857 | Texp_construct( _, _, el) ->
1858 List.for_all is_nonexpansive el
1859 | Texp_variant(_, arg) -> is_nonexpansive_opt arg
1860 | Texp_record { fields; extended_expression } ->
1861 Array.for_all
1862 (fun (lbl, definition) ->
1863 match definition with
1864 | Overridden (_, exp) ->
1865 lbl.lbl_mut = Immutable && is_nonexpansive exp
1866 | Kept _ -> true)
1867 fields
1868 && is_nonexpansive_opt extended_expression
1869 | Texp_field(exp, _, _) -> is_nonexpansive exp
1870 | Texp_ifthenelse(_cond, ifso, ifnot) ->
1871 is_nonexpansive ifso && is_nonexpansive_opt ifnot
1872 | Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *)
1873 | Texp_new (_, _, cl_decl) -> Ctype.class_type_arity cl_decl.cty_type > 0
1874 (* Note: nonexpansive only means no _observable_ side effects *)
1875 | Texp_lazy e -> is_nonexpansive e
1876 | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) ->
1877 let count = ref 0 in
1878 List.for_all
1879 (fun field -> match field.cf_desc with
1880 Tcf_method _ -> true
1881 | Tcf_val (_, _, _, Tcfk_concrete (_, e), _) ->
1882 incr count; is_nonexpansive e
1883 | Tcf_val (_, _, _, Tcfk_virtual _, _) ->
1884 incr count; true
1885 | Tcf_initializer e -> is_nonexpansive e
1886 | Tcf_constraint _ -> true
1887 | Tcf_inherit _ -> false
1888 | Tcf_attribute _ -> true)
1889 fields &&
1890 Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
1891 vars true &&
1892 !count = 0
1893 | Texp_letmodule (_, _, _, mexp, e)
1894 | Texp_open ({ open_expr = mexp; _}, e) ->
1895 is_nonexpansive_mod mexp && is_nonexpansive e
1896 | Texp_pack mexp ->
1897 is_nonexpansive_mod mexp
1898 (* Computations which raise exceptions are nonexpansive, since (raise e) is
1899 equivalent to (raise e; diverge), and a nonexpansive "diverge" can be
1900 produced using lazy values or the relaxed value restriction.
1901 See GPR#1142 *)
1902 | Texp_assert exp ->
1903 is_nonexpansive exp
1904 | Texp_apply (
1905 { exp_desc = Texp_ident (_, _, {val_kind =
1906 Val_prim {Primitive.prim_name =
1907 ("%raise" | "%reraise" | "%raise_notrace")}}) },
1908 [Nolabel, Some e]) ->
1909 is_nonexpansive e
1910 | Texp_array (_ :: _)
1911 | Texp_apply _
1912 | Texp_try _
1913 | Texp_setfield _
1914 | Texp_while _
1915 | Texp_for _
1916 | Texp_send _
1917 | Texp_instvar _
1918 | Texp_setinstvar _
1919 | Texp_override _
1920 | Texp_letexception _
1921 | Texp_letop _
1922 | Texp_extension_constructor _ ->
1923 false
1924
1925 and is_nonexpansive_mod mexp =
1926 match mexp.mod_desc with
1927 | Tmod_ident _
1928 | Tmod_functor _ -> true
1929 | Tmod_unpack (e, _) -> is_nonexpansive e
1930 | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m
1931 | Tmod_structure str ->
1932 List.for_all
1933 (fun item -> match item.str_desc with
1934 | Tstr_eval _ | Tstr_primitive _ | Tstr_type _
1935 | Tstr_modtype _ | Tstr_class_type _ -> true
1936 | Tstr_value (_, pat_exp_list) ->
1937 List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
1938 | Tstr_module {mb_expr=m;_}
1939 | Tstr_open {open_expr=m;_}
1940 | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m
1941 | Tstr_recmodule id_mod_list ->
1942 List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
1943 id_mod_list
1944 | Tstr_exception {tyexn_constructor = {ext_kind = Text_decl _}} ->
1945 false (* true would be unsound *)
1946 | Tstr_exception {tyexn_constructor = {ext_kind = Text_rebind _}} ->
1947 true
1948 | Tstr_typext te ->
1949 List.for_all
1950 (function {ext_kind = Text_decl _} -> false
1951 | {ext_kind = Text_rebind _} -> true)
1952 te.tyext_constructors
1953 | Tstr_class _ -> false (* could be more precise *)
1954 | Tstr_attribute _ -> true
1955 )
1956 str.str_items
1957 | Tmod_apply _ -> false
1958
1959 and is_nonexpansive_opt = function
1960 | None -> true
1961 | Some e -> is_nonexpansive e
1962
1963 let maybe_expansive e = not (is_nonexpansive e)
1964
1965 let check_recursive_bindings env valbinds =
1966 let ids = let_bound_idents valbinds in
1967 List.iter
1968 (fun {vb_expr} ->
1969 if not (Rec_check.is_valid_recursive_expression ids vb_expr) then
1970 raise(Error(vb_expr.exp_loc, env, Illegal_letrec_expr))
1971 )
1972 valbinds
1973
1974 let check_recursive_class_bindings env ids exprs =
1975 List.iter
1976 (fun expr ->
1977 if not (Rec_check.is_valid_class_expr ids expr) then
1978 raise(Error(expr.cl_loc, env, Illegal_class_expr)))
1979 exprs
1980
1981 (* Approximate the type of an expression, for better recursion *)
1982
1983 let rec approx_type env sty =
1984 match sty.ptyp_desc with
1985 Ptyp_arrow (p, _, sty) ->
1986 let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
1987 newty (Tarrow (p, ty1, approx_type env sty, Cok))
1988 | Ptyp_tuple args ->
1989 newty (Ttuple (List.map (approx_type env) args))
1990 | Ptyp_constr (lid, ctl) ->
1991 let path, decl = Env.lookup_type ~use:false ~loc:lid.loc lid.txt env in
1992 if List.length ctl <> decl.type_arity then newvar ()
1993 else begin
1994 let tyl = List.map (approx_type env) ctl in
1995 newconstr path tyl
1996 end
1997 | Ptyp_poly (_, sty) ->
1998 approx_type env sty
1999 | _ -> newvar ()
2000
2001 let rec type_approx env sexp =
2002 match sexp.pexp_desc with
2003 Pexp_let (_, _, e) -> type_approx env e
2004 | Pexp_fun (p, _, _, e) ->
2005 let ty = if is_optional p then type_option (newvar ()) else newvar () in
2006 newty (Tarrow(p, ty, type_approx env e, Cok))
2007 | Pexp_function ({pc_rhs=e}::_) ->
2008 newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok))
2009 | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
2010 | Pexp_try (e, _) -> type_approx env e
2011 | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
2012 | Pexp_ifthenelse (_,e,_) -> type_approx env e
2013 | Pexp_sequence (_,e) -> type_approx env e
2014 | Pexp_constraint (e, sty) ->
2015 let ty = type_approx env e in
2016 let ty1 = approx_type env sty in
2017 begin try unify env ty ty1 with Unify trace ->
2018 raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))
2019 end;
2020 ty1
2021 | Pexp_coerce (e, sty1, sty2) ->
2022 let approx_ty_opt = function
2023 | None -> newvar ()
2024 | Some sty -> approx_type env sty
2025 in
2026 let ty = type_approx env e
2027 and ty1 = approx_ty_opt sty1
2028 and ty2 = approx_type env sty2 in
2029 begin try unify env ty ty1 with Unify trace ->
2030 raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None)))
2031 end;
2032 ty2
2033 | _ -> newvar ()
2034
2035 (* List labels in a function type, and whether return type is a variable *)
2036 let rec list_labels_aux env visited ls ty_fun =
2037 let ty = expand_head env ty_fun in
2038 if List.memq ty visited then
2039 List.rev ls, false
2040 else match ty.desc with
2041 Tarrow (l, _, ty_res, _) ->
2042 list_labels_aux env (ty::visited) (l::ls) ty_res
2043 | _ ->
2044 List.rev ls, is_Tvar ty
2045
2046 let list_labels env ty =
2047 wrap_trace_gadt_instances env (list_labels_aux env [] []) ty
2048
2049 (* Check that all univars are safe in a type *)
2050 let check_univars env expans kind exp ty_expected vars =
2051 if expans && maybe_expansive exp then
2052 lower_contravariant env exp.exp_type;
2053 (* need to expand twice? cf. Ctype.unify2 *)
2054 let vars = List.map (expand_head env) vars in
2055 let vars = List.map (expand_head env) vars in
2056 let vars' =
2057 List.filter
2058 (fun t ->
2059 let t = repr t in
2060 generalize t;
2061 match t.desc with
2062 Tvar name when t.level = generic_level ->
2063 set_type_desc t (Tunivar name); true
2064 | _ -> false)
2065 vars in
2066 if List.length vars = List.length vars' then () else
2067 let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
2068 and ty_expected = repr ty_expected in
2069 raise (Error (exp.exp_loc, env,
2070 Less_general(kind, [Unification_trace.diff ty ty_expected])))
2071
2072 let check_partial_application statement exp =
2073 let rec f delay =
2074 let ty = (expand_head exp.exp_env exp.exp_type).desc in
2075 let check_statement () =
2076 match ty with
2077 | Tconstr (p, _, _) when Path.same p Predef.path_unit ->
2078 ()
2079 | _ ->
2080 if statement then
2081 let rec loop {exp_loc; exp_desc; exp_extra; _} =
2082 match exp_desc with
2083 | Texp_let (_, _, e)
2084 | Texp_sequence (_, e)
2085 | Texp_letexception (_, e)
2086 | Texp_letmodule (_, _, _, _, e) ->
2087 loop e
2088 | _ ->
2089 let loc =
2090 match List.find_opt (function
2091 | (Texp_constraint _, _, _) -> true
2092 | _ -> false) exp_extra
2093 with
2094 | Some (_, loc, _) -> loc
2095 | None -> exp_loc
2096 in
2097 Location.prerr_warning loc Warnings.Statement_type
2098 in
2099 loop exp
2100 in
2101 match ty, exp.exp_desc with
2102 | Tarrow _, _ ->
2103 let rec check {exp_desc; exp_loc; exp_extra; _} =
2104 if List.exists (function
2105 | (Texp_constraint _, _, _) -> true
2106 | _ -> false) exp_extra then check_statement ()
2107 else begin
2108 match exp_desc with
2109 | Texp_ident _ | Texp_constant _ | Texp_tuple _
2110 | Texp_construct _ | Texp_variant _ | Texp_record _
2111 | Texp_field _ | Texp_setfield _ | Texp_array _
2112 | Texp_while _ | Texp_for _ | Texp_instvar _
2113 | Texp_setinstvar _ | Texp_override _ | Texp_assert _
2114 | Texp_lazy _ | Texp_object _ | Texp_pack _ | Texp_unreachable
2115 | Texp_extension_constructor _ | Texp_ifthenelse (_, _, None)
2116 | Texp_function _ ->
2117 check_statement ()
2118 | Texp_match (_, cases, _) ->
2119 List.iter (fun {c_rhs; _} -> check c_rhs) cases
2120 | Texp_try (e, cases) ->
2121 check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases
2122 | Texp_ifthenelse (_, e1, Some e2) ->
2123 check e1; check e2
2124 | Texp_let (_, _, e) | Texp_sequence (_, e) | Texp_open (_, e)
2125 | Texp_letexception (_, e) | Texp_letmodule (_, _, _, _, e) ->
2126 check e
2127 | Texp_apply _ | Texp_send _ | Texp_new _ | Texp_letop _ ->
2128 Location.prerr_warning exp_loc Warnings.Partial_application
2129 end
2130 in
2131 check exp
2132 | Tvar _, _ ->
2133 if delay then add_delayed_check (fun () -> f false)
2134 | _ ->
2135 check_statement ()
2136 in
2137 f true
2138
2139 (* Check that a type is generalizable at some level *)
2140 let generalizable level ty =
2141 let rec check ty =
2142 let ty = repr ty in
2143 if ty.level < lowest_level then () else
2144 if ty.level <= level then raise Exit else
2145 (mark_type_node ty; iter_type_expr check ty)
2146 in
2147 try check ty; unmark_type ty; true
2148 with Exit -> unmark_type ty; false
2149
2150 (* Hack to allow coercion of self. Will clean-up later. *)
2151 let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
2152
2153 (* Helpers for packaged modules. *)
2154 let create_package_type loc env (p, l) =
2155 let s = !Typetexp.transl_modtype_longident loc env p in
2156 let fields = List.map (fun (name, ct) ->
2157 name, Typetexp.transl_simple_type env false ct) l in
2158 let ty = newty (Tpackage (s,
2159 List.map fst l,
2160 List.map (fun (_, cty) -> cty.ctyp_type) fields))
2161 in
2162 (s, fields, ty)
2163
2164 let wrap_unpacks sexp unpacks =
2165 let open Ast_helper in
2166 List.fold_left
2167 (fun sexp (name, loc) ->
2168 Exp.letmodule ~loc:{ sexp.pexp_loc with loc_ghost = true }
2169 ~attrs:[Attr.mk (mknoloc "#modulepat") (PStr [])]
2170 { name with txt = Some name.txt }
2171 (Mod.unpack ~loc
2172 (Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)
2173 name.loc)))
2174 sexp
2175 )
2176 sexp unpacks
2177
2178 (* Helpers for type_cases *)
2179
2180 let contains_variant_either ty =
2181 let rec loop ty =
2182 let ty = repr ty in
2183 if ty.level >= lowest_level then begin
2184 mark_type_node ty;
2185 match ty.desc with
2186 Tvariant row ->
2187 let row = row_repr row in
2188 if not (is_fixed row) then
2189 List.iter
2190 (fun (_,f) ->
2191 match row_field_repr f with Reither _ -> raise Exit | _ -> ())
2192 row.row_fields;
2193 iter_row loop row
2194 | _ ->
2195 iter_type_expr loop ty
2196 end
2197 in
2198 try loop ty; unmark_type ty; false
2199 with Exit -> unmark_type ty; true
2200
2201 let shallow_iter_ppat f p =
2202 match p.ppat_desc with
2203 | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _
2204 | Ppat_extension _
2205 | Ppat_type _ | Ppat_unpack _ -> ()
2206 | Ppat_array pats -> List.iter f pats
2207 | Ppat_or (p1,p2) -> f p1; f p2
2208 | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> Option.iter f arg
2209 | Ppat_tuple lst -> List.iter f lst
2210 | Ppat_exception p | Ppat_alias (p,_)
2211 | Ppat_open (_,p)
2212 | Ppat_constraint (p,_) | Ppat_lazy p -> f p
2213 | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args
2214
2215 let exists_ppat f p =
2216 let exception Found in
2217 let rec loop p =
2218 if f p then raise Found else ();
2219 shallow_iter_ppat loop p in
2220 match loop p with
2221 | exception Found -> true
2222 | () -> false
2223
2224 let contains_polymorphic_variant p =
2225 exists_ppat
2226 (function
2227 | {ppat_desc = (Ppat_variant _ | Ppat_type _)} -> true
2228 | _ -> false)
2229 p
2230
2231 let contains_gadt cp =
2232 exists_pattern
2233 (function
2234 | {pat_desc = Tpat_construct (_, cd, _)} when cd.cstr_generalized -> true
2235 | _ -> false)
2236 cp
2237
2238 (* There are various things that we need to do in presence of GADT constructors
2239 that aren't required if there are none.
2240 However, because of disambiguation, we can't know for sure whether the
2241 patterns contain some GADT constructors. So we conservatively assume that
2242 any constructor might be a GADT constructor. *)
2243 let may_contain_gadts p =
2244 exists_ppat
2245 (function
2246 | {ppat_desc = Ppat_construct (_, _)} -> true
2247 | _ -> false)
2248 p
2249
2250 let check_absent_variant env =
2251 iter_pattern
2252 (function {pat_desc = Tpat_variant (s, arg, row)} as pat ->
2253 let row = row_repr !row in
2254 if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
2255 row.row_fields
2256 || not (is_fixed row) && not (static_row row) (* same as Ctype.poly *)
2257 then () else
2258 let ty_arg =
2259 match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
2260 let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
2261 row_more = newvar (); row_bound = ();
2262 row_closed = false; row_fixed = None; row_name = None} in
2263 (* Should fail *)
2264 unify_pat (ref env) {pat with pat_type = newty (Tvariant row')}
2265 (correct_levels pat.pat_type)
2266 | _ -> ())
2267
2268 (* Getting proper location of already typed expressions.
2269
2270 Used to avoid confusing locations on type error messages in presence of
2271 type constraints.
2272 For example:
2273
2274 (* Before patch *)
2275 # let x : string = (5 : int);;
2276 ^
2277 (* After patch *)
2278 # let x : string = (5 : int);;
2279 ^^^^^^^^^
2280 *)
2281 let proper_exp_loc exp =
2282 let rec aux = function
2283 | [] -> exp.exp_loc
2284 | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc
2285 | _ :: rest -> aux rest
2286 in
2287 aux exp.exp_extra
2288
2289 (* To find reasonable names for let-bound and lambda-bound idents *)
2290
2291 let rec name_pattern default = function
2292 [] -> Ident.create_local default
2293 | p :: rem ->
2294 match p.pat_desc with
2295 Tpat_var (id, _) -> id
2296 | Tpat_alias(_, id, _) -> id
2297 | _ -> name_pattern default rem
2298
2299 let name_cases default lst =
2300 name_pattern default (List.map (fun c -> c.c_lhs) lst)
2301
2302 (* Typing of expressions *)
2303
2304 let unify_exp env exp expected_ty =
2305 let loc = proper_exp_loc exp in
2306 try
2307 unify_exp_types loc env exp.exp_type expected_ty
2308 with Error(loc, env, Expr_type_clash(trace, tfc, None)) ->
2309 raise (Error(loc, env, Expr_type_clash(trace, tfc, Some exp.exp_desc)))
2310
2311 let rec type_exp ?recarg env sexp =
2312 (* We now delegate everything to type_expect *)
2313 type_expect ?recarg env sexp (mk_expected (newvar ()))
2314
2315 (* Typing of an expression with an expected type.
2316 This provide better error messages, and allows controlled
2317 propagation of return type information.
2318 In the principal case, [type_expected'] may be at generic_level.
2319 *)
2320
2321 and type_expect ?in_function ?recarg env sexp ty_expected_explained =
2322 let previous_saved_types = Cmt_format.get_saved_types () in
2323 let exp =
2324 Builtin_attributes.warning_scope sexp.pexp_attributes
2325 (fun () ->
2326 type_expect_ ?in_function ?recarg env sexp ty_expected_explained
2327 )
2328 in
2329 Cmt_format.set_saved_types
2330 (Cmt_format.Partial_expression exp :: previous_saved_types);
2331 exp
2332
2333 and with_explanation explanation f =
2334 match explanation with
2335 | None -> f ()
2336 | Some explanation ->
2337 try f ()
2338 with Error (loc', env', Expr_type_clash(trace', None, exp'))
2339 when not loc'.Location.loc_ghost ->
2340 let err = Expr_type_clash(trace', Some explanation, exp') in
2341 raise (Error (loc', env', err))
2342
2343 and type_expect_
2344 ?in_function ?(recarg=Rejected)
2345 env sexp ty_expected_explained =
2346 let { ty = ty_expected; explanation } = ty_expected_explained in
2347 let loc = sexp.pexp_loc in
2348 (* Record the expression type before unifying it with the expected type *)
2349 let with_explanation = with_explanation explanation in
2350 let rue exp =
2351 with_explanation (fun () ->
2352 unify_exp env (re exp) (instance ty_expected));
2353 exp
2354 in
2355 match sexp.pexp_desc with
2356 | Pexp_ident lid ->
2357 let path, desc = type_ident env ~recarg lid in
2358 let exp_desc =
2359 match desc.val_kind with
2360 | Val_ivar (_, cl_num) ->
2361 let (self_path, _) =
2362 Env.find_value_by_name
2363 (Longident.Lident ("self-" ^ cl_num)) env
2364 in
2365 Texp_instvar(self_path, path,
2366 match lid.txt with
2367 Longident.Lident txt -> { txt; loc = lid.loc }
2368 | _ -> assert false)
2369 | Val_self (_, _, cl_num, _) ->
2370 let (path, _) =
2371 Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
2372 in
2373 Texp_ident(path, lid, desc)
2374 | _ ->
2375 Texp_ident(path, lid, desc)
2376 in
2377 rue {
2378 exp_desc; exp_loc = loc; exp_extra = [];
2379 exp_type = instance desc.val_type;
2380 exp_attributes = sexp.pexp_attributes;
2381 exp_env = env }
2382 | Pexp_constant(Pconst_string (str, _) as cst) -> (
2383 let cst = constant_or_raise env loc cst in
2384 (* Terrible hack for format strings *)
2385 let ty_exp = expand_head env ty_expected in
2386 let fmt6_path =
2387 Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"),
2388 "format6"))
2389 in
2390 let is_format = match ty_exp.desc with
2391 | Tconstr(path, _, _) when Path.same path fmt6_path ->
2392 if !Clflags.principal && ty_exp.level <> generic_level then
2393 Location.prerr_warning loc
2394 (Warnings.Not_principal "this coercion to format6");
2395 true
2396 | _ -> false
2397 in
2398 if is_format then
2399 let format_parsetree =
2400 { (type_format loc str env) with pexp_loc = sexp.pexp_loc } in
2401 type_expect ?in_function env format_parsetree ty_expected_explained
2402 else
2403 rue {
2404 exp_desc = Texp_constant cst;
2405 exp_loc = loc; exp_extra = [];
2406 exp_type = instance Predef.type_string;
2407 exp_attributes = sexp.pexp_attributes;
2408 exp_env = env }
2409 )
2410 | Pexp_constant cst ->
2411 let cst = constant_or_raise env loc cst in
2412 rue {
2413 exp_desc = Texp_constant cst;
2414 exp_loc = loc; exp_extra = [];
2415 exp_type = type_constant cst;
2416 exp_attributes = sexp.pexp_attributes;
2417 exp_env = env }
2418 | Pexp_let(Nonrecursive,
2419 [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)
2420 when may_contain_gadts spat ->
2421 (* TODO: allow non-empty attributes? *)
2422 type_expect ?in_function env
2423 {sexp with
2424 pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
2425 ty_expected_explained
2426 | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
2427 let existential_context =
2428 if rec_flag = Recursive then In_rec
2429 else if List.compare_length_with spat_sexp_list 1 > 0 then In_group
2430 else With_attributes in
2431 let scp =
2432 match sexp.pexp_attributes, rec_flag with
2433 | [{attr_name = {txt="#default"}; _}], _ -> None
2434 | _, Recursive -> Some (Annot.Idef loc)
2435 | _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
2436 in
2437 let (pat_exp_list, new_env, unpacks) =
2438 type_let existential_context env rec_flag spat_sexp_list scp true in
2439 let body =
2440 type_expect new_env (wrap_unpacks sbody unpacks)
2441 ty_expected_explained in
2442 let () =
2443 if rec_flag = Recursive then
2444 check_recursive_bindings env pat_exp_list
2445 in
2446 re {
2447 exp_desc = Texp_let(rec_flag, pat_exp_list, body);
2448 exp_loc = loc; exp_extra = [];
2449 exp_type = body.exp_type;
2450 exp_attributes = sexp.pexp_attributes;
2451 exp_env = env }
2452 | Pexp_fun (l, Some default, spat, sbody) ->
2453 assert(is_optional l); (* default allowed only with optional argument *)
2454 let open Ast_helper in
2455 let default_loc = default.pexp_loc in
2456 let scases = [
2457 Exp.case
2458 (Pat.construct ~loc:default_loc
2459 (mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
2460 (Some (Pat.var ~loc:default_loc (mknoloc "*sth*"))))
2461 (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
2462
2463 Exp.case
2464 (Pat.construct ~loc:default_loc
2465 (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
2466 None)
2467 default;
2468 ]
2469 in
2470 let sloc =
2471 { Location.loc_start = spat.ppat_loc.Location.loc_start;
2472 loc_end = default_loc.Location.loc_end;
2473 loc_ghost = true }
2474 in
2475 let smatch =
2476 Exp.match_ ~loc:sloc
2477 (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
2478 scases
2479 in
2480 let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in
2481 let body =
2482 Exp.let_ ~loc Nonrecursive
2483 ~attrs:[Attr.mk (mknoloc "#default") (PStr [])]
2484 [Vb.mk spat smatch] sbody
2485 in
2486 type_function ?in_function loc sexp.pexp_attributes env
2487 ty_expected_explained l [Exp.case pat body]
2488 | Pexp_fun (l, None, spat, sbody) ->
2489 type_function ?in_function loc sexp.pexp_attributes env
2490 ty_expected_explained l [Ast_helper.Exp.case spat sbody]
2491 | Pexp_function caselist ->
2492 type_function ?in_function
2493 loc sexp.pexp_attributes env ty_expected_explained Nolabel caselist
2494 | Pexp_apply(sfunct, sargs) ->
2495 assert (sargs <> []);
2496 begin_def (); (* one more level for non-returning functions *)
2497 if !Clflags.principal then begin_def ();
2498 let funct = type_exp env sfunct in
2499 if !Clflags.principal then begin
2500 end_def ();
2501 generalize_structure funct.exp_type
2502 end;
2503 let rec lower_args seen ty_fun =
2504 let ty = expand_head env ty_fun in
2505 if List.memq ty seen then () else
2506 match ty.desc with
2507 Tarrow (_l, ty_arg, ty_fun, _com) ->
2508 (try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
2509 lower_args (ty::seen) ty_fun
2510 | _ -> ()
2511 in
2512 let ty = instance funct.exp_type in
2513 end_def ();
2514 wrap_trace_gadt_instances env (lower_args []) ty;
2515 begin_def ();
2516 let (args, ty_res) = type_application env funct sargs in
2517 end_def ();
2518 unify_var env (newvar()) funct.exp_type;
2519 rue {
2520 exp_desc = Texp_apply(funct, args);
2521 exp_loc = loc; exp_extra = [];
2522 exp_type = ty_res;
2523 exp_attributes = sexp.pexp_attributes;
2524 exp_env = env }
2525 | Pexp_match(sarg, caselist) ->
2526 begin_def ();
2527 let arg = type_exp env sarg in
2528 end_def ();
2529 if maybe_expansive arg then lower_contravariant env arg.exp_type;
2530 generalize arg.exp_type;
2531 let cases, partial =
2532 type_cases ~exception_allowed:true env arg.exp_type ty_expected true loc
2533 caselist
2534 in
2535 re {
2536 exp_desc = Texp_match(arg, cases, partial);
2537 exp_loc = loc; exp_extra = [];
2538 exp_type = instance ty_expected;
2539 exp_attributes = sexp.pexp_attributes;
2540 exp_env = env }
2541 | Pexp_try(sbody, caselist) ->
2542 let body = type_expect env sbody ty_expected_explained in
2543 let cases, _ =
2544 type_cases env Predef.type_exn ty_expected false loc caselist in
2545 re {
2546 exp_desc = Texp_try(body, cases);
2547 exp_loc = loc; exp_extra = [];
2548 exp_type = body.exp_type;
2549 exp_attributes = sexp.pexp_attributes;
2550 exp_env = env }
2551 | Pexp_tuple sexpl ->
2552 assert (List.length sexpl >= 2);
2553 let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
2554 let to_unify = newgenty (Ttuple subtypes) in
2555 with_explanation (fun () ->
2556 unify_exp_types loc env to_unify ty_expected);
2557 let expl =
2558 List.map2 (fun body ty -> type_expect env body (mk_expected ty))
2559 sexpl subtypes
2560 in
2561 re {
2562 exp_desc = Texp_tuple expl;
2563 exp_loc = loc; exp_extra = [];
2564 (* Keep sharing *)
2565 exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
2566 exp_attributes = sexp.pexp_attributes;
2567 exp_env = env }
2568 | Pexp_construct(lid, sarg) ->
2569 type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes
2570 | Pexp_variant(l, sarg) ->
2571 (* Keep sharing *)
2572 let ty_expected0 = instance ty_expected in
2573 begin try match
2574 sarg, expand_head env ty_expected, expand_head env ty_expected0 with
2575 | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->
2576 let row = row_repr row in
2577 begin match row_field_repr (List.assoc l row.row_fields),
2578 row_field_repr (List.assoc l row0.row_fields) with
2579 Rpresent (Some ty), Rpresent (Some ty0) ->
2580 let arg = type_argument env sarg ty ty0 in
2581 re { exp_desc = Texp_variant(l, Some arg);
2582 exp_loc = loc; exp_extra = [];
2583 exp_type = ty_expected0;
2584 exp_attributes = sexp.pexp_attributes;
2585 exp_env = env }
2586 | _ -> raise Not_found
2587 end
2588 | _ -> raise Not_found
2589 with Not_found ->
2590 let arg = Option.map (type_exp env) sarg in
2591 let arg_type = Option.map (fun arg -> arg.exp_type) arg in
2592 rue {
2593 exp_desc = Texp_variant(l, arg);
2594 exp_loc = loc; exp_extra = [];
2595 exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
2596 row_more = newvar ();
2597 row_bound = ();
2598 row_closed = false;
2599 row_fixed = None;
2600 row_name = None});
2601 exp_attributes = sexp.pexp_attributes;
2602 exp_env = env }
2603 end
2604 | Pexp_record(lid_sexp_list, opt_sexp) ->
2605 assert (lid_sexp_list <> []);
2606 let opt_exp =
2607 match opt_sexp with
2608 None -> None
2609 | Some sexp ->
2610 if !Clflags.principal then begin_def ();
2611 let exp = type_exp ~recarg env sexp in
2612 if !Clflags.principal then begin
2613 end_def ();
2614 generalize_structure exp.exp_type
2615 end;
2616 Some exp
2617 in
2618 let ty_record, opath =
2619 let get_path ty =
2620 try
2621 let (p0, p,_) = extract_concrete_record env ty in
2622 let principal =
2623 (repr ty).level = generic_level || not !Clflags.principal
2624 in
2625 Some (p0, p, principal)
2626 with Not_found -> None
2627 in
2628 match get_path ty_expected with
2629 None ->
2630 begin match opt_exp with
2631 None -> newvar (), None
2632 | Some exp ->
2633 match get_path exp.exp_type with
2634 None -> newvar (), None
2635 | Some (_, p', _) as op ->
2636 let decl = Env.find_type p' env in
2637 begin_def ();
2638 let ty =
2639 newconstr p' (instance_list decl.type_params) in
2640 end_def ();
2641 generalize_structure ty;
2642 ty, op
2643 end
2644 | op -> ty_expected, op
2645 in
2646 let closed = (opt_sexp = None) in
2647 let lbl_exp_list =
2648 wrap_disambiguate "This record expression is expected to have"
2649 (mk_expected ty_record)
2650 (type_label_a_list loc closed env
2651 (fun e k -> k (type_label_exp true env loc ty_record e))
2652 opath lid_sexp_list)
2653 (fun x -> x)
2654 in
2655 with_explanation (fun () ->
2656 unify_exp_types loc env ty_record (instance ty_expected));
2657
2658 (* type_label_a_list returns a list of labels sorted by lbl_pos *)
2659 (* note: check_duplicates would better be implemented in
2660 type_label_a_list directly *)
2661 let rec check_duplicates = function
2662 | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->
2663 raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name))
2664 | _ :: rem ->
2665 check_duplicates rem
2666 | [] -> ()
2667 in
2668 check_duplicates lbl_exp_list;
2669 let opt_exp, label_definitions =
2670 let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in
2671 let matching_label lbl =
2672 List.find
2673 (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
2674 lbl_exp_list
2675 in
2676 match opt_exp with
2677 None ->
2678 let label_definitions =
2679 Array.map (fun lbl ->
2680 match matching_label lbl with
2681 | (lid, _lbl, lbl_exp) ->
2682 Overridden (lid, lbl_exp)
2683 | exception Not_found ->
2684 let present_indices =
2685 List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list
2686 in
2687 let label_names = extract_label_names env ty_expected in
2688 let rec missing_labels n = function
2689 [] -> []
2690 | lbl :: rem ->
2691 if List.mem n present_indices
2692 then missing_labels (n + 1) rem
2693 else lbl :: missing_labels (n + 1) rem
2694 in
2695 let missing = missing_labels 0 label_names in
2696 raise(Error(loc, env, Label_missing missing)))
2697 lbl.lbl_all
2698 in
2699 None, label_definitions
2700 | Some exp ->
2701 let ty_exp = instance exp.exp_type in
2702 let unify_kept lbl =
2703 let _, ty_arg1, ty_res1 = instance_label false lbl in
2704 unify_exp_types exp.exp_loc env ty_exp ty_res1;
2705 match matching_label lbl with
2706 | lid, _lbl, lbl_exp ->
2707 (* do not connect result types for overridden labels *)
2708 Overridden (lid, lbl_exp)
2709 | exception Not_found -> begin
2710 let _, ty_arg2, ty_res2 = instance_label false lbl in
2711 unify_exp_types loc env ty_arg1 ty_arg2;
2712 with_explanation (fun () ->
2713 unify_exp_types loc env (instance ty_expected) ty_res2);
2714 Kept ty_arg1
2715 end
2716 in
2717 let label_definitions = Array.map unify_kept lbl.lbl_all in
2718 Some {exp with exp_type = ty_exp}, label_definitions
2719 in
2720 let num_fields =
2721 match lbl_exp_list with [] -> assert false
2722 | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
2723 let opt_exp =
2724 if opt_sexp <> None && List.length lid_sexp_list = num_fields then
2725 (Location.prerr_warning loc Warnings.Useless_record_with; None)
2726 else opt_exp
2727 in
2728 let label_descriptions, representation =
2729 let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
2730 lbl_all, lbl_repres
2731 in
2732 let fields =
2733 Array.map2 (fun descr def -> descr, def)
2734 label_descriptions label_definitions
2735 in
2736 re {
2737 exp_desc = Texp_record {
2738 fields; representation;
2739 extended_expression = opt_exp
2740 };
2741 exp_loc = loc; exp_extra = [];
2742 exp_type = instance ty_expected;
2743 exp_attributes = sexp.pexp_attributes;
2744 exp_env = env }
2745 | Pexp_field(srecord, lid) ->
2746 let (record, label, _) = type_label_access env srecord lid in
2747 let (_, ty_arg, ty_res) = instance_label false label in
2748 unify_exp env record ty_res;
2749 rue {
2750 exp_desc = Texp_field(record, lid, label);
2751 exp_loc = loc; exp_extra = [];
2752 exp_type = ty_arg;
2753 exp_attributes = sexp.pexp_attributes;
2754 exp_env = env }
2755 | Pexp_setfield(srecord, lid, snewval) ->
2756 let (record, label, opath) = type_label_access env srecord lid in
2757 let ty_record = if opath = None then newvar () else record.exp_type in
2758 let (label_loc, label, newval) =
2759 type_label_exp false env loc ty_record (lid, label, snewval) in
2760 unify_exp env record ty_record;
2761 if label.lbl_mut = Immutable then
2762 raise(Error(loc, env, Label_not_mutable lid.txt));
2763 rue {
2764 exp_desc = Texp_setfield(record, label_loc, label, newval);
2765 exp_loc = loc; exp_extra = [];
2766 exp_type = instance Predef.type_unit;
2767 exp_attributes = sexp.pexp_attributes;
2768 exp_env = env }
2769 | Pexp_array(sargl) ->
2770 let ty = newgenvar() in
2771 let to_unify = Predef.type_array ty in
2772 with_explanation (fun () ->
2773 unify_exp_types loc env to_unify ty_expected);
2774 let argl =
2775 List.map (fun sarg -> type_expect env sarg (mk_expected ty)) sargl in
2776 re {
2777 exp_desc = Texp_array argl;
2778 exp_loc = loc; exp_extra = [];
2779 exp_type = instance ty_expected;
2780 exp_attributes = sexp.pexp_attributes;
2781 exp_env = env }
2782 | Pexp_ifthenelse(scond, sifso, sifnot) ->
2783 let cond = type_expect env scond
2784 (mk_expected ~explanation:If_conditional Predef.type_bool) in
2785 begin match sifnot with
2786 None ->
2787 let ifso = type_expect env sifso
2788 (mk_expected ~explanation:If_no_else_branch Predef.type_unit) in
2789 rue {
2790 exp_desc = Texp_ifthenelse(cond, ifso, None);
2791 exp_loc = loc; exp_extra = [];
2792 exp_type = ifso.exp_type;
2793 exp_attributes = sexp.pexp_attributes;
2794 exp_env = env }
2795 | Some sifnot ->
2796 let ifso = type_expect env sifso ty_expected_explained in
2797 let ifnot = type_expect env sifnot ty_expected_explained in
2798 (* Keep sharing *)
2799 unify_exp env ifnot ifso.exp_type;
2800 re {
2801 exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
2802 exp_loc = loc; exp_extra = [];
2803 exp_type = ifso.exp_type;
2804 exp_attributes = sexp.pexp_attributes;
2805 exp_env = env }
2806 end
2807 | Pexp_sequence(sexp1, sexp2) ->
2808 let exp1 = type_statement ~explanation:Sequence_left_hand_side
2809 env sexp1 in
2810 let exp2 = type_expect env sexp2 ty_expected_explained in
2811 re {
2812 exp_desc = Texp_sequence(exp1, exp2);
2813 exp_loc = loc; exp_extra = [];
2814 exp_type = exp2.exp_type;
2815 exp_attributes = sexp.pexp_attributes;
2816 exp_env = env }
2817 | Pexp_while(scond, sbody) ->
2818 let cond = type_expect env scond
2819 (mk_expected ~explanation:While_loop_conditional Predef.type_bool) in
2820 let body = type_statement ~explanation:While_loop_body env sbody in
2821 rue {
2822 exp_desc = Texp_while(cond, body);
2823 exp_loc = loc; exp_extra = [];
2824 exp_type = instance Predef.type_unit;
2825 exp_attributes = sexp.pexp_attributes;
2826 exp_env = env }
2827 | Pexp_for(param, slow, shigh, dir, sbody) ->
2828 let low = type_expect env slow
2829 (mk_expected ~explanation:For_loop_start_index Predef.type_int) in
2830 let high = type_expect env shigh
2831 (mk_expected ~explanation:For_loop_stop_index Predef.type_int) in
2832 let id, new_env =
2833 match param.ppat_desc with
2834 | Ppat_any -> Ident.create_local "_for", env
2835 | Ppat_var {txt} ->
2836 Env.enter_value txt {val_type = instance Predef.type_int;
2837 val_attributes = [];
2838 val_kind = Val_reg; Types.val_loc = loc; } env
2839 ~check:(fun s -> Warnings.Unused_for_index s)
2840 | _ ->
2841 raise (Error (param.ppat_loc, env, Invalid_for_loop_index))
2842 in
2843 let body = type_statement ~explanation:For_loop_body new_env sbody in
2844 rue {
2845 exp_desc = Texp_for(id, param, low, high, dir, body);
2846 exp_loc = loc; exp_extra = [];
2847 exp_type = instance Predef.type_unit;
2848 exp_attributes = sexp.pexp_attributes;
2849 exp_env = env }
2850 | Pexp_constraint (sarg, sty) ->
2851 (* Pretend separate = true, 1% slowdown for lablgtk *)
2852 begin_def ();
2853 let cty = Typetexp.transl_simple_type env false sty in
2854 let ty = cty.ctyp_type in
2855 end_def ();
2856 generalize_structure ty;
2857 let (arg, ty') = (type_argument env sarg ty (instance ty), instance ty) in
2858 rue {
2859 exp_desc = arg.exp_desc;
2860 exp_loc = arg.exp_loc;
2861 exp_type = ty';
2862 exp_attributes = arg.exp_attributes;
2863 exp_env = env;
2864 exp_extra =
2865 (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
2866 }
2867 | Pexp_coerce(sarg, sty, sty') ->
2868 (* Pretend separate = true, 1% slowdown for lablgtk *)
2869 (* Also see PR#7199 for a problem with the following:
2870 let separate = !Clflags.principal || Env.has_local_constraints env in*)
2871 let (arg, ty',cty,cty') =
2872 match sty with
2873 | None ->
2874 let (cty', force) =
2875 Typetexp.transl_simple_type_delayed env sty'
2876 in
2877 let ty' = cty'.ctyp_type in
2878 begin_def ();
2879 let arg = type_exp env sarg in
2880 end_def ();
2881 let tv = newvar () in
2882 let gen = generalizable tv.level arg.exp_type in
2883 unify_var env tv arg.exp_type;
2884 begin match arg.exp_desc, !self_coercion, (repr ty').desc with
2885 Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _,
2886 Tconstr(path',_,_) when Path.same path path' ->
2887 (* prerr_endline "self coercion"; *)
2888 r := loc :: !r;
2889 force ()
2890 | _ when free_variables ~env arg.exp_type = []
2891 && free_variables ~env ty' = [] ->
2892 if not gen && (* first try a single coercion *)
2893 let snap = snapshot () in
2894 let ty, _b = enlarge_type env ty' in
2895 try
2896 force (); Ctype.unify env arg.exp_type ty; true
2897 with Unify _ ->
2898 backtrack snap; false
2899 then ()
2900 else begin try
2901 let force' = subtype env arg.exp_type ty' in
2902 force (); force' ();
2903 if not gen && !Clflags.principal then
2904 Location.prerr_warning loc
2905 (Warnings.Not_principal "this ground coercion");
2906 with Subtype (tr1, tr2) ->
2907 (* prerr_endline "coercion failed"; *)
2908 raise(Error(loc, env, Not_subtype(tr1, tr2)))
2909 end;
2910 | _ ->
2911 let ty, b = enlarge_type env ty' in
2912 force ();
2913 begin try Ctype.unify env arg.exp_type ty with Unify trace ->
2914 raise(Error(sarg.pexp_loc, env,
2915 Coercion_failure(ty', full_expand env ty', trace, b)))
2916 end
2917 end;
2918 (arg, ty', None, cty')
2919 | Some sty ->
2920 begin_def ();
2921 let (cty, force) =
2922 Typetexp.transl_simple_type_delayed env sty
2923 and (cty', force') =
2924 Typetexp.transl_simple_type_delayed env sty'
2925 in
2926 let ty = cty.ctyp_type in
2927 let ty' = cty'.ctyp_type in
2928 begin try
2929 let force'' = subtype env ty ty' in
2930 force (); force' (); force'' ()
2931 with Subtype (tr1, tr2) ->
2932 raise(Error(loc, env, Not_subtype(tr1, tr2)))
2933 end;
2934 end_def ();
2935 generalize_structure ty;
2936 generalize_structure ty';
2937 (type_argument env sarg ty (instance ty),
2938 instance ty', Some cty, cty')
2939 in
2940 rue {
2941 exp_desc = arg.exp_desc;
2942 exp_loc = arg.exp_loc;
2943 exp_type = ty';
2944 exp_attributes = arg.exp_attributes;
2945 exp_env = env;
2946 exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::
2947 arg.exp_extra;
2948 }
2949 | Pexp_send (e, {txt=met}) ->
2950 if !Clflags.principal then begin_def ();
2951 let obj = type_exp env e in
2952 let obj_meths = ref None in
2953 begin try
2954 let (meth, exp, typ) =
2955 match obj.exp_desc with
2956 Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
2957 obj_meths := Some meths;
2958 let (id, typ) =
2959 filter_self_method env met Private meths privty
2960 in
2961 if is_Tvar (repr typ) then
2962 Location.prerr_warning loc
2963 (Warnings.Undeclared_virtual_method met);
2964 (Tmeth_val id, None, typ)
2965 | Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
2966 let method_id =
2967 begin try List.assoc met methods with Not_found ->
2968 let valid_methods = List.map fst methods in
2969 raise(Error(e.pexp_loc, env,
2970 Undefined_inherited_method (met, valid_methods)))
2971 end
2972 in
2973 begin match
2974 Env.find_value_by_name
2975 (Longident.Lident ("selfpat-" ^ cl_num)) env,
2976 Env.find_value_by_name
2977 (Longident.Lident ("self-" ^cl_num)) env
2978 with
2979 | (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
2980 (path, _) ->
2981 obj_meths := Some meths;
2982 let (_, typ) =
2983 filter_self_method env met Private meths privty
2984 in
2985 let method_type = newvar () in
2986 let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in
2987 unify env obj_ty desc.val_type;
2988 unify env res_ty (instance typ);
2989 let method_desc =
2990 {val_type = method_type;
2991 val_kind = Val_reg;
2992 val_attributes = [];
2993 Types.val_loc = Location.none}
2994 in
2995 let exp_env = Env.add_value method_id method_desc env in
2996 let exp =
2997 Texp_apply({exp_desc =
2998 Texp_ident(Path.Pident method_id,
2999 lid, method_desc);
3000 exp_loc = loc; exp_extra = [];
3001 exp_type = method_type;
3002 exp_attributes = []; (* check *)
3003 exp_env = exp_env},
3004 [ Nolabel,
3005 Some {exp_desc = Texp_ident(path, lid, desc);
3006 exp_loc = obj.exp_loc; exp_extra = [];
3007 exp_type = desc.val_type;
3008 exp_attributes = []; (* check *)
3009 exp_env = exp_env}
3010 ])
3011 in
3012 (Tmeth_name met, Some (re {exp_desc = exp;
3013 exp_loc = loc; exp_extra = [];
3014 exp_type = typ;
3015 exp_attributes = []; (* check *)
3016 exp_env = exp_env}), typ)
3017 | _ ->
3018 assert false
3019 end
3020 | _ ->
3021 (Tmeth_name met, None,
3022 filter_method env met Public obj.exp_type)
3023 in
3024 if !Clflags.principal then begin
3025 end_def ();
3026 generalize_structure typ;
3027 end;
3028 let typ =
3029 match repr typ with
3030 {desc = Tpoly (ty, [])} ->
3031 instance ty
3032 | {desc = Tpoly (ty, tl); level = l} ->
3033 if !Clflags.principal && l <> generic_level then
3034 Location.prerr_warning loc
3035 (Warnings.Not_principal "this use of a polymorphic method");
3036 snd (instance_poly false tl ty)
3037 | {desc = Tvar _} as ty ->
3038 let ty' = newvar () in
3039 unify env (instance ty) (newty(Tpoly(ty',[])));
3040 (* if not !Clflags.nolabels then
3041 Location.prerr_warning loc (Warnings.Unknown_method met); *)
3042 ty'
3043 | _ ->
3044 assert false
3045 in
3046 rue {
3047 exp_desc = Texp_send(obj, meth, exp);
3048 exp_loc = loc; exp_extra = [];
3049 exp_type = typ;
3050 exp_attributes = sexp.pexp_attributes;
3051 exp_env = env }
3052 with Unify _ ->
3053 let valid_methods =
3054 match !obj_meths with
3055 | Some meths ->
3056 Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths [])
3057 | None ->
3058 match (expand_head env obj.exp_type).desc with
3059 | Tobject (fields, _) ->
3060 let (fields, _) = Ctype.flatten_fields fields in
3061 let collect_fields li (meth, meth_kind, _meth_ty) =
3062 if meth_kind = Fpresent then meth::li else li in
3063 Some (List.fold_left collect_fields [] fields)
3064 | _ -> None
3065 in
3066 raise(Error(e.pexp_loc, env,
3067 Undefined_method (obj.exp_type, met, valid_methods)))
3068 end
3069 | Pexp_new cl ->
3070 let (cl_path, cl_decl) = Env.lookup_class ~loc:cl.loc cl.txt env in
3071 begin match cl_decl.cty_new with
3072 None ->
3073 raise(Error(loc, env, Virtual_class cl.txt))
3074 | Some ty ->
3075 rue {
3076 exp_desc = Texp_new (cl_path, cl, cl_decl);
3077 exp_loc = loc; exp_extra = [];
3078 exp_type = instance ty;
3079 exp_attributes = sexp.pexp_attributes;
3080 exp_env = env }
3081 end
3082 | Pexp_setinstvar (lab, snewval) -> begin
3083 let (path, mut, cl_num, ty) =
3084 Env.lookup_instance_variable ~loc lab.txt env
3085 in
3086 match mut with
3087 | Mutable ->
3088 let newval =
3089 type_expect env snewval (mk_expected (instance ty))
3090 in
3091 let (path_self, _) =
3092 Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
3093 in
3094 rue {
3095 exp_desc = Texp_setinstvar(path_self, path, lab, newval);
3096 exp_loc = loc; exp_extra = [];
3097 exp_type = instance Predef.type_unit;
3098 exp_attributes = sexp.pexp_attributes;
3099 exp_env = env }
3100 | _ ->
3101 raise(Error(loc, env, Instance_variable_not_mutable lab.txt))
3102 end
3103 | Pexp_override lst ->
3104 let _ =
3105 List.fold_right
3106 (fun (lab, _) l ->
3107 if List.exists (fun l -> l.txt = lab.txt) l then
3108 raise(Error(loc, env,
3109 Value_multiply_overridden lab.txt));
3110 lab::l)
3111 lst
3112 [] in
3113 begin match
3114 try
3115 Env.find_value_by_name (Longident.Lident "selfpat-*") env,
3116 Env.find_value_by_name (Longident.Lident "self-*") env
3117 with Not_found ->
3118 raise(Error(loc, env, Outside_class))
3119 with
3120 (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
3121 (path_self, _) ->
3122 let type_override (lab, snewval) =
3123 begin try
3124 let (id, _, _, ty) = Vars.find lab.txt !vars in
3125 (Path.Pident id, lab,
3126 type_expect env snewval (mk_expected (instance ty)))
3127 with
3128 Not_found ->
3129 let vars = Vars.fold (fun var _ li -> var::li) !vars [] in
3130 raise(Error(loc, env,
3131 Unbound_instance_variable (lab.txt, vars)))
3132 end
3133 in
3134 let modifs = List.map type_override lst in
3135 rue {
3136 exp_desc = Texp_override(path_self, modifs);
3137 exp_loc = loc; exp_extra = [];
3138 exp_type = self_ty;
3139 exp_attributes = sexp.pexp_attributes;
3140 exp_env = env }
3141 | _ ->
3142 assert false
3143 end
3144 | Pexp_letmodule(name, smodl, sbody) ->
3145 let ty = newvar() in
3146 (* remember original level *)
3147 begin_def ();
3148 let context = Typetexp.narrow () in
3149 let modl = !type_module env smodl in
3150 Mtype.lower_nongen ty.level modl.mod_type;
3151 let pres =
3152 match modl.mod_type with
3153 | Mty_alias _ -> Mp_absent
3154 | _ -> Mp_present
3155 in
3156 let scope = create_scope () in
3157 let md =
3158 { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc }
3159 in
3160 let (id, new_env) =
3161 match name.txt with
3162 | None -> None, env
3163 | Some name ->
3164 let id, env = Env.enter_module_declaration ~scope name pres md env in
3165 Some id, env
3166 in
3167 Typetexp.widen context;
3168 (* ideally, we should catch Expr_type_clash errors
3169 in type_expect triggered by escaping identifiers from the local module
3170 and refine them into Scoping_let_module errors
3171 *)
3172 let body = type_expect new_env sbody ty_expected_explained in
3173 (* go back to original level *)
3174 end_def ();
3175 Ctype.unify_var new_env ty body.exp_type;
3176 re {
3177 exp_desc = Texp_letmodule(id, name, pres, modl, body);
3178 exp_loc = loc; exp_extra = [];
3179 exp_type = ty;
3180 exp_attributes = sexp.pexp_attributes;
3181 exp_env = env }
3182 | Pexp_letexception(cd, sbody) ->
3183 let (cd, newenv) = Typedecl.transl_exception env cd in
3184 let body = type_expect newenv sbody ty_expected_explained in
3185 re {
3186 exp_desc = Texp_letexception(cd, body);
3187 exp_loc = loc; exp_extra = [];
3188 exp_type = body.exp_type;
3189 exp_attributes = sexp.pexp_attributes;
3190 exp_env = env }
3191
3192 | Pexp_assert (e) ->
3193 let cond = type_expect env e
3194 (mk_expected ~explanation:Assert_condition Predef.type_bool) in
3195 let exp_type =
3196 match cond.exp_desc with
3197 | Texp_construct(_, {cstr_name="false"}, _) ->
3198 instance ty_expected
3199 | _ ->
3200 instance Predef.type_unit
3201 in
3202 rue {
3203 exp_desc = Texp_assert cond;
3204 exp_loc = loc; exp_extra = [];
3205 exp_type;
3206 exp_attributes = sexp.pexp_attributes;
3207 exp_env = env;
3208 }
3209 | Pexp_lazy e ->
3210 let ty = newgenvar () in
3211 let to_unify = Predef.type_lazy_t ty in
3212 with_explanation (fun () ->
3213 unify_exp_types loc env to_unify ty_expected);
3214 let arg = type_expect env e (mk_expected ty) in
3215 re {
3216 exp_desc = Texp_lazy arg;
3217 exp_loc = loc; exp_extra = [];
3218 exp_type = instance ty_expected;
3219 exp_attributes = sexp.pexp_attributes;
3220 exp_env = env;
3221 }
3222 | Pexp_object s ->
3223 let desc, sign, meths = !type_object env loc s in
3224 rue {
3225 exp_desc = Texp_object (desc, (*sign,*) meths);
3226 exp_loc = loc; exp_extra = [];
3227 exp_type = sign.csig_self;
3228 exp_attributes = sexp.pexp_attributes;
3229 exp_env = env;
3230 }
3231 | Pexp_poly(sbody, sty) ->
3232 if !Clflags.principal then begin_def ();
3233 let ty, cty =
3234 match sty with None -> repr ty_expected, None
3235 | Some sty ->
3236 let sty = Ast_helper.Typ.force_poly sty in
3237 let cty = Typetexp.transl_simple_type env false sty in
3238 repr cty.ctyp_type, Some cty
3239 in
3240 if !Clflags.principal then begin
3241 end_def ();
3242 generalize_structure ty
3243 end;
3244 if sty <> None then
3245 with_explanation (fun () ->
3246 unify_exp_types loc env (instance ty) (instance ty_expected));
3247 let exp =
3248 match (expand_head env ty).desc with
3249 Tpoly (ty', []) ->
3250 let exp = type_expect env sbody (mk_expected ty') in
3251 { exp with exp_type = instance ty }
3252 | Tpoly (ty', tl) ->
3253 (* One more level to generalize locally *)
3254 begin_def ();
3255 if !Clflags.principal then begin_def ();
3256 let vars, ty'' = instance_poly true tl ty' in
3257 if !Clflags.principal then begin
3258 end_def ();
3259 generalize_structure ty''
3260 end;
3261 let exp = type_expect env sbody (mk_expected ty'') in
3262 end_def ();
3263 check_univars env false "method" exp ty_expected vars;
3264 { exp with exp_type = instance ty }
3265 | Tvar _ ->
3266 let exp = type_exp env sbody in
3267 let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
3268 unify_exp env exp ty;
3269 exp
3270 | _ -> assert false
3271 in
3272 re { exp with exp_extra =
3273 (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
3274 | Pexp_newtype({txt=name}, sbody) ->
3275 let ty =
3276 if Typetexp.valid_tyvar_name name then
3277 newvar ~name ()
3278 else
3279 newvar ()
3280 in
3281 (* remember original level *)
3282 begin_def ();
3283 (* Create a fake abstract type declaration for name. *)
3284 let decl = {
3285 type_params = [];
3286 type_arity = 0;
3287 type_kind = Type_abstract;
3288 type_private = Public;
3289 type_manifest = None;
3290 type_variance = [];
3291 type_is_newtype = true;
3292 type_expansion_scope = Btype.lowest_level;
3293 type_loc = loc;
3294 type_attributes = [];
3295 type_immediate = Unknown;
3296 type_unboxed = unboxed_false_default_false;
3297 }
3298 in
3299 let scope = create_scope () in
3300 let (id, new_env) = Env.enter_type ~scope name decl env in
3301
3302 let body = type_exp new_env sbody in
3303 (* Replace every instance of this type constructor in the resulting
3304 type. *)
3305 let seen = Hashtbl.create 8 in
3306 let rec replace t =
3307 if Hashtbl.mem seen t.id then ()
3308 else begin
3309 Hashtbl.add seen t.id ();
3310 match t.desc with
3311 | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty
3312 | _ -> Btype.iter_type_expr replace t
3313 end
3314 in
3315 let ety = Subst.type_expr Subst.identity body.exp_type in
3316 replace ety;
3317 (* back to original level *)
3318 end_def ();
3319 (* lower the levels of the result type *)
3320 (* unify_var env ty ety; *)
3321
3322 (* non-expansive if the body is non-expansive, so we don't introduce
3323 any new extra node in the typed AST. *)
3324 rue { body with exp_loc = loc; exp_type = ety;
3325 exp_extra =
3326 (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
3327 | Pexp_pack m ->
3328 let (p, nl) =
3329 match Ctype.expand_head env (instance ty_expected) with
3330 {desc = Tpackage (p, nl, _tl)} ->
3331 if !Clflags.principal &&
3332 (Ctype.expand_head env ty_expected).level < Btype.generic_level
3333 then
3334 Location.prerr_warning loc
3335 (Warnings.Not_principal "this module packing");
3336 (p, nl)
3337 | {desc = Tvar _} ->
3338 raise (Error (loc, env, Cannot_infer_signature))
3339 | _ ->
3340 raise (Error (loc, env, Not_a_packed_module ty_expected))
3341 in
3342 let (modl, tl') = !type_package env m p nl in
3343 rue {
3344 exp_desc = Texp_pack modl;
3345 exp_loc = loc; exp_extra = [];
3346 exp_type = newty (Tpackage (p, nl, tl'));
3347 exp_attributes = sexp.pexp_attributes;
3348 exp_env = env }
3349 | Pexp_open (od, e) ->
3350 let (od, _, newenv) = !type_open_decl env od in
3351 let exp = type_expect newenv e ty_expected_explained in
3352 rue {
3353 exp_desc = Texp_open (od, exp);
3354 exp_type = exp.exp_type;
3355 exp_loc = loc;
3356 exp_extra = [];
3357 exp_attributes = sexp.pexp_attributes;
3358 exp_env = env;
3359 }
3360 | Pexp_letop{ let_ = slet; ands = sands; body = sbody } ->
3361 let rec loop spat_acc ty_acc sands =
3362 match sands with
3363 | [] -> spat_acc, ty_acc
3364 | { pbop_pat = spat; _} :: rest ->
3365 let ty = newvar () in
3366 let loc = { slet.pbop_op.loc with Location.loc_ghost = true } in
3367 let spat_acc = Ast_helper.Pat.tuple ~loc [spat_acc; spat] in
3368 let ty_acc = newty (Ttuple [ty_acc; ty]) in
3369 loop spat_acc ty_acc rest
3370 in
3371 if !Clflags.principal then begin_def ();
3372 let let_loc = slet.pbop_op.loc in
3373 let op_path, op_desc = type_binding_op_ident env slet.pbop_op in
3374 let op_type = instance op_desc.val_type in
3375 let spat_params, ty_params = loop slet.pbop_pat (newvar ()) sands in
3376 let ty_func_result = newvar () in
3377 let ty_func = newty (Tarrow(Nolabel, ty_params, ty_func_result, Cok)) in
3378 let ty_result = newvar () in
3379 let ty_andops = newvar () in
3380 let ty_op =
3381 newty (Tarrow(Nolabel, ty_andops,
3382 newty (Tarrow(Nolabel, ty_func, ty_result, Cok)), Cok))
3383 in
3384 begin try
3385 unify env op_type ty_op
3386 with Unify trace ->
3387 raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, trace)))
3388 end;
3389 if !Clflags.principal then begin
3390 end_def ();
3391 generalize_structure ty_andops;
3392 generalize_structure ty_params;
3393 generalize_structure ty_func_result;
3394 generalize_structure ty_result
3395 end;
3396 let exp, ands = type_andops env slet.pbop_exp sands ty_andops in
3397 let scase = Ast_helper.Exp.case spat_params sbody in
3398 let cases, partial =
3399 type_cases env ty_params ty_func_result true loc [scase]
3400 in
3401 let body =
3402 match cases with
3403 | [case] -> case
3404 | _ -> assert false
3405 in
3406 let param = name_cases "param" cases in
3407 let let_ =
3408 { bop_op_name = slet.pbop_op;
3409 bop_op_path = op_path;
3410 bop_op_val = op_desc;
3411 bop_op_type = op_type;
3412 bop_exp = exp;
3413 bop_loc = slet.pbop_loc; }
3414 in
3415 let desc =
3416 Texp_letop{let_; ands; param; body; partial}
3417 in
3418 rue { exp_desc = desc;
3419 exp_loc = sexp.pexp_loc;
3420 exp_extra = [];
3421 exp_type = instance ty_result;
3422 exp_env = env;
3423 exp_attributes = sexp.pexp_attributes; }
3424
3425 | Pexp_extension ({ txt = ("ocaml.extension_constructor"
3426 |"extension_constructor"); _ },
3427 payload) ->
3428 begin match payload with
3429 | PStr [ { pstr_desc =
3430 Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _)
3431 } ] ->
3432 let path =
3433 let cd =
3434 Env.lookup_constructor Env.Positive ~loc:lid.loc lid.txt env
3435 in
3436 match cd.cstr_tag with
3437 | Cstr_extension (path, _) -> path
3438 | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor))
3439 in
3440 rue {
3441 exp_desc = Texp_extension_constructor (lid, path);
3442 exp_loc = loc; exp_extra = [];
3443 exp_type = instance Predef.type_extension_constructor;
3444 exp_attributes = sexp.pexp_attributes;
3445 exp_env = env }
3446 | _ ->
3447 raise (Error (loc, env, Invalid_extension_constructor_payload))
3448 end
3449 | Pexp_extension ext ->
3450 raise (Error_forward (Builtin_attributes.error_of_extension ext))
3451
3452 | Pexp_unreachable ->
3453 re { exp_desc = Texp_unreachable;
3454 exp_loc = loc; exp_extra = [];
3455 exp_type = instance ty_expected;
3456 exp_attributes = sexp.pexp_attributes;
3457 exp_env = env }
3458
3459 and type_ident env ?(recarg=Rejected) lid =
3460 let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in
3461 if !Clflags.annotations then begin
3462 let dloc = desc.Types.val_loc in
3463 let annot =
3464 if dloc.Location.loc_ghost then Annot.Iref_external
3465 else Annot.Iref_internal dloc
3466 in
3467 let name = Path.name ~paren:Oprint.parenthesized_ident path in
3468 Stypes.record (Stypes.An_ident (lid.loc, name, annot))
3469 end;
3470 let is_recarg =
3471 match (repr desc.val_type).desc with
3472 | Tconstr(p, _, _) -> Path.is_constructor_typath p
3473 | _ -> false
3474 in
3475 begin match is_recarg, recarg, (repr desc.val_type).desc with
3476 | _, Allowed, _
3477 | true, Required, _
3478 | false, Rejected, _ -> ()
3479 | true, Rejected, _
3480 | false, Required, (Tvar _ | Tconstr _) ->
3481 raise (Error (lid.loc, env, Inlined_record_escape))
3482 | false, Required, _ -> () (* will fail later *)
3483 end;
3484 path, desc
3485
3486 and type_binding_op_ident env s =
3487 let loc = s.loc in
3488 let lid = Location.mkloc (Longident.Lident s.txt) loc in
3489 let path, desc = type_ident env lid in
3490 let path =
3491 match desc.val_kind with
3492 | Val_ivar _ ->
3493 fatal_error "Illegal name for instance variable"
3494 | Val_self (_, _, cl_num, _) ->
3495 let path, _ =
3496 Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env
3497 in
3498 path
3499 | _ -> path
3500 in
3501 path, desc
3502
3503 and type_function ?in_function loc attrs env ty_expected_explained l caselist =
3504 let { ty = ty_expected; explanation } = ty_expected_explained in
3505 let (loc_fun, ty_fun) =
3506 match in_function with Some p -> p
3507 | None -> (loc, instance ty_expected)
3508 in
3509 let separate = !Clflags.principal || Env.has_local_constraints env in
3510 if separate then begin_def ();
3511 let (ty_arg, ty_res) =
3512 try filter_arrow env (instance ty_expected) l
3513 with Unify _ ->
3514 match expand_head env ty_expected with
3515 {desc = Tarrow _} as ty ->
3516 raise(Error(loc, env, Abstract_wrong_label(l, ty, explanation)))
3517 | _ ->
3518 raise(Error(loc_fun, env,
3519 Too_many_arguments (in_function <> None,
3520 ty_fun,
3521 explanation)))
3522 in
3523 let ty_arg =
3524 if is_optional l then
3525 let tv = newvar() in
3526 begin
3527 try unify env ty_arg (type_option tv)
3528 with Unify _ -> assert false
3529 end;
3530 type_option tv
3531 else ty_arg
3532 in
3533 if separate then begin
3534 end_def ();
3535 generalize_structure ty_arg;
3536 generalize_structure ty_res
3537 end;
3538 let cases, partial =
3539 type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
3540 true loc caselist in
3541 let not_function ty =
3542 let ls, tvar = list_labels env ty in
3543 ls = [] && not tvar
3544 in
3545 if is_optional l && not_function ty_res then
3546 Location.prerr_warning (List.hd cases).c_lhs.pat_loc
3547 Warnings.Unerasable_optional_argument;
3548 let param = name_cases "param" cases in
3549 re {
3550 exp_desc = Texp_function { arg_label = l; param; cases; partial; };
3551 exp_loc = loc; exp_extra = [];
3552 exp_type = instance (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
3553 exp_attributes = attrs;
3554 exp_env = env }
3555
3556
3557 and type_label_access env srecord lid =
3558 if !Clflags.principal then begin_def ();
3559 let record = type_exp ~recarg:Allowed env srecord in
3560 if !Clflags.principal then begin
3561 end_def ();
3562 generalize_structure record.exp_type
3563 end;
3564 let ty_exp = record.exp_type in
3565 let opath =
3566 try
3567 let (p0, p,_) = extract_concrete_record env ty_exp in
3568 Some(p0, p, (repr ty_exp).level = generic_level || not !Clflags.principal)
3569 with Not_found -> None
3570 in
3571 let labels = Env.lookup_all_labels ~loc:lid.loc lid.txt env in
3572 let label =
3573 wrap_disambiguate "This expression has" (mk_expected ty_exp)
3574 (Label.disambiguate () lid env opath) labels in
3575 (record, label, opath)
3576
3577 (* Typing format strings for printing or reading.
3578 These formats are used by functions in modules Printf, Format, and Scanf.
3579 (Handling of * modifiers contributed by Thorsten Ohl.) *)
3580
3581 and type_format loc str env =
3582 let loc = {loc with Location.loc_ghost = true} in
3583 try
3584 CamlinternalFormatBasics.(CamlinternalFormat.(
3585 let mk_exp_loc pexp_desc = {
3586 pexp_desc = pexp_desc;
3587 pexp_loc = loc;
3588 pexp_loc_stack = [];
3589 pexp_attributes = [];
3590 } and mk_lid_loc lid = {
3591 txt = lid;
3592 loc = loc;
3593 } in
3594 let mk_constr name args =
3595 let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in
3596 let arg = match args with
3597 | [] -> None
3598 | [ e ] -> Some e
3599 | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in
3600 mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in
3601 let mk_cst cst = mk_exp_loc (Pexp_constant cst) in
3602 let mk_int n = mk_cst (Pconst_integer (Int.to_string n, None))
3603 and mk_string str = mk_cst (Pconst_string (str, None))
3604 and mk_char chr = mk_cst (Pconst_char chr) in
3605 let rec mk_formatting_lit fmting = match fmting with
3606 | Close_box ->
3607 mk_constr "Close_box" []
3608 | Close_tag ->
3609 mk_constr "Close_tag" []
3610 | Break (org, ns, ni) ->
3611 mk_constr "Break" [ mk_string org; mk_int ns; mk_int ni ]
3612 | FFlush ->
3613 mk_constr "FFlush" []
3614 | Force_newline ->
3615 mk_constr "Force_newline" []
3616 | Flush_newline ->
3617 mk_constr "Flush_newline" []
3618 | Magic_size (org, sz) ->
3619 mk_constr "Magic_size" [ mk_string org; mk_int sz ]
3620 | Escaped_at ->
3621 mk_constr "Escaped_at" []
3622 | Escaped_percent ->
3623 mk_constr "Escaped_percent" []
3624 | Scan_indic c ->
3625 mk_constr "Scan_indic" [ mk_char c ]
3626 and mk_formatting_gen : type a b c d e f .
3627 (a, b, c, d, e, f) formatting_gen -> Parsetree.expression =
3628 fun fmting -> match fmting with
3629 | Open_tag (Format (fmt', str')) ->
3630 mk_constr "Open_tag" [ mk_format fmt' str' ]
3631 | Open_box (Format (fmt', str')) ->
3632 mk_constr "Open_box" [ mk_format fmt' str' ]
3633 and mk_format : type a b c d e f .
3634 (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string ->
3635 Parsetree.expression = fun fmt str ->
3636 mk_constr "Format" [ mk_fmt fmt; mk_string str ]
3637 and mk_side side = match side with
3638 | Left -> mk_constr "Left" []
3639 | Right -> mk_constr "Right" []
3640 | Zeros -> mk_constr "Zeros" []
3641 and mk_iconv iconv = match iconv with
3642 | Int_d -> mk_constr "Int_d" [] | Int_pd -> mk_constr "Int_pd" []
3643 | Int_sd -> mk_constr "Int_sd" [] | Int_i -> mk_constr "Int_i" []
3644 | Int_pi -> mk_constr "Int_pi" [] | Int_si -> mk_constr "Int_si" []
3645 | Int_x -> mk_constr "Int_x" [] | Int_Cx -> mk_constr "Int_Cx" []
3646 | Int_X -> mk_constr "Int_X" [] | Int_CX -> mk_constr "Int_CX" []
3647 | Int_o -> mk_constr "Int_o" [] | Int_Co -> mk_constr "Int_Co" []
3648 | Int_u -> mk_constr "Int_u" [] | Int_Cd -> mk_constr "Int_Cd" []
3649 | Int_Ci -> mk_constr "Int_Ci" [] | Int_Cu -> mk_constr "Int_Cu" []
3650 and mk_fconv fconv =
3651 let flag = match fst fconv with
3652 | Float_flag_ -> mk_constr "Float_flag_" []
3653 | Float_flag_p -> mk_constr "Float_flag_p" []
3654 | Float_flag_s -> mk_constr "Float_flag_s" [] in
3655 let kind = match snd fconv with
3656 | Float_f -> mk_constr "Float_f" []
3657 | Float_e -> mk_constr "Float_e" []
3658 | Float_E -> mk_constr "Float_E" []
3659 | Float_g -> mk_constr "Float_g" []
3660 | Float_G -> mk_constr "Float_G" []
3661 | Float_h -> mk_constr "Float_h" []
3662 | Float_H -> mk_constr "Float_H" []
3663 | Float_F -> mk_constr "Float_F" []
3664 | Float_CF -> mk_constr "Float_CF" [] in
3665 mk_exp_loc (Pexp_tuple [flag; kind])
3666 and mk_counter cnt = match cnt with
3667 | Line_counter -> mk_constr "Line_counter" []
3668 | Char_counter -> mk_constr "Char_counter" []
3669 | Token_counter -> mk_constr "Token_counter" []
3670 and mk_int_opt n_opt = match n_opt with
3671 | None ->
3672 let lid_loc = mk_lid_loc (Longident.Lident "None") in
3673 mk_exp_loc (Pexp_construct (lid_loc, None))
3674 | Some n ->
3675 let lid_loc = mk_lid_loc (Longident.Lident "Some") in
3676 mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n)))
3677 and mk_fmtty : type a b c d e f g h i j k l .
3678 (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression
3679 =
3680 fun fmtty -> match fmtty with
3681 | Char_ty rest -> mk_constr "Char_ty" [ mk_fmtty rest ]
3682 | String_ty rest -> mk_constr "String_ty" [ mk_fmtty rest ]
3683 | Int_ty rest -> mk_constr "Int_ty" [ mk_fmtty rest ]
3684 | Int32_ty rest -> mk_constr "Int32_ty" [ mk_fmtty rest ]
3685 | Nativeint_ty rest -> mk_constr "Nativeint_ty" [ mk_fmtty rest ]
3686 | Int64_ty rest -> mk_constr "Int64_ty" [ mk_fmtty rest ]
3687 | Float_ty rest -> mk_constr "Float_ty" [ mk_fmtty rest ]
3688 | Bool_ty rest -> mk_constr "Bool_ty" [ mk_fmtty rest ]
3689 | Alpha_ty rest -> mk_constr "Alpha_ty" [ mk_fmtty rest ]
3690 | Theta_ty rest -> mk_constr "Theta_ty" [ mk_fmtty rest ]
3691 | Any_ty rest -> mk_constr "Any_ty" [ mk_fmtty rest ]
3692 | Reader_ty rest -> mk_constr "Reader_ty" [ mk_fmtty rest ]
3693 | Ignored_reader_ty rest ->
3694 mk_constr "Ignored_reader_ty" [ mk_fmtty rest ]
3695 | Format_arg_ty (sub_fmtty, rest) ->
3696 mk_constr "Format_arg_ty" [ mk_fmtty sub_fmtty; mk_fmtty rest ]
3697 | Format_subst_ty (sub_fmtty1, sub_fmtty2, rest) ->
3698 mk_constr "Format_subst_ty"
3699 [ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ]
3700 | End_of_fmtty -> mk_constr "End_of_fmtty" []
3701 and mk_ignored : type a b c d e f .
3702 (a, b, c, d, e, f) ignored -> Parsetree.expression =
3703 fun ign -> match ign with
3704 | Ignored_char ->
3705 mk_constr "Ignored_char" []
3706 | Ignored_caml_char ->
3707 mk_constr "Ignored_caml_char" []
3708 | Ignored_string pad_opt ->
3709 mk_constr "Ignored_string" [ mk_int_opt pad_opt ]
3710 | Ignored_caml_string pad_opt ->
3711 mk_constr "Ignored_caml_string" [ mk_int_opt pad_opt ]
3712 | Ignored_int (iconv, pad_opt) ->
3713 mk_constr "Ignored_int" [ mk_iconv iconv; mk_int_opt pad_opt ]
3714 | Ignored_int32 (iconv, pad_opt) ->
3715 mk_constr "Ignored_int32" [ mk_iconv iconv; mk_int_opt pad_opt ]
3716 | Ignored_nativeint (iconv, pad_opt) ->
3717 mk_constr "Ignored_nativeint" [ mk_iconv iconv; mk_int_opt pad_opt ]
3718 | Ignored_int64 (iconv, pad_opt) ->
3719 mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ]
3720 | Ignored_float (pad_opt, prec_opt) ->
3721 mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ]
3722 | Ignored_bool pad_opt ->
3723 mk_constr "Ignored_bool" [ mk_int_opt pad_opt ]
3724 | Ignored_format_arg (pad_opt, fmtty) ->
3725 mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ]
3726 | Ignored_format_subst (pad_opt, fmtty) ->
3727 mk_constr "Ignored_format_subst" [
3728 mk_int_opt pad_opt; mk_fmtty fmtty ]
3729 | Ignored_reader ->
3730 mk_constr "Ignored_reader" []
3731 | Ignored_scan_char_set (width_opt, char_set) ->
3732 mk_constr "Ignored_scan_char_set" [
3733 mk_int_opt width_opt; mk_string char_set ]
3734 | Ignored_scan_get_counter counter ->
3735 mk_constr "Ignored_scan_get_counter" [
3736 mk_counter counter
3737 ]
3738 | Ignored_scan_next_char ->
3739 mk_constr "Ignored_scan_next_char" []
3740 and mk_padding : type x y . (x, y) padding -> Parsetree.expression =
3741 fun pad -> match pad with
3742 | No_padding -> mk_constr "No_padding" []
3743 | Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ]
3744 | Arg_padding s -> mk_constr "Arg_padding" [ mk_side s ]
3745 and mk_precision : type x y . (x, y) precision -> Parsetree.expression =
3746 fun prec -> match prec with
3747 | No_precision -> mk_constr "No_precision" []
3748 | Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ]
3749 | Arg_precision -> mk_constr "Arg_precision" []
3750 and mk_fmt : type a b c d e f .
3751 (a, b, c, d, e, f) fmt -> Parsetree.expression =
3752 fun fmt -> match fmt with
3753 | Char rest ->
3754 mk_constr "Char" [ mk_fmt rest ]
3755 | Caml_char rest ->
3756 mk_constr "Caml_char" [ mk_fmt rest ]
3757 | String (pad, rest) ->
3758 mk_constr "String" [ mk_padding pad; mk_fmt rest ]
3759 | Caml_string (pad, rest) ->
3760 mk_constr "Caml_string" [ mk_padding pad; mk_fmt rest ]
3761 | Int (iconv, pad, prec, rest) ->
3762 mk_constr "Int" [
3763 mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
3764 | Int32 (iconv, pad, prec, rest) ->
3765 mk_constr "Int32" [
3766 mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
3767 | Nativeint (iconv, pad, prec, rest) ->
3768 mk_constr "Nativeint" [
3769 mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
3770 | Int64 (iconv, pad, prec, rest) ->
3771 mk_constr "Int64" [
3772 mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
3773 | Float (fconv, pad, prec, rest) ->
3774 mk_constr "Float" [
3775 mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
3776 | Bool (pad, rest) ->
3777 mk_constr "Bool" [ mk_padding pad; mk_fmt rest ]
3778 | Flush rest ->
3779 mk_constr "Flush" [ mk_fmt rest ]
3780 | String_literal (s, rest) ->
3781 mk_constr "String_literal" [ mk_string s; mk_fmt rest ]
3782 | Char_literal (c, rest) ->
3783 mk_constr "Char_literal" [ mk_char c; mk_fmt rest ]
3784 | Format_arg (pad_opt, fmtty, rest) ->
3785 mk_constr "Format_arg" [
3786 mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
3787 | Format_subst (pad_opt, fmtty, rest) ->
3788 mk_constr "Format_subst" [
3789 mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ]
3790 | Alpha rest ->
3791 mk_constr "Alpha" [ mk_fmt rest ]
3792 | Theta rest ->
3793 mk_constr "Theta" [ mk_fmt rest ]
3794 | Formatting_lit (fmting, rest) ->
3795 mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ]
3796 | Formatting_gen (fmting, rest) ->
3797 mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ]
3798 | Reader rest ->
3799 mk_constr "Reader" [ mk_fmt rest ]
3800 | Scan_char_set (width_opt, char_set, rest) ->
3801 mk_constr "Scan_char_set" [
3802 mk_int_opt width_opt; mk_string char_set; mk_fmt rest ]
3803 | Scan_get_counter (cnt, rest) ->
3804 mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ]
3805 | Scan_next_char rest ->
3806 mk_constr "Scan_next_char" [ mk_fmt rest ]
3807 | Ignored_param (ign, rest) ->
3808 mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ]
3809 | End_of_format ->
3810 mk_constr "End_of_format" []
3811 | Custom _ ->
3812 (* Custom formatters have no syntax so they will never appear
3813 in formats parsed from strings. *)
3814 assert false
3815 in
3816 let legacy_behavior = not !Clflags.strict_formats in
3817 let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in
3818 mk_constr "Format" [ mk_fmt fmt; mk_string str ]
3819 ))
3820 with Failure msg ->
3821 raise (Error (loc, env, Invalid_format msg))
3822
3823 and type_label_exp create env loc ty_expected
3824 (lid, label, sarg) =
3825 (* Here also ty_expected may be at generic_level *)
3826 begin_def ();
3827 let separate = !Clflags.principal || Env.has_local_constraints env in
3828 if separate then (begin_def (); begin_def ());
3829 let (vars, ty_arg, ty_res) = instance_label true label in
3830 if separate then begin
3831 end_def ();
3832 (* Generalize label information *)
3833 generalize_structure ty_arg;
3834 generalize_structure ty_res
3835 end;
3836 begin try
3837 unify env (instance ty_res) (instance ty_expected)
3838 with Unify trace ->
3839 raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace)))
3840 end;
3841 (* Instantiate so that we can generalize internal nodes *)
3842 let ty_arg = instance ty_arg in
3843 if separate then begin
3844 end_def ();
3845 (* Generalize information merged from ty_expected *)
3846 generalize_structure ty_arg
3847 end;
3848 if label.lbl_private = Private then
3849 if create then
3850 raise (Error(loc, env, Private_type ty_expected))
3851 else
3852 raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
3853 let arg =
3854 let snap = if vars = [] then None else Some (Btype.snapshot ()) in
3855 let arg = type_argument env sarg ty_arg (instance ty_arg) in
3856 end_def ();
3857 try
3858 check_univars env (vars <> []) "field value" arg label.lbl_arg vars;
3859 arg
3860 with exn when maybe_expansive arg -> try
3861 (* Try to retype without propagating ty_arg, cf PR#4862 *)
3862 Option.iter Btype.backtrack snap;
3863 begin_def ();
3864 let arg = type_exp env sarg in
3865 end_def ();
3866 lower_contravariant env arg.exp_type;
3867 unify_exp env arg ty_arg;
3868 check_univars env false "field value" arg label.lbl_arg vars;
3869 arg
3870 with Error (_, _, Less_general _) as e -> raise e
3871 | _ -> raise exn (* In case of failure return the first error *)
3872 in
3873 (lid, label, {arg with exp_type = instance arg.exp_type})
3874
3875 and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =
3876 (* ty_expected' may be generic *)
3877 let no_labels ty =
3878 let ls, tvar = list_labels env ty in
3879 not tvar && List.for_all ((=) Nolabel) ls
3880 in
3881 let rec is_inferred sexp =
3882 match sexp.pexp_desc with
3883 Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _
3884 | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true
3885 | Pexp_sequence (_, e) | Pexp_open (_, e) -> is_inferred e
3886 | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2
3887 | _ -> false
3888 in
3889 match expand_head env ty_expected' with
3890 {desc = Tarrow(Nolabel,ty_arg,ty_res,_); level = lv}
3891 when is_inferred sarg ->
3892 (* apply optional arguments when expected type is "" *)
3893 (* we must be very careful about not breaking the semantics *)
3894 if !Clflags.principal then begin_def ();
3895 let texp = type_exp env sarg in
3896 if !Clflags.principal then begin
3897 end_def ();
3898 generalize_structure texp.exp_type
3899 end;
3900 let rec make_args args ty_fun =
3901 match (expand_head env ty_fun).desc with
3902 | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
3903 let ty = option_none env (instance ty_arg) sarg.pexp_loc in
3904 make_args ((l, Some ty) :: args) ty_fun
3905 | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic ->
3906 List.rev args, ty_fun, no_labels ty_res'
3907 | Tvar _ -> List.rev args, ty_fun, false
3908 | _ -> [], texp.exp_type, false
3909 in
3910 let args, ty_fun', simple_res = make_args [] texp.exp_type in
3911 let warn = !Clflags.principal &&
3912 (lv <> generic_level || (repr ty_fun').level <> generic_level)
3913 and texp = {texp with exp_type = instance texp.exp_type}
3914 and ty_fun = instance ty_fun' in
3915 if not (simple_res || no_labels ty_res) then begin
3916 unify_exp env texp ty_expected;
3917 texp
3918 end else begin
3919 unify_exp env {texp with exp_type = ty_fun} ty_expected;
3920 if args = [] then texp else
3921 (* eta-expand to avoid side effects *)
3922 let var_pair name ty =
3923 let id = Ident.create_local name in
3924 let desc =
3925 { val_type = ty; val_kind = Val_reg;
3926 val_attributes = [];
3927 Types.val_loc = Location.none}
3928 in
3929 let exp_env = Env.add_value id desc env in
3930 {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
3931 pat_attributes = [];
3932 pat_loc = Location.none; pat_env = env},
3933 {exp_type = ty; exp_loc = Location.none; exp_env = exp_env;
3934 exp_extra = []; exp_attributes = [];
3935 exp_desc =
3936 Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), desc)}
3937 in
3938 let eta_pat, eta_var = var_pair "eta" ty_arg in
3939 let func texp =
3940 let e =
3941 {texp with exp_type = ty_res; exp_desc =
3942 Texp_apply
3943 (texp,
3944 args @ [Nolabel, Some eta_var])}
3945 in
3946 let cases = [case eta_pat e] in
3947 let param = name_cases "param" cases in
3948 { texp with exp_type = ty_fun; exp_desc =
3949 Texp_function { arg_label = Nolabel; param; cases;
3950 partial = Total; } }
3951 in
3952 Location.prerr_warning texp.exp_loc
3953 (Warnings.Eliminated_optional_arguments
3954 (List.map (fun (l, _) -> Printtyp.string_of_label l) args));
3955 if warn then Location.prerr_warning texp.exp_loc
3956 (Warnings.Without_principality "eliminated optional argument");
3957 (* let-expand to have side effects *)
3958 let let_pat, let_var = var_pair "arg" texp.exp_type in
3959 re { texp with exp_type = ty_fun; exp_desc =
3960 Texp_let (Nonrecursive,
3961 [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[];
3962 vb_loc=Location.none;
3963 }],
3964 func let_var) }
3965 end
3966 | _ ->
3967 let texp = type_expect ?recarg env sarg
3968 (mk_expected ?explanation ty_expected') in
3969 unify_exp env texp ty_expected;
3970 texp
3971
3972 and type_application env funct sargs =
3973 (* funct.exp_type may be generic *)
3974 let result_type omitted ty_fun =
3975 List.fold_left
3976 (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
3977 ty_fun omitted
3978 in
3979 let has_label l ty_fun =
3980 let ls, tvar = list_labels env ty_fun in
3981 tvar || List.mem l ls
3982 in
3983 let ignored = ref [] in
3984 let rec type_unknown_args
3985 (args :
3986 (Asttypes.arg_label * (unit -> Typedtree.expression) option) list)
3987 omitted ty_fun = function
3988 [] ->
3989 (List.map
3990 (function l, None -> l, None
3991 | l, Some f -> l, Some (f ()))
3992 (List.rev args),
3993 instance (result_type omitted ty_fun))
3994 | (l1, sarg1) :: sargl ->
3995 let (ty1, ty2) =
3996 let ty_fun = expand_head env ty_fun in
3997 match ty_fun.desc with
3998 Tvar _ ->
3999 let t1 = newvar () and t2 = newvar () in
4000 let not_identity = function
4001 Texp_ident(_,_,{val_kind=Val_prim
4002 {Primitive.prim_name="%identity"}}) ->
4003 false
4004 | _ -> true
4005 in
4006 if ty_fun.level >= t1.level && not_identity funct.exp_desc then
4007 Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
4008 unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
4009 (t1, t2)
4010 | Tarrow (l,t1,t2,_) when l = l1
4011 || !Clflags.classic && l1 = Nolabel && not (is_optional l) ->
4012 (t1, t2)
4013 | td ->
4014 let ty_fun =
4015 match td with Tarrow _ -> newty td | _ -> ty_fun in
4016 let ty_res = result_type (omitted @ !ignored) ty_fun in
4017 match ty_res.desc with
4018 Tarrow _ ->
4019 if (!Clflags.classic || not (has_label l1 ty_fun)) then
4020 raise (Error(sarg1.pexp_loc, env,
4021 Apply_wrong_label(l1, ty_res)))
4022 else
4023 raise (Error(funct.exp_loc, env, Incoherent_label_order))
4024 | _ ->
4025 raise(Error(funct.exp_loc, env, Apply_non_function
4026 (expand_head env funct.exp_type)))
4027 in
4028 let optional = is_optional l1 in
4029 let arg1 () =
4030 let arg1 = type_expect env sarg1 (mk_expected ty1) in
4031 if optional then
4032 unify_exp env arg1 (type_option(newvar()));
4033 arg1
4034 in
4035 type_unknown_args ((l1, Some arg1) :: args) omitted ty2 sargl
4036 in
4037 let ignore_labels =
4038 !Clflags.classic ||
4039 begin
4040 let ls, tvar = list_labels env funct.exp_type in
4041 not tvar &&
4042 let labels = List.filter (fun l -> not (is_optional l)) ls in
4043 List.length labels = List.length sargs &&
4044 List.for_all (fun (l,_) -> l = Nolabel) sargs &&
4045 List.exists (fun l -> l <> Nolabel) labels &&
4046 (Location.prerr_warning
4047 funct.exp_loc
4048 (Warnings.Labels_omitted
4049 (List.map Printtyp.string_of_label
4050 (List.filter ((<>) Nolabel) labels)));
4051 true)
4052 end
4053 in
4054 let warned = ref false in
4055 let rec type_args args omitted ty_fun ty_fun0 ty_old sargs more_sargs =
4056 match expand_head env ty_fun, expand_head env ty_fun0 with
4057 {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun',
4058 {desc=Tarrow (_, ty0, ty_fun0, _)}
4059 when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->
4060 let may_warn loc w =
4061 if not !warned && !Clflags.principal && lv <> generic_level
4062 then begin
4063 warned := true;
4064 Location.prerr_warning loc w
4065 end
4066 in
4067 let name = label_name l
4068 and optional = is_optional l in
4069 let sargs, more_sargs, arg =
4070 if ignore_labels && not (is_optional l) then begin
4071 (* In classic mode, omitted = [] *)
4072 match sargs, more_sargs with
4073 (l', sarg0) :: _, _ ->
4074 raise(Error(sarg0.pexp_loc, env,
4075 Apply_wrong_label(l', ty_old)))
4076 | _, (l', sarg0) :: more_sargs ->
4077 if l <> l' && l' <> Nolabel then
4078 raise(Error(sarg0.pexp_loc, env,
4079 Apply_wrong_label(l', ty_fun')))
4080 else
4081 ([], more_sargs,
4082 Some (fun () -> type_argument env sarg0 ty ty0))
4083 | _ ->
4084 assert false
4085 end else try
4086 let (l', sarg0, sargs, more_sargs) =
4087 try
4088 let (l', sarg0, sargs1, sargs2) = extract_label name sargs in
4089 if sargs1 <> [] then
4090 may_warn sarg0.pexp_loc
4091 (Warnings.Not_principal "commuting this argument");
4092 (l', sarg0, sargs1 @ sargs2, more_sargs)
4093 with Not_found ->
4094 let (l', sarg0, sargs1, sargs2) =
4095 extract_label name more_sargs in
4096 if sargs1 <> [] || sargs <> [] then
4097 may_warn sarg0.pexp_loc
4098 (Warnings.Not_principal "commuting this argument");
4099 (l', sarg0, sargs @ sargs1, sargs2)
4100 in
4101 if not optional && is_optional l' then
4102 Location.prerr_warning sarg0.pexp_loc
4103 (Warnings.Nonoptional_label (Printtyp.string_of_label l));
4104 sargs, more_sargs,
4105 if not optional || is_optional l' then
4106 Some (fun () -> type_argument env sarg0 ty ty0)
4107 else begin
4108 may_warn sarg0.pexp_loc
4109 (Warnings.Not_principal "using an optional argument here");
4110 Some (fun () -> option_some env (type_argument env sarg0
4111 (extract_option_type env ty)
4112 (extract_option_type env ty0)))
4113 end
4114 with Not_found ->
4115 sargs, more_sargs,
4116 if optional &&
4117 (List.mem_assoc Nolabel sargs
4118 || List.mem_assoc Nolabel more_sargs)
4119 then begin
4120 may_warn funct.exp_loc
4121 (Warnings.Without_principality "eliminated optional argument");
4122 ignored := (l,ty,lv) :: !ignored;
4123 Some (fun () -> option_none env (instance ty) Location.none)
4124 end else begin
4125 may_warn funct.exp_loc
4126 (Warnings.Without_principality "commuted an argument");
4127 None
4128 end
4129 in
4130 let omitted =
4131 if arg = None then (l,ty,lv) :: omitted else omitted in
4132 let ty_old = if sargs = [] then ty_fun else ty_old in
4133 type_args ((l,arg)::args) omitted ty_fun ty_fun0
4134 ty_old sargs more_sargs
4135 | _ ->
4136 match sargs with
4137 (l, sarg0) :: _ when ignore_labels ->
4138 raise(Error(sarg0.pexp_loc, env,
4139 Apply_wrong_label(l, ty_old)))
4140 | _ ->
4141 type_unknown_args args omitted ty_fun0
4142 (sargs @ more_sargs)
4143 in
4144 let is_ignore funct =
4145 match funct.exp_desc with
4146 Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}) ->
4147 (try ignore (filter_arrow env (instance funct.exp_type) Nolabel);
4148 true
4149 with Unify _ -> false)
4150 | _ -> false
4151 in
4152 match sargs with
4153 (* Special case for ignore: avoid discarding warning *)
4154 [Nolabel, sarg] when is_ignore funct ->
4155 let ty_arg, ty_res =
4156 filter_arrow env (instance funct.exp_type) Nolabel
4157 in
4158 let exp = type_expect env sarg (mk_expected ty_arg) in
4159 check_partial_application false exp;
4160 ([Nolabel, Some exp], ty_res)
4161 | _ ->
4162 let ty = funct.exp_type in
4163 if ignore_labels then
4164 type_args [] [] ty (instance ty) ty [] sargs
4165 else
4166 type_args [] [] ty (instance ty) ty sargs []
4167
4168 and type_construct env loc lid sarg ty_expected_explained attrs =
4169 let { ty = ty_expected; explanation } = ty_expected_explained in
4170 let opath =
4171 try
4172 let (p0, p,_) = extract_concrete_variant env ty_expected in
4173 let principal =
4174 (repr ty_expected).level = generic_level || not !Clflags.principal
4175 in
4176 Some(p0, p, principal)
4177 with Not_found -> None
4178 in
4179 let constrs =
4180 Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env
4181 in
4182 let constr =
4183 wrap_disambiguate "This variant expression is expected to have"
4184 ty_expected_explained
4185 (Constructor.disambiguate Env.Positive lid env opath) constrs
4186 in
4187 let sargs =
4188 match sarg with
4189 None -> []
4190 | Some {pexp_desc = Pexp_tuple sel} when
4191 constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs
4192 -> sel
4193 | Some se -> [se] in
4194 if List.length sargs <> constr.cstr_arity then
4195 raise(Error(loc, env, Constructor_arity_mismatch
4196 (lid.txt, constr.cstr_arity, List.length sargs)));
4197 let separate = !Clflags.principal || Env.has_local_constraints env in
4198 if separate then (begin_def (); begin_def ());
4199 let (ty_args, ty_res) = instance_constructor constr in
4200 let texp =
4201 re {
4202 exp_desc = Texp_construct(lid, constr, []);
4203 exp_loc = loc; exp_extra = [];
4204 exp_type = ty_res;
4205 exp_attributes = attrs;
4206 exp_env = env } in
4207 if separate then begin
4208 end_def ();
4209 generalize_structure ty_res;
4210 with_explanation explanation (fun () ->
4211 unify_exp env {texp with exp_type = instance ty_res}
4212 (instance ty_expected));
4213 end_def ();
4214 List.iter generalize_structure ty_args;
4215 generalize_structure ty_res;
4216 end;
4217 let ty_args0, ty_res =
4218 match instance_list (ty_res :: ty_args) with
4219 t :: tl -> tl, t
4220 | _ -> assert false
4221 in
4222 let texp = {texp with exp_type = ty_res} in
4223 if not separate then unify_exp env texp (instance ty_expected);
4224 let recarg =
4225 match constr.cstr_inlined with
4226 | None -> Rejected
4227 | Some _ ->
4228 begin match sargs with
4229 | [{pexp_desc =
4230 Pexp_ident _ |
4231 Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] ->
4232 Required
4233 | _ ->
4234 raise (Error(loc, env, Inlined_record_expected))
4235 end
4236 in
4237 let args =
4238 List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs
4239 (List.combine ty_args ty_args0) in
4240 if constr.cstr_private = Private then
4241 begin match constr.cstr_tag with
4242 | Cstr_extension _ ->
4243 raise(Error(loc, env, Private_constructor (constr, ty_res)))
4244 | Cstr_constant _ | Cstr_block _ | Cstr_unboxed ->
4245 raise (Error(loc, env, Private_type ty_res));
4246 end;
4247 (* NOTE: shouldn't we call "re" on this final expression? -- AF *)
4248 { texp with
4249 exp_desc = Texp_construct(lid, constr, args) }
4250
4251 (* Typing of statements (expressions whose values are discarded) *)
4252
4253 and type_statement ?explanation env sexp =
4254 begin_def();
4255 let exp = type_exp env sexp in
4256 end_def();
4257 let ty = expand_head env exp.exp_type and tv = newvar() in
4258 if is_Tvar ty && ty.level > tv.level then
4259 Location.prerr_warning
4260 (final_subexpression exp).exp_loc
4261 Warnings.Nonreturning_statement;
4262 if !Clflags.strict_sequence then
4263 let expected_ty = instance Predef.type_unit in
4264 with_explanation explanation (fun () ->
4265 unify_exp env exp expected_ty);
4266 exp
4267 else begin
4268 check_partial_application true exp;
4269 unify_var env tv ty;
4270 exp
4271 end
4272
4273 (* Typing of match cases *)
4274 and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag
4275 loc caselist =
4276 (* ty_arg is _fully_ generalized *)
4277 let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
4278 let contains_polyvars = List.exists contains_polymorphic_variant patterns in
4279 let erase_either = contains_polyvars && contains_variant_either ty_arg in
4280 let may_contain_gadts = List.exists may_contain_gadts patterns in
4281 let ty_arg =
4282 if (may_contain_gadts || erase_either) && not !Clflags.principal
4283 then correct_levels ty_arg else ty_arg
4284 in
4285 let rec is_var spat =
4286 match spat.ppat_desc with
4287 Ppat_any | Ppat_var _ -> true
4288 | Ppat_alias (spat, _) -> is_var spat
4289 | _ -> false in
4290 let needs_exhaust_check =
4291 match caselist with
4292 [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true
4293 | [{pc_lhs}] when is_var pc_lhs -> false
4294 | _ -> true
4295 in
4296 let outer_level = get_current_level () in
4297 let lev =
4298 if may_contain_gadts then begin_def ();
4299 get_current_level ()
4300 in
4301 let take_partial_instance =
4302 if !Clflags.principal || erase_either
4303 then Some false else None
4304 in
4305 begin_def (); (* propagation of the argument *)
4306 let pattern_force = ref [] in
4307 (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
4308 Printtyp.raw_type_expr ty_arg; *)
4309 let half_typed_cases =
4310 List.map
4311 (fun ({pc_lhs; pc_guard; pc_rhs} as case) ->
4312 let loc =
4313 let open Location in
4314 match pc_guard with
4315 | None -> pc_rhs.pexp_loc
4316 | Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start}
4317 in
4318 if !Clflags.principal then begin_def (); (* propagation of pattern *)
4319 let scope = Some (Annot.Idef loc) in
4320 begin_def ();
4321 let ty_arg = instance ?partial:take_partial_instance ty_arg in
4322 end_def ();
4323 generalize_structure ty_arg;
4324 let (pat, ext_env, force, pvs, unpacks) =
4325 type_pattern ?exception_allowed ~lev env pc_lhs scope ty_arg
4326 in
4327 pattern_force := force @ !pattern_force;
4328 let pat =
4329 if !Clflags.principal then begin
4330 end_def ();
4331 iter_pattern_variables_type generalize_structure pvs;
4332 { pat with pat_type = instance pat.pat_type }
4333 end else pat
4334 in
4335 (* Ensure that no ambivalent pattern type escapes its branch *)
4336 check_scope_escape pat.pat_loc env outer_level ty_arg;
4337 { typed_pat = pat;
4338 pat_type_for_unif = ty_arg;
4339 untyped_case = case;
4340 branch_env = ext_env;
4341 pat_vars = pvs;
4342 unpacks;
4343 contains_gadt = contains_gadt pat; }
4344 )
4345 caselist in
4346 let patl = List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in
4347 let does_contain_gadt =
4348 List.exists (fun { contains_gadt; _ } -> contains_gadt) half_typed_cases
4349 in
4350 let ty_res, do_copy_types =
4351 if does_contain_gadt && not !Clflags.principal then
4352 correct_levels ty_res, Env.make_copy_of_types env
4353 else ty_res, (fun env -> env)
4354 in
4355 (* Unify all cases (delayed to keep it order-free) *)
4356 let ty_arg' = newvar () in
4357 let unify_pats ty =
4358 List.iter (fun { typed_pat = pat; pat_type_for_unif = pat_ty; _ } ->
4359 unify_pat_types pat.pat_loc (ref env) pat_ty ty
4360 ) half_typed_cases
4361 in
4362 unify_pats ty_arg';
4363 (* Check for polymorphic variants to close *)
4364 if List.exists has_variants patl then begin
4365 Parmatch.pressure_variants env patl;
4366 List.iter (iter_pattern finalize_variant) patl
4367 end;
4368 (* `Contaminating' unifications start here *)
4369 List.iter (fun f -> f()) !pattern_force;
4370 (* Post-processing and generalization *)
4371 if take_partial_instance <> None then unify_pats (instance ty_arg);
4372 List.iter (fun { pat_vars; _ } ->
4373 iter_pattern_variables_type (fun t -> unify_var env (newvar()) t) pat_vars
4374 ) half_typed_cases;
4375 end_def ();
4376 generalize ty_arg';
4377 List.iter (fun { pat_vars; _ } ->
4378 iter_pattern_variables_type generalize pat_vars
4379 ) half_typed_cases;
4380 (* type bodies *)
4381 let in_function = if List.length caselist = 1 then in_function else None in
4382 let cases =
4383 List.map
4384 (fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks;
4385 untyped_case = {pc_lhs = _; pc_guard; pc_rhs};
4386 contains_gadt; _ } ->
4387 let ext_env =
4388 if contains_gadt then
4389 do_copy_types ext_env
4390 else
4391 ext_env
4392 in
4393 let ext_env =
4394 add_pattern_variables ext_env pvs
4395 ~check:(fun s -> Warnings.Unused_var_strict s)
4396 ~check_as:(fun s -> Warnings.Unused_var s)
4397 in
4398 let sexp = wrap_unpacks pc_rhs unpacks in
4399 let ty_res' =
4400 if !Clflags.principal then begin
4401 begin_def ();
4402 let ty = instance ~partial:true ty_res in
4403 end_def ();
4404 generalize_structure ty; ty
4405 end
4406 else if contains_gadt then
4407 (* Even though we've already done that, apparently we need to do it
4408 again.
4409 stdlib/camlinternalFormat.ml:2288 is an example of use of this
4410 call to [correct_levels]... *)
4411 correct_levels ty_res
4412 else ty_res in
4413 (* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
4414 Printtyp.raw_type_expr ty_res'; *)
4415 let guard =
4416 match pc_guard with
4417 | None -> None
4418 | Some scond ->
4419 Some
4420 (type_expect ext_env (wrap_unpacks scond unpacks)
4421 (mk_expected ~explanation:When_guard Predef.type_bool))
4422 in
4423 let exp =
4424 type_expect ?in_function ext_env sexp (mk_expected ty_res') in
4425 {
4426 c_lhs = pat;
4427 c_guard = guard;
4428 c_rhs = {exp with exp_type = instance ty_res'}
4429 }
4430 )
4431 half_typed_cases
4432 in
4433 if !Clflags.principal || does_contain_gadt then begin
4434 let ty_res' = instance ty_res in
4435 List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
4436 end;
4437 let do_init = may_contain_gadts || needs_exhaust_check in
4438 let ty_arg_check =
4439 if do_init then
4440 (* Hack: use for_saving to copy variables too *)
4441 Subst.type_expr (Subst.for_saving Subst.identity) ty_arg'
4442 else ty_arg'
4443 in
4444 let val_cases, exn_cases = split_cases env cases in
4445 if val_cases = [] && exn_cases <> [] then
4446 raise (Error (loc, env, No_value_clauses));
4447 let partial =
4448 if partial_flag then
4449 check_partial ~lev env ty_arg_check loc val_cases
4450 else
4451 Partial
4452 in
4453 let unused_check delayed =
4454 List.iter (fun { typed_pat; branch_env; _ } ->
4455 check_absent_variant branch_env typed_pat
4456 ) half_typed_cases;
4457 if delayed then (begin_def (); init_def lev);
4458 check_unused ~lev env ty_arg_check val_cases ;
4459 check_unused ~lev env Predef.type_exn exn_cases ;
4460 if delayed then end_def ();
4461 Parmatch.check_ambiguous_bindings val_cases ;
4462 Parmatch.check_ambiguous_bindings exn_cases
4463 in
4464 if contains_polyvars then
4465 add_delayed_check (fun () -> unused_check true)
4466 else
4467 (* Check for unused cases, do not delay because of gadts *)
4468 unused_check false;
4469 if may_contain_gadts then begin
4470 end_def ();
4471 (* Ensure that existential types do not escape *)
4472 unify_exp_types loc env (instance ty_res) (newvar ()) ;
4473 end;
4474 cases, partial
4475
4476 (* Typing of let bindings *)
4477
4478 and type_let
4479 ?(check = fun s -> Warnings.Unused_var s)
4480 ?(check_strict = fun s -> Warnings.Unused_var_strict s)
4481 existential_context
4482 env rec_flag spat_sexp_list scope allow =
4483 let open Ast_helper in
4484 begin_def();
4485 if !Clflags.principal then begin_def ();
4486
4487 let is_fake_let =
4488 match spat_sexp_list with
4489 | [{pvb_expr={pexp_desc=Pexp_match(
4490 {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->
4491 true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
4492 | _ ->
4493 false
4494 in
4495 let check = if is_fake_let then check_strict else check in
4496
4497 let spatl =
4498 List.map
4499 (fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=attrs} ->
4500 attrs,
4501 match spat.ppat_desc, sexp.pexp_desc with
4502 (Ppat_any | Ppat_constraint _), _ -> spat
4503 | _, Pexp_coerce (_, _, sty)
4504 | _, Pexp_constraint (_, sty) when !Clflags.principal ->
4505 (* propagate type annotation to pattern,
4506 to allow it to be generalized in -principal mode *)
4507 Pat.constraint_
4508 ~loc:{spat.ppat_loc with Location.loc_ghost=true}
4509 spat
4510 sty
4511 | _ -> spat)
4512 spat_sexp_list in
4513 let nvs = List.map (fun _ -> newvar ()) spatl in
4514 let (pat_list, new_env, force, pvs, unpacks) =
4515 type_pattern_list existential_context env spatl scope nvs allow in
4516 let attrs_list = List.map fst spatl in
4517 let is_recursive = (rec_flag = Recursive) in
4518 (* If recursive, first unify with an approximation of the expression *)
4519 if is_recursive then
4520 List.iter2
4521 (fun pat binding ->
4522 let pat =
4523 match pat.pat_type.desc with
4524 | Tpoly (ty, tl) ->
4525 {pat with pat_type =
4526 snd (instance_poly ~keep_names:true false tl ty)}
4527 | _ -> pat
4528 in unify_pat (ref env) pat (type_approx env binding.pvb_expr))
4529 pat_list spat_sexp_list;
4530 (* Polymorphic variant processing *)
4531 List.iter
4532 (fun pat ->
4533 if has_variants pat then begin
4534 Parmatch.pressure_variants env [pat];
4535 iter_pattern finalize_variant pat
4536 end)
4537 pat_list;
4538 (* Generalize the structure *)
4539 let pat_list =
4540 if !Clflags.principal then begin
4541 end_def ();
4542 iter_pattern_variables_type generalize_structure pvs;
4543 List.map (fun pat ->
4544 generalize_structure pat.pat_type;
4545 {pat with pat_type = instance pat.pat_type}
4546 ) pat_list
4547 end else
4548 pat_list
4549 in
4550 (* Only bind pattern variables after generalizing *)
4551 List.iter (fun f