@@ -278,7 +278,7 @@ let option_none ty loc =
278
278
let cnone = Env. lookup_constructor lid env in
279
279
mkexp (Texp_construct (mknoloc lid, cnone, [] )) ty loc env
280
280
281
- let tainted () =
281
+ let tainted_expr () =
282
282
let lid = Longident. Lident " None" and env = Env. initial_safe_string in
283
283
let cnone = Env. lookup_constructor lid env in
284
284
{
@@ -290,6 +290,19 @@ let tainted () =
290
290
exp_attributes = [(Location. mknoloc " tainted" , PStr [] )];
291
291
}
292
292
293
+ let tainted_pat expected_type =
294
+ let env = Env. initial_safe_string in
295
+ {
296
+ pat_desc = Tpat_var (Ident. create " tainted$" , Location. mknoloc " tainted$" );
297
+ pat_type = expected_type;
298
+ pat_loc = Location. none;
299
+ pat_env = env;
300
+ pat_extra = [] ;
301
+ pat_attributes = [(Location. mknoloc " tainted" , PStr [] )];
302
+ }
303
+
304
+ let _ = ignore tainted_pat
305
+
293
306
let option_some texp =
294
307
let lid = Longident. Lident " Some" in
295
308
let csome = Env. lookup_constructor lid Env. initial_safe_string in
@@ -1529,21 +1542,27 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp
1529
1542
if vars = [] then end_def () ;
1530
1543
(try unify_pat_types loc ! env ty_res record_ty
1531
1544
with Unify trace ->
1532
- raise
1545
+ raise_or_continue
1533
1546
(Error (label_lid.loc, ! env, Label_mismatch (label_lid.txt, trace))));
1534
- type_pat sarg ty_arg (fun arg ->
1535
- if vars <> [] then (
1536
- end_def () ;
1537
- generalize ty_arg;
1538
- List. iter generalize vars;
1539
- let instantiated tv =
1540
- let tv = expand_head ! env tv in
1541
- (not (is_Tvar tv)) || tv.level <> generic_level
1542
- in
1543
- if List. exists instantiated vars then
1544
- raise
1545
- (Error (label_lid.loc, ! env, Polymorphic_label label_lid.txt)));
1546
- k (label_lid, label, arg, opt))
1547
+ try
1548
+ type_pat sarg ty_arg (fun arg ->
1549
+ if vars <> [] then (
1550
+ end_def () ;
1551
+ generalize ty_arg;
1552
+ List. iter generalize vars;
1553
+ let instantiated tv =
1554
+ let tv = expand_head ! env tv in
1555
+ (not (is_Tvar tv)) || tv.level <> generic_level
1556
+ in
1557
+ if List. exists instantiated vars then
1558
+ raise_or_continue
1559
+ (Error (label_lid.loc, ! env, Polymorphic_label label_lid.txt)));
1560
+ k (label_lid, label, arg, opt))
1561
+ with err ->
1562
+ if ! Clflags. editor_mode then (
1563
+ add_delayed_error err;
1564
+ k (label_lid, label, tainted_pat ty_arg, opt))
1565
+ else raise err
1547
1566
in
1548
1567
let k' k lbl_pat_list =
1549
1568
check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list
@@ -3578,7 +3597,7 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
3578
3597
( l,
3579
3598
Some
3580
3599
(if ! Clflags. editor_mode then
3581
- try f () with _ -> tainted ()
3600
+ try f () with _ -> tainted_expr ()
3582
3601
else f () ) ))
3583
3602
(List. rev args),
3584
3603
instance env (result_type omitted ty_fun) )
0 commit comments