Merge branch 'master' into merge_tags_record

src/exp.ml

@@ -1043,82 +1043,89 @@ and of_module_expr
   let { mod_desc; mod_env; mod_loc; mod_type = local_module_type; _ } = module_expr in
   set_env mod_env (
   set_loc mod_loc (
-  match mod_desc with
-  | Tmod_ident (path, _) ->
-    MixedPath.of_path false path >>= fun mixed_path ->
-    let default_result = return (Variable (mixed_path, [])) in
-    let* is_first_class =
-      IsFirstClassModule.is_module_typ_first_class
-        local_module_type (Some path) in
-    let local_module_type_path =
-      match is_first_class with
-      | Found local_module_type_path -> Some local_module_type_path
-      | Not_found _ -> None in
-    begin match module_type with
-    | None -> default_result
+  let* is_local_module_typ_first_class =
+    let path =
+      match mod_desc with
+      | Tmod_ident (path, _) -> Some path
+      | _ -> None in
+    IsFirstClassModule.is_module_typ_first_class local_module_type path in
+  let* is_module_typ_first_class =
+    match module_type with
+    | None -> return None
     | Some module_type ->
       let* is_first_class =
         IsFirstClassModule.is_module_typ_first_class module_type None in
-      begin match is_first_class with
-      | Found module_type_path ->
-        ModuleTypParams.get_module_typ_typ_params_arity module_type
-          >>= fun module_typ_params_arity ->
-        let* are_module_paths_similar =
-          match local_module_type_path with
-          | None -> return false
-          | Some local_module_type_path ->
-            let* comparison =
-              PathName.compare_paths local_module_type_path module_type_path in
-              return (comparison = 0) in
-        if are_module_paths_similar then
-          return (Variable (mixed_path, []))
-        else
-          let* values = ModuleTypValues.get typ_vars module_type in
-          let mixed_path_of_value_or_typ (name : Name.t)
-            : MixedPath.t Monad.t =
-            match local_module_type_path with
-            | Some local_module_type_path ->
-              let* base = PathName.of_path_with_convert false path in
-              let* field =
-                PathName.of_path_and_name_with_convert
-                  local_module_type_path
-                  name in
-              return (MixedPath.Access (base, [field]))
-            | None ->
-              let* path_name =
-                PathName.of_path_and_name_with_convert path name in
-              return (MixedPath.PathName path_name) in
-          build_module
-            module_typ_params_arity
-            values
-            module_type_path
-            mixed_path_of_value_or_typ
-      | Not_found _ -> default_result
-      end
+      return (Some (is_first_class, module_type)) in
+  (* We consider casts to a first-class module of a different kind, either from
+     another first-class module or from a plain module. *)
+  let get_is_cast_needed module_type_path =
+    match is_local_module_typ_first_class with
+    | Found local_module_type_path ->
+      let* comparison =
+        PathName.compare_paths local_module_type_path module_type_path in
+      return (comparison <> 0)
+    | _ -> return true in
+  let cast_path path module_type module_type_path =
+    let* values = ModuleTypValues.get typ_vars module_type in
+    let* module_typ_params_arity =
+      ModuleTypParams.get_module_typ_typ_params_arity module_type in
+    let mixed_path_of_value_or_typ (name : Name.t)
+      : MixedPath.t Monad.t =
+      match is_local_module_typ_first_class with
+      | Found local_module_type_path ->
+        let* base = PathName.of_path_with_convert false path in
+        let* field =
+          PathName.of_path_and_name_with_convert
+            local_module_type_path
+            name in
+        return (MixedPath.Access (base, [field]))
+      | _ ->
+        let* path_name =
+          PathName.of_path_and_name_with_convert path name in
+        return (MixedPath.PathName path_name) in
+    build_module
+      module_typ_params_arity
+      values
+      module_type_path
+      mixed_path_of_value_or_typ in
+  match mod_desc with
+  | Tmod_ident (path, _) ->
+    let* mixed_path = MixedPath.of_path false path in
+    let default_result = return (Variable (mixed_path, [])) in
+    begin match is_module_typ_first_class with
+    | Some (Found module_type_path, module_type) ->
+      let* is_cast_needed = get_is_cast_needed module_type_path in
+      if not is_cast_needed then
+        default_result
+      else
+        cast_path path module_type module_type_path
+    | _ -> default_result
     end
   | Tmod_structure structure ->
-    let module_type =
-      match module_type with
-      | Some module_type -> module_type
-      | None -> local_module_type in
-    let* is_first_class =
-      IsFirstClassModule.is_module_typ_first_class module_type None in
-    begin match is_first_class with
-    | IsFirstClassModule.Found signature_path ->
+    begin match is_module_typ_first_class with
+    | Some (Found signature_path, module_type) ->
       of_structure
         typ_vars
         signature_path
         module_type
         structure.str_items
         structure.str_final_env
-    | IsFirstClassModule.Not_found reason ->
+    | Some (IsFirstClassModule.Not_found reason, _) ->
       error_message
         (Error "first_class_module_value_of_unknown_signature")
         Module
         (
           "The signature name of this module could not be found\n\n" ^
           reason
         )
+    | None ->
+      error_message
+        (Error "no_expected_module_type_found")
+        Unexpected
+        (
+          "No module type was found for this structure.\n" ^
+          "Try to add a module type annotation."
+        )
     end
   | Tmod_functor (parameter, e) ->
     let* e = of_module_expr typ_vars e None in
@@ -1137,15 +1144,28 @@ and of_module_expr
       match e1_mod_type with
       | Mty_functor (Named (_, module_typ_arg), _) -> Some module_typ_arg
       | _ -> None in
-    of_module_expr typ_vars e1 None >>= fun e1 ->
+    let* e1 = of_module_expr typ_vars e1 None in
     let* es =
       match e1_mod_type with
       | Mty_functor (Unit, _) -> return []
       | _ ->
         let* e2 =
           of_module_expr typ_vars e2 expected_module_typ_for_e2 in
         return [Some e2] in
-    return (Apply (e1, es))
+    let application = Apply (e1, es) in
+    begin match is_module_typ_first_class with
+    | Some (Found module_type_path, module_type) ->
+      let* is_cast_needed = get_is_cast_needed module_type_path in
+      if not is_cast_needed then
+        return application
+      else
+        let ident = Ident.create_local "functor_result" in
+        let* name = Name.of_ident false ident in
+        let path = Path.Pident ident in
+        let* casted_result = cast_path path module_type module_type_path in
+        return (LetVar (None, name, [], application, casted_result))
+    | _ -> return application
+    end
   | Tmod_constraint (module_expr, mod_type, _, _) ->
     let module_type =
       match module_type with

src/structure.ml

@@ -249,6 +249,15 @@ let typ_definitions_of_typ_extension (typ_extension : extension_constructor)
     List.map (fun typ_definition -> TypeDefinition typ_definition)
   )
 
+let rec kind_of_signature (module_typ : Typedtree.module_type) : string =
+  match module_typ.mty_desc with
+  | Tmty_alias _ -> "alias"
+  | Tmty_ident _ -> "ident"
+  | Tmty_signature _ -> "signature"
+  | Tmty_functor _ -> "functor"
+  | Tmty_with (module_typ, _) -> kind_of_signature module_typ
+  | Tmty_typeof _ -> "typeof"
+
 (** Import an OCaml structure. *)
 let rec of_structure (structure : structure) : t list Monad.t =
   let get_include_items
@@ -363,18 +372,19 @@ let rec of_structure (structure : structure) : t list Monad.t =
         (Error "abstract_module_type")
         NotSupported
         "Abstract module types not handled."
-    | Tstr_modtype { mtd_id; mtd_type = Some { mty_desc; _ }; _ } ->
+    | Tstr_modtype { mtd_id; mtd_type = Some module_typ; _ } ->
       let* name = Name.of_ident false mtd_id in
       begin
-        match mty_desc with
+        match module_typ.mty_desc with
         | Tmty_signature signature ->
           Signature.of_signature signature >>= fun signature ->
           return [Signature (name, signature)]
         | _ ->
+          let signature_kind = kind_of_signature module_typ in
           error_message
             (Error "unhandled_module_type")
             NotSupported
-            "This kind of signature is not handled."
+            ("This kind of signature (" ^ signature_kind ^ ") is not handled.")
       end
     | Tstr_primitive { val_id; val_val = { val_type; _ }; _ } ->
       let* name = Name.of_ident true val_id in
@@ -501,7 +511,12 @@ and of_module_expr
       return (ModuleSynonym (name, reference))
     end
   | Tmod_apply _ ->
-      let* module_exp = Exp.of_module_expr Name.Map.empty module_expr None in
+      let module_type_annotation =
+        match module_type_annotation with
+        | None -> None
+        | Some module_type_annotation -> Some module_type_annotation.mty_type in
+      let* module_exp =
+        Exp.of_module_expr Name.Map.empty module_expr module_type_annotation in
       return (ModuleExpression (name, module_typ, module_exp))
   | Tmod_functor (parameter, module_expr) ->
     let* functor_parameters =

tests/functor_application.ml

@@ -52,3 +52,16 @@ module GenFun () : Target = struct
 end
 
 module AppliedGenFun : Target = GenFun ()
+
+module type LargeTarget = sig
+  include Target
+  val z : t
+end
+
+module LargeF (X : Source) : LargeTarget = struct
+  type t = X.t
+  let y = X.x
+  let z = y
+end
+
+module CastedLarge : Target = LargeF (M)

tests/functor_application.v

@@ -131,3 +131,41 @@ End GenFun.
 Definition GenFun : Target (t := _) := GenFun.module.
 
 Definition AppliedGenFun : Target (t := _) := GenFun.
+
+Module LargeTarget.
+  Record signature {t : Set} : Set := {
+    t := t;
+    y : t;
+    z : t;
+  }.
+End LargeTarget.
+Definition LargeTarget := @LargeTarget.signature.
+Arguments LargeTarget {_}.
+
+Module LargeF.
+  Class FArgs {X_t : Set} := {
+    X : Source (t := X_t);
+  }.
+  Arguments Build_FArgs {_}.
+
+  Definition t `{FArgs} : Set := X.(Source.t).
+
+  Definition y `{FArgs} : X.(Source.t) := X.(Source.x).
+
+  Definition z `{FArgs} : X.(Source.t) := y.
+
+  Definition functor `{FArgs} :=
+    {|
+      LargeTarget.y := y;
+      LargeTarget.z := z
+    |}.
+End LargeF.
+Definition LargeF {X_t : Set} (X : Source (t := X_t)) : LargeTarget (t := _) :=
+  let '_ := LargeF.Build_FArgs X in
+  LargeF.functor.
+
+Definition CastedLarge : Target (t := _) :=
+  let functor_result := LargeF M in
+  {|
+    Target.y := functor_result.(LargeTarget.y)
+  |}.