Merge pull request ocaml#8970 from gasche/computation_pattern-trunk

typedtree: split patterns into "value patterns" and "computation patterns"

Changes

@@ -29,6 +29,10 @@ Working version
 
 ### Internal/compiler-libs changes:
 
+- #8970: separate value patterns (matching on values) from computation patterns
+  (matching on the effects of a copmutation) in the typedtree.
+  (Gabriel Scherer, review by Jacques Garrigue and Alain Frisch)
+
 - #9078: make all compilerlibs/ available to ocamltest.
   (Gabriel Scherer, review by Sébastien Hinderer)
 

file_formats/cmt_format.ml

@@ -39,7 +39,7 @@ and binary_part =
 | Partial_structure of structure
 | Partial_structure_item of structure_item
 | Partial_expression of expression
-| Partial_pattern of pattern
+| Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
 | Partial_class_expr of class_expr
 | Partial_signature of signature
 | Partial_signature_item of signature_item
@@ -81,7 +81,7 @@ let clear_part = function
   | Partial_structure_item s ->
       Partial_structure_item (cenv.structure_item cenv s)
   | Partial_expression e -> Partial_expression (cenv.expr cenv e)
-  | Partial_pattern p -> Partial_pattern (cenv.pat cenv p)
+  | Partial_pattern (category, p) -> Partial_pattern (category, cenv.pat cenv p)
   | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce)
   | Partial_signature s -> Partial_signature (cenv.signature cenv s)
   | Partial_signature_item s ->

file_formats/cmt_format.mli

@@ -44,7 +44,7 @@ and binary_part =
   | Partial_structure of structure
   | Partial_structure_item of structure_item
   | Partial_expression of expression
-  | Partial_pattern of pattern
+  | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
   | Partial_class_expr of class_expr
   | Partial_signature of signature
   | Partial_signature_item of signature_item

lambda/matching.ml

@@ -869,7 +869,7 @@ let half_simplify_cases args cls =
         | Tpat_variant _
         | Tpat_array _
         | Tpat_lazy _
-        | Tpat_exception _ ->
+          ->
             cl
       )
   in
@@ -3221,7 +3221,6 @@ let is_lazy_pat p = match p.pat_desc with
   | Tpat_var _
   | Tpat_any ->
       false
-  | Tpat_exception _ -> assert false
 
 let has_lazy p =
   Typedtree.exists_pattern is_lazy_pat p
@@ -3246,7 +3245,6 @@ let is_record_with_mutable_field p =
   | Tpat_var _
   | Tpat_any ->
       false
-  | Tpat_exception _ -> assert false
 
 let has_mutable p =
   Typedtree.exists_pattern is_record_with_mutable_field p
@@ -3271,10 +3269,13 @@ let check_partial has_mutable has_lazy pat_act_list = function
       else
         Total
 
-let check_partial_list =
+let check_partial_list pats_act_list =
   check_partial (List.exists has_mutable) (List.exists has_lazy)
+    pats_act_list
 
-let check_partial = check_partial has_mutable has_lazy
+let check_partial pat_act_list =
+  check_partial has_mutable has_lazy
+    pat_act_list
 
 (* have toplevel handler when appropriate *)
 

lambda/translcore.ml

@@ -131,6 +131,10 @@ let rec push_defaults loc bindings cases partial =
       let env = Env.add_value param desc exp.exp_env in
       let name = Ident.name param in
       let exp =
+        let cases =
+          let pure_case ({c_lhs; _} as case) =
+            {case with c_lhs = as_computation_pattern c_lhs} in
+          List.map pure_case cases in
         { exp with exp_loc = loc; exp_env = env; exp_desc =
           Texp_match
             ({exp with exp_type = pat.pat_type; exp_env = env; exp_desc =
@@ -966,7 +970,7 @@ and transl_match e arg pat_expr_list partial =
       assert (static_handlers = []);
       Matching.for_function e.exp_loc None (transl_exp arg) val_cases partial
     | arg, _ :: _ ->
-        let val_id = Typecore.name_cases "val" pat_expr_list in
+        let val_id = Typecore.name_pattern "val" (List.map fst val_cases) in
         let k = Typeopt.value_kind arg.exp_env arg.exp_type in
         static_catch [transl_exp arg] [val_id, k]
           (Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial)

tools/cmt2annot.ml

@@ -21,7 +21,7 @@ open Tast_iterator
 
 let variables_iterator scope =
   let super = default_iterator in
-  let pat sub p =
+  let pat sub (type k) (p : k general_pattern) =
     begin match p.pat_desc with
     | Tpat_var (id, _) | Tpat_alias (_, id, _) ->
         Stypes.record (Stypes.An_ident (p.pat_loc,
@@ -113,8 +113,8 @@ let rec iterator ~scope rebuild_env =
     Stypes.record (Stypes.Ti_expr exp);
     super.expr sub exp
 
-  and pat sub p =
-    Stypes.record (Stypes.Ti_pat p);
+  and pat sub (type k) (p : k general_pattern) =
+    Stypes.record (Stypes.Ti_pat (classify_pattern p, p));
     super.pat sub p
   in
 
@@ -163,7 +163,7 @@ let binary_part iter x =
   | Partial_structure x -> iter.structure iter x
   | Partial_structure_item x -> iter.structure_item iter x
   | Partial_expression x -> iter.expr iter x
-  | Partial_pattern x -> iter.pat iter x
+  | Partial_pattern (_, x) -> iter.pat iter x
   | Partial_class_expr x -> iter.class_expr iter x
   | Partial_signature x -> iter.signature iter x
   | Partial_signature_item x -> iter.signature_item iter x

typing/parmatch.ml

@@ -141,8 +141,6 @@ end = struct
       | Tpat_lazy p ->
           Lazy, [p]
       | Tpat_or _ -> invalid_arg "Parmatch.Pattern_head.deconstruct: (P | Q)"
-      | Tpat_exception _ ->
-          invalid_arg "Parmatch.Pattern_head.deconstruct: (exception P)"
     in
     let desc, pats = deconstruct_desc q.pat_desc in
     { desc; typ = q.pat_type; loc = q.pat_loc;
@@ -1229,8 +1227,6 @@ let rec has_instance p = match p.pat_desc with
   | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
   | Tpat_lazy p
     -> has_instance p
-  | Tpat_exception _ -> assert false
-
 
 and has_instances = function
   | [] -> true
@@ -1955,19 +1951,24 @@ and lubs ps qs = match ps,qs with
 (* Apply pressure to variants *)
 
 let pressure_variants tdefs patl =
+  ignore (pressure_variants
+            (Some tdefs)
+            (List.map (fun p -> [p; omega]) patl))
+
+let pressure_variants_in_computation_pattern tdefs patl =
   let add_row pss p_opt =
     match p_opt with
     | None -> pss
-    | Some p -> [p; omega] :: pss
+    | Some p -> p :: pss
   in
   let val_pss, exn_pss =
     List.fold_right (fun pat (vpss, epss)->
       let (vp, ep) = split_pattern pat in
       add_row vpss vp, add_row epss ep
     ) patl ([], [])
   in
-  ignore (pressure_variants (Some tdefs) val_pss);
-  ignore (pressure_variants (Some tdefs) exn_pss)
+  pressure_variants tdefs val_pss;
+  pressure_variants tdefs exn_pss
 
 (*****************************)
 (* Utilities for diagnostics *)
@@ -2055,8 +2056,6 @@ module Conv = struct
           mkpat (Ppat_array (List.map loop lst))
       | Tpat_lazy p ->
           mkpat (Ppat_lazy (loop p))
-      | Tpat_exception _ ->
-          assert false
     in
     let ps = loop typed in
     (ps, constrs, labels)
@@ -2182,7 +2181,6 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
 | Tpat_lazy p
     ->
     collect_paths_from_pat r p
-| Tpat_exception _ -> assert false
 
 
 (*
@@ -2314,7 +2312,6 @@ let inactive ~partial pat =
               ldps
         | Tpat_or (p,q,_) ->
             loop p && loop q
-        | Tpat_exception _ -> assert false
       in
       loop pat
   end

typing/parmatch.mli

@@ -90,7 +90,10 @@ val ppat_of_type :
     (string, constructor_description) Hashtbl.t *
     (string, label_description) Hashtbl.t
 
-val pressure_variants: Env.t -> pattern list -> unit
+val pressure_variants:
+  Env.t -> pattern list -> unit
+val pressure_variants_in_computation_pattern:
+  Env.t -> computation general_pattern list -> unit
 
 (** [check_partial pred loc caselist] and [check_unused refute pred caselist]
     are called with a function [pred] which will be given counter-example
@@ -103,13 +106,13 @@ val check_partial:
     ((string, constructor_description) Hashtbl.t ->
      (string, label_description) Hashtbl.t ->
      Parsetree.pattern -> pattern option) ->
-    Location.t -> case list -> partial
+    Location.t -> value case list -> partial
 val check_unused:
     (bool ->
      (string, constructor_description) Hashtbl.t ->
      (string, label_description) Hashtbl.t ->
      Parsetree.pattern -> pattern option) ->
-    case list -> unit
+    value case list -> unit
 
 (* Irrefutability tests *)
 val irrefutable : pattern -> bool
@@ -121,7 +124,7 @@ val irrefutable : pattern -> bool
 val inactive : partial:partial -> pattern -> bool
 
 (* Ambiguous bindings *)
-val check_ambiguous_bindings : case list -> unit
+val check_ambiguous_bindings : value case list -> unit
 
 (* The tag used for open polymorphic variant types with an abstract row *)
 val some_private_tag : label

typing/printpat.ml

@@ -33,19 +33,22 @@ let pretty_const c = match c with
 | Const_int64 i -> Printf.sprintf "%LdL" i
 | Const_nativeint i -> Printf.sprintf "%ndn" i
 
-let rec pretty_val ppf v =
+let pretty_extra ppf (cstr, _loc, _attrs) pretty_rest rest =
+  match cstr with
+  | Tpat_unpack ->
+     fprintf ppf "@[(module %a)@]" pretty_rest rest
+  | Tpat_constraint _ ->
+     fprintf ppf "@[(%a : _)@]" pretty_rest rest
+  | Tpat_type _ ->
+     fprintf ppf "@[(# %a)@]" pretty_rest rest
+  | Tpat_open _ ->
+     fprintf ppf "@[(# %a)@]" pretty_rest rest
+
+let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
   match v.pat_extra with
-      (cstr, _loc, _attrs) :: rem ->
-        begin match cstr with
-          | Tpat_unpack ->
-            fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
-          | Tpat_constraint _ ->
-            fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem }
-          | Tpat_type _ ->
-            fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
-          | Tpat_open _ ->
-              fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
-        end
+    | extra :: rem ->
+       pretty_extra ppf extra
+         pretty_val { v with pat_extra = rem }
     | [] ->
   match v.pat_desc with
   | Tpat_any -> fprintf ppf "_"
@@ -89,12 +92,14 @@ let rec pretty_val ppf v =
       fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
   | Tpat_lazy v ->
       fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
-  | Tpat_exception v ->
-      fprintf ppf "@[<2>exception@ %a@]" pretty_arg v
   | Tpat_alias (v, x,_) ->
       fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
-  | Tpat_or (v,w,_)    ->
-      fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
+  | Tpat_value v ->
+      fprintf ppf "%a" pretty_val (v :> pattern)
+  | Tpat_exception v ->
+      fprintf ppf "@[<2>exception@ %a@]" pretty_arg v
+  | Tpat_or _ ->
+      fprintf ppf "@[(%a)@]" pretty_or v
 
 and pretty_car ppf v = match v.pat_desc with
 | Tpat_construct (_,cstr, [_ ; _])
@@ -113,10 +118,11 @@ and pretty_arg ppf v = match v.pat_desc with
 | Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
 |  _ -> pretty_val ppf v
 
-and pretty_or ppf v = match v.pat_desc with
-| Tpat_or (v,w,_) ->
-    fprintf ppf "%a|@,%a" pretty_or v pretty_or w
-| _ -> pretty_val ppf v
+and pretty_or : type k . _ -> k general_pattern -> _ = fun ppf v ->
+  match v.pat_desc with
+  | Tpat_or (v,w,_) ->
+      fprintf ppf "%a|@,%a" pretty_or v pretty_or w
+  | _ -> pretty_val ppf v
 
 and pretty_vals sep ppf = function
   | [] -> ()
@@ -135,12 +141,11 @@ and pretty_lvals ppf = function
 let top_pretty ppf v =
   fprintf ppf "@[%a@]@?" pretty_val v
 
-
 let pretty_pat p =
   top_pretty Format.str_formatter p ;
   prerr_string (Format.flush_str_formatter ())
 
-type matrix = pattern list list
+type 'k matrix = 'k general_pattern list list
 
 let pretty_line fmt =
   List.iter (fun p ->
@@ -149,7 +154,7 @@ let pretty_line fmt =
     Format.fprintf fmt ">";
   )
 
-let pretty_matrix fmt (pss : matrix) =
+let pretty_matrix fmt (pss : 'k matrix) =
   Format.fprintf fmt "begin matrix\n" ;
   List.iter (fun ps ->
     pretty_line fmt ps ;

typing/printpat.mli

@@ -15,8 +15,13 @@
 
 
 
-val pretty_const : Asttypes.constant -> string
-val top_pretty : Format.formatter -> Typedtree.pattern -> unit
-val pretty_pat : Typedtree.pattern -> unit
-val pretty_line : Format.formatter -> Typedtree.pattern list -> unit
-val pretty_matrix : Format.formatter -> Typedtree.pattern list list -> unit
+val pretty_const
+    : Asttypes.constant -> string
+val top_pretty
+    : Format.formatter -> 'k Typedtree.general_pattern -> unit
+val pretty_pat
+    : 'k Typedtree.general_pattern -> unit
+val pretty_line
+    : Format.formatter -> 'k Typedtree.general_pattern list -> unit
+val pretty_matrix
+    : Format.formatter -> 'k Typedtree.general_pattern list list -> unit