Matching: propagate constructor descriptions in complete_pats_constrs

This simplifies this particular interface boundary between Matching
and Parmatch.

(Suggested by Florian Angeletti)

.depend

@@ -811,7 +811,6 @@ typing/parmatch.cmx : \
 typing/parmatch.cmi : \
     typing/types.cmi \
     typing/typedtree.cmi \
-    typing/patterns.cmi \
     parsing/parsetree.cmi \
     parsing/location.cmi \
     typing/env.cmi \

Changes

@@ -76,7 +76,7 @@ Working version
 
 ### Internal/compiler-libs changes:
 
-- #9493, #9520, #9563: refactor the pattern-matching compiler
+- #9493, #9520, #9563, #9599: refactor the pattern-matching compiler
   (Thomas Refis and Gabriel Scherer, review by Florian Angeletti)
 
 ### Build system:

lambda/matching.ml

@@ -2498,16 +2498,14 @@ let rec list_as_pat = function
   | pat :: rem -> { pat with pat_desc = Tpat_or (pat, list_as_pat rem, None) }
 
 let complete_pats_constrs = function
-  | p :: _ as pats ->
-      (* We (indirectly) call this function
-         from [combine_constructor], and nowhere else.
-         So we know patterns have been fully simplified. *)
-      let p_simple = match (Patterns.General.view p).pat_desc with
-        | #Patterns.Simple.view as simple -> { p with pat_desc = simple }
-        | _ -> invalid_arg "complete_pats_constrs" in
-      let tag_of_pat p = (get_key_constr p).cstr_tag in
-      List.map (pat_of_constr p)
-        (complete_constrs p_simple (List.map tag_of_pat pats))
+  | constr :: _ as constrs ->
+      let tag_of_constr constr =
+        constr.pat_desc.cstr_tag in
+      let pat_of_constr cstr =
+        let open Patterns.Head in
+        to_omega_pattern { constr with pat_desc = Construct cstr } in
+      List.map pat_of_constr
+        (complete_constrs constr (List.map tag_of_constr constrs))
   | _ -> assert false
 
 (*
@@ -2725,10 +2723,14 @@ let combine_constructor loc arg pat_env cstr partial ctx def
         if sig_complete then
           (None, [], Jumps.empty)
         else
-          mk_failaction_pos partial pats ctx def
+          let constrs =
+            List.map2 (fun (constr, _act) p -> { p with pat_desc = constr })
+              descr_lambda_list pats in
+          mk_failaction_pos partial constrs ctx def
       in
       let descr_lambda_list = fails @ descr_lambda_list in
-      let consts, nonconsts = split_cases (List.map tag_lambda descr_lambda_list) in
+      let consts, nonconsts =
+        split_cases (List.map tag_lambda descr_lambda_list) in
       let lambda1 =
         match (fail_opt, same_actions descr_lambda_list) with
         | None, Some act -> act (* Identical actions, no failure *)

typing/parmatch.ml

@@ -881,11 +881,10 @@ let rec get_variant_constructors env ty =
   | _ -> fatal_error "Parmatch.get_variant_constructors"
 
 (* Sends back a pattern that complements constructor tags all_tag *)
-let complete_constrs p all_tags =
-  let open Patterns.Head in
-  let c = match p.pat_desc with Construct c -> c | _ -> assert false in
+let complete_constrs constr all_tags =
+  let c = constr.pat_desc in
   let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
-  let constrs = get_variant_constructors p.pat_env c.cstr_res in
+  let constrs = get_variant_constructors constr.pat_env c.cstr_res in
   let others =
     List.filter
       (fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag)
@@ -897,24 +896,16 @@ let complete_constrs p all_tags =
 let build_other_constrs env p =
   let open Patterns.Head in
   match p.pat_desc with
-  | Construct { cstr_tag = Cstr_constant _ | Cstr_block _ } ->
+  | Construct ({ cstr_tag = Cstr_constant _ | Cstr_block _ } as c) ->
+      let constr = { p with pat_desc = c } in
       let get_tag q =
         match q.pat_desc with
         | Construct c -> c.cstr_tag
         | _ -> fatal_error "Parmatch.get_tag" in
       let all_tags =  List.map (fun (p,_) -> get_tag p) env in
-      pat_of_constrs p (complete_constrs p all_tags)
+      pat_of_constrs p (complete_constrs constr all_tags)
   | _ -> extra_pat
 
-let complete_constrs p all_tags =
-  (* This wrapper is here for [Matching].
-
-     TODO: instead of a simple pattern, it would be nicer to pass
-     a constructor payload directly:
-     [Types.constructor_description pattern_data].
-  *)
-  complete_constrs (fst (Patterns.Head.deconstruct p)) all_tags
-
 (* Auxiliary for build_other *)
 
 let build_other_constant proj make first next p env =

typing/parmatch.mli

@@ -67,7 +67,7 @@ val set_args_erase_mutable : pattern -> pattern list -> pattern list
 
 val pat_of_constr : pattern -> constructor_description -> pattern
 val complete_constrs :
-    Patterns.Simple.pattern ->
+    constructor_description pattern_data ->
     constructor_tag list ->
     constructor_description list