Merge pull request #10007 from AbstractMachinesLab/return-signature-when-typing

Expose module signature when typing implementation

.depend

@@ -5743,6 +5743,7 @@ driver/compenv.cmx : \
 driver/compenv.cmi : \
     utils/clflags.cmi
 driver/compile.cmo : \
+    typing/typedtree.cmi \
     lambda/translmod.cmi \
     lambda/simplif.cmi \
     utils/profile.cmi \
@@ -5756,6 +5757,7 @@ driver/compile.cmo : \
     bytecomp/bytegen.cmi \
     driver/compile.cmi
 driver/compile.cmx : \
+    typing/typedtree.cmx \
     lambda/translmod.cmx \
     lambda/simplif.cmx \
     utils/profile.cmx \
@@ -5934,6 +5936,7 @@ driver/makedepend.cmx : \
     driver/makedepend.cmi
 driver/makedepend.cmi :
 driver/optcompile.cmo : \
+    typing/typedtree.cmi \
     lambda/translmod.cmi \
     lambda/simplif.cmi \
     utils/profile.cmi \
@@ -5949,6 +5952,7 @@ driver/optcompile.cmo : \
     asmcomp/asmgen.cmi \
     driver/optcompile.cmi
 driver/optcompile.cmx : \
+    typing/typedtree.cmx \
     lambda/translmod.cmx \
     lambda/simplif.cmx \
     utils/profile.cmx \

driver/compile.ml

@@ -27,8 +27,8 @@ let interface ~source_file ~output_prefix =
 
 (** Bytecode compilation backend for .ml files. *)
 
-let to_bytecode i (typedtree, coercion) =
-  (typedtree, coercion)
+let to_bytecode i Typedtree.{structure; coercion; _} =
+  (structure, coercion)
   |> Profile.(record transl)
     (Translmod.transl_implementation i.module_name)
   |> Profile.(record ~accumulate:true generate)

driver/compile.mli

@@ -25,7 +25,7 @@ val implementation:
 
 val to_bytecode :
   Compile_common.info ->
-  Typedtree.structure * Typedtree.module_coercion ->
+  Typedtree.implementation ->
   Instruct.instruction list * Ident.Set.t
 (** [to_bytecode info typed] takes a typechecked implementation
     and returns its bytecode.

driver/compile_common.mli

@@ -68,17 +68,14 @@ val interface : info -> unit
 val parse_impl : info -> Parsetree.structure
 (** [parse_impl info] parses an implementation (usually an [.ml] file). *)
 
-val typecheck_impl :
-  info -> Parsetree.structure -> Typedtree.structure * Typedtree.module_coercion
+val typecheck_impl : info -> Parsetree.structure -> Typedtree.implementation
 (** [typecheck_impl info parsetree] typechecks an implementation and returns
-    the typedtree of the associated module, along with a coercion against
-    its public interface.
+    the typedtree of the associated module, its public interface, and a
+    coercion against that public interface.
 *)
 
 val implementation :
-  info ->
-  backend:(info -> Typedtree.structure * Typedtree.module_coercion -> unit) ->
-  unit
+  info -> backend:(info -> Typedtree.implementation -> unit) -> unit
 (** The complete compilation pipeline for implementations. *)
 
 (** {2 Build artifacts} *)

driver/optcompile.ml

@@ -31,14 +31,14 @@ let (|>>) (x, y) f = (x, f y)
 
 (** Native compilation backend for .ml files. *)
 
-let flambda i backend typed =
+let flambda i backend Typedtree.{structure; coercion; _} =
   if !Clflags.classic_inlining then begin
     Clflags.default_simplify_rounds := 1;
     Clflags.use_inlining_arguments_set Clflags.classic_arguments;
     Clflags.unbox_free_vars_of_closures := false;
     Clflags.unbox_specialised_args := false
   end;
-  typed
+  (structure, coercion)
   |> Profile.(record transl)
       (Translmod.transl_implementation_flambda i.module_name)
   |> Profile.(record generate)
@@ -66,9 +66,9 @@ let flambda i backend typed =
         program);
     Compilenv.save_unit_info (cmx i))
 
-let clambda i backend typed =
+let clambda i backend Typedtree.{structure; coercion; _} =
   Clflags.use_inlining_arguments_set Clflags.classic_arguments;
-  typed
+  (structure, coercion)
   |> Profile.(record transl)
     (Translmod.transl_store_implementation i.module_name)
   |> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.program

driver/optcompile.mli

@@ -27,7 +27,7 @@ val implementation:
 val clambda :
   Compile_common.info ->
   (module Backend_intf.S) ->
-  Typedtree.structure * Typedtree.module_coercion -> unit
+  Typedtree.implementation -> unit
 (** [clambda info typed] applies the regular compilation pipeline to the
     given typechecked implementation and outputs the resulting files.
 *)
@@ -35,7 +35,7 @@ val clambda :
 val flambda :
   Compile_common.info ->
   (module Backend_intf.S) ->
-  Typedtree.structure * Typedtree.module_coercion -> unit
+  Typedtree.implementation -> unit
 (** [flambda info backend typed] applies the Flambda compilation pipeline to the
     given typechecked implementation and outputs the resulting files.
 *)

ocamldoc/odoc_analyse.ml

@@ -151,7 +151,8 @@ let process_file sourcefile =
          match parsetree_typedtree_opt with
            None ->
              None
-         | Some (parsetree, typedtree) ->
+         | Some (parsetree, Typedtree.{structure; coercion; _}) ->
+             let typedtree = (structure, coercion) in
              let file_module = Ast_analyser.analyse_typed_tree file
                  input_file parsetree typedtree
              in

typing/printtyped.ml

@@ -942,4 +942,5 @@ let interface ppf x = list 0 signature_item ppf x.sig_items;;
 
 let implementation ppf x = list 0 structure_item ppf x.str_items;;
 
-let implementation_with_coercion ppf (x, _) = implementation ppf x
+let implementation_with_coercion ppf Typedtree.{structure; _} =
+  implementation ppf structure

typing/printtyped.mli

@@ -20,4 +20,4 @@ val interface : formatter -> signature -> unit;;
 val implementation : formatter -> structure -> unit;;
 
 val implementation_with_coercion :
-    formatter -> (structure * module_coercion) -> unit;;
+  formatter -> Typedtree.implementation -> unit;;

typing/typedtree.ml

@@ -613,6 +613,13 @@ and 'a class_infos =
     ci_attributes: attribute list;
    }
 
+type implementation = {
+  structure: structure;
+  coercion: module_coercion;
+  signature: Types.signature
+}
+
+
 (* Auxiliary functions over the a.s.t. *)
 
 let as_computation_pattern (p : pattern) : computation general_pattern =

typing/typedtree.mli

@@ -752,6 +752,21 @@ and 'a class_infos =
     ci_attributes: attributes;
    }
 
+type implementation = {
+  structure: structure;
+  coercion: module_coercion;
+  signature: Types.signature
+}
+(** A typechecked implementation including its module structure, its exported
+    signature, and a coercion of the module against that signature.
+
+    If an .mli file is present, the signature will come from that file and be
+    the exported signature of the module.
+
+    If there isn't one, the signature will be inferred from the module
+    structure.
+*)
+
 (* Auxiliary functions over the a.s.t. *)
 
 (** [as_computation_pattern p] is a computation pattern with description

typing/typemod.ml

@@ -2631,7 +2631,10 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
               (Printtyp.printed_signature sourcefile) simple_sg
           );
         gen_annot outputprefix sourcefile (Cmt_format.Implementation str);
-        (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
+        { structure = str;
+          coercion = Tcoerce_none;
+          signature = simple_sg
+        } (* result is ignored by Compile.implementation *)
       end else begin
         let sourceintf =
           Filename.remove_extension sourcefile ^ !Config.interface_suffix in
@@ -2655,7 +2658,10 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
           Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
             annots (Some sourcefile) initial_env None;
           gen_annot outputprefix sourcefile annots;
-          (str, coercion)
+          { structure = str;
+            coercion;
+            signature = dclsig
+          }
         end else begin
           let coercion =
             Includemod.compunit initial_env ~mark:Mark_positive
@@ -2679,7 +2685,10 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
               annots (Some sourcefile) initial_env (Some cmi);
             gen_annot outputprefix sourcefile annots
           end;
-          (str, coercion)
+          { structure = str;
+            coercion;
+            signature = simple_sg
+          }
         end
       end
     )

typing/typemod.mli

@@ -38,8 +38,8 @@ val type_toplevel_phrase:
   Env.t -> Parsetree.structure ->
   Typedtree.structure * Types.signature * Signature_names.t * Env.t
 val type_implementation:
-  string -> string -> string -> Env.t -> Parsetree.structure ->
-  Typedtree.structure * Typedtree.module_coercion
+  string -> string -> string -> Env.t ->
+  Parsetree.structure -> Typedtree.implementation
 val type_interface:
         Env.t -> Parsetree.signature -> Typedtree.signature
 val transl_signature:

typing/untypeast.ml

@@ -605,7 +605,7 @@ let functor_parameter sub : functor_parameter -> Parsetree.functor_parameter =
   | Unit -> Unit
   | Named (_, name, mtype) -> Named (name, sub.module_type sub mtype)
 
-let module_type sub mty =
+let module_type (sub : mapper) mty =
   let loc = sub.location sub mty.mty_loc in
   let attrs = sub.attributes sub mty.mty_attributes in
   let desc = match mty.mty_desc with
@@ -633,7 +633,7 @@ let with_constraint sub (_path, lid, cstr) =
   | Twith_modsubst (_path, lid2) ->
       Pwith_modsubst (map_loc sub lid, map_loc sub lid2)
 
-let module_expr sub mexpr =
+let module_expr (sub : mapper) mexpr =
   let loc = sub.location sub mexpr.mod_loc in
   let attrs = sub.attributes sub mexpr.mod_attributes in
   match mexpr.mod_desc with
@@ -882,10 +882,10 @@ let default_mapper =
     object_field = object_field ;
   }
 
-let untype_structure ?(mapper=default_mapper) structure =
+let untype_structure ?(mapper : mapper = default_mapper) structure =
   mapper.structure mapper structure
 
-let untype_signature ?(mapper=default_mapper) signature =
+let untype_signature ?(mapper : mapper = default_mapper) signature =
   mapper.signature mapper signature
 
 let untype_expression ?(mapper=default_mapper) expression =