Skip to content

Commit 37709c7

Browse files
committed
handle ppat_record labels as tainted
1 parent e3f8084 commit 37709c7

File tree

2 files changed

+37
-17
lines changed

2 files changed

+37
-17
lines changed

analysis/src/ProcessExtra.ml

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -373,7 +373,8 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator)
373373
(* Log.log("Entering pattern " ++ Utils.showLocation(pat_loc)); *)
374374
(match pattern.pat_desc with
375375
| Tpat_record (items, _) ->
376-
addForRecord ~env ~extra ~recordType:pattern.pat_type items
376+
addForRecord ~env ~extra ~recordType:pattern.pat_type items;
377+
addLocItem extra pattern.pat_loc (OtherPattern pattern.pat_type)
377378
| Tpat_construct (lident, constructor, _) ->
378379
addForConstructor ~env ~extra pattern.pat_type lident constructor
379380
| Tpat_alias (_inner, ident, name) ->

compiler/ml/typecore.ml

Lines changed: 35 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -278,7 +278,7 @@ let option_none ty loc =
278278
let cnone = Env.lookup_constructor lid env in
279279
mkexp (Texp_construct (mknoloc lid, cnone, [])) ty loc env
280280

281-
let tainted () =
281+
let tainted_expr () =
282282
let lid = Longident.Lident "None" and env = Env.initial_safe_string in
283283
let cnone = Env.lookup_constructor lid env in
284284
{
@@ -290,6 +290,19 @@ let tainted () =
290290
exp_attributes = [(Location.mknoloc "tainted", PStr [])];
291291
}
292292

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+
293306
let option_some texp =
294307
let lid = Longident.Lident "Some" in
295308
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
15291542
if vars = [] then end_def ();
15301543
(try unify_pat_types loc !env ty_res record_ty
15311544
with Unify trace ->
1532-
raise
1545+
raise_or_continue
15331546
(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
15471566
in
15481567
let k' k lbl_pat_list =
15491568
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) :
35783597
( l,
35793598
Some
35803599
(if !Clflags.editor_mode then
3581-
try f () with _ -> tainted ()
3600+
try f () with _ -> tainted_expr ()
35823601
else f ()) ))
35833602
(List.rev args),
35843603
instance env (result_type omitted ty_fun) )

0 commit comments

Comments
 (0)