handle ppat_record labels as tainted

Author: zth

analysis/src/ProcessExtra.ml

@@ -373,7 +373,8 @@ let pat ~(file : File.t) ~env ~extra (iter : Tast_iterator.iterator)
   (* Log.log("Entering pattern " ++ Utils.showLocation(pat_loc)); *)
   (match pattern.pat_desc with
   | Tpat_record (items, _) ->
-    addForRecord ~env ~extra ~recordType:pattern.pat_type items
+    addForRecord ~env ~extra ~recordType:pattern.pat_type items;
+    addLocItem extra pattern.pat_loc (OtherPattern pattern.pat_type)
   | Tpat_construct (lident, constructor, _) ->
     addForConstructor ~env ~extra pattern.pat_type lident constructor
   | Tpat_alias (_inner, ident, name) ->

compiler/ml/typecore.ml

@@ -275,7 +275,7 @@ let option_none ty loc =
   let cnone = Env.lookup_constructor lid env in
   mkexp (Texp_construct (mknoloc lid, cnone, [])) ty loc env
 
-let tainted () =
+let tainted_expr () =
   let lid = Longident.Lident "None" and env = Env.initial_safe_string in
   let cnone = Env.lookup_constructor lid env in
   {
@@ -287,6 +287,19 @@ let tainted () =
     exp_attributes = [(Location.mknoloc "tainted", PStr [])];
   }
 
+let tainted_pat expected_type =
+  let env = Env.initial_safe_string in
+  {
+    pat_desc = Tpat_var (Ident.create "tainted$", Location.mknoloc "tainted$");
+    pat_type = expected_type;
+    pat_loc = Location.none;
+    pat_env = env;
+    pat_extra = [];
+    pat_attributes = [(Location.mknoloc "tainted", PStr [])];
+  }
+
+let _ = ignore tainted_pat
+
 let option_some texp =
   let lid = Longident.Lident "Some" in
   let csome = Env.lookup_constructor lid Env.initial_safe_string in
@@ -1526,21 +1539,27 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp
       if vars = [] then end_def ();
       (try unify_pat_types loc !env ty_res record_ty
        with Unify trace ->
-         raise
+         raise_or_continue
            (Error (label_lid.loc, !env, Label_mismatch (label_lid.txt, trace))));
-      type_pat sarg ty_arg (fun arg ->
-          if vars <> [] then (
-            end_def ();
-            generalize ty_arg;
-            List.iter generalize vars;
-            let instantiated tv =
-              let tv = expand_head !env tv in
-              (not (is_Tvar tv)) || tv.level <> generic_level
-            in
-            if List.exists instantiated vars then
-              raise
-                (Error (label_lid.loc, !env, Polymorphic_label label_lid.txt)));
-          k (label_lid, label, arg, opt))
+      try
+        type_pat sarg ty_arg (fun arg ->
+            if vars <> [] then (
+              end_def ();
+              generalize ty_arg;
+              List.iter generalize vars;
+              let instantiated tv =
+                let tv = expand_head !env tv in
+                (not (is_Tvar tv)) || tv.level <> generic_level
+              in
+              if List.exists instantiated vars then
+                raise_or_continue
+                  (Error (label_lid.loc, !env, Polymorphic_label label_lid.txt)));
+            k (label_lid, label, arg, opt))
+      with err ->
+        if !Clflags.editor_mode then (
+          add_delayed_error err;
+          k (label_lid, label, tainted_pat ty_arg, opt))
+        else raise err
     in
     let k' k lbl_pat_list =
       check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list
@@ -3572,7 +3591,7 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
                 ( l,
                   Some
                     (if !Clflags.editor_mode then
-                       try f () with _ -> tainted ()
+                       try f () with _ -> tainted_expr ()
                      else f ()) ))
             (List.rev args),
           instance env (result_type omitted ty_fun) )