From 1e6e8de7431eb5af21270daab5bd4e8f9290e416 Mon Sep 17 00:00:00 2001
From: Frederic Bour <frederic.bour@lakaban.net>
Date: Fri, 2 May 2014 11:34:38 +0100
Subject: [PATCH] Add Typemod.type_implicit_instance

Do the same work as type_package but directly packing a
Typedtree.module_expr rather than a Parsetree.module_expr.
---
 typing/path.ml         |  5 +++++
 typing/path.mli        |  2 ++
 typing/typeimplicit.ml | 17 +++++++++++------
 typing/typemod.ml      | 13 ++++---------
 4 files changed, 22 insertions(+), 15 deletions(-)

diff --git a/typing/path.ml b/typing/path.ml
index 260fc0731c..bc486259d1 100644
--- a/typing/path.ml
+++ b/typing/path.ml
@@ -52,3 +52,8 @@ let rec last = function
   | Pident id -> Ident.name id
   | Pdot(_, s, _) -> s
   | Papply(_, p) -> last p
+
+let rec to_longident = function
+  | Pident id -> Longident.Lident (Ident.name id)
+  | Pdot(p, s, _) -> Longident.Ldot (to_longident p, s)
+  | Papply (p1, p2) -> Longident.Lapply (to_longident p1, to_longident p2)
diff --git a/typing/path.mli b/typing/path.mli
index c3f84130db..8f1ef05d2f 100644
--- a/typing/path.mli
+++ b/typing/path.mli
@@ -28,3 +28,5 @@ val name: ?paren:(string -> bool) -> t -> string
 val head: t -> Ident.t
 
 val last: t -> string
+
+val to_longident: t -> Longident.t
diff --git a/typing/typeimplicit.ml b/typing/typeimplicit.ml
index 29972d5ca8..3f350bce8e 100644
--- a/typing/typeimplicit.ml
+++ b/typing/typeimplicit.ml
@@ -5,8 +5,8 @@ open Typedtree
 
 (* Forward declaration, to be filled in by Typemod.type_package *)
 
-let type_package
-  : (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list ->
+let type_implicit_instance
+  : (Env.t -> Typedtree.module_expr -> Path.t -> Longident.t list ->
      type_expr list -> Typedtree.module_expr * type_expr list) ref
   = ref (fun _ -> assert false)
 
@@ -160,10 +160,15 @@ let pack_implicit inst path =
         implicit_env  = env;
         implicit_loc  = loc } = inst in
   let md = Env.find_module path env in
-  let md = {md with md_type = (Mty_alias path)} in
-  let _, env' = Env.enter_module_declaration "%P" md env in
-  let pmd = Ast_helper.(Mod.ident (Convenience.lid "%P")) in
-  let (modl, tl') = !type_package env' pmd p nl tl in
+  let lident = Location.mkloc (Path.to_longident path) loc in
+  let modl = {
+    mod_desc = Tmod_ident (path, lident);
+    mod_loc = loc;
+    mod_type = md.md_type;
+    mod_env = env;
+    mod_attributes = [];
+  } in
+  let (modl, tl') = !type_implicit_instance env modl p nl tl in
   {
     exp_desc = Texp_pack modl;
     exp_loc = loc; exp_extra = [];
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 3d661f80a7..2c27183c1f 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -1677,16 +1677,11 @@ let type_package env m p nl tl =
     nl tl';
   (wrap_constraint env modl mty Tmodtype_implicit, tl')
 
-let type_implicit_instance env m p nl tl =
-  (* Same as Pexp_letmodule *)
-  (* remember original level *)
+let type_implicit_instance env modl p nl tl =
+  (* Same as type_package *)
   let lv = Ctype.get_current_level () in
   Ctype.begin_def ();
   Ident.set_current_time lv;
-  let context = Typetexp.narrow () in
-  let modl = type_module env m in
-  Ctype.init_def(Ident.current_time());
-  Typetexp.widen context;
   let (mp, env) =
     match modl.mod_desc with
       Tmod_ident (mp,_) -> (mp, env)
@@ -1712,7 +1707,7 @@ let type_implicit_instance env m p nl tl =
     (fun n ty ->
       try Ctype.unify env ty (Ctype.newvar ())
       with Ctype.Unify _ ->
-        raise (Error(m.pmod_loc, env, Scoping_pack (n,ty))))
+        raise (Error(modl.mod_loc, env, Scoping_pack (n,ty))))
     nl tl';
   (wrap_constraint env modl mty Tmodtype_implicit, tl')
 
@@ -1723,7 +1718,7 @@ let () =
   Typetexp.transl_modtype := transl_modtype;
   Typecore.type_open := type_open_ ?toplevel:None;
   Typecore.type_package := type_package;
-  Typeimplicit.type_package := type_package;
+  Typeimplicit.type_implicit_instance := type_implicit_instance;
   type_module_type_of_fwd := type_module_type_of