Skip to content

Commit

Permalink
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Add Typemod.type_implicit_instance
Browse files Browse the repository at this point in the history
Do the same work as type_package but directly packing a
Typedtree.module_expr rather than a Parsetree.module_expr.
let-def authored and Kakadu committed Jan 17, 2016
1 parent f8ed4e9 commit 1e6e8de
Showing 4 changed files with 22 additions and 15 deletions.
5 changes: 5 additions & 0 deletions typing/path.ml
Original file line number Diff line number Diff line change
@@ -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)
2 changes: 2 additions & 0 deletions typing/path.mli
Original file line number Diff line number Diff line change
@@ -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
17 changes: 11 additions & 6 deletions typing/typeimplicit.ml
Original file line number Diff line number Diff line change
@@ -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 = [];
13 changes: 4 additions & 9 deletions typing/typemod.ml
Original file line number Diff line number Diff line change
@@ -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


0 comments on commit 1e6e8de

Please sign in to comment.