Fix warning 102 suppression for polymorphic comparisons

Author: cknitt

compiler/core/lam_compile_primitive.ml

@@ -389,23 +389,19 @@ let translate output_prefix loc (cxt : Lam_compile_context.t)
               || E.is_null_undefined_constant e2) ->
       E.neq_null_undefined_boolean e1 e2
     | [e1; e2] ->
-      Location.prerr_warning loc Warnings.Bs_polymorphic_comparison;
       E.runtime_call Primitive_modules.object_
         (Lam_compile_util.runtime_of_comp cmp)
         args
     | _ -> assert false)
   | Pobjorder -> (
-    Location.prerr_warning loc Warnings.Bs_polymorphic_comparison;
     match args with
     | [a; b] -> E.runtime_call Primitive_modules.object_ "compare" args
     | _ -> assert false)
   | Pobjmin -> (
-    Location.prerr_warning loc Warnings.Bs_polymorphic_comparison;
     match args with
     | [a; b] -> E.runtime_call Primitive_modules.object_ "min" args
     | _ -> assert false)
   | Pobjmax -> (
-    Location.prerr_warning loc Warnings.Bs_polymorphic_comparison;
     match args with
     | [a; b] -> E.runtime_call Primitive_modules.object_ "max" args
     | _ -> assert false)

compiler/ml/translcore.ml

@@ -439,6 +439,19 @@ let specialize_primitive p env ty (* ~has_constant_constructor *) =
       | None -> table.objcomp
     with Not_found -> find_primitive p.prim_name)
 
+let is_null_undefined_constant = function
+  | Lprim ((Pnull | Pundefined), [], _) -> true
+  | _ -> false
+
+let warn_polymorphic_comparison loc prim args =
+  match (prim, args) with
+  | Pobjcomp (Ceq | Cneq), [arg1; arg2]
+    when is_null_undefined_constant arg1 || is_null_undefined_constant arg2 ->
+    ()
+  | (Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax), _ ->
+    Location.prerr_warning loc Warnings.Bs_polymorphic_comparison
+  | _ -> ()
+
 (* Eta-expand a primitive *)
 
 let transl_primitive loc p env ty =
@@ -447,6 +460,7 @@ let transl_primitive loc p env ty =
     try specialize_primitive p env ty (* ~has_constant_constructor:false *)
     with Not_found -> Pccall p
   in
+  warn_polymorphic_comparison loc prim [];
   match prim with
   | Ploc kind -> (
     let lam = lam_of_loc kind loc in
@@ -653,8 +667,9 @@ let extract_directive_for_fn exp =
          else None)
 
 let rec transl_exp e =
-  List.iter (Translattribute.check_attribute e) e.exp_attributes;
-  transl_exp0 e
+  Builtin_attributes.warning_scope ~ppwarning:false e.exp_attributes (fun () ->
+      List.iter (Translattribute.check_attribute e) e.exp_attributes;
+      transl_exp0 e)
 
 and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
   match e.exp_desc with
@@ -734,6 +749,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
     let prim =
       transl_primitive_application e.exp_loc p e.exp_env prim_type args
     in
+    warn_polymorphic_comparison e.exp_loc prim argl;
     match (prim, args) with
     | Praise k, [_] ->
       let targ = List.hd argl in
@@ -1082,7 +1098,10 @@ and transl_let rec_flag pat_expr_list body =
     let rec transl = function
       | [] -> body
       | {vb_pat = pat; vb_expr = expr; vb_attributes = attr; vb_loc} :: rem ->
-        let lam = transl_exp expr in
+        let lam =
+          Builtin_attributes.warning_scope ~ppwarning:false attr (fun () ->
+              transl_exp expr)
+        in
         let lam = Translattribute.add_inline_attribute lam vb_loc attr in
         Matching.for_let pat.pat_loc lam pat (transl rem)
     in
@@ -1098,7 +1117,10 @@ and transl_let rec_flag pat_expr_list body =
            Only variables are allowed as left-hand side of `let rec'
         *)
       in
-      let lam = transl_exp expr in
+      let lam =
+        Builtin_attributes.warning_scope ~ppwarning:false vb_attributes
+          (fun () -> transl_exp expr)
+      in
       let lam = Translattribute.add_inline_attribute lam vb_loc vb_attributes in
       (id, lam)
     in

tests/build_tests/super_errors/expected/warning102.res.expected

@@ -0,0 +1,20 @@
+
+  Warning number 22
+  /.../fixtures/warning102.res:1:32-38
+
+  1 │ let ppwarningOnce = @ppwarning("hello") 1
+  2 │ 
+  3 │ @warning("-102")
+
+  hello
+
+
+  Warning number 102
+  /.../fixtures/warning102.res:11:13-22
+
+   9 │ let comparesToNull = x => x == Nullable.null
+  10 │ 
+  11 │ let warns = [3] == [3]
+  12 │ 
+
+  Polymorphic comparison introduced (maybe unsafe)

tests/build_tests/super_errors/fixtures/warning102.res

@@ -0,0 +1,11 @@
+let ppwarningOnce = @ppwarning("hello") 1
+
+@warning("-102")
+let suppressedBinding =
+  [1] == [1]
+
+let suppressedExpression = @warning("-102") ([2] == [2])
+
+let comparesToNull = x => x == Nullable.null
+
+let warns = [3] == [3]