Merge pull request #10637 from gasche/outcomdetree-constructor-record

[refactoring] Outcometree: introduce a record type for constructors

Changes

@@ -163,6 +163,9 @@ Working version
 - #10618: Expose more Pprintast functions
   (Guillaume Petiot, review by Gabriel Scherer)
 
+- #10637: Outcometree: introduce a record type for constructors
+  (Gabriel Scherer, review by Thomas Refis)
+
 ### Build system:
 
 ### Bug fixes:

typing/oprint.ml

@@ -496,6 +496,15 @@ let collect_functor_args mty =
   let l, rest = collect_functor_args [] mty in
   List.rev l, rest
 
+let constructor_of_extension_constructor
+    (ext : out_extension_constructor) : out_constructor
+=
+  {
+    ocstr_name = ext.oext_name;
+    ocstr_args = ext.oext_args;
+    ocstr_return_type = ext.oext_ret_type;
+  }
+
 let split_anon_functor_arguments params =
   let rec uncollect_anonymous_suffix acc rest = match acc with
     | Some (None, mty_arg) :: acc ->
@@ -561,13 +570,13 @@ and print_out_signature ppf =
         match items with
             Osig_typext(ext, Oext_next) :: items ->
               gather_extensions
-                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                (constructor_of_extension_constructor ext :: acc)
                 items
           | _ -> (List.rev acc, items)
       in
       let exts, items =
         gather_extensions
-          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          [constructor_of_extension_constructor ext]
           items
       in
       let te =
@@ -593,7 +602,7 @@ and print_out_sig_item ppf =
         name !out_class_type clt
   | Osig_typext (ext, Oext_exception) ->
       fprintf ppf "@[<2>exception %a@]"
-        print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+        print_out_constr (constructor_of_extension_constructor ext)
   | Osig_typext (ext, _es) ->
       print_out_extension_constructor ppf ext
   | Osig_modtype (name, Omty_abstract) ->
@@ -703,13 +712,18 @@ and print_out_type_decl kwd ppf td =
     print_immediate
     print_unboxed
 
-and print_out_constr ppf (name, tyl,ret_type_opt) =
+and print_out_constr ppf constr =
+  let {
+    ocstr_name = name;
+    ocstr_args = tyl;
+    ocstr_return_type = return_type;
+  } = constr in
   let name =
     match name with
     | "::" -> "(::)"   (* #7200 *)
     | s -> s
   in
-  match ret_type_opt with
+  match return_type with
   | None ->
       begin match tyl with
       | [] ->
@@ -746,7 +760,8 @@ and print_out_extension_constructor ppf ext =
   fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]"
     print_extended_type
     (if ext.oext_private = Asttypes.Private then " private" else "")
-    print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
+    print_out_constr
+    (constructor_of_extension_constructor ext)
 
 and print_out_type_extension ppf te =
   let print_extended_type ppf =
@@ -796,13 +811,13 @@ let rec print_items ppf =
         match items with
             (Osig_typext(ext, Oext_next), None) :: items ->
               gather_extensions
-                ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+                (constructor_of_extension_constructor ext :: acc)
                 items
           | _ -> (List.rev acc, items)
       in
       let exts, items =
         gather_extensions
-          [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+          [constructor_of_extension_constructor ext]
           items
       in
       let te =

typing/oprint.mli

@@ -20,8 +20,7 @@ val out_ident : (formatter -> out_ident -> unit) ref
 val out_value : (formatter -> out_value -> unit) ref
 val out_label : (formatter -> string * bool * out_type -> unit) ref
 val out_type : (formatter -> out_type -> unit) ref
-val out_constr :
-  (formatter -> string * out_type list * out_type option -> unit) ref
+val out_constr : (formatter -> out_constructor -> unit) ref
 val out_class_type : (formatter -> out_class_type -> unit) ref
 val out_module_type : (formatter -> out_module_type -> unit) ref
 val out_sig_item : (formatter -> out_sig_item -> unit) ref

typing/outcometree.mli

@@ -69,7 +69,7 @@ type out_type =
   | Otyp_object of (string * out_type) list * bool option
   | Otyp_record of (string * bool * out_type) list
   | Otyp_stuff of string
-  | Otyp_sum of (string * out_type list * out_type option) list
+  | Otyp_sum of out_constructor list
   | Otyp_tuple of out_type list
   | Otyp_var of bool * string
   | Otyp_variant of
@@ -78,6 +78,12 @@ type out_type =
   | Otyp_module of out_ident * (string * out_type) list
   | Otyp_attribute of out_type * out_attribute
 
+and out_constructor = {
+  ocstr_name: string;
+  ocstr_args: out_type list;
+  ocstr_return_type: out_type option;
+}
+
 and out_variant =
   | Ovar_fields of (string * bool * out_type list) list
   | Ovar_typ of out_type
@@ -128,7 +134,7 @@ and out_extension_constructor =
 and out_type_extension =
   { otyext_name: string;
     otyext_params: string list;
-    otyext_constructors: (string * out_type list * out_type option) list;
+    otyext_constructors: out_constructor list;
     otyext_private: Asttypes.private_flag }
 and out_val_decl =
   { oval_name: string;

typing/printtyp.ml

@@ -1421,12 +1421,20 @@ and tree_of_constructor cd =
   let name = Ident.name cd.cd_id in
   let arg () = tree_of_constructor_arguments cd.cd_args in
   match cd.cd_res with
-  | None -> (name, arg (), None)
+  | None -> {
+      ocstr_name = name;
+      ocstr_args = arg ();
+      ocstr_return_type = None;
+    }
   | Some res ->
       Names.with_local_names (fun () ->
         let ret = tree_of_typexp Type res in
         let args = arg () in
-        (name, args, Some ret))
+        {
+          ocstr_name = name;
+          ocstr_args = args;
+          ocstr_return_type = Some ret;
+        })
 
 and tree_of_label l =
   (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp Type l.ld_type)
@@ -1511,7 +1519,11 @@ let extension_only_constructor id ppf ext =
       ext.ext_ret_type
   in
   Format.fprintf ppf "@[<hv>%a@]"
-    !Oprint.out_constr (name, args, ret)
+    !Oprint.out_constr {
+      ocstr_name = name;
+      ocstr_args = args;
+      ocstr_return_type = ret;
+    }
 
 (* Print a value declaration *)