split patterns into "value patterns" and "computation patterns"

Value patterns match on a value (the result of computation), while
computation patterns handle the effects (hint hint) of
a computation. The only forms of computation patterns in OCaml today
are value patterns and exception patterns (exception p).

The sub-pattern `p` of the `lazy p` construction should be
a computation pattern, rather than a value pattern. This pull-request
does not make this change.

Most of the changes in this PR are boilerplate -- it really is a lot
of work now to add a new syntactic category to the typed-tree
syntax. This boilerplate is fairly automatic and should be easy to
review.

There is a subtle part to the patch, though: the implementation of the
pattern type-checking. It now has to reconstruct the value/computation
distinction (absent from the parse-tree), and return values from two
different types. Instead of splitting the type-checker in several
functions (which risked code duplications), I choose to use a GADT to
have the same [type_pat] function return two different types depending
on the caller. This is the least invasive way to adapt this part of
the codebase, whose inherent complexity is so large (unfortunately)
that adding a GADT to the mix barely makes a difference.

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 = {c_lhs with pat_desc = Tpat_value 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
+  | 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