PR#7031 Handle module variables in patterns.

testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml

@@ -166,12 +166,27 @@ let not_ambiguous__constructor = function
 ;;
 
 
-type tt = Z of int | Y of int * int  | X of tt * tt
+type amoi = Z of int | Y of int * int  | X of amoi * amoi
 ;;
 
-let ambiguous a = match a with
+let ambiguous__amoi a = match a with
 | X (Z x,Y (y,0))
 | X (Z y,Y (x,_))
  when x+y > 0 -> 0
 | X _|Y _|Z _ -> 1
 ;;
+
+module type S = sig val b : bool end
+;;
+
+let ambiguous__module_variable x b =  match x with
+  | (module M:S),_,(1,_)
+  | _,(module M:S),(_,1) when M.b && b -> 1
+  | _ -> 2
+;;
+
+let not_ambiguous__module_variable x b =  match x with
+  | (module M:S),_,(1,_)
+  | _,(module M:S),(_,1) when b -> 1
+  | _ -> 2
+;;

testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml.reference

@@ -93,10 +93,19 @@ val ambiguous__second_orpat :
 #           val not_ambiguous__lazy : ('a list * 'b list) * bool lazy_t -> unit = <fun>
 #   type t = A of int * int option * int option | B
 #         val not_ambiguous__constructor : t -> unit = <fun>
-#       type tt = Z of int | Y of int * int | X of tt * tt
-#             Characters 34-67:
+#       type amoi = Z of int | Y of int * int | X of amoi * amoi
+#             Characters 40-73:
   ..X (Z x,Y (y,0))
   | X (Z y,Y (x,_))
 Warning 57: Ambiguous guarded pattern, variables x,y may match different or-pattern arguments
-val ambiguous : tt -> int = <fun>
+val ambiguous__amoi : amoi -> int = <fun>
+#     module type S = sig val b : bool end
+#           Characters 56-101:
+  ....(module M:S),_,(1,_)
+    | _,(module M:S),(_,1)...................
+Warning 57: Ambiguous guarded pattern, variable M may match different or-pattern arguments
+val ambiguous__module_variable :
+  (module S) * (module S) * (int * int) -> bool -> int = <fun>
+#           val not_ambiguous__module_variable :
+  (module S) * (module S) * (int * int) -> bool -> int = <fun>
 # 

typing/parmatch.ml

@@ -2165,20 +2165,56 @@ let rec do_stable rs = match rs with
 let stable p = do_stable [{unseen=[p]; seen=[];}]
 
 
-(* all identifier paths that appear in an expression.
+(* All identifier paths that appear in an expression that occurs
+   as a clause right hand side or guard.
 
-   This could be in a more general place, but for the ambiguous guards
-   seem to be the only user. At the same time, it cannot go in
-   typedtree.mli, as it depends on TypedtreeIter.
+  The function is rather complex due to the compilation of
+  unpack patterns by introducing code in rhs expressions
+  and **guards**.
+
+  For pattern (module M:S)  -> e the code is
+  let module M_mod = unpack M .. in e
+
+  Hence M is "free" in e iff M_mod is free in e.
+
+  Not doing so will yield excessive  warning in
+  (module (M:S) } ...) when true -> ....
+  as M is always present in 
+  let module M_mod = unpack M .. in true 
 *)
-let all_exp_idents exp =
+
+let all_rhs_idents exp =
   let ids = ref IdSet.empty in
   let module Iterator = TypedtreeIter.MakeIterator(struct
     include TypedtreeIter.DefaultIteratorArgument
     let enter_expression exp = match exp.exp_desc with
-      | Texp_ident (Path.Pident id, _lid, _descr) ->
-         ids := IdSet.add id !ids 
+      | Texp_ident (path, _lid, _descr) ->
+          List.iter
+            (fun id -> ids := IdSet.add id !ids)
+            (Path.heads path)
       | _ -> ()
+
+(* Very hackish, detect unpack pattern  compilation
+   and perfom "indirect check for them" *)
+    let is_unpack exp =
+      List.exists
+        (fun (attr, _) -> attr.txt = "#modulepat") exp.exp_attributes
+
+    let leave_expression exp =
+      if is_unpack exp then begin match exp.exp_desc with
+      | Texp_letmodule
+          (id_mod,_,
+           {mod_desc=
+            Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
+           _) ->
+             assert (IdSet.mem id_exp !ids) ;
+             if not (IdSet.mem id_mod !ids) then begin
+               ids := IdSet.remove id_exp !ids
+             end
+      | _ -> assert false
+      end
+
+
   end) in
   Iterator.iter_expression exp;
   !ids
@@ -2193,7 +2229,7 @@ let check_ambiguous_bindings =
         | { c_guard=None ; _} -> ()
         | { c_lhs=p; c_guard=Some g; _} ->
             let all =
-              IdSet.inter (pattern_vars p) (all_exp_idents g) in
+              IdSet.inter (pattern_vars p) (all_rhs_idents g) in
             if not (IdSet.is_empty all) then begin
               let st = stable p in
               let ambiguous = IdSet.diff all st in