Simplify Texp_function and related code to only have 1 case.

Author: cristianoc

analysis/reanalyze/src/Arnold.ml

@@ -908,7 +908,7 @@ module Compile = struct
         let open Command in
         c +++ ConstrOption Rnone
       | _ -> c)
-    | Texp_function {cases} -> cases |> List.map (case ~ctx) |> Command.nondet
+    | Texp_function {case = case_} -> case ~ctx case_
     | Texp_match (e, casesOk, casesExn, _partial)
       when not
              (casesExn

analysis/reanalyze/src/DeadValue.ml

@@ -156,18 +156,16 @@ let rec collectExpr super self (e : Typedtree.expression) =
           exp_desc =
             Texp_function
               {
-                cases =
-                  [
-                    {
-                      c_lhs = {pat_desc = Tpat_var (etaArg, _)};
-                      c_rhs =
-                        {
-                          exp_desc =
-                            Texp_apply
-                              ({exp_desc = Texp_ident (idArg2, _, _)}, args);
-                        };
-                    };
-                  ];
+                case =
+                  {
+                    c_lhs = {pat_desc = Tpat_var (etaArg, _)};
+                    c_rhs =
+                      {
+                        exp_desc =
+                          Texp_apply
+                            ({exp_desc = Texp_ident (idArg2, _, _)}, args);
+                      };
+                  };
               };
         } )
     when Ident.name idArg = "arg"

compiler/gentype/TranslateStructure.ml

@@ -3,9 +3,8 @@ open GenTypeCommon
 let rec addAnnotationsToTypes_ ~config ~(expr : Typedtree.expression)
     (arg_types : arg_type list) =
   match (expr.exp_desc, expr.exp_type.desc, arg_types) with
-  | ( Texp_function {arg_label; param; cases = [{c_rhs}]},
-      _,
-      {a_type} :: next_types ) ->
+  | Texp_function {arg_label; param; case = {c_rhs}}, _, {a_type} :: next_types
+    ->
     let next_types1 =
       next_types |> addAnnotationsToTypes_ ~config ~expr:c_rhs
     in
@@ -51,7 +50,7 @@ and add_annotations_to_fields ~config (expr : Typedtree.expression)
     (fields : fields) (arg_types : arg_type list) =
   match (expr.exp_desc, fields, arg_types) with
   | _, [], _ -> ([], arg_types |> add_annotations_to_types ~config ~expr)
-  | Texp_function {cases = [{c_rhs}]}, field :: next_fields, _ ->
+  | Texp_function {case = {c_rhs}}, field :: next_fields, _ ->
     let next_fields1, types1 =
       add_annotations_to_fields ~config c_rhs next_fields arg_types
     in

compiler/ml/printtyped.ml

@@ -285,11 +285,11 @@ and expression i ppf x =
     line i ppf "Texp_let %a\n" fmt_rec_flag rf;
     list i value_binding ppf l;
     expression i ppf e
-  | Texp_function {arg_label = p; param; cases; partial = _} ->
+  | Texp_function {arg_label = p; param; case = case_; partial = _} ->
     line i ppf "Texp_function\n";
     line i ppf "%a" Ident.print param;
     arg_label i ppf p;
-    list i case ppf cases
+    case i ppf case_
   | Texp_apply (e, l) ->
     line i ppf "Texp_apply\n";
     expression i ppf e;

compiler/ml/rec_check.ml

@@ -292,8 +292,8 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t =
     let case env {Typedtree.c_rhs} = expression env c_rhs in
     Use.join (expression env e) (list case env cases)
   | Texp_override () -> assert false
-  | Texp_function {cases} ->
-    Use.delay (list (case ~scrutinee:Use.empty) env cases)
+  | Texp_function {case = case_} ->
+    Use.delay (list (case ~scrutinee:Use.empty) env [case_])
   | Texp_lazy e -> (
     match Typeopt.classify_lazy_argument e with
     | `Constant_or_function | `Identifier _ | `Float -> expression env e

compiler/ml/tast_iterator.ml

@@ -155,7 +155,7 @@ let expr sub {exp_extra; exp_desc; exp_env; _} =
   | Texp_let (rec_flag, list, exp) ->
     sub.value_bindings sub (rec_flag, list);
     sub.expr sub exp
-  | Texp_function {cases; _} -> sub.cases sub cases
+  | Texp_function {case; _} -> sub.case sub case
   | Texp_apply (exp, list) ->
     sub.expr sub exp;
     List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list

compiler/ml/tast_mapper.ml

@@ -199,8 +199,8 @@ let expr sub x =
     | Texp_let (rec_flag, list, exp) ->
       let rec_flag, list = sub.value_bindings sub (rec_flag, list) in
       Texp_let (rec_flag, list, sub.expr sub exp)
-    | Texp_function {arg_label; param; cases; partial} ->
-      Texp_function {arg_label; param; cases = sub.cases sub cases; partial}
+    | Texp_function {arg_label; param; case; partial} ->
+      Texp_function {arg_label; param; case = sub.case sub case; partial}
     | Texp_apply (exp, list) ->
       Texp_apply
         (sub.expr sub exp, List.map (tuple2 id (opt (sub.expr sub))) list)

compiler/ml/translcore.ml

@@ -549,58 +549,50 @@ type binding =
   | Bind_value of value_binding list
   | Bind_module of Ident.t * string loc * module_expr
 
-let rec push_defaults loc bindings cases partial =
-  match cases with
-  | [
-   {
-     c_lhs = pat;
-     c_guard = None;
-     c_rhs =
-       {exp_desc = Texp_function {arg_label; param; cases; partial}} as exp;
-   };
-  ] ->
-    let cases = push_defaults exp.exp_loc bindings cases partial in
-    [
-      {
-        c_lhs = pat;
-        c_guard = None;
-        c_rhs =
-          {exp with exp_desc = Texp_function {arg_label; param; cases; partial}};
-      };
-    ]
-  | [
-   {
-     c_lhs = pat;
-     c_guard = None;
-     c_rhs =
-       {
-         exp_attributes = [({txt = "#default"}, _)];
-         exp_desc =
-           Texp_let (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2));
-       };
-   };
-  ] ->
+let rec push_defaults loc bindings case partial =
+  match case with
+  | {
+   c_lhs = pat;
+   c_guard = None;
+   c_rhs = {exp_desc = Texp_function {arg_label; param; case; partial}} as exp;
+  } ->
+    let case = push_defaults exp.exp_loc bindings case partial in
+
+    {
+      c_lhs = pat;
+      c_guard = None;
+      c_rhs =
+        {exp with exp_desc = Texp_function {arg_label; param; case; partial}};
+    }
+  | {
+   c_lhs = pat;
+   c_guard = None;
+   c_rhs =
+     {
+       exp_attributes = [({txt = "#default"}, _)];
+       exp_desc =
+         Texp_let (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2));
+     };
+  } ->
     push_defaults loc
       (Bind_value binds :: bindings)
-      [{c_lhs = pat; c_guard = None; c_rhs = e2}]
+      {c_lhs = pat; c_guard = None; c_rhs = e2}
       partial
-  | [
-   {
-     c_lhs = pat;
-     c_guard = None;
-     c_rhs =
-       {
-         exp_attributes = [({txt = "#modulepat"}, _)];
-         exp_desc =
-           Texp_letmodule (id, name, mexpr, ({exp_desc = Texp_function _} as e2));
-       };
-   };
-  ] ->
+  | {
+   c_lhs = pat;
+   c_guard = None;
+   c_rhs =
+     {
+       exp_attributes = [({txt = "#modulepat"}, _)];
+       exp_desc =
+         Texp_letmodule (id, name, mexpr, ({exp_desc = Texp_function _} as e2));
+     };
+  } ->
     push_defaults loc
       (Bind_module (id, name, mexpr) :: bindings)
-      [{c_lhs = pat; c_guard = None; c_rhs = e2}]
+      {c_lhs = pat; c_guard = None; c_rhs = e2}
       partial
-  | [case] ->
+  | case ->
     let exp =
       List.fold_left
         (fun exp binds ->
@@ -614,45 +606,7 @@ let rec push_defaults loc bindings cases partial =
           })
         case.c_rhs bindings
     in
-    [{case with c_rhs = exp}]
-  | {c_lhs = pat; c_rhs = exp; c_guard = _} :: _ when bindings <> [] ->
-    let param = Typecore.name_pattern "param" cases in
-    let name = Ident.name param in
-    let exp =
-      {
-        exp with
-        exp_loc = loc;
-        exp_desc =
-          Texp_match
-            ( {
-                exp with
-                exp_type = pat.pat_type;
-                exp_desc =
-                  Texp_ident
-                    ( Path.Pident param,
-                      mknoloc (Longident.Lident name),
-                      {
-                        val_type = pat.pat_type;
-                        val_kind = Val_reg;
-                        val_attributes = [];
-                        Types.val_loc = Location.none;
-                      } );
-              },
-              cases,
-              [],
-              partial );
-      }
-    in
-    push_defaults loc bindings
-      [
-        {
-          c_lhs = {pat with pat_desc = Tpat_var (param, mknoloc name)};
-          c_guard = None;
-          c_rhs = exp;
-        };
-      ]
-      Total
-  | _ -> cases
+    {case with c_rhs = exp}
 
 (* Assertions *)
 
@@ -716,15 +670,15 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
   | Texp_constant cst -> Lconst (Const_base cst)
   | Texp_let (rec_flag, pat_expr_list, body) ->
     transl_let rec_flag pat_expr_list (transl_exp body)
-  | Texp_function {arg_label = _; param; cases; partial} ->
+  | Texp_function {arg_label = _; param; case; partial} ->
     let async = has_async_attribute e in
     let directive =
       match extract_directive_for_fn e with
       | None -> None
       | Some (directive, _) -> Some directive
     in
     let params, body, return_unit =
-      let pl = push_defaults e.exp_loc [] cases partial in
+      let pl = push_defaults e.exp_loc [] case partial in
       transl_function e.exp_loc partial param pl
     in
     let attr =
@@ -1088,32 +1042,28 @@ and transl_apply ?(inlined = Default_inline)
           sargs)
       : Lambda.lambda)
 
-and transl_function loc partial param cases =
-  match cases with
-  | [
-   {
-     c_lhs = pat;
-     c_guard = None;
-     c_rhs =
-       {
-         exp_desc =
-           Texp_function
-             {arg_label = _; param = param'; cases; partial = partial'};
-       } as exp;
-   };
-  ]
+and transl_function loc partial param case =
+  match case with
+  | {
+   c_lhs = pat;
+   c_guard = None;
+   c_rhs =
+     {
+       exp_desc =
+         Texp_function {arg_label = _; param = param'; case; partial = partial'};
+     } as exp;
+  }
     when Parmatch.inactive ~partial pat && not (exp |> has_async_attribute) ->
     let params, body, return_unit =
-      transl_function exp.exp_loc partial' param' cases
+      transl_function exp.exp_loc partial' param' case
     in
     ( param :: params,
       Matching.for_function loc None (Lvar param) [(pat, body)] partial,
       return_unit )
-  | {c_rhs = {exp_env; exp_type}; _} :: _ ->
+  | {c_rhs = {exp_env; exp_type}; _} ->
     ( [param],
-      Matching.for_function loc None (Lvar param) (transl_cases cases) partial,
+      Matching.for_function loc None (Lvar param) [transl_case case] partial,
       is_base_type exp_env exp_type Predef.path_unit )
-  | _ -> assert false
 
 and transl_let rec_flag pat_expr_list body =
   match rec_flag with

compiler/ml/typecore.ml

@@ -3306,13 +3306,14 @@ and type_function ?in_function loc attrs env ty_expected l caselist =
     type_cases ~in_function:(loc_fun, ty_fun) env ty_arg ty_res true loc
       caselist
   in
+  let case = List.hd cases in
   if is_optional l && not_function env ty_res then
-    Location.prerr_warning (List.hd cases).c_lhs.pat_loc
+    Location.prerr_warning case.c_lhs.pat_loc
       Warnings.Unerasable_optional_argument;
   let param = name_pattern "param" cases in
   re
     {
-      exp_desc = Texp_function {arg_label = l; param; cases; partial};
+      exp_desc = Texp_function {arg_label = l; param; case; partial};
       exp_loc = loc;
       exp_extra = [];
       exp_type = instance env (newgenty (Tarrow (l, ty_arg, ty_res, Cok)));
@@ -3481,13 +3482,13 @@ and type_argument ?type_clash_context ?recarg env sarg ty_expected' ty_expected
               exp_desc = Texp_apply (texp, args @ [(Nolabel, Some eta_var)]);
             }
           in
-          let cases = [case eta_pat e] in
-          let param = name_pattern "param" cases in
+          let case = case eta_pat e in
+          let param = name_pattern "param" [case] in
           {
             texp with
             exp_type = ty_fun;
             exp_desc =
-              Texp_function {arg_label = Nolabel; param; cases; partial = Total};
+              Texp_function {arg_label = Nolabel; param; case; partial = Total};
           }
         in
         Location.prerr_warning texp.exp_loc

compiler/ml/typedtree.ml

@@ -79,7 +79,7 @@ and expression_desc =
   | Texp_function of {
       arg_label: arg_label;
       param: Ident.t;
-      cases: case list;
+      case: case;
       partial: partial;
     }
   | Texp_apply of expression * (arg_label * expression option) list