Warn on literal patterns found anywhere in a constructor's arguments.

Changes

@@ -145,6 +145,10 @@ Working version
 
 ### Compiler user-interface and warnings:
 
+- GPR#2133: Warn on literal patterns found anywhere in a constructor's
+  arguments.
+  (Jeremy Yallop, review by Gabriel Scherer)
+
 - PR#2096: Add source highlighting for errors & warnings in batch mode
   (Armaël Guéneau, review by Gabriel Scherer and Jérémie Dimino)
 

manual/manual/cmds/comp.etex

@@ -423,6 +423,11 @@ let dy { y; _ } = y (* explicit field elision: do not trigger warning 9 *)
   this attribute set: "Invalid_argument", "Failure", "Sys_error" will
   all raise this warning if you match for a specific string argument.
 
+  Additionally, built-in exceptions with a structured argument that
+  includes a string also have the attribute set: "Assert_failure" and
+  "Match_failure" will raise the warning for a pattern that uses a
+  literal string to match the first element of their tuple argument.
+
   If your code raises this warning, you should {\em not} change the
   way you test for the specific string to avoid the warning (for
   example using a string equality inside the right-hand-side instead

testsuite/tests/warnings/w52.ml

@@ -1,33 +1,100 @@
 (* TEST
-
-flags = "-w A"
-
-* setup-ocamlc.byte-build-env
-** ocamlc.byte
-compile_only = "true"
-*** check-ocamlc.byte-output
-
+   flags = "-w A"
+   * expect
 *)
 
 let () = try () with Invalid_argument "Any" -> ();;
+[%%expect{|
+Line 1, characters 38-43:
+1 | let () = try () with Invalid_argument "Any" -> ();;
+                                          ^^^^^
+Warning 52: Code should not depend on the actual values of
+this constructor's arguments. They are only for information
+and may change in future versions. (See manual section 9.5)
+|}];;
+
+let () = try () with Match_failure ("Any",_,_) -> ();;
+[%%expect{|
+Line 1, characters 35-46:
+1 | let () = try () with Match_failure ("Any",_,_) -> ();;
+                                       ^^^^^^^^^^^
+Warning 52: Code should not depend on the actual values of
+this constructor's arguments. They are only for information
+and may change in future versions. (See manual section 9.5)
+|}];;
+
+let () = try () with Match_failure (_,0,_) -> ();;
+[%%expect{|
+Line 1, characters 35-42:
+1 | let () = try () with Match_failure (_,0,_) -> ();;
+                                       ^^^^^^^
+Warning 52: Code should not depend on the actual values of
+this constructor's arguments. They are only for information
+and may change in future versions. (See manual section 9.5)
+|}];;
 
 type t =
   | Warn of string  [@ocaml.warn_on_literal_pattern]
   | Without_warning of string
-  | Warn' of nativeint [@ocaml.warn_on_literal_pattern];;
+  | Warn' of nativeint [@ocaml.warn_on_literal_pattern]
+  | Deep of (string * int) list [@ocaml.warn_on_literal_pattern];;
+[%%expect{|
+type t =
+    Warn of string
+  | Without_warning of string
+  | Warn' of nativeint
+  | Deep of (string * int) list
+|}];;
 
 let f = function
 | Warn "anything" -> ()
-| Warn _ | Warn' _ | Without_warning _ -> ()
-;;
+| Warn _ | Warn' _ | Without_warning _ | Deep _ -> ();;
+[%%expect{|
+Line 2, characters 7-17:
+2 | | Warn "anything" -> ()
+           ^^^^^^^^^^
+Warning 52: Code should not depend on the actual values of
+this constructor's arguments. They are only for information
+and may change in future versions. (See manual section 9.5)
+val f : t -> unit = <fun>
+|}];;
 
 let g = function
 | Warn' 0n -> ()
-| Warn _ | Warn' _ | Without_warning _ -> ()
-;;
-
+| Warn _ | Warn' _ | Without_warning _ | Deep _ -> ();;
+[%%expect{|
+Line 2, characters 8-10:
+2 | | Warn' 0n -> ()
+            ^^
+Warning 52: Code should not depend on the actual values of
+this constructor's arguments. They are only for information
+and may change in future versions. (See manual section 9.5)
+val g : t -> unit = <fun>
+|}];;
 
 let h = function
 | Without_warning "outside" -> ()
-| Warn _ | Warn' _ | Without_warning _ -> ()
-;;
+| Warn _ | Warn' _ | Without_warning _ | Deep _ -> ();;
+[%%expect{|
+val h : t -> unit = <fun>
+|}];;
+
+let i = function
+| Deep (_ :: _ :: _ :: _) -> ()
+| Warn _ | Warn' _ | Without_warning _ | Deep _ -> ();;
+[%%expect{|
+val i : t -> unit = <fun>
+|}];;
+
+let j = function
+| Deep (_ :: _ :: ("deep",_) :: _) -> ()
+| Warn _ | Warn' _ | Without_warning _ | Deep _ -> ();;
+[%%expect{|
+Line 2, characters 7-34:
+2 | | Deep (_ :: _ :: ("deep",_) :: _) -> ()
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 52: Code should not depend on the actual values of
+this constructor's arguments. They are only for information
+and may change in future versions. (See manual section 9.5)
+val j : t -> unit = <fun>
+|}];;

typing/typecore.ml

@@ -1063,6 +1063,33 @@ let all_idents_cases half_typed_cases =
     half_typed_cases;
   Hashtbl.fold (fun x () rest -> x :: rest) idents []
 
+let rec has_literal_pattern p = match p.ppat_desc with
+  | Ppat_constant _
+  | Ppat_interval _ ->
+     true
+  | Ppat_any
+  | Ppat_variant (_, None)
+  | Ppat_construct (_, None)
+  | Ppat_type _
+  | Ppat_var _
+  | Ppat_unpack _
+  | Ppat_extension _ ->
+     false
+  | Ppat_exception p
+  | Ppat_variant (_, Some p)
+  | Ppat_construct (_, Some p)
+  | Ppat_constraint (p, _)
+  | Ppat_alias (p, _)
+  | Ppat_lazy p
+  | Ppat_open (_, p) ->
+     has_literal_pattern p
+  | Ppat_tuple ps
+  | Ppat_array ps ->
+     List.exists has_literal_pattern ps
+  | Ppat_record (ps, _) ->
+     List.exists (fun (_,p) -> has_literal_pattern p) ps
+  | Ppat_or (p, q) ->
+     has_literal_pattern p || has_literal_pattern q
 
 exception Need_backtrack
 
@@ -1273,14 +1300,12 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode
                                      Warnings.Wildcard_arg_to_constant_constr;
             replicate_list sp constr.cstr_arity
         | Some sp -> [sp] in
-      begin match sargs with
-      | [{ppat_desc = Ppat_constant _} as sp]
-        when Builtin_attributes.warn_on_literal_pattern
-            constr.cstr_attributes ->
-          Location.prerr_warning sp.ppat_loc
-            Warnings.Fragile_literal_pattern
-      | _ -> ()
-      end;
+      if Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes then
+        begin match List.filter has_literal_pattern sargs with
+        | sp :: _ ->
+           Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern
+        | _ -> ()
+        end;
       if List.length sargs <> constr.cstr_arity then
         raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
                                      constr.cstr_arity, List.length sargs)));