patterns: move Parmatch.Pattern_head into Patterns.Head

The aim is to also move the Simple/Half_simple/General stuff from
matching, but we need to split in those modules the part that are
purely structural (they go in Patterns) and the parts that are
actually compilation logic (Half_simple.of_clause), those stay in
Matching.

8 files changed, 373 insertions, 320 deletions

diff --git a/.depend b/.depend
index 1c2692e1e0..5699200974 100644
--- a/.depend
+++ b/.depend
@@ -771,6 +771,7 @@ typing/parmatch.cmo : \
     typing/subst.cmi \
     typing/printpat.cmi \
     typing/predef.cmi \
+    typing/patterns.cmi \
     typing/path.cmi \
     parsing/parsetree.cmi \
     utils/misc.cmi \
@@ -793,6 +794,7 @@ typing/parmatch.cmx : \
     typing/subst.cmx \
     typing/printpat.cmx \
     typing/predef.cmx \
+    typing/patterns.cmx \
     typing/path.cmx \
     parsing/parsetree.cmi \
     utils/misc.cmx \
@@ -821,6 +823,32 @@ typing/path.cmx : \
     typing/path.cmi
 typing/path.cmi : \
     typing/ident.cmi
+typing/patterns.cmo : \
+    typing/types.cmi \
+    typing/typedtree.cmi \
+    parsing/longident.cmi \
+    parsing/location.cmi \
+    typing/env.cmi \
+    typing/ctype.cmi \
+    typing/btype.cmi \
+    parsing/asttypes.cmi \
+    typing/patterns.cmi
+typing/patterns.cmx : \
+    typing/types.cmx \
+    typing/typedtree.cmx \
+    parsing/longident.cmx \
+    parsing/location.cmx \
+    typing/env.cmx \
+    typing/ctype.cmx \
+    typing/btype.cmx \
+    parsing/asttypes.cmi \
+    typing/patterns.cmi
+typing/patterns.cmi : \
+    typing/types.cmi \
+    typing/typedtree.cmi \
+    parsing/location.cmi \
+    typing/env.cmi \
+    parsing/asttypes.cmi
 typing/persistent_env.cmo : \
     utils/warnings.cmi \
     utils/misc.cmi \
@@ -3270,6 +3298,7 @@ lambda/matching.cmo : \
     lambda/printlambda.cmi \
     typing/primitive.cmi \
     typing/predef.cmi \
+    typing/patterns.cmi \
     typing/parmatch.cmi \
     utils/misc.cmi \
     parsing/longident.cmi \
@@ -3291,6 +3320,7 @@ lambda/matching.cmx : \
     lambda/printlambda.cmx \
     typing/primitive.cmx \
     typing/predef.cmx \
+    typing/patterns.cmx \
     typing/parmatch.cmx \
     utils/misc.cmx \
     parsing/longident.cmx \
diff --git a/compilerlibs/Makefile.compilerlibs b/compilerlibs/Makefile.compilerlibs
index 59d8050cfb..9ab36d608e 100644
--- a/compilerlibs/Makefile.compilerlibs
+++ b/compilerlibs/Makefile.compilerlibs
@@ -57,7 +57,7 @@ TYPING=typing/ident.cmo typing/path.cmo \
   typing/tast_iterator.cmo typing/tast_mapper.cmo typing/stypes.cmo \
   file_formats/cmt_format.cmo typing/cmt2annot.cmo typing/untypeast.cmo \
   typing/includemod.cmo typing/typetexp.cmo typing/printpat.cmo \
-  typing/parmatch.cmo \
+  typing/patterns.cmo typing/parmatch.cmo \
   typing/typedecl_properties.cmo typing/typedecl_variance.cmo \
   typing/typedecl_unboxed.cmo typing/typedecl_immediacy.cmo \
   typing/typedecl_separability.cmo \
diff --git a/dune b/dune
index f80f6391d6..f5b52af0f1 100644
--- a/dune
+++ b/dune
@@ -59,7 +59,8 @@
    cmi_format persistent_env env type_immediacy
    typedtree printtyped ctype printtyp includeclass mtype envaux includecore
    tast_iterator tast_mapper cmt_format untypeast includemod
-   typetexp printpat parmatch stypes typedecl typeopt rec_check typecore
+   typetexp patterns printpat parmatch stypes typedecl typeopt rec_check
+   typecore
    typeclass typemod typedecl_variance typedecl_properties typedecl_immediacy
    typedecl_unboxed typedecl_separability cmt2annot
    ; manual update: mli only files
diff --git a/lambda/matching.ml b/lambda/matching.ml
index 0dc275d971..7d6f34e84b 100644
--- a/lambda/matching.ml
+++ b/lambda/matching.ml
@@ -135,7 +135,8 @@ let all_record_args lbls =
   | (_, { lbl_all }, _) :: _ ->
       let t =
         Array.map
-          (fun lbl -> (mknoloc (Longident.Lident "?temp?"), lbl, omega))
+          (fun lbl ->
+            (mknoloc (Longident.Lident "?temp?"), lbl, Patterns.omega))
           lbl_all
       in
       List.iter (fun ((_, lbl, _) as x) -> t.(lbl.lbl_pos) <- x) lbls;
@@ -149,14 +150,14 @@ let rec expand_record p =
   | _ -> p
 
 let expand_record_head head =
-  match Pattern_head.desc head with
+  match Patterns.Head.desc head with
   | Record _ ->
-      head |> Pattern_head.to_omega_pattern |> expand_record
-      |> Pattern_head.deconstruct |> fst
+      head |> Patterns.Head.to_omega_pattern |> expand_record
+      |> Patterns.Head.deconstruct |> fst
   | _ -> head
 
 let head_loc ~scopes head =
-  Scoped_location.of_location ~scopes (Pattern_head.loc head)
+  Scoped_location.of_location ~scopes (Patterns.Head.loc head)
 
 type 'a clause = 'a * lambda
 
@@ -296,7 +297,7 @@ end = struct
       in
       match p.pat_desc with
       | `Any -> stop p `Any
-      | `Var (id, s) -> continue p (`Alias (omega, id, s))
+      | `Var (id, s) -> continue p (`Alias (Patterns.omega, id, s))
       | `Alias (p, id, _) ->
           let k = Typeopt.value_kind p.pat_env p.pat_type in
           aux
@@ -326,7 +327,7 @@ module Simple : sig
 
   type clause = pattern Non_empty_clause.t
 
-  val head : pattern -> Pattern_head.t
+  val head : pattern -> Patterns.Head.t
 
   val explode_or_pat :
     Half_simple.pattern * Typedtree.pattern list ->
@@ -341,7 +342,7 @@ end = struct
   type clause = pattern Non_empty_clause.t
 
   let head p =
-    fst (Pattern_head.deconstruct (General.erase (p :> General.pattern)))
+    fst (Patterns.Head.deconstruct (General.erase (p :> General.pattern)))
 
   let alpha env (p : pattern) : pattern =
     let alpha_pat env p = Typedtree.alpha_pat env p in
@@ -384,7 +385,7 @@ end = struct
       | `Alias (p, id, _) -> split_explode p (id :: aliases) rem
       | `Var (id, str) ->
           explode
-            { p with pat_desc = `Alias (Parmatch.omega, id, str) }
+            { p with pat_desc = `Alias (Patterns.omega, id, str) }
             aliases rem
       | #simple_view as view ->
           let env = mk_alpha_env arg aliases vars in
@@ -405,7 +406,7 @@ type initial_clause = pattern list clause
 
 type matrix = pattern list list
 
-let add_omega_column pss = List.map (fun ps -> omega :: ps) pss
+let add_omega_column pss = List.map (fun ps -> Patterns.omega :: ps) pss
 
 let rec rev_split_at n ps =
   if n <= 0 then
@@ -422,8 +423,8 @@ exception NoMatch
 let matcher discr (p : Simple.pattern) rem =
   let discr = expand_record_head discr in
   let p = expand_record_simple p in
-  let omegas = omegas (Pattern_head.arity discr) in
-  let ph, args = Pattern_head.deconstruct (General.erase p) in
+  let omegas = Patterns.(omegas (Head.arity discr)) in
+  let ph, args = Patterns.Head.deconstruct (General.erase p) in
   let yes () = args @ rem in
   let no () = raise NoMatch in
   let yesif b =
@@ -432,7 +433,7 @@ let matcher discr (p : Simple.pattern) rem =
     else
       no ()
   in
-  match (Pattern_head.desc discr, Pattern_head.desc ph) with
+  match (Patterns.Head.desc discr, Patterns.Head.desc ph) with
   | Any, _ -> rem
   | ( ( Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _
       | Tuple _ ),
@@ -489,7 +490,7 @@ module Context : sig
 
   val eprintf : t -> unit
 
-  val specialize : Pattern_head.t -> t -> t
+  val specialize : Patterns.Head.t -> t -> t
 
   val lshift : t -> t
 
@@ -522,7 +523,7 @@ end = struct
 
     let lforget { left; right } =
       match right with
-      | _ :: xs -> { left = omega :: left; right = xs }
+      | _ :: xs -> { left = Patterns.omega :: left; right = xs }
       | _ -> assert false
 
     let rshift { left; right } =
@@ -547,7 +548,7 @@ end = struct
 
   let empty = []
 
-  let start n : t = [ { left = []; right = omegas n } ]
+  let start n : t = [ { left = []; right = Patterns.omegas n } ]
 
   let is_empty = function
     | [] -> true
@@ -583,13 +584,13 @@ end = struct
           | `Or (p1, p2, _) ->
               filter_rec ((left, p1, right) :: (left, p2, right) :: rem)
           | `Alias (p, _, _) -> filter_rec ((left, p, right) :: rem)
-          | `Var _ -> filter_rec ((left, omega, right) :: rem)
+          | `Var _ -> filter_rec ((left, Patterns.omega, right) :: rem)
           | #simple_view as view -> (
               let p = { p with pat_desc = view } in
               match matcher head p right with
               | exception NoMatch -> filter_rec rem
               | right ->
-                  let left = Pattern_head.to_omega_pattern head :: left in
+                  let left = Patterns.Head.to_omega_pattern head :: left in
                   { Row.left; right }
                   :: filter_rec rem
             )
@@ -628,7 +629,7 @@ end
 
 let rec flatten_pat_line size p k =
   match p.pat_desc with
-  | Tpat_any -> omegas size :: k
+  | Tpat_any -> Patterns.omegas size :: k
   | Tpat_tuple args -> args :: k
   | Tpat_or (p1, p2, _) ->
       flatten_pat_line size p1 (flatten_pat_line size p2 k)
@@ -675,7 +676,7 @@ module Default_environment : sig
 
   val cons : matrix -> int -> t -> t
 
-  val specialize : Pattern_head.t -> t -> t
+  val specialize : Patterns.Head.t -> t -> t
 
   val pop_column : t -> t
 
@@ -708,7 +709,7 @@ end = struct
           let p = General.view p in
           match p.pat_desc with
           | `Alias (p, _, _) -> filter_rec ((p, ps) :: rem)
-          | `Var _ -> filter_rec ((omega, ps) :: rem)
+          | `Var _ -> filter_rec ((Patterns.omega, ps) :: rem)
           | `Or (p1, p2, _) -> filter_rec_or p1 p2 ps rem
           | #simple_view as view -> (
               let p = { p with pat_desc = view } in
@@ -806,7 +807,7 @@ end = struct
     make_rec env
 
   let specialize head def =
-    specialize_ (Pattern_head.arity head) (matcher head) def
+    specialize_ (Patterns.Head.arity head) (matcher head) def
 
   let pop_column def = specialize_ 0 (fun _p rem -> rem) def
 
@@ -1125,10 +1126,10 @@ let half_simplify_clause ~arg (cls : Typedtree.pattern list clause) =
 
 let rec what_is_cases ~skip_any cases =
   match cases with
-  | [] -> Pattern_head.omega
+  | [] -> Patterns.Head.omega
   | ((p, _), _) :: rem -> (
       let head = Simple.head p in
-      match Pattern_head.desc head with
+      match Patterns.Head.desc head with
       | Any when skip_any -> what_is_cases ~skip_any rem
       | _ -> head
     )
@@ -1145,7 +1146,7 @@ let pm_free_variables { cases } =
 (* Basic grouping predicates *)
 
 let can_group discr pat =
-  match (Pattern_head.desc discr, Pattern_head.desc (Simple.head pat)) with
+  match (Patterns.Head.desc discr, Patterns.Head.desc (Simple.head pat)) with
   | Any, Any
   | Constant (Const_int _), Constant (Const_int _)
   | Constant (Const_char _), Constant (Const_char _)
@@ -1193,7 +1194,7 @@ let rec omega_like p =
   | _ -> false
 
 let simple_omega_like p =
-  match Pattern_head.desc (Simple.head p) with
+  match Patterns.Head.desc (Simple.head p) with
   | Any -> true
   | _ -> false
 
@@ -1413,7 +1414,7 @@ and split_no_or cls args def k =
         insert_split group_discr yes no def k
   and insert_split group_discr yes no def k =
     let precompile_group =
-      match Pattern_head.desc group_discr with
+      match Patterns.Head.desc group_discr with
       | Any -> precompile_var
       | _ -> do_not_precompile
     in
@@ -1426,7 +1427,7 @@ and split_no_or cls args def k =
           (Default_environment.cons matrix idef def)
           ((idef, next) :: nexts)
   and should_split group_discr =
-    match Pattern_head.desc group_discr with
+    match Patterns.Head.desc group_discr with
     | Construct { cstr_tag = Cstr_extension _ } ->
         (* it is unlikely that we will raise anything, so we split now *)
         true
@@ -1548,7 +1549,7 @@ and precompile_or argo (cls : Simple.clause list) ors args def k =
                      (id, Typeopt.value_kind orp.pat_env ty))
             in
             let or_num = next_raise_count () in
-            let new_patl = Parmatch.omega_list patl in
+            let new_patl = Patterns.omega_list patl in
             let mk_new_action ~vars =
               Lstaticraise (or_num, List.map (fun v -> Lvar v) vars)
             in
@@ -1616,7 +1617,7 @@ let split_and_precompile ~arg_id ~arg_lambda pm =
 type cell = {
   pm : initial_clause pattern_matching;
   ctx : Context.t;
-  discr : Pattern_head.t
+  discr : Patterns.Head.t
 }
 (** a submatrix after specializing by discriminant pattern;
     [ctx] is the context shared by all rows. *)
@@ -1730,7 +1731,7 @@ let get_pat_args_constr p rem =
 
 let get_expr_args_constr ~scopes head (arg, _mut) rem =
   let cstr =
-    match Pattern_head.desc head with
+    match Patterns.Head.desc head with
     | Construct cstr -> cstr
     | _ -> fatal_error "Matching.get_expr_args_constr"
   in
@@ -1819,13 +1820,13 @@ let divide_var ctx pm =
   divide_line Context.lshift
     get_expr_args_var
     get_pat_args_var
-    Pattern_head.omega ctx pm
+    Patterns.Head.omega ctx pm
 
 (* Matching and forcing a lazy value *)
 
 let get_pat_args_lazy p rem =
   match p with
-  | { pat_desc = Tpat_any } -> omega :: rem
+  | { pat_desc = Tpat_any } -> Patterns.omega :: rem
   | { pat_desc = Tpat_lazy arg } -> arg :: rem
   | _ -> assert false
 
@@ -1976,13 +1977,13 @@ let divide_lazy ~scopes head ctx pm =
 
 let get_pat_args_tuple arity p rem =
   match p with
-  | { pat_desc = Tpat_any } -> omegas arity @ rem
+  | { pat_desc = Tpat_any } -> Patterns.omegas arity @ rem
   | { pat_desc = Tpat_tuple args } -> args @ rem
   | _ -> assert false
 
 let get_expr_args_tuple ~scopes head (arg, _mut) rem =
   let loc = head_loc ~scopes head in
-  let arity = Pattern_head.arity head in
+  let arity = Patterns.Head.arity head in
   let rec make_args pos =
     if pos >= arity then
       rem
@@ -1992,7 +1993,7 @@ let get_expr_args_tuple ~scopes head (arg, _mut) rem =
   make_args 0
 
 let divide_tuple ~scopes head ctx pm =
-  let arity = Pattern_head.arity head in
+  let arity = Patterns.Head.arity head in
   divide_line (Context.specialize head)
     (get_expr_args_tuple ~scopes)
     (get_pat_args_tuple arity)
@@ -2001,7 +2002,7 @@ let divide_tuple ~scopes head ctx pm =
 (* Matching against a record pattern *)
 
 let record_matching_line num_fields lbl_pat_list =
-  let patv = Array.make num_fields omega in
+  let patv = Array.make num_fields Patterns.omega in
   List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
   Array.to_list patv
 
@@ -2015,7 +2016,7 @@ let get_pat_args_record num_fields p rem =
 let get_expr_args_record ~scopes head (arg, _mut) rem =
   let loc = head_loc ~scopes head in
   let all_labels =
-    match Pattern_head.desc head with
+    match Patterns.Head.desc head with
     | Record (lbl :: _) -> lbl.lbl_all
     | Record []
     | _ ->
@@ -2069,7 +2070,7 @@ let get_pat_args_array p rem =
 
 let get_expr_args_array ~scopes kind head (arg, _mut) rem =
   let len =
-    match Pattern_head.desc head with
+    match Patterns.Head.desc head with
     | Array len -> len
     | _ -> assert false
   in
@@ -2972,7 +2973,7 @@ let compile_list compile_fun division =
             in
             ( (key, lambda1) :: c_rem,
               total,
-              Pattern_head.to_omega_pattern cell.discr :: new_discrs )
+              Patterns.Head.to_omega_pattern cell.discr :: new_discrs )
           with Unused -> c_rec totals rem
       )
   in
@@ -3219,9 +3220,9 @@ and do_compile_matching ~scopes repr partial ctx pmh =
             assert false
       in
       let ph = what_is_cases pm.cases in
-      let pomega = Pattern_head.to_omega_pattern ph in
+      let pomega = Patterns.Head.to_omega_pattern ph in
       let ploc = head_loc ~scopes ph in
-      match Pattern_head.desc ph with
+      match Patterns.Head.desc ph with
       | Any ->
           compile_no_test ~scopes
             divide_var
@@ -3246,7 +3247,7 @@ and do_compile_matching ~scopes repr partial ctx pmh =
             (compile_match ~scopes repr partial)
             partial (divide_constructor ~scopes)
             (combine_constructor ploc arg
-               (Pattern_head.env ph) cstr partial)
+               (Patterns.Head.env ph) cstr partial)
             ctx pm
       | Array _ ->
           let kind = Typeopt.array_pattern_kind pomega in
@@ -3385,7 +3386,8 @@ let compile_matching ~scopes repr handler_fun arg pat_act_list partial =
       let pm =
         { cases = List.map (fun (pat, act) -> ([ pat ], act)) pat_act_list;
           args = [ (arg, Strict) ];
-          default = Default_environment.(cons [ [ omega ] ] raise_num empty)
+          default =
+            Default_environment.(cons [ [ Patterns.omega ] ] raise_num empty)
         }
       in
       try
@@ -3609,11 +3611,11 @@ let for_let ~scopes loc param pat body =
 let for_tupled_function ~scopes loc paraml pats_act_list partial =
   let partial = check_partial_list pats_act_list partial in
   let raise_num = next_raise_count () in
-  let omegas = [ List.map (fun _ -> omega) paraml ] in
+  let omega_params = [ Patterns.omega_list paraml ] in
   let pm =
     { cases = pats_act_list;
       args = List.map (fun id -> (Lvar id, Strict)) paraml;
-      default = Default_environment.(cons omegas raise_num empty)
+      default = Default_environment.(cons omega_params raise_num empty)
     }
   in
   try
@@ -3627,7 +3629,7 @@ let for_tupled_function ~scopes loc paraml pats_act_list partial =
 let flatten_pattern size p =
   match p.pat_desc with
   | Tpat_tuple args -> args
-  | Tpat_any -> omegas size
+  | Tpat_any -> Patterns.omegas size
   | _ -> raise Cannot_flatten
 
 let flatten_cases size cases =
@@ -3685,7 +3687,9 @@ let do_for_multiple_match ~scopes loc paraml pat_act_list partial =
       match partial with
       | Partial ->
           let raise_num = next_raise_count () in
-          (raise_num, Default_environment.(cons [ [ omega ] ] raise_num empty))
+          ( raise_num,
+            Default_environment.(cons [ [ Patterns.omega ] ] raise_num empty)
+          )
       | Total -> (-1, Default_environment.empty)
     in
     let loc = Scoped_location.of_location ~scopes loc in
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 5b1750c2cd..762d48e6f5 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -20,6 +20,7 @@ open Asttypes
 open Types
 open Typedtree
 
+
 (*************************************)
 (* Utilities for building patterns   *)
 (*************************************)
@@ -30,173 +31,15 @@ let make_pat desc ty tenv =
    pat_attributes = [];
   }
 
-let omega = make_pat Tpat_any Ctype.none Env.empty
+let omega = Patterns.omega
+let omegas = Patterns.omegas
+let omega_list = Patterns.omega_list
 
 let extra_pat =
   make_pat
     (Tpat_var (Ident.create_local "+", mknoloc "+"))
     Ctype.none Env.empty
 
-let rec omegas i =
-  if i <= 0 then [] else omega :: omegas (i-1)
-
-let omega_list l = List.map (fun _ -> omega) l
-
-module Pattern_head : sig
-  type desc =
-    | Any
-    | Construct of constructor_description
-    | Constant of constant
-    | Tuple of int
-    | Record of label_description list
-    | Variant of
-        { tag: label; has_arg: bool;
-          cstr_row: row_desc ref;
-          type_row : unit -> row_desc; }
-          (* the row of the type may evolve if [close_variant] is called,
-             hence the (unit -> ...) delay *)
-    | Array of int
-    | Lazy
-
-  type t
-
-  val desc : t -> desc
-  val env : t -> Env.t
-  val loc : t -> Location.t
-  val typ : t -> Types.type_expr
-
-  val arity : t -> int
-
-  (** [deconstruct p] returns the head of [p] and the list of sub patterns.
-
-      @raises [Invalid_arg _] if [p] is an or- or an exception-pattern.  *)
-  val deconstruct : pattern -> t * pattern list
-
-  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
-  val to_omega_pattern : t -> pattern
-
-  val make
-    :  loc:Location.t
-    -> typ:Types.type_expr
-    -> env:Env.t
-    -> desc
-    -> t
-
-  val omega : t
-
-end = struct
-  type desc =
-    | Any
-    | Construct of constructor_description
-    | Constant of constant
-    | Tuple of int
-    | Record of label_description list
-    | Variant of
-        { tag: label;
-          has_arg: bool;
-          cstr_row: row_desc ref;
-          type_row: unit -> row_desc; }
-    | Array of int
-    | Lazy
-
-  type t = {
-    desc: desc;
-    typ : Types.type_expr;
-    loc : Location.t;
-    env : Env.t;
-    attributes : attributes;
-  }
-
-  let desc { desc } = desc
-  let env { env } = env
-  let loc { loc } = loc
-  let typ { typ } = typ
-
-  let deconstruct q =
-    let rec deconstruct_desc = function
-      | Tpat_any
-      | Tpat_var _ -> Any, []
-      | Tpat_constant c -> Constant c, []
-      | Tpat_alias (p,_,_) -> deconstruct_desc p.pat_desc
-      | Tpat_tuple args ->
-          Tuple (List.length args), args
-      | Tpat_construct (_, c, args) ->
-          Construct c, args
-      | Tpat_variant (tag, arg, cstr_row) ->
-          let has_arg, pats =
-            match arg with
-            | None -> false, []
-            | Some a -> true, [a]
-          in
-          let type_row () =
-            match Ctype.expand_head q.pat_env q.pat_type with
-              | {desc = Tvariant type_row} -> Btype.row_repr type_row
-              | _ -> assert false
-          in
-          Variant {tag; has_arg; cstr_row; type_row}, pats
-      | Tpat_array args ->
-          Array (List.length args), args
-      | Tpat_record (largs, _) ->
-          let lbls = List.map (fun (_,lbl,_) -> lbl) largs in
-          let pats = List.map (fun (_,_,pat) -> pat) largs in
-          Record lbls, pats
-      | Tpat_lazy p ->
-          Lazy, [p]
-      | Tpat_or _ -> invalid_arg "Parmatch.Pattern_head.deconstruct: (P | Q)"
-    in
-    let desc, pats = deconstruct_desc q.pat_desc in
-    { desc; typ = q.pat_type; loc = q.pat_loc;
-      env = q.pat_env; attributes = q.pat_attributes }, pats
-
-  let arity t =
-    match t.desc with
-      | Any -> 0
-      | Constant _ -> 0
-      | Construct c -> c.cstr_arity
-      | Tuple n | Array n -> n
-      | Record l -> List.length l
-      | Variant { has_arg; _ } -> if has_arg then 1 else 0
-      | Lazy -> 1
-
-  let to_omega_pattern t =
-    let pat_desc =
-      match t.desc with
-      | Any -> Tpat_any
-      | Lazy -> Tpat_lazy omega
-      | Constant c -> Tpat_constant c
-      | Tuple n -> Tpat_tuple (omegas n)
-      | Array n -> Tpat_array (omegas n)
-      | Construct c ->
-          let lid_loc = Location.mkloc (Longident.Lident c.cstr_name) t.loc in
-          Tpat_construct (lid_loc, c, omegas c.cstr_arity)
-      | Variant { tag; has_arg; cstr_row } ->
-          let arg_opt = if has_arg then Some omega else None in
-          Tpat_variant (tag, arg_opt, cstr_row)
-      | Record lbls ->
-          let lst =
-            List.map (fun lbl ->
-              let lid_loc =
-                Location.mkloc (Longident.Lident lbl.lbl_name) t.loc
-              in
-              (lid_loc, lbl, omega)
-            ) lbls
-          in
-          Tpat_record (lst, Closed)
-    in
-    { pat_desc; pat_type = t.typ; pat_loc = t.loc; pat_extra = [];
-      pat_env = t.env; pat_attributes = t.attributes }
-
-  let make ~loc ~typ ~env desc =
-    { desc; loc; typ; env; attributes = [] }
-
-  let omega =
-    { desc = Any
-    ; loc = Location.none
-    ; typ = Ctype.none
-    ; env = Env.empty
-    ; attributes = []
-    }
-end
 
 (*******************)
 (* Coherence check *)
@@ -275,7 +118,7 @@ end
 *)
 let all_coherent column =
   let coherent_heads hp1 hp2 =
-    match Pattern_head.desc hp1, Pattern_head.desc hp2 with
+    match Patterns.Head.desc hp1, Patterns.Head.desc hp2 with
     | Construct c, Construct c' ->
       c.cstr_consts = c'.cstr_consts
       && c.cstr_nonconsts = c'.cstr_nonconsts
@@ -309,7 +152,7 @@ let all_coherent column =
   in
   match
     List.find (fun head_pat ->
-      match Pattern_head.desc head_pat with
+      match Patterns.Head.desc head_pat with
       | Any -> false
       | _ -> true
     ) column
@@ -390,7 +233,7 @@ let first_column simplified_matrix =
 let is_absent tag row = Btype.row_field tag !row = Rabsent
 
 let is_absent_pat d =
-  match Pattern_head.desc d with
+  match Patterns.Head.desc d with
   | Variant { tag; cstr_row; _ } -> is_absent tag cstr_row
   | _ -> false
 
@@ -510,7 +353,7 @@ let get_constructor_type_path ty tenv =
 
 (* Check top matching *)
 let simple_match d h =
-  match Pattern_head.desc d, Pattern_head.desc h with
+  match Patterns.Head.desc d, Patterns.Head.desc h with
   | Construct c1, Construct c2 ->
       Types.equal_tag c1.cstr_tag c2.cstr_tag
   | Variant { tag = t1; _ }, Variant { tag = t2 } ->
@@ -526,7 +369,7 @@ let simple_match d h =
 
 
 (* extract record fields as a whole *)
-let record_arg ph = match Pattern_head.desc ph with
+let record_arg ph = match Patterns.Head.desc ph with
 | Any -> []
 | Record args -> args
 | _ -> fatal_error "Parmatch.as_record"
@@ -541,7 +384,7 @@ let extract_fields lbls arg =
   List.map (fun lbl -> get_field lbl.lbl_pos arg) lbls
 
 (* Build argument list when p2 >= p1, where p1 is a simple pattern *)
-let simple_match_args discr head args = match Pattern_head.desc head with
+let simple_match_args discr head args = match Patterns.Head.desc head with
 | Constant _ -> []
 | Construct _
 | Variant _
@@ -550,7 +393,7 @@ let simple_match_args discr head args = match Pattern_head.desc head with
 | Lazy -> args
 | Record lbls ->  extract_fields (record_arg discr) (List.combine lbls args)
 | Any ->
-    begin match Pattern_head.desc discr with
+    begin match Patterns.Head.desc discr with
     | Construct cstr -> omegas cstr.cstr_arity
     | Variant { has_arg = true }
     | Lazy -> [omega]
@@ -593,7 +436,7 @@ let discr_pat q pss =
   let rec refine_pat acc = function
     | [] -> acc
     | ((head, _), _) :: rows ->
-      match Pattern_head.desc head with
+      match Patterns.Head.desc head with
       | Any -> refine_pat acc rows
       | Tuple _ | Lazy -> head
       | Record lbls ->
@@ -612,14 +455,14 @@ let discr_pat q pss =
           ) lbls (record_arg acc)
         in
         let d =
-          let open Pattern_head in
+          let open Patterns.Head in
           make ~loc:(loc head) ~typ:(typ head) ~env:(env head) (Record fields)
         in
         refine_pat d rows
       | _ -> acc
   in
-  let q, _ = Pattern_head.deconstruct q in
-  match Pattern_head.desc q with
+  let q, _ = Patterns.Head.deconstruct q in
+  match Patterns.Head.desc q with
   (* short-circuiting: clearly if we have anything other than [Record] or
      [Any] to start with, we're not going to be able refine at all. So
      there's no point going over the matrix. *)
@@ -719,10 +562,10 @@ let simplify_head_pat ~add_column p ps k =
     match p.pat_desc with
     | Tpat_alias (p,_,_) ->
         (* We have to handle aliases here, because there can be or-patterns
-           underneath, that [Pattern_head.deconstruct] won't handle. *)
+           underneath, that [Patterns.Head.deconstruct] won't handle. *)
         simplify_head_pat p ps k
     | Tpat_or (p1,p2,_) -> simplify_head_pat p1 ps (simplify_head_pat p2 ps k)
-    | _ -> add_column (Pattern_head.deconstruct p) ps k
+    | _ -> add_column (Patterns.Head.deconstruct p) ps k
   in simplify_head_pat p ps k
 
 let rec simplify_first_col = function
@@ -756,7 +599,7 @@ let build_specialized_submatrix ~extend_row discr pss =
 *)
 type 'matrix specialized_matrices = {
   default : 'matrix;
-  constrs : (Pattern_head.t * 'matrix) list;
+  constrs : (Patterns.Head.t * 'matrix) list;
 }
 
 (* Consider a pattern matrix whose first column has been simplified
@@ -804,13 +647,13 @@ let build_specialized_submatrices ~extend_row discr rows =
 
   (* insert a row of head omega into all groups *)
   let insert_omega r env =
-    List.map (fun (q0,rs) -> extend_group q0 Pattern_head.omega [] r rs) env
+    List.map (fun (q0,rs) -> extend_group q0 Patterns.Head.omega [] r rs) env
   in
 
   let rec form_groups constr_groups omega_tails = function
     | [] -> (constr_groups, omega_tails)
     | ((head, args), tail) :: rest ->
-        match Pattern_head.desc head with
+        match Patterns.Head.desc head with
         | Any ->
             (* note that calling insert_omega here would be wrong
                as some groups may not have been formed yet, if the
@@ -823,7 +666,7 @@ let build_specialized_submatrices ~extend_row discr rows =
 
   let constr_groups, omega_tails =
     let initial_constr_group =
-      match Pattern_head.desc discr with
+      match Patterns.Head.desc discr with
       | Record _ | Tuple _ | Lazy ->
         (* [discr] comes from [discr_pat], and in this case subsumes any of the
            patterns we could find on the first column of [rows]. So it is better
@@ -850,14 +693,14 @@ let set_last a =
     | x::l -> x :: loop l
   in
   function
-  | (_, []) -> (Pattern_head.deconstruct a, [])
+  | (_, []) -> (Patterns.Head.deconstruct a, [])
   | (first, row) -> (first, loop row)
 
 (* mark constructor lines for failure when they are incomplete *)
 let mark_partial =
   let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty in
   List.map (fun ((hp, _), _ as ps) ->
-    match Pattern_head.desc hp with
+    match Patterns.Head.desc hp with
     | Any -> ps
     | _ -> set_last zero ps
   )
@@ -890,7 +733,7 @@ let close_variant env row =
 let full_match closing env =  match env with
 | [] -> false
 | (discr, _) :: _ ->
-  match Pattern_head.desc discr with
+  match Patterns.Head.desc discr with
   | Any -> assert false
   | Construct { cstr_tag = Cstr_extension _ ; _ } -> false
   | Construct c -> List.length env = c.cstr_consts + c.cstr_nonconsts
@@ -898,7 +741,7 @@ let full_match closing env =  match env with
       let fields =
         List.map
           (fun (d, _) ->
-            match Pattern_head.desc d with
+            match Patterns.Head.desc d with
             | Variant { tag } -> tag
             | _ -> assert false)
           env
@@ -935,10 +778,10 @@ let should_extend ext env = match ext with
 | Some ext -> begin match env with
   | [] -> assert false
   | (p,_)::_ ->
-      begin match Pattern_head.desc p with
+      begin match Patterns.Head.desc p with
       | Construct {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)} ->
           let path =
-            get_constructor_type_path (Pattern_head.typ p) (Pattern_head.env p)
+            get_constructor_type_path (Patterns.Head.typ p) (Patterns.Head.env p)
           in
           Path.same path ext
       | Construct {cstr_tag=(Cstr_extension _)} -> false
@@ -991,7 +834,7 @@ let rec orify_many = function
 
 (* build an or-pattern from a constructor list *)
 let pat_of_constrs ex_pat cstrs =
-  let ex_pat = Pattern_head.to_omega_pattern ex_pat in
+  let ex_pat = Patterns.Head.to_omega_pattern ex_pat in
   if cstrs = [] then raise Empty else
   orify_many (List.map (pat_of_constr ex_pat) cstrs)
 
@@ -1037,9 +880,9 @@ let rec get_variant_constructors env ty =
 
 (* Sends back a pattern that complements constructor tags all_tag *)
 let complete_constrs p all_tags =
-  let c = match Pattern_head.desc p with Construct c -> c | _ -> assert false in
+  let c = match Patterns.Head.desc p with Construct c -> c | _ -> assert false in
   let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
-  let constrs = get_variant_constructors (Pattern_head.env p) c.cstr_res in
+  let constrs = get_variant_constructors (Patterns.Head.env p) c.cstr_res in
   let others =
     List.filter
       (fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag)
@@ -1049,10 +892,10 @@ let complete_constrs p all_tags =
   const @ nonconst
 
 let build_other_constrs env p =
-  match Pattern_head.desc p with
+  match Patterns.Head.desc p with
   | Construct { cstr_tag = Cstr_constant _ | Cstr_block _ } ->
       let get_tag q =
-        match Pattern_head.desc q with
+        match Patterns.Head.desc q with
         | Construct c -> c.cstr_tag
         | _ -> fatal_error "Parmatch.get_tag" in
       let all_tags =  List.map (fun (p,_) -> get_tag p) env in
@@ -1063,16 +906,16 @@ let complete_constrs p all_tags =
   (* This wrapper is here for [Matching], which (indirectly) calls this function
      from [combine_constructor], and nowhere else.
      So we know patterns have been fully simplified. *)
-  complete_constrs (fst @@ Pattern_head.deconstruct p) all_tags
+  complete_constrs (fst @@ Patterns.Head.deconstruct p) all_tags
 
 (* Auxiliary for build_other *)
 
 let build_other_constant proj make first next p env =
-  let all = List.map (fun (p, _) -> proj (Pattern_head.desc p)) env in
+  let all = List.map (fun (p, _) -> proj (Patterns.Head.desc p)) env in
   let rec try_const i =
     if List.mem i all
     then try_const (next i)
-    else make_pat (make i) (Pattern_head.typ p) (Pattern_head.env p)
+    else make_pat (make i) (Patterns.Head.typ p) (Patterns.Head.env p)
   in try_const first
 
 (*
@@ -1086,19 +929,19 @@ let build_other ext env =
   match env with
   | [] -> omega
   | (d, _) :: _ ->
-      match Pattern_head.desc d with
+      match Patterns.Head.desc d with
       | Construct { cstr_tag = Cstr_extension _ } ->
           (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
           make_pat
             (Tpat_var (Ident.create_local "*extension*",
-                       {txt="*extension*"; loc = Pattern_head.loc d}))
+                       {txt="*extension*"; loc = Patterns.Head.loc d}))
             Ctype.none Env.empty
       | Construct _ ->
           begin match ext with
           | Some ext ->
               if Path.same ext
                    (get_constructor_type_path
-                      (Pattern_head.typ d) (Pattern_head.env d))
+                      (Patterns.Head.typ d) (Patterns.Head.env d))
               then
                 extra_pat
               else
@@ -1110,7 +953,7 @@ let build_other ext env =
           let tags =
             List.map
               (fun (d, _) ->
-                match Pattern_head.desc d with
+                match Patterns.Head.desc d with
                 | Variant { tag } -> tag
                 | _ -> assert false)
               env
@@ -1118,7 +961,7 @@ let build_other ext env =
             let make_other_pat tag const =
               let arg = if const then None else Some omega in
               make_pat (Tpat_variant(tag, arg, cstr_row))
-                (Pattern_head.typ d) (Pattern_head.env d)
+                (Patterns.Head.typ d) (Patterns.Head.env d)
             in
             let row = type_row () in
             begin match
@@ -1143,13 +986,13 @@ let build_other ext env =
                 List.fold_left
                   (fun p_res pat ->
                     make_pat (Tpat_or (pat, p_res, None))
-                      (Pattern_head.typ d) (Pattern_head.env d))
+                      (Patterns.Head.typ d) (Patterns.Head.env d))
                   pat other_pats
             end
       | Constant Const_char _ ->
           let all_chars =
             List.map
-              (fun (p,_) -> match Pattern_head.desc p with
+              (fun (p,_) -> match Patterns.Head.desc p with
               | Constant (Const_char c) -> c
               | _ -> assert false)
               env
@@ -1162,7 +1005,7 @@ let build_other ext env =
                 find_other (i+1) imax
               else
                 make_pat (Tpat_constant (Const_char ci))
-                  (Pattern_head.typ d) (Pattern_head.env d)
+                  (Patterns.Head.typ d) (Patterns.Head.env d)
           in
           let rec try_chars = function
             | [] -> omega
@@ -1212,7 +1055,7 @@ let build_other ext env =
       | Array _ ->
           let all_lengths =
             List.map
-              (fun (p,_) -> match Pattern_head.desc p with
+              (fun (p,_) -> match Patterns.Head.desc p with
               | Array len -> len
               | _ -> assert false)
               env in
@@ -1221,7 +1064,7 @@ let build_other ext env =
             else
               make_pat
                 (Tpat_array (omegas l))
-                (Pattern_head.typ d) (Pattern_head.env d) in
+                (Patterns.Head.typ d) (Patterns.Head.env d) in
           try_arrays 0
       | _ -> omega
 
@@ -1287,13 +1130,13 @@ let rec satisfiable pss qs = match pss with
               (fun (p,pss) ->
                  not (is_absent_pat p) &&
                  satisfiable pss
-                   (simple_match_args p Pattern_head.omega [] @ qs))
+                   (simple_match_args p Patterns.Head.omega [] @ qs))
               constrs
         end
     | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
     | q::qs ->
         let pss = simplify_first_col pss in
-        let hq, qargs = Pattern_head.deconstruct q in
+        let hq, qargs = Patterns.Head.deconstruct q in
         if not (all_coherent (hq :: first_column pss)) then
           false
         else begin
@@ -1346,15 +1189,15 @@ let rec list_satisfying_vectors pss qs =
                       else
                         let witnesses =
                           list_satisfying_vectors pss
-                            (simple_match_args p Pattern_head.omega [] @ qs)
+                            (simple_match_args p Patterns.Head.omega [] @ qs)
                         in
-                        let p = Pattern_head.to_omega_pattern p in
+                        let p = Patterns.Head.to_omega_pattern p in
                         List.map (set_args p) witnesses
                     ) constrs
                   )
                 in
                 if full_match false constrs then for_constrs () else
-                begin match Pattern_head.desc p with
+                begin match Patterns.Head.desc p with
                 | Construct _ ->
                     (* activate this code for checking non-gadt constructors *)
                     wild default (build_other_constrs constrs p)
@@ -1365,13 +1208,13 @@ let rec list_satisfying_vectors pss qs =
           end
       | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> []
       | q::qs ->
-          let hq, qargs = Pattern_head.deconstruct q in
+          let hq, qargs = Patterns.Head.deconstruct q in
           let pss = simplify_first_col pss in
           if not (all_coherent (hq :: first_column pss)) then
             []
           else begin
             let q0 = discr_pat q pss in
-            List.map (set_args (Pattern_head.to_omega_pattern q0))
+            List.map (set_args (Patterns.Head.to_omega_pattern q0))
               (list_satisfying_vectors
                  (build_specialized_submatrix ~extend_row:(@) q0 pss)
                  (simple_match_args q0 hq qargs @ qs))
@@ -1406,7 +1249,7 @@ let rec do_match pss qs = match qs with
       (* [q] is generated by us, it doesn't come from the source. So we know
          it's not of the form [P as name].
          Therefore there is no risk of [deconstruct] raising. *)
-      let q0, qargs = Pattern_head.deconstruct q in
+      let q0, qargs = Patterns.Head.deconstruct q in
       let pss = simplify_first_col pss in
       (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of
          its first column. *)
@@ -1485,7 +1328,7 @@ let rec exhaust (ext:Path.t option) pss n = match pss with
           (* first column of pss is made of variables only *)
           begin match exhaust ext default (n-1) with
           | Witnesses r ->
-              let q0 = Pattern_head.to_omega_pattern q0 in
+              let q0 = Patterns.Head.to_omega_pattern q0 in
               Witnesses (List.map (fun row -> q0::row) r)
           | r -> r
         end
@@ -1497,11 +1340,11 @@ let rec exhaust (ext:Path.t option) pss n = match pss with
               match
                 exhaust
                   ext pss
-                  (List.length (simple_match_args p Pattern_head.omega [])
+                  (List.length (simple_match_args p Patterns.Head.omega [])
                    + n - 1)
               with
               | Witnesses r ->
-                  let p = Pattern_head.to_omega_pattern p in
+                  let p = Patterns.Head.to_omega_pattern p in
                   Witnesses (List.map (set_args p) r)
               | r       -> r in
           let before = try_many try_non_omega constrs in
@@ -1594,7 +1437,7 @@ let rec pressure_variants tdefs = function
               | [], _
               | _, None -> ()
               | (d, _) :: _, Some env ->
-                match Pattern_head.desc d with
+                match Patterns.Head.desc d with
                 | Variant { type_row; _ } ->
                   let row = type_row () in
                   if Btype.row_fixed row
@@ -1796,7 +1639,7 @@ let rec every_satisfiables pss qs = match qs.active with
     | _ ->
 (* standard case, filter matrix *)
         let pss = simplify_first_usefulness_col pss in
-        let huq, args = Pattern_head.deconstruct uq in
+        let huq, args = Patterns.Head.deconstruct uq in
         (* The handling of incoherent matrices is kept in line with
            [satisfiable] *)
         if not (all_coherent (huq :: first_column pss)) then
@@ -2450,12 +2293,12 @@ let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
       let rest_of_the_row =
         { row = ps; varsets = Ident.Set.add x head_bound_variables :: varsets; }
       in
-      add_column (Pattern_head.deconstruct omega) rest_of_the_row k
+      add_column (Patterns.Head.deconstruct omega) rest_of_the_row k
     | Tpat_or (p1,p2,_) ->
       simpl head_bound_variables varsets p1 ps
         (simpl head_bound_variables varsets p2 ps k)
     | _ ->
-      add_column (Pattern_head.deconstruct p)
+      add_column (Patterns.Head.deconstruct p)
         { row = ps; varsets = head_bound_variables :: varsets; } k
   in simpl head_bound_variables varsets p ps k
 
diff --git a/typing/parmatch.mli b/typing/parmatch.mli
index d8484c92e0..c226911fad 100644
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -19,59 +19,6 @@ open Asttypes
 open Typedtree
 open Types
 
-val omega : pattern
-(** aka. "Tpat_any" or "_"  *)
-
-val omegas : int -> pattern list
-(** [List.init (fun _ -> omega)] *)
-
-val omega_list : 'a list -> pattern list
-(** [List.map (fun _ -> omega)] *)
-
-module Pattern_head : sig
-  type desc =
-    | Any
-    | Construct of constructor_description
-    | Constant of constant
-    | Tuple of int
-    | Record of label_description list
-    | Variant of
-        { tag: label; has_arg: bool;
-          cstr_row: row_desc ref;
-          type_row : unit -> row_desc; }
-          (* the row of the type may evolve if [close_variant] is called,
-             hence the (unit -> ...) delay *)
-    | Array of int
-    | Lazy
-
-  type t
-
-  val desc : t -> desc
-  val env : t -> Env.t
-  val loc : t -> Location.t
-  val typ : t -> Types.type_expr
-
-  val arity : t -> int
-
-  (** [deconstruct p] returns the head of [p] and the list of sub patterns.
-
-      @raises [Invalid_arg _] if [p] is an or- or an exception-pattern.  *)
-  val deconstruct : pattern -> t * pattern list
-
-  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
-  val to_omega_pattern : t -> pattern
-
-  val make
-    :  loc:Location.t
-    -> typ:Types.type_expr
-    -> env:Env.t
-    -> desc
-    -> t
-
-  val omega : t
-
-end
-
 val const_compare : constant -> constant -> int
 (** [const_compare c1 c2] compares the actual values represented by [c1] and
     [c2], while simply using [Stdlib.compare] would compare the
diff --git a/typing/patterns.ml b/typing/patterns.ml
new file mode 100644
index 0000000000..63eaddfa31
--- /dev/null
+++ b/typing/patterns.ml
@@ -0,0 +1,172 @@
+open Asttypes
+open Types
+open Typedtree
+
+let omega = {
+  pat_desc = Tpat_any;
+  pat_loc = Location.none;
+  pat_extra = [];
+  pat_type = Ctype.none;
+  pat_env = Env.empty;
+  pat_attributes = [];
+}
+
+let rec omegas i =
+  if i <= 0 then [] else omega :: omegas (i-1)
+
+let omega_list l = List.map (fun _ -> omega) l
+
+module Head : sig
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+    | Array of int
+    | Lazy
+
+  type t
+
+  val desc : t -> desc
+  val env : t -> Env.t
+  val loc : t -> Location.t
+  val typ : t -> Types.type_expr
+
+  val arity : t -> int
+
+  (** [deconstruct p] returns the head of [p] and the list of sub patterns.
+
+      @raises [Invalid_arg _] if [p] is an or-pattern.  *)
+  val deconstruct : pattern -> t * pattern list
+
+  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
+  val to_omega_pattern : t -> pattern
+
+  val make
+    :  loc:Location.t
+    -> typ:Types.type_expr
+    -> env:Env.t
+    -> desc
+    -> t
+
+  val omega : t
+
+end = struct
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+          (* the row of the type may evolve if [close_variant] is called,
+             hence the (unit -> ...) delay *)
+    | Array of int
+    | Lazy
+
+  type t = {
+    desc: desc;
+    typ : Types.type_expr;
+    loc : Location.t;
+    env : Env.t;
+    attributes : attributes;
+  }
+
+  let desc { desc } = desc
+  let env { env } = env
+  let loc { loc } = loc
+  let typ { typ } = typ
+
+  let deconstruct q =
+    let rec deconstruct_desc = function
+      | Tpat_any
+      | Tpat_var _ -> Any, []
+      | Tpat_constant c -> Constant c, []
+      | Tpat_alias (p,_,_) -> deconstruct_desc p.pat_desc
+      | Tpat_tuple args ->
+          Tuple (List.length args), args
+      | Tpat_construct (_, c, args) ->
+          Construct c, args
+      | Tpat_variant (tag, arg, cstr_row) ->
+          let has_arg, pats =
+            match arg with
+            | None -> false, []
+            | Some a -> true, [a]
+          in
+          let type_row () =
+            match Ctype.expand_head q.pat_env q.pat_type with
+              | {desc = Tvariant type_row} -> Btype.row_repr type_row
+              | _ -> assert false
+          in
+          Variant {tag; has_arg; cstr_row; type_row}, pats
+      | Tpat_array args ->
+          Array (List.length args), args
+      | Tpat_record (largs, _) ->
+          let lbls = List.map (fun (_,lbl,_) -> lbl) largs in
+          let pats = List.map (fun (_,_,pat) -> pat) largs in
+          Record lbls, pats
+      | Tpat_lazy p ->
+          Lazy, [p]
+      | Tpat_or _ -> invalid_arg "Parmatch.Pattern_head.deconstruct: (P | Q)"
+    in
+    let desc, pats = deconstruct_desc q.pat_desc in
+    { desc; typ = q.pat_type; loc = q.pat_loc;
+      env = q.pat_env; attributes = q.pat_attributes }, pats
+
+  let arity t =
+    match t.desc with
+      | Any -> 0
+      | Constant _ -> 0
+      | Construct c -> c.cstr_arity
+      | Tuple n | Array n -> n
+      | Record l -> List.length l
+      | Variant { has_arg; _ } -> if has_arg then 1 else 0
+      | Lazy -> 1
+
+  let to_omega_pattern t =
+    let pat_desc =
+      match t.desc with
+      | Any -> Tpat_any
+      | Lazy -> Tpat_lazy omega
+      | Constant c -> Tpat_constant c
+      | Tuple n -> Tpat_tuple (omegas n)
+      | Array n -> Tpat_array (omegas n)
+      | Construct c ->
+          let lid_loc = Location.mkloc (Longident.Lident c.cstr_name) t.loc in
+          Tpat_construct (lid_loc, c, omegas c.cstr_arity)
+      | Variant { tag; has_arg; cstr_row } ->
+          let arg_opt = if has_arg then Some omega else None in
+          Tpat_variant (tag, arg_opt, cstr_row)
+      | Record lbls ->
+          let lst =
+            List.map (fun lbl ->
+              let lid_loc =
+                Location.mkloc (Longident.Lident lbl.lbl_name) t.loc
+              in
+              (lid_loc, lbl, omega)
+            ) lbls
+          in
+          Tpat_record (lst, Closed)
+    in
+    { pat_desc; pat_type = t.typ; pat_loc = t.loc; pat_extra = [];
+      pat_env = t.env; pat_attributes = t.attributes }
+
+  let make ~loc ~typ ~env desc =
+    { desc; loc; typ; env; attributes = [] }
+
+  let omega =
+    { desc = Any
+    ; loc = Location.none
+    ; typ = Ctype.none
+    ; env = Env.empty
+    ; attributes = []
+    }
+end
diff --git a/typing/patterns.mli b/typing/patterns.mli
new file mode 100644
index 0000000000..56d76b39a7
--- /dev/null
+++ b/typing/patterns.mli
@@ -0,0 +1,56 @@
+open Asttypes
+open Typedtree
+open Types
+
+val omega : pattern
+(** aka. "Tpat_any" or "_"  *)
+
+val omegas : int -> pattern list
+(** [List.init (fun _ -> omega)] *)
+
+val omega_list : 'a list -> pattern list
+(** [List.map (fun _ -> omega)] *)
+
+module Head : sig
+  type desc =
+    | Any
+    | Construct of constructor_description
+    | Constant of constant
+    | Tuple of int
+    | Record of label_description list
+    | Variant of
+        { tag: label; has_arg: bool;
+          cstr_row: row_desc ref;
+          type_row : unit -> row_desc; }
+          (* the row of the type may evolve if [close_variant] is called,
+             hence the (unit -> ...) delay *)
+    | Array of int
+    | Lazy
+
+  type t
+
+  val desc : t -> desc
+  val env : t -> Env.t
+  val loc : t -> Location.t
+  val typ : t -> Types.type_expr
+
+  val arity : t -> int
+
+  (** [deconstruct p] returns the head of [p] and the list of sub patterns.
+
+      @raises [Invalid_arg _] if [p] is an or- or an exception-pattern.  *)
+  val deconstruct : pattern -> t * pattern list
+
+  (** reconstructs a pattern, putting wildcards as sub-patterns. *)
+  val to_omega_pattern : t -> pattern
+
+  val make
+    :  loc:Location.t
+    -> typ:Types.type_expr
+    -> env:Env.t
+    -> desc
+    -> t
+
+  val omega : t
+
+end