Per type warn 4

testsuite/tests/warnings/w04.ml

@@ -10,3 +10,34 @@ type t = A | B
 let g x = match x with
 | A -> 0
 | _ -> 1
+
+type u = C | D [@@ ocaml.warning "-4"]
+(* should not warn. *)
+let h x = match x with
+| C -> 0
+| _ -> 1
+
+[@@@ocaml.warning "-4"]
+
+type v = F | G [@@ ocaml.warning "+4"]
+
+let k x = match x with
+| F -> 0
+| _ -> 1
+
+(* should not warn. *)
+let l x = match x with
+| A -> 0
+| _ -> 1
+
+[@@@ocaml.warning "--4"]
+(* should not warn. *)
+let m x = match x with
+| F -> 0
+| _ -> 1
+
+[@@@ocaml.warning "++4"]
+(*should warn. *)
+let n x = match x with
+| C -> 0
+| _ -> 1

testsuite/tests/warnings/w04.reference

@@ -1,3 +1,9 @@
 File "w04.ml", line 10, characters 10-40:
 Warning 4: this pattern-matching is fragile.
 It will remain exhaustive when constructors are added to type t.
+File "w04.ml", line 24, characters 10-40:
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type v.
+File "w04.ml", line 41, characters 10-40:
+Warning 4: this pattern-matching is fragile.
+It will remain exhaustive when constructors are added to type u.

typing/parmatch.ml

@@ -127,8 +127,10 @@ let clean_copy ty =
 let get_type_path ty tenv =
   let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in
   match ty.desc with
-  | Tconstr (path,_,_) -> path
-  | _ -> fatal_error "Parmatch.get_type_path"
+  | Tconstr (path,_,_) -> Some path
+  | _ -> None
+   (* Same as PR#6394: we have an incoherence due to recursive module. It
+      will result in a type error later on. *)
 
 (*************************************)
 (* Values as patterns pretty printer *)
@@ -670,7 +672,9 @@ let should_extend ext env = match ext with
       | Tpat_construct
           (_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},_) ->
             let path = get_type_path p.pat_type p.pat_env in
-            Path.same path ext
+            (match path with
+             | Some path -> Path.same path ext
+             | None -> false)
       | Tpat_construct
           (_, {cstr_tag=(Cstr_extension _)},_) -> false
       | Tpat_constant _|Tpat_tuple _|Tpat_variant _
@@ -802,8 +806,11 @@ let build_other ext env = match env with
                             {lid with txt="*extension*"})) Ctype.none Env.empty
 | ({pat_desc = Tpat_construct _} as p,_) :: _ ->
     begin match ext with
-    | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
-        extra_pat
+    | Some ext ->
+        let path =  (get_type_path p.pat_type p.pat_env) in
+        (match path with
+         | Some path when Path.same ext path -> extra_pat
+         | _ -> build_other_constrs env p)
     | _ ->
         build_other_constrs env p
     end
@@ -1869,14 +1876,28 @@ let extendable_path path =
     Path.same path Predef.path_unit ||
     Path.same path Predef.path_option)
 
+let warn_fragile_type ty env =
+  let _,_,decl = Ctype.extract_concrete_typedecl env ty in
+  let warn = Warnings.Fragile_match "" in
+  match Warnings.status warn with
+    | Warnings.Always -> true
+    | Warnings.Never -> false
+    | Warnings.Implicit | Warnings.Explicit ->
+        Builtin_attributes.with_warning_attribute
+          decl.Types.type_attributes
+          (fun () -> Warnings.(is_active warn))
+
 let rec collect_paths_from_pat r p = match p.pat_desc with
 | Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps)
   ->
-    let path =  get_type_path p.pat_type p.pat_env in
-    List.fold_left
-      collect_paths_from_pat
-      (if extendable_path path then add_path path r else r)
-      ps
+    (match get_type_path p.pat_type p.pat_env with
+     | Some path ->
+         List.fold_left
+           collect_paths_from_pat
+           (if extendable_path path && warn_fragile_type p.pat_type p.pat_env
+            then add_path path r else r)
+           ps
+     | None -> r)
 | Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
 | Tpat_tuple ps | Tpat_array ps
 | Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps)->
@@ -1896,7 +1917,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
 (*
   Actual fragile check
    1. Collect data types in the patterns of the match.
-   2. One exhautivity check per datatype, considering that
+   2. One exhaustivity check per datatype, considering that
       the type is extended.
 *)
 
@@ -1910,6 +1931,8 @@ let do_check_fragile_param exhaust loc casel pss =
   | _ -> match pss with
     | [] -> ()
     | ps::_ ->
+        let old_status = Warnings.is_active (Warnings.Fragile_match "") in
+        Warnings.parse_options false "+4";
         List.iter
           (fun ext ->
             match exhaust (Some ext) pss (List.length ps) with
@@ -1918,7 +1941,8 @@ let do_check_fragile_param exhaust loc casel pss =
                   loc
                   (Warnings.Fragile_match (Path.name ext))
             | Rsome _ -> ())
-          exts
+          exts;
+        if not old_status then Warnings.parse_options false "-4"
 
 (*let do_check_fragile_normal = do_check_fragile_param exhaust*)
 let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt
@@ -2034,7 +2058,7 @@ let check_partial_param do_check_partial do_check_fragile loc casel =
       let pss = get_mins le_pats pss in
       let total = do_check_partial loc casel pss in
       if
-        total = Total && Warnings.is_active (Warnings.Fragile_match "")
+        total = Total
       then begin
         do_check_fragile loc casel pss
       end ;

utils/warnings.ml

@@ -193,16 +193,20 @@ let letter = function
   | _ -> assert false
 ;;
 
+type status = Always | Implicit | Explicit | Never
+
 type state =
   {
     active: bool array;
+    flexible: bool array;
     error: bool array;
   }
 
 let current =
   ref
     {
       active = Array.make (last_warning_number + 1) true;
+      flexible = Array.make (last_warning_number + 1) true;
       error = Array.make (last_warning_number + 1) false;
     }
 
@@ -211,12 +215,27 @@ let backup () = !current
 let restore x = current := x
 
 let is_active x = (!current).active.(number x);;
+
+let status x =
+  let n = number x in
+  match (!current).active.(n), (!current).flexible.(n) with
+    | true, false -> Always
+    | true, true -> Implicit
+    | false, true -> Explicit
+    | false, false -> Never
+;;
+
 let is_error x = (!current).error.(number x);;
 
-let parse_opt error active flags s =
-  let set i = flags.(i) <- true in
-  let clear i = flags.(i) <- false in
-  let set_all i = active.(i) <- true; error.(i) <- true in
+let parse_opt error active flexible flags s =
+  let set i = flags.(i) <- true; flexible.(i) <- true in
+  let set_strict i = flags.(i) <- true; flexible.(i) <- false in
+  let clear i = flags.(i) <- false; flexible.(i) <- true in
+  let clear_strict i = flags.(i) <- false; flexible.(i) <- false in
+  let set_all i = active.(i) <- true; error.(i) <- true; flexible.(i) <- true in
+  let set_all_strict i =
+    active.(i) <- true; error.(i) <- true; flexible.(i) <- false
+  in
   let error () = raise (Arg.Bad "Ill-formed list of warnings") in
   let rec get_num n i =
     if i >= String.length s then i, n
@@ -233,6 +252,7 @@ let parse_opt error active flags s =
     else
       i, n1, n1
   in
+  let need_char i = if i + 1 >= String.length s then error () in
   let rec loop i =
     if i >= String.length s then () else
     match s.[i] with
@@ -242,9 +262,18 @@ let parse_opt error active flags s =
     | 'a' .. 'z' ->
        List.iter clear (letter s.[i]);
        loop (i+1)
-    | '+' -> loop_letter_num set (i+1)
-    | '-' -> loop_letter_num clear (i+1)
-    | '@' -> loop_letter_num set_all (i+1)
+    | '+' ->
+        need_char i;
+        if s.[i+1] = '+' then loop_letter_num set_strict (i+2)
+        else loop_letter_num set (i+1)
+    | '-' ->
+        need_char i;
+        if s.[i+1] = '-' then loop_letter_num clear_strict (i+2)
+        else loop_letter_num clear (i+1)
+    | '@' ->
+        need_char i;
+        if s.[i+1] = '@' then loop_letter_num set_all_strict (i+2)
+        else loop_letter_num set_all (i+1)
     | _ -> error ()
   and loop_letter_num myset i =
     if i >= String.length s then error () else
@@ -267,8 +296,9 @@ let parse_opt error active flags s =
 let parse_options errflag s =
   let error = Array.copy (!current).error in
   let active = Array.copy (!current).active in
-  parse_opt error active (if errflag then error else active) s;
-  current := {error; active}
+  let flexible = Array.copy (!current).flexible in
+  parse_opt error active flexible (if errflag then error else active) s;
+  current := {error; active; flexible}
 
 (* If you change these, don't forget to change them in man/ocamlc.m *)
 let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48-50-60";;

utils/warnings.mli

@@ -78,9 +78,24 @@ type t =
   | Constraint_on_gadt                      (* 62 *)
 ;;
 
+(* For warnings that can be enabled by attributes on external declarations,
+    the status indicates whether we should follow the current state of the
+    warning or the one given by those external declarations.
+
+    An example of such warning is Fragile_match, which can be (de)activated on a
+    per-type basis. See PR#7310 for an extended discussion.
+*)
+type status =
+  | Always (* warning always active. *)
+  | Implicit (* warning active, but external declarations may deactivate it.*)
+  | Explicit (* warning not active, external declaration may activate it.*)
+  | Never (* warning never active. *)
+;;
+
 val parse_options : bool -> string -> unit;;
 
 val is_active : t -> bool;;
+val status : t -> status;;
 val is_error : t -> bool;;
 
 val defaults_w : string;;