Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

a better representation for modules with no name (#8908)

master
Thomas Refis 2019-10-09 14:15:37 +01:00 committed by GitHub
parent dbd717e817
commit 8e928caea7
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
52 changed files with 6229 additions and 5702 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Changes
View File

@ -15,6 +15,8 @@ Working version
use String_val as a char* instead of const char*
(Kate Deplaix)
- #6662, #8908: Add "module _ = X" syntax
(Thomas Refis, review by Gabriel Radanne)
### Internal/compiler-libs changes:
@ -70,6 +72,11 @@ Working version
skipped lines/bytes into account
(Gabriel Scherer, review by Sébastien Hinderer)
- #8908: Use an option instead of a string for module names ("_" becomes None),
and a dedicated type for functor parameters: "()" maps to "Unit" (instead of
"*").
(Thomas Refis, review by Gabriel Radanne)
- #8928: Move contains_calls and num_stack_slots from Proc to Mach.fundecl
(Greta Yorsh, review by Florian Angeletti and Vincent Laviron)

10180
boot/menhir/parser.ml
View File

File diff suppressed because one or more lines are too long

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

11
lambda/translcore.ml
View File

@ -84,7 +84,7 @@ let extract_float = function
type binding =
| Bind_value of value_binding list
| Bind_module of Ident.t * string loc * module_presence * module_expr
| Bind_module of Ident.t * string option loc * module_presence * module_expr
let rec push_defaults loc bindings cases partial =
match cases with
@ -105,7 +105,7 @@ let rec push_defaults loc bindings cases partial =
| [{c_lhs=pat; c_guard=None;
c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}];
exp_desc = Texp_letmodule
(id, name, pres, mexpr,
(Some id, name, pres, mexpr,
({exp_desc = Texp_function _} as e2))}}] ->
push_defaults loc (Bind_module (id, name, pres, mexpr) :: bindings)
[{c_lhs=pat;c_guard=None;c_rhs=e2}]
@ -118,7 +118,7 @@ let rec push_defaults loc bindings cases partial =
match binds with
| Bind_value binds -> Texp_let(Nonrecursive, binds, exp)
| Bind_module (id, name, pres, mexpr) ->
Texp_letmodule (id, name, pres, mexpr, exp)})
Texp_letmodule (Some id, name, pres, mexpr, exp)})
case.c_rhs bindings
in
[{case with c_rhs=exp}]
@ -465,7 +465,10 @@ and transl_exp0 e =
(Lvar cpy) var expr, rem))
modifs
(Lvar cpy))
| Texp_letmodule(id, loc, Mp_present, modl, body) ->
| Texp_letmodule(None, loc, Mp_present, modl, body) ->
let lam = !transl_module Tcoerce_none None modl in
Lsequence(Lprim(Pignore, [lam], loc.loc), transl_exp body)
| Texp_letmodule(Some id, loc, Mp_present, modl, body) ->
let defining_expr =
Levent (!transl_module Tcoerce_none None modl, {
lev_loc = loc.loc;

214
lambda/translmod.ml
View File

@ -32,13 +32,20 @@ type unsafe_component =
| Unsafe_non_function
| Unsafe_typext
type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t }
type unsafe_info =
| Unsafe of { reason:unsafe_component; loc:Location.t; subid:Ident.t }
| Unnamed
type error =
Circular_dependency of (Ident.t * unsafe_info) list
| Conflicting_inline_attributes
exception Error of Location.t * error
let cons_opt x_opt xs =
match x_opt with
| None -> xs
| Some x -> x :: xs
(* Keep track of the root path (from the root of the namespace to the
currently compiled module expression). Useful for naming extensions. *)
@ -218,12 +225,14 @@ let init_shape id modl =
match Mtype.scrape env mty with
Mty_ident _
| Mty_alias _ ->
raise (Initialization_failure {reason=Unsafe_module_binding;loc;subid})
raise (Initialization_failure
(Unsafe {reason=Unsafe_module_binding;loc;subid}))
| Mty_signature sg ->
Const_block(0, [Const_block(0, init_shape_struct env sg)])
| Mty_functor _ ->
(* can we do better? *)
raise (Initialization_failure {reason=Unsafe_functor;loc;subid})
raise (Initialization_failure
(Unsafe {reason=Unsafe_functor;loc;subid}))
and init_shape_struct env sg =
match sg with
[] -> []
@ -235,7 +244,9 @@ let init_shape id modl =
| {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t ->
Const_pointer 1 (* camlinternalMod.Lazy *)
| _ ->
let not_a_function = {reason=Unsafe_non_function; loc; subid } in
let not_a_function =
Unsafe {reason=Unsafe_non_function; loc; subid }
in
raise (Initialization_failure not_a_function) in
init_v :: init_shape_struct env rem
| Sig_value(_, {val_kind=Val_prim _}, _) :: rem ->
@ -245,7 +256,7 @@ let init_shape id modl =
| Sig_type(id, tdecl, _, _) :: rem ->
init_shape_struct (Env.add_type ~check:false id tdecl env) rem
| Sig_typext (subid, {ext_loc=loc},_,_) :: _ ->
raise (Initialization_failure {reason=Unsafe_typext; loc; subid})
raise (Initialization_failure (Unsafe {reason=Unsafe_typext;loc;subid}))
| Sig_module(id, Mp_present, md, _, _) :: rem ->
init_shape_mod id md.md_loc env md.md_type ::
init_shape_struct (Env.add_module_declaration ~check:false
@ -274,9 +285,18 @@ type binding_status =
| Inprogress of int option (** parent node *)
| Defined
type id_or_ignore_loc =
| Id of Ident.t
| Ignore_loc of Location.t
let extract_unsafe_cycle id status init cycle_start =
let info i = match init.(i) with
| Result.Error r -> id.(i), r
| Result.Error r ->
begin match id.(i) with
| Id id -> id, r
| Ignore_loc _ ->
assert false (* Can't refer to something without a name. *)
end
| Ok _ -> assert false in
let rec collect stop l i = match status.(i) with
| Inprogress None | Undefined | Defined -> assert false
@ -310,7 +330,9 @@ let reorder_rec_bindings bindings =
if is_unsafe i then begin
status.(i) <- Inprogress parent;
for j = 0 to num_bindings - 1 do
if Ident.Set.mem id.(j) fv.(i) then emit_binding (Some i) j
match id.(j) with
| Id id when Ident.Set.mem id fv.(i) -> emit_binding (Some i) j
| _ -> ()
done
end;
res := (id.(i), init_res i, rhs.(i)) :: !res;
@ -329,9 +351,10 @@ let eval_rec_bindings bindings cont =
let rec bind_inits = function
[] ->
bind_strict bindings
| (_id, None, _rhs) :: rem ->
| (Ignore_loc _, _, _) :: rem
| (_, None, _) :: rem ->
bind_inits rem
| (id, Some(loc, shape), _rhs) :: rem ->
| (Id id, Some(loc, shape), _rhs) :: rem ->
Llet(Strict, Pgenval, id,
Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
@ -343,16 +366,19 @@ let eval_rec_bindings bindings cont =
and bind_strict = function
[] ->
patch_forwards bindings
| (id, None, rhs) :: rem ->
| (Ignore_loc loc, None, rhs) :: rem ->
Lsequence(Lprim(Pignore, [rhs], loc), bind_strict rem)
| (Id id, None, rhs) :: rem ->
Llet(Strict, Pgenval, id, rhs, bind_strict rem)
| (_id, Some _, _rhs) :: rem ->
bind_strict rem
and patch_forwards = function
[] ->
cont
| (_id, None, _rhs) :: rem ->
| (Ignore_loc _, _, _rhs) :: rem
| (_, None, _rhs) :: rem ->
patch_forwards rem
| (id, Some(_loc, shape), rhs) :: rem ->
| (Id id, Some(_loc, shape), rhs) :: rem ->
Lsequence(Lapply{ap_should_be_tailcall=false;
ap_loc=Location.none;
ap_func=mod_prim "update_mod";
@ -367,8 +393,13 @@ let compile_recmodule compile_rhs bindings cont =
eval_rec_bindings
(reorder_rec_bindings
(List.map
(fun {mb_id=id; mb_expr=modl; mb_loc=loc; _} ->
(id, modl.mod_loc, init_shape id modl, compile_rhs id modl loc))
(fun {mb_id=id; mb_name; mb_expr=modl; mb_loc=loc; _} ->
let id_or_ignore_loc, shape =
match id with
| None -> Ignore_loc mb_name.loc, Result.Error Unnamed
| Some id -> Id id, init_shape id modl
in
(id_or_ignore_loc, modl.mod_loc, shape, compile_rhs id modl loc))
bindings))
cont
@ -397,7 +428,7 @@ let merge_functors mexp coercion root_path =
let rec merge mexp coercion path acc inline_attribute =
let finished = acc, mexp, path, coercion, inline_attribute in
match mexp.mod_desc with
| Tmod_functor (param, _, _, body) ->
| Tmod_functor (param, body) ->
let inline_attribute' =
Translattribute.get_inline_attribute mexp.mod_attributes
in
@ -409,7 +440,14 @@ let merge_functors mexp coercion root_path =
| _ -> fatal_error "Translmod.merge_functors: bad coercion"
in
let loc = mexp.mod_loc in
let path = functor_path path param in
let path, param =
match param with
| Unit -> None, Ident.create_local "*"
| Named (None, _, _) ->
let id = Ident.create_local "_" in
functor_path path id, id
| Named (Some id, _, _) -> functor_path path id, id
in
let inline_attribute =
merge_inline_attributes inline_attribute inline_attribute' loc
in
@ -582,7 +620,8 @@ and transl_structure loc fields cc rootpath final_env = function
let id = mb.mb_id in
(* Translate module first *)
let module_body =
transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr
transl_module Tcoerce_none (Option.bind id (field_path rootpath))
mb.mb_expr
in
let module_body =
Translattribute.add_inline_attribute module_body mb.mb_loc
@ -590,42 +629,48 @@ and transl_structure loc fields cc rootpath final_env = function
in
(* Translate remainder second *)
let body, size =
transl_structure loc (id :: fields) cc rootpath final_env rem
transl_structure loc (cons_opt id fields) cc rootpath final_env rem
in
let module_body =
Levent (module_body, {
lev_loc = mb.mb_loc;
lev_kind = Lev_module_definition id;
lev_repr = None;
lev_env = Env.empty;
})
in
Llet(pure_module mb.mb_expr, Pgenval, id,
module_body,
body), size
begin match id with
| None ->
Lsequence (Lprim(Pignore, [module_body], mb.mb_name.loc), body),
size
| Some id ->
let module_body =
Levent (module_body, {
lev_loc = mb.mb_loc;
lev_kind = Lev_module_definition id;
lev_repr = None;
lev_env = Env.empty;
})
in
Llet(pure_module mb.mb_expr, Pgenval, id, module_body, body), size
end
| Tstr_module {mb_presence=Mp_absent} ->
transl_structure loc fields cc rootpath final_env rem
| Tstr_recmodule bindings ->
let ext_fields =
List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields
List.rev_append (List.filter_map (fun mb -> mb.mb_id) bindings)
fields
in
let body, size =
transl_structure loc ext_fields cc rootpath final_env rem
in
let lam =
compile_recmodule
(fun id modl loc ->
let module_body =
transl_module Tcoerce_none (field_path rootpath id) modl
in
Levent (module_body, {
lev_loc = loc;
lev_kind = Lev_module_definition id;
lev_repr = None;
lev_env = Env.empty;
}))
bindings
body
compile_recmodule (fun id modl loc ->
match id with
| None -> transl_module Tcoerce_none None modl
| Some id ->
let module_body =
transl_module Tcoerce_none (field_path rootpath id) modl
in
Levent (module_body, {
lev_loc = loc;
lev_kind = Lev_module_definition id;
lev_repr = None;
lev_env = Env.empty;
})
) bindings body
in
lam, size
| Tstr_class cl_list ->
@ -768,10 +813,12 @@ let rec defined_idents = function
List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
@ defined_idents rem
| Tstr_exception ext -> ext.tyexn_constructor.ext_id :: defined_idents rem
| Tstr_module {mb_id; mb_presence=Mp_present} -> mb_id :: defined_idents rem
| Tstr_module {mb_presence=Mp_absent} -> defined_idents rem
| Tstr_module {mb_id = Some id; mb_presence=Mp_present} ->
id :: defined_idents rem
| Tstr_module ({mb_id = None}
|{mb_presence=Mp_absent}) -> defined_idents rem
| Tstr_recmodule decls ->
List.map (fun mb -> mb.mb_id) decls @ defined_idents rem
List.filter_map (fun mb -> mb.mb_id) decls @ defined_idents rem
| Tstr_modtype _ -> defined_idents rem
| Tstr_open od ->
bound_value_identifiers od.open_bound_items @ defined_idents rem
@ -833,7 +880,7 @@ and all_idents = function
@ all_idents rem
| Tstr_exception ext -> ext.tyexn_constructor.ext_id :: all_idents rem
| Tstr_recmodule decls ->
List.map (fun mb -> mb.mb_id) decls @ all_idents rem
List.filter_map (fun mb -> mb.mb_id) decls @ all_idents rem
| Tstr_modtype _ -> all_idents rem
| Tstr_open od ->
let rest = all_idents rem in
@ -858,15 +905,19 @@ and all_idents = function
bound_value_identifiers incl.incl_type @ all_idents rem
| Tstr_module
{mb_id;mb_presence=Mp_present;mb_expr={mod_desc = Tmod_structure str}}
{ mb_id = Some id;
mb_presence=Mp_present;
mb_expr={mod_desc = Tmod_structure str} }
| Tstr_module
{mb_id;mb_presence=Mp_present;
mb_expr=
{mod_desc =
Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} ->
mb_id :: all_idents str.str_items @ all_idents rem
| Tstr_module {mb_id;mb_presence=Mp_present} -> mb_id :: all_idents rem
| Tstr_module {mb_presence=Mp_absent} -> all_idents rem
{ mb_id = Some id;
mb_presence = Mp_present;
mb_expr =
{mod_desc =
Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} ->
id :: all_idents str.str_items @ all_idents rem
| Tstr_module {mb_id = Some id;mb_presence=Mp_present} ->
id :: all_idents rem
| Tstr_module ({mb_id = None} | {mb_presence=Mp_absent}) -> all_idents rem
| Tstr_attribute _ -> all_idents rem
@ -951,7 +1002,17 @@ let transl_store_structure glob map prims aliases str =
store_ident ext.tyexn_constructor.ext_loc id),
transl_store rootpath
(add_ident false id subst) cont rem)
| Tstr_module{mb_id=id;mb_loc=loc;mb_presence=Mp_present;
| Tstr_module
{mb_id=None; mb_name; mb_presence=Mp_present; mb_expr=modl;
mb_loc=loc; mb_attributes} ->
let lam =
Translattribute.add_inline_attribute
(transl_module Tcoerce_none None modl)
loc mb_attributes
in
Lsequence(Lprim(Pignore, [lam], mb_name.loc),
transl_store rootpath subst cont rem)
| Tstr_module{mb_id=Some id;mb_loc=loc;mb_presence=Mp_present;
mb_expr={mod_desc = Tmod_structure str} as mexp;
mb_attributes} ->
List.iter (Translattribute.check_attribute_on_module mexp)
@ -973,7 +1034,7 @@ let transl_store_structure glob map prims aliases str =
(add_ident true id subst)
cont rem)))
| Tstr_module{
mb_id=id;mb_loc=loc;mb_presence=Mp_present;
mb_id=Some id;mb_loc=loc;mb_presence=Mp_present;
mb_expr= {
mod_desc = Tmod_constraint (
{mod_desc = Tmod_structure str} as mexp, _, _,
@ -1001,7 +1062,7 @@ let transl_store_structure glob map prims aliases str =
(add_ident true id subst)
cont rem)))
| Tstr_module
{mb_id=id; mb_presence=Mp_present; mb_expr=modl;
{mb_id=Some id; mb_presence=Mp_present; mb_expr=modl;
mb_loc=loc; mb_attributes} ->
let lam =
Translattribute.add_inline_attribute
@ -1021,12 +1082,12 @@ let transl_store_structure glob map prims aliases str =
| Tstr_module {mb_presence=Mp_absent} ->
transl_store rootpath subst cont rem
| Tstr_recmodule bindings ->
let ids = List.map (fun mb -> mb.mb_id) bindings in
let ids = List.filter_map (fun mb -> mb.mb_id) bindings in
compile_recmodule
(fun id modl _loc ->
Lambda.subst no_env_update subst
(transl_module Tcoerce_none
(field_path rootpath id) modl))
(Option.bind id (field_path rootpath)) modl))
bindings
(Lsequence(store_idents Location.none ids,
transl_store rootpath (add_idents true ids subst)
@ -1349,16 +1410,19 @@ let transl_toplevel_item item =
set_toplevel_unique_name ext.tyexn_constructor.ext_id;
toploop_setvalue ext.tyexn_constructor.ext_id
(transl_extension_constructor item.str_env None ext.tyexn_constructor)
| Tstr_module {mb_id=id; mb_presence=Mp_present; mb_expr=modl} ->
| Tstr_module {mb_id=None; mb_presence=Mp_present; mb_expr=modl} ->
transl_module Tcoerce_none None modl
| Tstr_module {mb_id=Some id; mb_presence=Mp_present; mb_expr=modl} ->
(* we need to use the unique name for the module because of issues
with "open" (PR#8133) *)
set_toplevel_unique_name id;
let lam = transl_module Tcoerce_none (Some(Pident id)) modl in
toploop_setvalue id lam
| Tstr_recmodule bindings ->
let idents = List.map (fun mb -> mb.mb_id) bindings in
let idents = List.filter_map (fun mb -> mb.mb_id) bindings in
compile_recmodule
(fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl)
(fun id modl _loc ->
transl_module Tcoerce_none (Option.map (fun i -> Pident i) id) modl)
bindings
(make_sequence toploop_setvalue_id idents)
| Tstr_class cl_list ->
@ -1523,16 +1587,20 @@ let print_cycle ppf cycle =
(Ident.name @@ fst @@ List.hd cycle)
(* we repeat the first element to make the cycle more apparent *)
let explanation_submsg (id, {reason;loc;subid}) =
let print fmt =
let printer = Format.dprintf fmt (Ident.name id) (Ident.name subid) in
Location.mkloc printer loc in
match reason with
| Unsafe_module_binding -> print "Module %s defines an unsafe module, %s ."
| Unsafe_functor -> print "Module %s defines an unsafe functor, %s ."
| Unsafe_typext ->
print "Module %s defines an unsafe extension constructor, %s ."
| Unsafe_non_function -> print "Module %s defines an unsafe value, %s ."
let explanation_submsg (id, unsafe_info) =
match unsafe_info with
| Unnamed -> assert false (* can't be part of a cycle. *)
| Unsafe {reason;loc;subid} ->
let print fmt =
let printer = Format.dprintf fmt (Ident.name id) (Ident.name subid) in
Location.mkloc printer loc in
match reason with
| Unsafe_module_binding ->
print "Module %s defines an unsafe module, %s ."
| Unsafe_functor -> print "Module %s defines an unsafe functor, %s ."
| Unsafe_typext ->
print "Module %s defines an unsafe extension constructor, %s ."
| Unsafe_non_function -> print "Module %s defines an unsafe value, %s ."
let report_error loc = function
| Circular_dependency cycle ->

4
lambda/translmod.mli
View File

@ -48,7 +48,9 @@ type unsafe_component =
| Unsafe_non_function
| Unsafe_typext
type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t }
type unsafe_info =
| Unsafe of { reason:unsafe_component; loc:Location.t; subid:Ident.t }
| Unnamed
type error =
Circular_dependency of (Ident.t * unsafe_info) list

118
ocamldoc/odoc_ast.ml
View File

@ -60,12 +60,15 @@ module Typedtree_search =
let add_to_hashes table table_values tt =
match tt with
| Typedtree.Tstr_module mb ->
Hashtbl.add table (M (Name.from_ident mb.mb_id)) tt
Option.iter (fun id ->
Hashtbl.add table (M (Name.from_ident id)) tt) mb.mb_id
| Typedtree.Tstr_recmodule mods ->
List.iter
(fun mb ->
Hashtbl.add table (M (Name.from_ident mb.mb_id))
(Typedtree.Tstr_module mb)
Option.iter (fun id ->
Hashtbl.add table (M (Name.from_ident id))
(Typedtree.Tstr_module mb)
) mb.mb_id
)
mods
| Typedtree.Tstr_modtype mtd ->
@ -1395,15 +1398,18 @@ module Analyser =
in
(0, new_env, [ Element_exception new_ext ])
| Parsetree.Pstr_module {Parsetree.pmb_name=name; pmb_expr=module_expr} ->
| Parsetree.Pstr_module {Parsetree.pmb_name={txt=None}} ->
(0, env, [])
| Parsetree.Pstr_module {Parsetree.pmb_name={txt=Some name}; pmb_expr=module_expr} ->
(
(* of string * module_expr *)
try
let tt_module_expr = Typedtree_search.search_module table name.txt in
let tt_module_expr = Typedtree_search.search_module table name in
let new_module_pre = analyse_module
env
current_module_name
name.txt
name
comment_opt
module_expr
tt_module_expr
@ -1433,7 +1439,7 @@ module Analyser =
(0, new_env2, [ Element_module new_module ])
with
Not_found ->
let complete_name = Name.concat current_module_name name.txt in
let complete_name = Name.concat current_module_name name in
raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
)
@ -1443,26 +1449,29 @@ module Analyser =
let new_env =
List.fold_left
(fun acc_env {Parsetree.pmb_name=name;pmb_expr=mod_exp} ->
let complete_name = Name.concat current_module_name name.txt in
let e = Odoc_env.add_module acc_env complete_name in
let tt_mod_exp =
try Typedtree_search.search_module table name.txt
with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
in
let new_module = analyse_module
e
current_module_name
name.txt
None
mod_exp
tt_mod_exp
in
match new_module.m_type with
Types.Mty_signature s ->
Odoc_env.add_signature e new_module.m_name
~rel: (Name.simple new_module.m_name) s
| _ ->
e
match name.txt with
| None -> acc_env
| Some name ->
let complete_name = Name.concat current_module_name name in
let e = Odoc_env.add_module acc_env complete_name in
let tt_mod_exp =
try Typedtree_search.search_module table name
with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
in
let new_module = analyse_module
e
current_module_name
name
None
mod_exp
tt_mod_exp
in
match new_module.m_type with
Types.Mty_signature s ->
Odoc_env.add_signature e new_module.m_name
~rel: (Name.simple new_module.m_name) s
| _ ->
e
)
env
mods
@ -1470,12 +1479,23 @@ module Analyser =
let rec f ?(first=false) last_pos name_mod_exp_list =
match name_mod_exp_list with
[] -> []
| {Parsetree.pmb_name=name;pmb_expr=mod_exp} :: q ->
let complete_name = Name.concat current_module_name name.txt in
| {Parsetree.pmb_name={txt=None};pmb_expr=mod_exp} :: q ->
let loc_start = mod_exp.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = mod_exp.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
let (_, ele_comments) = (* the comment for the first type was already retrieved *)
if first then
(None, [])
else
get_comments_in_module last_pos loc_start
in
let eles = f loc_end q in
ele_comments @ eles
| {Parsetree.pmb_name={txt=Some name};pmb_expr=mod_exp} :: q ->
let complete_name = Name.concat current_module_name name in
let loc_start = mod_exp.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = mod_exp.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
let tt_mod_exp =
try Typedtree_search.search_module table name.txt
try Typedtree_search.search_module table name
with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
in
let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *)
@ -1487,7 +1507,7 @@ module Analyser =
let new_module = analyse_module
new_env
current_module_name
name.txt
name
com_opt
mod_exp
tt_mod_exp
@ -1709,29 +1729,33 @@ module Analyser =
let elements2 = replace_dummy_included_modules elements included_modules_from_tt in
{ m_base with m_kind = Module_struct elements2 }
| (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2),
Typedtree.Tmod_functor (ident, _, mtyp, tt_module_expr2)) ->
let loc = match pmodule_type with None -> Location.none
| Some pmty -> pmty.Parsetree.pmty_loc in
| (Parsetree.Pmod_functor (param2, p_module_expr2),
Typedtree.Tmod_functor (param, tt_module_expr2)) ->
let loc, mp_name, mp_kind, mp_type =
match param2, param with
| Parsetree.Unit, Typedtree.Unit ->
Location.none, "*", Module_type_struct [], None
| Parsetree.Named (_, pmty), Typedtree.Named (ident, _, mty) ->
let loc = pmty.Parsetree.pmty_loc in
let mp_name = Option.fold ~none:"*" ~some:Name.from_ident ident in
let mp_kind =
Sig.analyse_module_type_kind env current_module_name pmty
mty.mty_type
in
let mp_type = Odoc_env.subst_module_type env mty.mty_type in
loc, mp_name, mp_kind, Some mp_type
| _, _ -> assert false
in
let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
let mp_type_code = get_string_of_file loc_start loc_end in
print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
let mp_name = Name.from_ident ident in
let mp_kind =
match pmodule_type, mtyp with
Some pmty, Some mty ->
Sig.analyse_module_type_kind env current_module_name pmty
mty.mty_type
| _ -> Module_type_struct []
in
let param =
{
mp_name = mp_name ;
mp_type = Option.map
(fun m -> Odoc_env.subst_module_type env m.mty_type) mtyp ;
mp_name ;
mp_type ;
mp_type_code = mp_type_code ;
mp_kind = mp_kind ;
mp_kind ;
}
in
let dummy_complete_name = (*Name.concat "__"*) param.mp_name in

14
ocamldoc/odoc_env.ml
View File

@ -216,15 +216,17 @@ let subst_type env t =
let subst_module_type env t =
let rec iter t =
let open Types in
match t with
Types.Mty_ident p ->
Mty_ident p ->
let new_p = Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in
Types.Mty_ident new_p
| Types.Mty_alias _
| Types.Mty_signature _ ->
Mty_ident new_p
| Mty_alias _
| Mty_signature _ ->
t
| Types.Mty_functor (id, mt1, mt2) ->
Types.Mty_functor (id, Option.map iter mt1, iter mt2)
| Mty_functor (Unit, mt) -> Mty_functor (Unit, iter mt)
| Mty_functor (Named (name, mt1), mt2) ->
Mty_functor (Named (name, iter mt1), iter mt2)
in
iter t

14
ocamldoc/odoc_print.ml
View File

@ -52,18 +52,20 @@ exception Use_code of string
than the "emptied" type.
*)
let simpl_module_type ?code t =
let open Types in
let rec iter t =
match t with
Types.Mty_ident _
| Types.Mty_alias _ -> t
| Types.Mty_signature _ ->
Mty_ident _
| Mty_alias _ -> t
| Mty_signature _ ->
(
match code with
None -> Types.Mty_signature []
None -> Mty_signature []
| Some s -> raise (Use_code s)
)
| Types.Mty_functor (id, mt1, mt2) ->
Types.Mty_functor (id, Option.map iter mt1, iter mt2)
| Mty_functor (Unit, mt) -> Mty_functor (Unit, iter mt)
| Mty_functor (Named (name, mt1), mt2) ->
Mty_functor (Named (name, iter mt1), iter mt2)
in
iter t

151
ocamldoc/odoc_sig.ml
View File

@ -491,10 +491,11 @@ module Analyser =
| [] -> acc
| types -> take_item (Parsetree.Psig_type (rf, types)))
| Parsetree.Psig_modsubst _ -> acc
| Parsetree.Psig_module ({Parsetree.pmd_name=name;
| Parsetree.Psig_module {Parsetree.pmd_name={ txt = None }} -> acc
| Parsetree.Psig_module ({Parsetree.pmd_name={txt = Some name };
pmd_type=module_type} as r)
as m ->
begin match Name.Map.find name.txt erased with
begin match Name.Map.find name erased with
| exception Not_found -> take_item m
| `Removed -> acc
| `Constrained constraints ->
@ -507,9 +508,15 @@ module Analyser =
| Parsetree.Psig_modtype {Parsetree.pmtd_name=name} as m ->
if is_erased name.txt erased then acc else take_item m
| Parsetree.Psig_recmodule mods ->
(match List.filter (fun pmd -> not (is_erased pmd.Parsetree.pmd_name.txt erased)) mods with
| [] -> acc
| mods -> take_item (Parsetree.Psig_recmodule mods)))
(match List.filter
(fun pmd ->
match pmd.Parsetree.pmd_name.txt with
| None -> false
| Some name -> not (is_erased name erased))
mods
with
| [] -> acc
| mods -> take_item (Parsetree.Psig_recmodule mods)))
signature []
(** Analysis of the elements of a class, from the information in the parsetree and in the class
@ -1141,13 +1148,16 @@ module Analyser =
| Parsetree.Psig_modsubst _ -> (* FIXME *)
(0, env, [])
| Parsetree.Psig_module {Parsetree.pmd_name=name; pmd_type=module_type} ->
let complete_name = Name.concat current_module_name name.txt in
| Parsetree.Psig_module {Parsetree.pmd_name={txt=None}} ->
(0, env, [])
| Parsetree.Psig_module {Parsetree.pmd_name={txt=Some name}; pmd_type=module_type} ->
let complete_name = Name.concat current_module_name name in
(* get the module type in the signature by the module name *)
let sig_module_type =
try Signature_search.search_module table name.txt
try Signature_search.search_module table name
with Not_found ->
raise (Failure (Odoc_messages.module_not_found current_module_name name.txt))
raise (Failure (Odoc_messages.module_not_found current_module_name name))
in
let module_kind = analyse_module_kind env complete_name module_type sig_module_type in
let code_intf =
@ -1193,31 +1203,60 @@ module Analyser =
let new_env =
List.fold_left
(fun acc_env {Parsetree.pmd_name={txt=name}} ->
let complete_name = Name.concat current_module_name name in
let e = Odoc_env.add_module acc_env complete_name in
(* get the information for the module in the signature *)
let sig_module_type =
try Signature_search.search_module table name
with Not_found ->
raise (Failure (Odoc_messages.module_not_found current_module_name name))
in
match sig_module_type with
(* FIXME : can this be a Tmty_ident? in this case, we wouldn't have the signature *)
Types.Mty_signature s ->
Odoc_env.add_signature e complete_name ~rel: name s
| _ ->
print_DEBUG "not a Tmty_signature";
e
)
env
decls
match name with
| None -> acc_env
| Some name ->
let complete_name = Name.concat current_module_name name in
let e = Odoc_env.add_module acc_env complete_name in
(* get the information for the module in the signature *)
let sig_module_type =
try Signature_search.search_module table name
with Not_found ->
raise (Failure (Odoc_messages.module_not_found current_module_name name))
in
match sig_module_type with
(* FIXME : can this be a Tmty_ident? in this case, we wouldn't have the signature *)
Types.Mty_signature s ->
Odoc_env.add_signature e complete_name ~rel: name s
| _ ->
print_DEBUG "not a Tmty_signature";
e
)
env
decls
in
let rec f ?(first=false) acc_maybe_more last_pos name_mtype_list =
match name_mtype_list with
[] ->
(acc_maybe_more, [])
| {Parsetree.pmd_name=name; pmd_type=modtype} :: q ->
let complete_name = Name.concat current_module_name name.txt in
| {Parsetree.pmd_name={txt = None}; pmd_type=modtype} :: q ->
let loc = modtype.Parsetree.pmty_loc in
let loc_start = Loc.start loc in
let loc_end = Loc.end_ loc in
let _, ele_comments =
if first then (None, [])
else get_comments_in_module last_pos loc_start
in
let pos_limit2 =
match q with
[] -> pos_limit
| _ :: _ -> Loc.start loc
in
let (maybe_more, _) =
My_ir.just_after_special
!file_name
(get_string_of_file loc_end pos_limit2)
in
let (maybe_more2, eles) = f
maybe_more
(loc_end + maybe_more)
q
in
(maybe_more2, ele_comments @ eles)
| {Parsetree.pmd_name={txt = Some name}; pmd_type=modtype} :: q ->
let complete_name = Name.concat current_module_name name in
let loc = modtype.Parsetree.pmty_loc in
let loc_start = Loc.start loc in
let loc_end = Loc.end_ loc in
@ -1236,9 +1275,9 @@ module Analyser =
in
(* get the information for the module in the signature *)
let sig_module_type =
try Signature_search.search_module table name.txt
try Signature_search.search_module table name
with Not_found ->
raise (Failure (Odoc_messages.module_not_found current_module_name name.txt))
raise (Failure (Odoc_messages.module_not_found current_module_name name))
in
(* associate the comments to each constructor and build the [Type.t_type] *)
let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in
@ -1543,28 +1582,31 @@ module Analyser =
raise (Failure "Parsetree.Pmty_signature signature but not Types.Mty_signature signat")
)
| Parsetree.Pmty_functor (_, pmodule_type2, module_type2) ->
| Parsetree.Pmty_functor (param2, module_type2) ->
(
let loc = match pmodule_type2 with None -> Location.none
| Some pmty -> pmty.Parsetree.pmty_loc in
let loc = match param2 with Parsetree.Unit -> Location.none
| Parsetree.Named (_, pmty) -> pmty.Parsetree.pmty_loc in
let loc_start = Loc.start loc in
let loc_end = Loc.end_ loc in
let mp_type_code = get_string_of_file loc_start loc_end in
print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
match sig_module_type with
Types.Mty_functor (ident, param_module_type, body_module_type) ->
let mp_kind =
match pmodule_type2, param_module_type with
Some pmty, Some mty ->
Types.Mty_functor (param, body_module_type) ->
let mp_name, mp_kind =
match param2, param with
Parsetree.Named (_, pmty), Types.Named (Some ident, mty) ->
Name.from_ident ident,
analyse_module_type_kind env current_module_name pmty mty
| _ -> Module_type_struct []
| _ -> "*", Module_type_struct []
in
let param =
{
mp_name = Name.from_ident ident ;
mp_name = mp_name;
mp_type =
Option.map (Odoc_env.subst_module_type env)
param_module_type;
(match param with
| Types.Unit -> None
| Types.Named (_, mty) ->
Some (Odoc_env.subst_module_type env mty));
mp_type_code = mp_type_code ;
mp_kind = mp_kind ;
}
@ -1638,27 +1680,30 @@ module Analyser =
(* if we're here something's wrong *)
raise (Failure "Parsetree.Pmty_signature signature but not Types.Mty_signature signat")
)
| Parsetree.Pmty_functor (_, pmodule_type2,module_type2) (* of string * module_type * module_type *) ->
| Parsetree.Pmty_functor (param2,module_type2) (* of string * module_type * module_type *) ->
(
match sig_module_type with
Types.Mty_functor (ident, param_module_type, body_module_type) ->
let loc = match pmodule_type2 with None -> Location.none
| Some pmty -> pmty.Parsetree.pmty_loc in
Types.Mty_functor (param, body_module_type) ->
let loc = match param2 with Parsetree.Unit -> Location.none
| Parsetree.Named (_, pmty) -> pmty.Parsetree.pmty_loc in
let loc_start = Loc.start loc in
let loc_end = Loc.end_ loc in
let mp_type_code = get_string_of_file loc_start loc_end in
print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
let mp_kind =
match pmodule_type2, param_module_type with
Some pmty, Some mty ->
let mp_name, mp_kind =
match param2, param with
Parsetree.Named (_, pmty), Types.Named (Some ident, mty) ->
Name.from_ident ident,
analyse_module_type_kind env current_module_name pmty mty
| _ -> Module_type_struct []
| _ -> "*", Module_type_struct []
in
let param =
{
mp_name = Name.from_ident ident ;
mp_type = Option.map
(Odoc_env.subst_module_type env) param_module_type ;
mp_name;
mp_type =
(match param with
| Types.Unit -> None
| Types.Named(_, mty) -> Some (Odoc_env.subst_module_type env mty));
mp_type_code = mp_type_code ;
mp_kind = mp_kind ;
}

7
parsing/ast_helper.ml
View File

@ -24,6 +24,7 @@ type loc = Location.t
type lid = Longident.t with_loc
type str = string with_loc
type str_opt = string option with_loc
type attrs = attribute list
let default_loc = ref Location.none
@ -236,7 +237,7 @@ module Mty = struct
let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a)
let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a)
let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a)
let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c))
let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b))
let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b))
let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a)
let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a)
@ -249,8 +250,8 @@ let mk ?(loc = !default_loc) ?(attrs = []) d =
let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x)
let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x)
let functor_ ?loc ?attrs arg arg_ty body =
mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body))
let functor_ ?loc ?attrs arg body =
mk ?loc ?attrs (Pmod_functor (arg, body))
let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2))
let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty))
let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e)

15
parsing/ast_helper.mli
View File

@ -29,6 +29,7 @@ type loc = Location.t
type lid = Longident.t with_loc
type str = string with_loc
type str_opt = string option with_loc
type attrs = attribute list
(** {1 Default locations} *)
@ -116,7 +117,7 @@ module Pat:
val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern
val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern
val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern
val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern
val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
@ -168,8 +169,8 @@ module Exp:
val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list
-> expression
val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression
-> expression
val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr
-> expression -> expression
val letexception:
?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
-> expression
@ -246,7 +247,7 @@ module Mty:
val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type
val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
val functor_: ?loc:loc -> ?attrs:attrs ->
str -> module_type option -> module_type -> module_type
functor_parameter -> module_type -> module_type
val with_: ?loc:loc -> ?attrs:attrs -> module_type ->
with_constraint list -> module_type
val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type
@ -262,7 +263,7 @@ module Mod:
val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr
val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr
val functor_: ?loc:loc -> ?attrs:attrs ->
str -> module_type option -> module_expr -> module_expr
functor_parameter -> module_expr -> module_expr
val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr ->
module_expr
val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type ->
@ -321,7 +322,7 @@ module Str:
module Md:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
str -> module_type -> module_declaration
str_opt -> module_type -> module_declaration
end
(** Module substitutions *)
@ -342,7 +343,7 @@ module Mtd:
module Mb:
sig
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
str -> module_expr -> module_binding
str_opt -> module_expr -> module_binding
end
(** Opens *)

16
parsing/ast_iterator.ml
View File

@ -233,6 +233,12 @@ module CT = struct
List.iter (sub.class_type_field sub) pcsig_fields
end
let iter_functor_param sub = function
| Unit -> ()
| Named (name, mty) ->
iter_loc sub name;
sub.module_type sub mty
module MT = struct
(* Type expressions for the module language *)
@ -243,9 +249,8 @@ module MT = struct
| Pmty_ident s -> iter_loc sub s
| Pmty_alias s -> iter_loc sub s
| Pmty_signature sg -> sub.signature sub sg
| Pmty_functor (s, mt1, mt2) ->
iter_loc sub s;
iter_opt (sub.module_type sub) mt1;
| Pmty_functor (param, mt2) ->
iter_functor_param sub param;
sub.module_type sub mt2
| Pmty_with (mt, l) ->
sub.module_type sub mt;
@ -298,9 +303,8 @@ module M = struct
match desc with
| Pmod_ident x -> iter_loc sub x
| Pmod_structure str -> sub.structure sub str
| Pmod_functor (arg, arg_ty, body) ->
iter_loc sub arg;
iter_opt (sub.module_type sub) arg_ty;
| Pmod_functor (param, body) ->
iter_functor_param sub param;
sub.module_expr sub body
| Pmod_apply (m1, m2) ->
sub.module_expr sub m1; sub.module_expr sub m2

18
parsing/ast_mapper.ml
View File

@ -249,6 +249,10 @@ module CT = struct
(List.map (sub.class_type_field sub) pcsig_fields)
end
let map_functor_param sub = function
| Unit -> Unit
| Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt)
module MT = struct
(* Type expressions for the module language *)
@ -260,10 +264,10 @@ module MT = struct
| Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
| Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
| Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
| Pmty_functor (s, mt1, mt2) ->
functor_ ~loc ~attrs (map_loc sub s)
(Option.map (sub.module_type sub) mt1)
(sub.module_type sub mt2)
| Pmty_functor (param, mt) ->
functor_ ~loc ~attrs
(map_functor_param sub param)
(sub.module_type sub mt)
| Pmty_with (mt, l) ->
with_ ~loc ~attrs (sub.module_type sub mt)
(List.map (sub.with_constraint sub) l)
@ -318,9 +322,9 @@ module M = struct
match desc with
| Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
| Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
| Pmod_functor (arg, arg_ty, body) ->
functor_ ~loc ~attrs (map_loc sub arg)
(Option.map (sub.module_type sub) arg_ty)
| Pmod_functor (param, body) ->
functor_ ~loc ~attrs
(map_functor_param sub param)
(sub.module_expr sub body)
| Pmod_apply (m1, m2) ->
apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)

64
parsing/depend.ml
View File

@ -182,7 +182,9 @@ let rec add_pattern bv pat =
| Ppat_variant(_, op) -> add_opt add_pattern bv op
| Ppat_type li -> add bv li
| Ppat_lazy p -> add_pattern bv p
| Ppat_unpack id -> pattern_bv := String.Map.add id.txt bound !pattern_bv
| Ppat_unpack id ->
Option.iter
(fun name -> pattern_bv := String.Map.add name bound !pattern_bv) id.txt
| Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p
| Ppat_exception p -> add_pattern bv p
| Ppat_extension e -> handle_extension e
@ -234,7 +236,12 @@ let rec add_expr bv exp =
| Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
| Pexp_letmodule(id, m, e) ->
let b = add_module_binding bv m in
add_expr (String.Map.add id.txt b bv) e
let bv =
match id.txt with
| None -> bv
| Some id -> String.Map.add id b bv
in
add_expr bv e
| Pexp_letexception(_, e) -> add_expr bv e
| Pexp_assert (e) -> add_expr bv e
| Pexp_lazy (e) -> add_expr bv e
@ -283,9 +290,17 @@ and add_modtype bv mty =
Pmty_ident l -> add bv l
| Pmty_alias l -> add_module_path bv l
| Pmty_signature s -> add_signature bv s
| Pmty_functor(id, mty1, mty2) ->
Option.iter (add_modtype bv) mty1;
add_modtype (String.Map.add id.txt bound bv) mty2
| Pmty_functor(param, mty2) ->
let bv =
match param with
| Unit -> bv
| Named (id, mty1) ->
add_modtype bv mty1;
match id.txt with
| None -> bv
| Some name -> String.Map.add name bound bv
in
add_modtype bv mty2
| Pmty_with(mty, cstrl) ->
add_modtype bv mty;
List.iter
@ -340,7 +355,11 @@ and add_sig_item (bv, m) item =
add_type_exception bv te; (bv, m)
| Psig_module pmd ->
let m' = add_modtype_binding bv pmd.pmd_type in
let add = String.Map.add pmd.pmd_name.txt m' in
let add map =
match pmd.pmd_name.txt with
| None -> map
| Some name -> String.Map.add name m' map
in
(add bv, add m)
| Psig_modsubst pms ->
let m' = add_module_alias bv pms.pms_manifest in
@ -348,8 +367,11 @@ and add_sig_item (bv, m) item =
(add bv, add m)
| Psig_recmodule decls ->
let add =
List.fold_right (fun pmd -> String.Map.add pmd.pmd_name.txt bound)
decls
List.fold_right (fun pmd map ->
match pmd.pmd_name.txt with
| None -> map
| Some name -> String.Map.add name bound map
) decls
in
let bv' = add bv and m' = add m in
List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
@ -397,9 +419,17 @@ and add_module_expr bv modl =
match modl.pmod_desc with
Pmod_ident l -> add_module_path bv l
| Pmod_structure s -> ignore (add_structure bv s)
| Pmod_functor(id, mty, modl) ->
Option.iter (add_modtype bv) mty;
add_module_expr (String.Map.add id.txt bound bv) modl
| Pmod_functor(param, modl) ->
let bv =
match param with
| Unit -> bv
| Named (id, mty) ->
add_modtype bv mty;
match id.txt with
| None -> bv
| Some name -> String.Map.add name bound bv
in
add_module_expr bv modl
| Pmod_apply(mod1, mod2) ->
add_module_expr bv mod1; add_module_expr bv mod2
| Pmod_constraint(modl, mty) ->
@ -463,11 +493,19 @@ and add_struct_item (bv, m) item : _ String.Map.t * _ String.Map.t =
(bv, m)
| Pstr_module x ->
let b = add_module_binding bv x.pmb_expr in
let add = String.Map.add x.pmb_name.txt b in
let add map =
match x.pmb_name.txt with
| None -> map
| Some name -> String.Map.add name b map
in
(add bv, add m)
| Pstr_recmodule bindings ->
let add =
List.fold_right (fun x -> String.Map.add x.pmb_name.txt bound) bindings
List.fold_right (fun x map ->
match x.pmb_name.txt with
| None -> map
| Some name -> String.Map.add name bound map
) bindings
in
let bv' = add bv and m = add m in
List.iter

66
parsing/parser.mly
View File

@ -1132,20 +1132,20 @@ parse_pattern:
functor_arg:
(* An anonymous and untyped argument. *)
x = mkrhs(LPAREN RPAREN {"*"})
{ x, None }
LPAREN RPAREN
{ Unit }
| (* An argument accompanied with an explicit type. *)
LPAREN x = mkrhs(functor_arg_name) COLON mty = module_type RPAREN
{ x, Some mty }
LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN
{ Named (x, mty) }
;
functor_arg_name:
module_name:
(* A named argument. *)
x = UIDENT
{ x }
{ Some x }
| (* An anonymous argument. *)
UNDERSCORE
{ "_" }
{ None }
;
(* -------------------------------------------------------------------------- *)
@ -1164,8 +1164,8 @@ module_expr:
{ unclosed "struct" $loc($1) "end" $loc($4) }
| FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr
{ wrap_mod_attrs ~loc:$sloc attrs (
List.fold_left (fun acc (x, mty) ->
mkmod ~loc:$sloc (Pmod_functor (x, mty, acc))
List.fold_left (fun acc arg ->
mkmod ~loc:$sloc (Pmod_functor (arg, acc))
) me args
) }
| me = paren_module_expr
@ -1307,13 +1307,13 @@ structure_item:
%inline module_binding:
MODULE
ext = ext attrs1 = attributes
uid = mkrhs(UIDENT)
name = mkrhs(module_name)
body = module_binding_body
attrs2 = post_item_attributes
{ let docs = symbol_docs $sloc in
let loc = make_loc $sloc in
let attrs = attrs1 @ attrs2 in
let body = Mb.mk uid body ~attrs ~loc ~docs in
let body = Mb.mk name body ~attrs ~loc ~docs in
Pstr_module body, ext }
;
@ -1325,8 +1325,7 @@ module_binding_body:
COLON mty = module_type EQUAL me = module_expr
{ Pmod_constraint(me, mty) }
| arg = functor_arg body = module_binding_body
{ let (x, mty) = arg in
Pmod_functor(x, mty, body) }
{ Pmod_functor(arg, body) }
) { $1 }
;
@ -1342,7 +1341,7 @@ module_binding_body:
ext = ext
attrs1 = attributes
REC
uid = mkrhs(UIDENT)
name = mkrhs(module_name)
body = module_binding_body
attrs2 = post_item_attributes
{
@ -1350,7 +1349,7 @@ module_binding_body:
let attrs = attrs1 @ attrs2 in
let docs = symbol_docs $sloc in
ext,
Mb.mk uid body ~attrs ~loc ~docs
Mb.mk name body ~attrs ~loc ~docs
}
;
@ -1358,7 +1357,7 @@ module_binding_body:
%inline and_module_binding:
AND
attrs1 = attributes
uid = mkrhs(UIDENT)
name = mkrhs(module_name)
body = module_binding_body
attrs2 = post_item_attributes
{
@ -1366,7 +1365,7 @@ module_binding_body:
let attrs = attrs1 @ attrs2 in
let docs = symbol_docs $sloc in
let text = symbol_text $symbolstartpos in
Mb.mk uid body ~attrs ~loc ~text ~docs
Mb.mk name body ~attrs ~loc ~text ~docs
}
;
@ -1459,8 +1458,8 @@ module_type:
MINUSGREATER mty = module_type
%prec below_WITH
{ wrap_mty_attrs ~loc:$sloc attrs (
List.fold_left (fun acc (x, mty) ->
mkmty ~loc:$sloc (Pmty_functor (x, mty, acc))
List.fold_left (fun acc arg ->
mkmty ~loc:$sloc (Pmty_functor (arg, acc))
) mty args
) }
| MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT
@ -1476,7 +1475,7 @@ module_type:
{ Pmty_ident $1 }
| module_type MINUSGREATER module_type
%prec below_WITH
{ Pmty_functor(mknoloc "_", Some $1, $3) }
{ Pmty_functor(Named (mknoloc None, $1), $3) }
| module_type WITH separated_nonempty_llist(AND, with_constraint)
{ Pmty_with($1, $3) }
/* | LPAREN MODULE mkrhs(mod_longident) RPAREN
@ -1550,14 +1549,14 @@ signature_item:
%inline module_declaration:
MODULE
ext = ext attrs1 = attributes
uid = mkrhs(UIDENT)
name = mkrhs(module_name)
body = module_declaration_body
attrs2 = post_item_attributes
{
let attrs = attrs1 @ attrs2 in
let loc = make_loc $sloc in
let docs = symbol_docs $sloc in
Md.mk uid body ~attrs ~loc ~docs, ext
Md.mk name body ~attrs ~loc ~docs, ext
}
;
@ -1567,8 +1566,7 @@ module_declaration_body:
{ mty }
| mkmty(
arg = functor_arg body = module_declaration_body
{ let (x, mty) = arg in
Pmty_functor(x, mty, body) }
{ Pmty_functor(arg, body) }
)
{ $1 }
;
@ -1577,7 +1575,7 @@ module_declaration_body:
%inline module_alias:
MODULE
ext = ext attrs1 = attributes
uid = mkrhs(UIDENT)
name = mkrhs(module_name)
EQUAL
body = module_expr_alias
attrs2 = post_item_attributes
@ -1585,7 +1583,7 @@ module_declaration_body:
let attrs = attrs1 @ attrs2 in
let loc = make_loc $sloc in
let docs = symbol_docs $sloc in
Md.mk uid body ~attrs ~loc ~docs, ext
Md.mk name body ~attrs ~loc ~docs, ext
}
;
%inline module_expr_alias:
@ -1620,7 +1618,7 @@ module_subst:
ext = ext
attrs1 = attributes
REC
uid = mkrhs(UIDENT)
name = mkrhs(module_name)
COLON
mty = module_type
attrs2 = post_item_attributes
@ -1628,13 +1626,13 @@ module_subst:
let attrs = attrs1 @ attrs2 in
let loc = make_loc $sloc in
let docs = symbol_docs $sloc in
ext, Md.mk uid mty ~attrs ~loc ~docs
ext, Md.mk name mty ~attrs ~loc ~docs
}
;
%inline and_module_declaration:
AND
attrs1 = attributes
uid = mkrhs(UIDENT)
name = mkrhs(module_name)
COLON
mty = module_type
attrs2 = post_item_attributes
@ -1643,7 +1641,7 @@ module_subst:
let docs = symbol_docs $sloc in
let loc = make_loc $sloc in
let text = symbol_text $symbolstartpos in
Md.mk uid mty ~attrs ~loc ~text ~docs
Md.mk name mty ~attrs ~loc ~text ~docs
}
;
@ -2131,7 +2129,7 @@ expr:
{ not_expecting $loc($1) "wildcard \"_\"" }
;
%inline expr_attrs:
| LET MODULE ext_attributes mkrhs(UIDENT) module_binding_body IN seq_expr
| LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr
{ Pexp_letmodule($4, $5, $7), $3 }
| LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr
{ Pexp_letexception($4, $6), $3 }
@ -2625,9 +2623,9 @@ simple_pattern_not_ident:
{ reloc_pat ~loc:$sloc $2 }
| simple_delimited_pattern
{ $1 }
| LPAREN MODULE ext_attributes mkrhs(UIDENT) RPAREN
| LPAREN MODULE ext_attributes mkrhs(module_name) RPAREN
{ mkpat_attrs ~loc:$sloc (Ppat_unpack $4) $3 }
| LPAREN MODULE ext_attributes mkrhs(UIDENT) COLON package_type RPAREN
| LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN
{ mkpat_attrs ~loc:$sloc
(Ppat_constraint(mkpat ~loc:$sloc (Ppat_unpack $4), $6))
$3 }
@ -2667,7 +2665,7 @@ simple_pattern_not_ident:
{ unclosed "(" $loc($1) ")" $loc($5) }
| LPAREN pattern COLON error
{ expecting $loc($4) "type" }
| LPAREN MODULE ext_attributes UIDENT COLON package_type
| LPAREN MODULE ext_attributes module_name COLON package_type
error
{ unclosed "(" $loc($1) ")" $loc($7) }
| extension

23
parsing/parsetree.mli
View File

@ -238,8 +238,10 @@ and pattern_desc =
(* #tconst *)
| Ppat_lazy of pattern
(* lazy P *)
| Ppat_unpack of string loc
(* (module P)
| Ppat_unpack of string option loc
(* (module P) Some "P"
(module _) None
Note: (module P : S) is represented as
Ppat_constraint(Ppat_unpack, Ptyp_package)
*)
@ -346,7 +348,7 @@ and expression_desc =
(* x <- 2 *)
| Pexp_override of (label loc * expression) list
(* {< x1 = E1; ...; Xn = En >} *)
| Pexp_letmodule of string loc * module_expr * expression
| Pexp_letmodule of string option loc * module_expr * expression
(* let module M = ME in E *)
| Pexp_letexception of extension_constructor * expression
(* let exception C in E *)
@ -713,7 +715,7 @@ and module_type_desc =
(* S *)
| Pmty_signature of signature
(* sig ... end *)
| Pmty_functor of string loc * module_type option * module_type
| Pmty_functor of functor_parameter * module_type
(* functor(X : MT1) -> MT2 *)
| Pmty_with of module_type * with_constraint list
(* MT with ... *)
@ -724,6 +726,13 @@ and module_type_desc =
| Pmty_alias of Longident.t loc
(* (module M) *)
and functor_parameter =
| Unit
(* () *)
| Named of string option loc * module_type
(* (X : MT) Some X, MT
(_ : MT) None, MT *)
and signature = signature_item list
and signature_item =
@ -771,7 +780,7 @@ and signature_item_desc =
and module_declaration =
{
pmd_name: string loc;
pmd_name: string option loc;
pmd_type: module_type;
pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
pmd_loc: Location.t;
@ -858,7 +867,7 @@ and module_expr_desc =
(* X *)
| Pmod_structure of structure
(* struct ... end *)
| Pmod_functor of string loc * module_type option * module_expr
| Pmod_functor of functor_parameter * module_expr
(* functor(X : MT1) -> ME *)
| Pmod_apply of module_expr * module_expr
(* ME1(ME2) *)
@ -923,7 +932,7 @@ and value_binding =
and module_binding =
{
pmb_name: string loc;
pmb_name: string option loc;
pmb_expr: module_expr;
pmb_attributes: attributes;
pmb_loc: Location.t;

67
parsing/pprintast.ml
View File

@ -442,8 +442,10 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
| Ppat_var ({txt = txt;_}) -> protect_ident f txt
| Ppat_array l ->
pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l
| Ppat_unpack (s) ->
pp f "(module@ %s)@ " s.txt
| Ppat_unpack { txt = None } ->
pp f "(module@ _)@ "
| Ppat_unpack { txt = Some s } ->
pp f "(module@ %s)@ " s
| Ppat_type li ->
pp f "#%a" longident_loc li
| Ppat_record (l, closed) ->
@ -704,7 +706,8 @@ and expression ctxt f x =
pp f "@[<hov2>{<%a>}@]"
(list string_x_expression ~sep:";" ) l;
| Pexp_letmodule (s, me, e) ->
pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]" s.txt
pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]"
(Option.value s.txt ~default:"_")
(module_expr reset_ctxt) me (expression ctxt) e
| Pexp_letexception (cd, e) ->
pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
@ -1025,15 +1028,17 @@ and module_type ctxt f x =
(attributes ctxt) x.pmty_attributes
end else
match x.pmty_desc with
| Pmty_functor (_, None, mt2) ->
| Pmty_functor (Unit, mt2) ->
pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
| Pmty_functor (s, Some mt1, mt2) ->
if s.txt = "_" then
pp f "@[<hov2>%a@ ->@ %a@]"
(module_type1 ctxt) mt1 (module_type ctxt) mt2
else
pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
(module_type ctxt) mt1 (module_type ctxt) mt2
| Pmty_functor (Named (s, mt1), mt2) ->
begin match s.txt with
| None ->
pp f "@[<hov2>%a@ ->@ %a@]"
(module_type1 ctxt) mt1 (module_type ctxt) mt2
| Some name ->
pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" name
(module_type ctxt) mt1 (module_type ctxt) mt2
end
| Pmty_with (mt, []) -> module_type ctxt f mt
| Pmty_with (mt, l) ->
let with_constraint f = function
@ -1107,12 +1112,13 @@ and signature_item ctxt f x : unit =
end
| Psig_module ({pmd_type={pmty_desc=Pmty_alias alias;
pmty_attributes=[]; _};_} as pmd) ->
pp f "@[<hov>module@ %s@ =@ %a@]%a" pmd.pmd_name.txt
pp f "@[<hov>module@ %s@ =@ %a@]%a"
(Option.value pmd.pmd_name.txt ~default:"_")
longident_loc alias
(item_attributes ctxt) pmd.pmd_attributes
| Psig_module pmd ->
pp f "@[<hov>module@ %s@ :@ %a@]%a"
pmd.pmd_name.txt
(Option.value pmd.pmd_name.txt ~default:"_")
(module_type ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes
| Psig_modsubst pms ->
@ -1145,11 +1151,13 @@ and signature_item ctxt f x : unit =
| [] -> () ;
| pmd :: tl ->
if not first then
pp f "@ @[<hov2>and@ %s:@ %a@]%a" pmd.pmd_name.txt
pp f "@ @[<hov2>and@ %s:@ %a@]%a"
(Option.value pmd.pmd_name.txt ~default:"_")
(module_type1 ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes
else
pp f "@[<hov2>module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt
pp f "@[<hov2>module@ rec@ %s:@ %a@]%a"
(Option.value pmd.pmd_name.txt ~default:"_")
(module_type1 ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes;
string_x_module_type_list f ~first:false tl
@ -1174,11 +1182,12 @@ and module_expr ctxt f x =
(module_type ctxt) mt
| Pmod_ident (li) ->
pp f "%a" longident_loc li;
| Pmod_functor (_, None, me) ->
| Pmod_functor (Unit, me) ->
pp f "functor ()@;->@;%a" (module_expr ctxt) me
| Pmod_functor (s, Some mt, me) ->
| Pmod_functor (Named (s, mt), me) ->
pp f "functor@ (%s@ :@ %a)@;->@;%a"
s.txt (module_type ctxt) mt (module_expr ctxt) me
(Option.value s.txt ~default:"_")
(module_type ctxt) mt (module_expr ctxt) me
| Pmod_apply (me1, me2) ->
pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
(* Cf: #7200 *)
@ -1303,14 +1312,18 @@ and structure_item ctxt f x =
| Pstr_exception ed -> exception_declaration ctxt f ed
| Pstr_module x ->
let rec module_helper = function
| {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} ->
if mt = None then pp f "()"
else Option.iter (pp f "(%s:%a)" s.txt (module_type ctxt)) mt;
| {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} ->
begin match arg_opt with
| Unit -> pp f "()"
| Named (s, mt) ->
pp f "(%s:%a)" (Option.value s.txt ~default:"_")
(module_type ctxt) mt
end;
module_helper me'
| me -> me
in
pp f "@[<hov2>module %s%a@]%a"
x.pmb_name.txt
(Option.value x.pmb_name.txt ~default:"_")
(fun f me ->
let me = module_helper me in
match me with
@ -1389,26 +1402,28 @@ and structure_item ctxt f x =
| Pstr_recmodule decls -> (* 3.07 *)
let aux f = function
| ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt
pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a"
(Option.value pmb.pmb_name.txt ~default:"_")
(module_type ctxt) typ
(module_expr ctxt) expr
(item_attributes ctxt) pmb.pmb_attributes
| pmb ->
pp f "@[<hov2>@ and@ %s@ =@ %a@]%a" pmb.pmb_name.txt
pp f "@[<hov2>@ and@ %s@ =@ %a@]%a"
(Option.value pmb.pmb_name.txt ~default:"_")
(module_expr ctxt) pmb.pmb_expr
(item_attributes ctxt) pmb.pmb_attributes
in
begin match decls with
| ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
pmb.pmb_name.txt
(Option.value pmb.pmb_name.txt ~default:"_")
(module_type ctxt) typ
(module_expr ctxt) expr
(item_attributes ctxt) pmb.pmb_attributes
(fun f l2 -> List.iter (aux f) l2) l2
| pmb :: l2 ->
pp f "@[<hv>@[<hov2>module@ rec@ %s@ =@ %a@]%a@ %a@]"
pmb.pmb_name.txt
(Option.value pmb.pmb_name.txt ~default:"_")
(module_expr ctxt) pmb.pmb_expr
(item_attributes ctxt) pmb.pmb_attributes
(fun f l2 -> List.iter (aux f) l2) l2

33
parsing/printast.ml
View File

@ -52,6 +52,10 @@ let fmt_string_loc f (x : string loc) =
fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
;;
let fmt_str_opt_loc f (x : string option loc) =
fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc;
;;
let fmt_char_option f = function
| None -> fprintf f "None"
| Some c -> fprintf f "Some %c" c
@ -132,6 +136,7 @@ let option i f ppf x =
let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
let string i ppf s = line i ppf "\"%s\"\n" s;;
let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s;;
let arg_label i ppf = function
| Nolabel -> line i ppf "Nolabel\n"
| Optional s -> line i ppf "Optional \"%s\"\n" s
@ -240,7 +245,7 @@ and pattern i ppf x =
line i ppf "Ppat_type\n";
longident_loc i ppf li
| Ppat_unpack s ->
line i ppf "Ppat_unpack %a\n" fmt_string_loc s;
line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s;
| Ppat_exception p ->
line i ppf "Ppat_exception\n";
pattern i ppf p
@ -347,7 +352,7 @@ and expression i ppf x =
line i ppf "Pexp_override\n";
list i string_x_expression ppf l;
| Pexp_letmodule (s, me, e) ->
line i ppf "Pexp_letmodule %a\n" fmt_string_loc s;
line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s;
module_expr i ppf me;
expression i ppf e;
| Pexp_letexception (cd, e) ->
@ -662,9 +667,12 @@ and module_type i ppf x =
| Pmty_signature (s) ->
line i ppf "Pmty_signature\n";
signature i ppf s;
| Pmty_functor (s, mt1, mt2) ->
line i ppf "Pmty_functor %a\n" fmt_string_loc s;
Option.iter (module_type i ppf) mt1;
| Pmty_functor (Unit, mt2) ->
line i ppf "Pmty_functor ()\n";
module_type i ppf mt2;
| Pmty_functor (Named (s, mt1), mt2) ->
line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s;
module_type i ppf mt1;
module_type i ppf mt2;
| Pmty_with (mt, l) ->
line i ppf "Pmty_with\n";
@ -699,7 +707,7 @@ and signature_item i ppf x =
line i ppf "Psig_exception\n";
type_exception i ppf te
| Psig_module pmd ->
line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name;
line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name;
attributes i ppf pmd.pmd_attributes;
module_type i ppf pmd.pmd_type
| Psig_modsubst pms ->
@ -765,9 +773,12 @@ and module_expr i ppf x =
| Pmod_structure (s) ->
line i ppf "Pmod_structure\n";
structure i ppf s;
| Pmod_functor (s, mt, me) ->
line i ppf "Pmod_functor %a\n" fmt_string_loc s;
Option.iter (module_type i ppf) mt;
| Pmod_functor (Unit, me) ->
line i ppf "Pmod_functor ()\n";
module_expr i ppf me;
| Pmod_functor (Named (s, mt), me) ->
line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s;
module_type i ppf mt;
module_expr i ppf me;
| Pmod_apply (me1, me2) ->
line i ppf "Pmod_apply\n";
@ -841,12 +852,12 @@ and structure_item i ppf x =
attribute i ppf "Pstr_attribute" a
and module_declaration i ppf pmd =
string_loc i ppf pmd.pmd_name;
str_opt_loc i ppf pmd.pmd_name;
attributes i ppf pmd.pmd_attributes;
module_type (i+1) ppf pmd.pmd_type;
and module_binding i ppf x =
string_loc i ppf x.pmb_name;
str_opt_loc i ppf x.pmb_name;
attributes i ppf x.pmb_attributes;
module_expr (i+1) ppf x.pmb_expr

43
testsuite/tests/basic-modules/anonymous.ml Normal file
View File

@ -0,0 +1,43 @@
(* TEST
flags = "-c -nostdlib -nopervasives -dlambda -dno-unique-ids"
* setup-ocamlc.byte-build-env
** ocamlc.byte
*** check-ocamlc.byte-output
compiler_reference = "${test_source_directory}/anonymous.ocamlc.reference"
* setup-ocamlopt.byte-build-env
** ocamlopt.byte
*** no-flambda
**** check-ocamlopt.byte-output
compiler_reference = "${test_source_directory}/anonymous.ocamlopt.reference"
*** flambda
**** check-ocamlc.byte-output
compiler_reference =
"${test_source_directory}/anonymous.ocamlopt.flambda.reference"
*)
module _ = struct
let x = 13, 37
end
module rec A : sig
type t = B.t
end = A
and _ : sig
type t = A.t
val x : int * int
end = struct
type t = B.t
let x = 4, 2
end
and B : sig
type t
end = struct
type t
let x = "foo", "bar"
end
module type S
let f (module _ : S) = ()

16
testsuite/tests/basic-modules/anonymous.ocamlc.reference Normal file
View File

@ -0,0 +1,16 @@
(setglobal Anonymous!
(seq (ignore (let (x = [0: 13 37]) (makeblock 0 x)))
(let
(A =
(apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 25 6]
[0: [0]])
B =
(apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 35 6]
[0: [0]]))
(seq (ignore (let (x = [0: 4 2]) (makeblock 0 x)))
(apply (field 1 (global CamlinternalMod!)) [0: [0]] A
(module-defn(A) anonymous.ml(23):567-608 A))
(apply (field 1 (global CamlinternalMod!)) [0: [0]] B
(module-defn(B) anonymous.ml(33):703-773
(let (x = [0: "foo" "bar"]) (makeblock 0))))
(let (f = (function param 0a)) (makeblock 0 A B f))))))

15
testsuite/tests/basic-modules/anonymous.ocamlopt.flambda.reference Normal file
View File

@ -0,0 +1,15 @@
(seq (ignore (let (x = [0: 13 37]) (makeblock 0 x)))
(let
(A =
(apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 25 6]
[0: [0]])
B =
(apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 35 6]
[0: [0]]))
(seq (ignore (let (x = [0: 4 2]) (makeblock 0 x)))
(apply (field 1 (global CamlinternalMod!)) [0: [0]] A
(module-defn(A) anonymous.ml(23):567-608 A))
(apply (field 1 (global CamlinternalMod!)) [0: [0]] B
(module-defn(B) anonymous.ml(33):703-773
(let (x = [0: "foo" "bar"]) (makeblock 0))))
(let (f = (function param 0a)) (makeblock 0 A B f)))))

17
testsuite/tests/basic-modules/anonymous.ocamlopt.reference Normal file
View File

@ -0,0 +1,17 @@
(seq (ignore (let (x = [0: 13 37]) (makeblock 0 x)))
(let
(A =
(apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 25 6]
[0: [0]])
B =
(apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 35 6]
[0: [0]]))
(seq (ignore (let (x = [0: 4 2]) (makeblock 0 x)))
(apply (field 1 (global CamlinternalMod!)) [0: [0]] A A)
(apply (field 1 (global CamlinternalMod!)) [0: [0]] B
(let (x = [0: "foo" "bar"]) (makeblock 0)))
(setfield_ptr(root-init) 0 (global Anonymous!) A)
(setfield_ptr(root-init) 1 (global Anonymous!) B)
(let (f = (function param 0a))
(setfield_ptr(root-init) 2 (global Anonymous!) f))
0a)))

8
testsuite/tests/shadow_include/shadow_all.ml
View File

@ -181,7 +181,7 @@ end
Line 4, characters 2-11:
4 | include S
^^^^^^^^^
Error: Illegal shadowing of included module type T/317 by T/335
Error: Illegal shadowing of included module type T/317 by T/334
Line 2, characters 2-11:
Module type T/317 came from this include
Line 3, characters 2-39:
@ -198,11 +198,11 @@ end
Line 4, characters 2-11:
4 | include S
^^^^^^^^^
Error: Illegal shadowing of included type ext/353 by ext/370
Error: Illegal shadowing of included type ext/352 by ext/369
Line 2, characters 2-11:
Type ext/353 came from this include
Type ext/352 came from this include
Line 3, characters 14-16:
The extension constructor C2 has no valid type if ext/353 is shadowed
The extension constructor C2 has no valid type if ext/352 is shadowed
|}]
module type Class = sig

39
testsuite/tests/typing-modules/anonymous.ml Normal file
View File

@ -0,0 +1,39 @@
(* TEST
* expect
*)
module _ = struct end;;
[%%expect{|
|}];;
module rec A : sig
type t = B.t
end = A
and _ : sig type t = A.t end = struct type t = A.t end
and B : sig type t end = B
;;
[%%expect{|
module rec A : sig type t = B.t end
and B : sig type t end
|}]
module type S = sig
module _ : sig end
module rec A : sig
type t = B.t
end
and _ : sig type t = A.t end
and B : sig type t end
end
;;
[%%expect{|
module type S =
sig module rec A : sig type t = B/2.t end and B : sig type t end end
|}]
let f (module _ : S) = ()
;;
[%%expect{|
val f : (module S) -> unit = <fun>
|}]

5
tools/cmt2annot.ml
View File

@ -57,7 +57,7 @@ let bind_cases l =
let record_module_binding scope mb =
Stypes.record (Stypes.An_ident
(mb.mb_name.loc,
mb.mb_name.txt,
Option.value mb.mb_name.txt ~default:"_",
Annot.Idef scope))
let rec iterator ~scope rebuild_env =
@ -106,7 +106,8 @@ let rec iterator ~scope rebuild_env =
bind_cases f
| Texp_letmodule (_, modname, _, _, body ) ->
Stypes.record (Stypes.An_ident
(modname.loc,modname.txt,Annot.Idef body.exp_loc))
(modname.loc,Option.value ~default:"_" modname.txt,
Annot.Idef body.exp_loc))
| _ -> ()
end;
Stypes.record (Stypes.Ti_expr exp);

2
tools/ocamlprof.ml
View File

@ -385,7 +385,7 @@ and rewrite_mod iflag smod =
match smod.pmod_desc with
Pmod_ident _ -> ()
| Pmod_structure sstr -> List.iter (rewrite_str_item iflag) sstr
| Pmod_functor(_param, _smty, sbody) -> rewrite_mod iflag sbody
| Pmod_functor(_param, sbody) -> rewrite_mod iflag sbody
| Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
| Pmod_constraint(smod, _smty) -> rewrite_mod iflag smod
| Pmod_unpack(sexp) -> rewrite_exp iflag sexp

2
toplevel/opttoploop.ml
View File

@ -187,7 +187,7 @@ let parse_mod_use_file name lb =
[ Ptop_def
[ Str.module_
(Mb.mk
(Location.mknoloc modname)
(Location.mknoloc (Some modname))
(Mod.structure items)
)
]

2
toplevel/toploop.ml
View File

@ -151,7 +151,7 @@ let parse_mod_use_file name lb =
[ Ptop_def
[ Str.module_
(Mb.mk
(Location.mknoloc modname)
(Location.mknoloc (Some modname))
(Mod.structure items)
)
]

13
typing/btype.ml
View File

@ -61,9 +61,6 @@ let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false
let dummy_method = "*dummy method*"
let default_mty = function
Some mty -> mty
| None -> Mty_signature []
(**** Definitions for backtracking ****)
@ -333,6 +330,7 @@ type type_iterators =
it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
it_class_declaration: type_iterators -> class_declaration -> unit;
it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
it_functor_param: type_iterators -> functor_parameter -> unit;
it_module_type: type_iterators -> module_type -> unit;
it_class_type: type_iterators -> class_type -> unit;
it_type_kind: type_iterators -> type_kind -> unit;
@ -399,12 +397,15 @@ let type_iterators =
List.iter (it.it_type_expr it) ctd.clty_params;
it.it_class_type it ctd.clty_type;
it.it_path ctd.clty_path
and it_functor_param it = function
| Unit -> ()
| Named (_, mt) -> it.it_module_type it mt
and it_module_type it = function
Mty_ident p
| Mty_alias p -> it.it_path p
| Mty_signature sg -> it.it_signature it sg
| Mty_functor (_, mto, mt) ->
Option.iter (it.it_module_type it) mto;
| Mty_functor (p, mt) ->
it.it_functor_param it p;
it.it_module_type it mt
and it_class_type it = function
Cty_constr (p, tyl, cty) ->
@ -435,7 +436,7 @@ let type_iterators =
and it_path _p = ()
in
{ it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
it_type_kind; it_class_type; it_module_type;
it_type_kind; it_class_type; it_functor_param; it_module_type;
it_signature; it_class_type_declaration; it_class_declaration;
it_modtype_declaration; it_module_declaration; it_extension_constructor;
it_type_declaration; it_value_description; it_signature_item; }

2
typing/btype.mli
View File

@ -48,7 +48,6 @@ val is_Tvar: type_expr -> bool
val is_Tunivar: type_expr -> bool
val is_Tconstr: type_expr -> bool
val dummy_method: label
val default_mty: module_type option -> module_type
val repr: type_expr -> type_expr
(* Return the canonical representative of a type. *)
@ -122,6 +121,7 @@ type type_iterators =
it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
it_class_declaration: type_iterators -> class_declaration -> unit;
it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
it_functor_param: type_iterators -> functor_parameter -> unit;
it_module_type: type_iterators -> module_type -> unit;
it_class_type: type_iterators -> class_type -> unit;
it_type_kind: type_iterators -> type_kind -> unit;

34
typing/env.ml
View File

@ -443,8 +443,8 @@ and structure_components = {
}
and functor_components = {
fcomp_param: Ident.t; (* Formal parameter *)
fcomp_arg: module_type option; (* Argument signature *)
fcomp_arg: functor_parameter;
(* Formal parameter and argument signature *)
fcomp_res: module_type; (* Result signature *)
fcomp_cache: (Path.t, module_components) Hashtbl.t; (* For memoization *)
fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
@ -821,9 +821,13 @@ let modtype_of_functor_appl fcomp p1 p2 =
with Not_found ->
let scope = Path.scope (Papply(p1, p2)) in
let mty =
Subst.modtype (Rescope scope)
(Subst.add_module fcomp.fcomp_param p2 Subst.identity)
mty
let subst =
match fcomp.fcomp_arg with
| Unit
| Named (None, _) -> Subst.identity
| Named (Some param, _) -> Subst.add_module param p2 Subst.identity
in
Subst.modtype (Rescope scope) subst mty
in
Hashtbl.add fcomp.fcomp_subst_cache p2 mty;
mty
@ -1577,16 +1581,19 @@ let rec components_of_module_maker
NameMap.add (Ident.name id) decl' c.comp_cltypes)
items_and_paths;
Ok (Structure_comps c)
| Mty_functor(param, ty_arg, ty_res) ->
| Mty_functor(arg, ty_res) ->
let sub =
may_subst Subst.compose cm_freshening_subst cm_prefixing_subst
in
let scoping = Subst.Rescope (Path.scope cm_path) in
Ok (Functor_comps {
fcomp_param = param;
(* fcomp_arg and fcomp_res must be prefixed eagerly, because
they are interpreted in the outer environment *)
fcomp_arg = Option.map (Subst.modtype scoping sub) ty_arg;
fcomp_arg =
(match arg with
| Unit -> Unit
| Named (param, ty_arg) ->
Named (param, Subst.modtype scoping sub ty_arg));
fcomp_res = Subst.modtype scoping sub ty_res;
fcomp_cache = Hashtbl.create 17;
fcomp_subst_cache = Hashtbl.create 17 })
@ -1762,7 +1769,12 @@ let components_of_functor_appl ~loc f env p1 p2 =
Hashtbl.find f.fcomp_cache p2
with Not_found ->
let p = Papply(p1, p2) in
let sub = Subst.add_module f.fcomp_param p2 Subst.identity in
let sub =
match f.fcomp_arg with
| Unit
| Named (None, _) -> Subst.identity
| Named (Some param, _) -> Subst.add_module param p2 Subst.identity
in
(* we have to apply eagerly instead of passing sub to [components_of_module]
because of the call to [check_well_formed_module]. *)
let mty = Subst.modtype (Rescope (Path.scope p)) sub f.fcomp_res in
@ -2409,9 +2421,9 @@ and lookup_functor_components ~errors ~use ~loc lid env =
match get_components_res comps with
| Ok (Functor_comps fcomps) -> begin
match fcomps.fcomp_arg with
| None -> (* PR#7611 *)
| Unit -> (* PR#7611 *)
may_lookup_error errors loc env (Generative_used_as_applicative lid)
| Some arg -> path, fcomps, arg
| Named (_, arg) -> path, fcomps, arg
end
| Ok (Structure_comps _) ->
may_lookup_error errors loc env (Structure_used_as_functor lid)

49
typing/includemod.ml
View File

@ -41,7 +41,10 @@ type symptom =
| Invalid_module_alias of Path.t
type pos =
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
| Module of Ident.t
| Modtype of Ident.t
| Arg of functor_parameter
| Body of functor_parameter
type error = pos list * Env.t * symptom
exception Error of error list
@ -294,25 +297,32 @@ and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
try_modtypes2 ~loc env ~mark cxt mty1 (Subst.modtype Keep subst mty2)
| (Mty_signature sig1, Mty_signature sig2) ->
signatures ~loc env ~mark cxt subst sig1 sig2
| (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) ->
| (Mty_functor(Unit, res1), Mty_functor(Unit, res2)) ->
begin
match modtypes ~loc env ~mark (Body param1::cxt) subst res1 res2 with
match modtypes ~loc env ~mark (Body Unit::cxt) subst res1 res2 with
| Tcoerce_none -> Tcoerce_none
| cc -> Tcoerce_functor (Tcoerce_none, cc)
end
| (Mty_functor(param1, Some arg1, res1),
Mty_functor(param2, Some arg2, res2)) ->
| (Mty_functor(Named (param1, arg1) as arg, res1),
Mty_functor(Named (param2, arg2), res2)) ->
let arg2' = Subst.modtype Keep subst arg2 in
let cc_arg =
modtypes ~loc env ~mark:(negate_mark mark)
(Arg param1::cxt) Subst.identity arg2' arg1
(Arg arg::cxt) Subst.identity arg2' arg1
in
let cc_res =
modtypes ~loc (Env.add_module param1 Mp_present arg2' env) ~mark
(Body param1::cxt)
(Subst.add_module param2 (Path.Pident param1) subst)
res1 res2
let env, subst =
match param1, param2 with
| Some p1, Some p2 ->
Env.add_module p1 Mp_present arg2' env,
Subst.add_module p2 (Path.Pident p1) subst
| None, Some p2 ->
Env.add_module p2 Mp_present arg2' env, subst
| Some p1, None ->
Env.add_module p1 Mp_present arg2' env, subst
| None, None ->
env, subst
in
let cc_res = modtypes ~loc env ~mark (Body arg::cxt) subst res1 res2 in
begin match (cc_arg, cc_res) with
(Tcoerce_none, Tcoerce_none) -> Tcoerce_none
| _ -> Tcoerce_functor(cc_arg, cc_res)
@ -661,8 +671,10 @@ module Illegal_permutation = struct
| Sig_module (id, _, md,_,_) -> find env (Module id :: ctx) q md.md_type
| _ -> raise Not_found
end
| Mty_functor(x,Some mt,_), InArg :: q -> find env (Arg x :: ctx) q mt
| Mty_functor(x,_,mt), InBody :: q -> find env (Body x :: ctx) q mt
| Mty_functor(Named (_,mt) as arg,_), InArg :: q ->
find env (Arg arg :: ctx) q mt
| Mty_functor(arg, mt), InBody :: q ->
find env (Body arg :: ctx) q mt
| _ -> raise Not_found
let find env path mt = find env [] path mt
@ -716,7 +728,7 @@ let rec context ppf = function
| Body x :: rem ->
fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
| Arg x :: rem ->
fprintf ppf "functor (%a : %a) -> ..." Printtyp.ident x context_mty rem
fprintf ppf "functor (%s : %a) -> ..." (argname x) context_mty rem
| [] ->
fprintf ppf "<here>"
and context_mty ppf = function
@ -727,12 +739,13 @@ and args ppf = function
Body x :: rem ->
fprintf ppf "(%s)%a" (argname x) args rem
| Arg x :: rem ->
fprintf ppf "(%a :@ %a) : ..." Printtyp.ident x context_mty rem
fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem
| cxt ->
fprintf ppf " :@ %a" context_mty cxt
and argname x =
let s = Ident.name x in
if s = "*" then "" else s
and argname = function
| Unit -> ""
| Named (None, _) -> "_"
| Named (Some id, _) -> Ident.name id
let alt_context ppf cxt =
if cxt = [] then () else

5
typing/includemod.mli
View File

@ -77,7 +77,10 @@ type symptom =
| Invalid_module_alias of Path.t
type pos =
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
| Module of Ident.t
| Modtype of Ident.t
| Arg of functor_parameter
| Body of functor_parameter
type error = pos list * Env.t * symptom
exception Error of error list

32
typing/mtype.ml
View File

@ -37,9 +37,14 @@ let rec strengthen ~aliasable env mty p =
match scrape env mty with
Mty_signature sg ->
Mty_signature(strengthen_sig ~aliasable env sg p)
| Mty_functor(param, arg, res)
when !Clflags.applicative_functors && Ident.name param <> "*" ->
Mty_functor(param, arg,
| Mty_functor(Named (Some param, arg), res)
when !Clflags.applicative_functors ->
Mty_functor(Named (Some param, arg),
strengthen ~aliasable:false env res (Papply(p, Pident param)))
| Mty_functor(Named (None, arg), res)
when !Clflags.applicative_functors ->
let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in
Mty_functor(Named (Some param, arg),
strengthen ~aliasable:false env res (Papply(p, Pident param)))
| mty ->
mty
@ -107,9 +112,9 @@ let rec make_aliases_absent pres mty =
| Mty_alias _ -> Mp_absent, mty
| Mty_signature sg ->
pres, Mty_signature(make_aliases_absent_sig sg)
| Mty_functor(param, arg, res) ->
| Mty_functor(arg, res) ->
let _, res = make_aliases_absent Mp_present res in
pres, Mty_functor(param, arg, res)
pres, Mty_functor(arg, res)
| mty ->
pres, mty
@ -171,14 +176,19 @@ let rec nondep_mty_with_presence env va ids pres mty =
| Mty_signature sg ->
let mty = Mty_signature(nondep_sig env va ids sg) in
pres, mty
| Mty_functor(param, arg, res) ->
| Mty_functor(Unit, res) ->
pres, Mty_functor(Unit, nondep_mty env va ids res)
| Mty_functor(Named (param, arg), res) ->
let var_inv =
match va with Co -> Contra | Contra -> Co | Strict -> Strict in
let res_env =
match param with
| None -> env
| Some param -> Env.add_module ~arg:true param Mp_present arg env
in
let mty =
Mty_functor(param, Option.map (nondep_mty env var_inv ids) arg,
nondep_mty
(Env.add_module ~arg:true param Mp_present
(Btype.default_mty arg) env) va ids res)
Mty_functor(Named (param, nondep_mty env var_inv ids arg),
nondep_mty res_env va ids res)
in
pres, mty
@ -335,7 +345,7 @@ let rec contains_type env = function
end
| Mty_signature sg ->
contains_type_sig env sg
| Mty_functor (_, _, body) ->
| Mty_functor (_, body) ->
contains_type env body
| Mty_alias _ ->
()

19
typing/oprint.ml
View File

@ -484,14 +484,15 @@ let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension")
that should be printed in long form. *)
let collect_functor_arguments mty =
let rec collect_args acc = function
| Omty_functor (name, mty_arg, mty_res) ->
collect_args ((name, mty_arg) :: acc) mty_res
| Omty_functor (param, mty_res) ->
collect_args (param :: acc) mty_res
| non_functor -> (acc, non_functor)
in
let rec uncollect_anonymous_suffix acc rest = match acc with
| ("_", mty_arg) :: acc ->
uncollect_anonymous_suffix acc (Omty_functor ("_", mty_arg, rest))
| (_, _) :: _ | [] ->
| Some (None, mty_arg) :: acc ->
uncollect_anonymous_suffix acc
(Omty_functor (Some (None, mty_arg), rest))
| _ :: _ | [] ->
(acc, rest)
in
let (acc, non_functor) = collect_args [] mty in
@ -503,18 +504,18 @@ let rec print_out_module_type ppf mty =
and print_out_functor ppf = function
| Omty_functor _ as t ->
let rec print_functor ppf = function
| Omty_functor ("_", Some mty_arg, mty_res) ->
| Omty_functor (Some (None, mty_arg), mty_res) ->
fprintf ppf "%a ->@ %a"
print_simple_out_module_type mty_arg
print_functor mty_res
| Omty_functor _ as non_anonymous_functor ->
let (args, rest) = collect_functor_arguments non_anonymous_functor in
let print_arg ppf = function
| (_, None) ->
| None ->
fprintf ppf "()"
| (name, Some mty) ->
| Some (param, mty) ->
fprintf ppf "(%s : %a)"
name
(Option.value param ~default:"_")
print_out_module_type mty
in
fprintf ppf "@[<2>functor@ %a@]@ ->@ %a"

2
typing/outcometree.mli
View File

@ -91,7 +91,7 @@ and out_class_sig_item =
type out_module_type =
| Omty_abstract
| Omty_functor of string * out_module_type option * out_module_type
| Omty_functor of (string option * out_module_type) option * out_module_type
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
| Omty_alias of out_ident

4
typing/parmatch.ml
View File

@ -2598,8 +2598,10 @@ let all_rhs_idents exp =
Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
_) ->
assert (Ident.Set.mem id_exp !ids) ;
if not (Ident.Set.mem id_mod !ids) then begin
begin match id_mod with
| Some id_mod when not (Ident.Set.mem id_mod !ids) ->
ids := Ident.Set.remove id_exp !ids
| _ -> ()
end
| _ -> assert false
end

23
typing/printtyp.ml
View File

@ -1622,15 +1622,22 @@ let rec tree_of_modtype ?(ellipsis=false) = function
| Mty_signature sg ->
Omty_signature (if ellipsis then [Osig_ellipsis]
else tree_of_signature sg)
| Mty_functor(param, ty_arg, ty_res) ->
let res =
match ty_arg with None -> tree_of_modtype ~ellipsis ty_res
| Some mty ->
wrap_env (Env.add_module ~arg:true param Mp_present mty)
(tree_of_modtype ~ellipsis) ty_res
| Mty_functor(param, ty_res) ->
let param, res =
match param with
| Unit -> None, tree_of_modtype ~ellipsis ty_res
| Named (param, ty_arg) ->
let name, env =
match param with
| None -> None, fun env -> env
| Some id ->
Some (Ident.name id),
Env.add_module ~arg:true id Mp_present ty_arg
in
Some (name, tree_of_modtype ~ellipsis:false ty_arg),
wrap_env env (tree_of_modtype ~ellipsis) ty_res
in
Omty_functor (Ident.name param,
Option.map (tree_of_modtype ~ellipsis:false) ty_arg, res)
Omty_functor (param, res)
| Mty_alias p ->
Omty_alias (tree_of_path Module p)

30
typing/printtyped.ml
View File

@ -43,6 +43,10 @@ let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;;
let fmt_ident = Ident.print
let fmt_modname f = function
| None -> fprintf f "_";
| Some id -> Ident.print f id
let rec fmt_path_aux f x =
match x with
| Path.Pident (s) -> fprintf f "%a" fmt_ident s;
@ -389,7 +393,7 @@ and expression i ppf x =
line i ppf "Texp_override\n";
list i string_x_expression ppf l;
| Texp_letmodule (s, _, _, me, e) ->
line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s;
line i ppf "Texp_letmodule \"%a\"\n" fmt_modname s;
module_expr i ppf me;
expression i ppf e;
| Texp_letexception (cd, e) ->
@ -668,9 +672,12 @@ and module_type i ppf x =
| Tmty_signature (s) ->
line i ppf "Tmty_signature\n";
signature i ppf s;
| Tmty_functor (s, _, mt1, mt2) ->
line i ppf "Tmty_functor \"%a\"\n" fmt_ident s;
Option.iter (module_type i ppf) mt1;
| Tmty_functor (Unit, mt2) ->
line i ppf "Tmty_functor ()\n";
module_type i ppf mt2;
| Tmty_functor (Named (s, _, mt1), mt2) ->
line i ppf "Tmty_functor \"%a\"\n" fmt_modname s;
module_type i ppf mt1;
module_type i ppf mt2;
| Tmty_with (mt, l) ->
line i ppf "Tmty_with\n";
@ -702,7 +709,7 @@ and signature_item i ppf x =
line i ppf "Tsig_exception\n";
type_exception i ppf ext
| Tsig_module md ->
line i ppf "Tsig_module \"%a\"\n" fmt_ident md.md_id;
line i ppf "Tsig_module \"%a\"\n" fmt_modname md.md_id;
attributes i ppf md.md_attributes;
module_type i ppf md.md_type
| Tsig_modsubst ms ->
@ -735,12 +742,12 @@ and signature_item i ppf x =
attribute i ppf "Tsig_attribute" a
and module_declaration i ppf md =
line i ppf "%a" fmt_ident md.md_id;
line i ppf "%a" fmt_modname md.md_id;
attributes i ppf md.md_attributes;
module_type (i+1) ppf md.md_type;
and module_binding i ppf x =
line i ppf "%a\n" fmt_ident x.mb_id;
line i ppf "%a\n" fmt_modname x.mb_id;
attributes i ppf x.mb_attributes;
module_expr (i+1) ppf x.mb_expr
@ -768,9 +775,12 @@ and module_expr i ppf x =
| Tmod_structure (s) ->
line i ppf "Tmod_structure\n";
structure i ppf s;
| Tmod_functor (s, _, mt, me) ->
line i ppf "Tmod_functor \"%a\"\n" fmt_ident s;
Option.iter (module_type i ppf) mt;
| Tmod_functor (Unit, me) ->
line i ppf "Tmod_functor ()\n";
module_expr i ppf me;
| Tmod_functor (Named (s, _, mt), me) ->
line i ppf "Tmod_functor \"%a\"\n" fmt_modname s;
module_type i ppf mt;
module_expr i ppf me;
| Tmod_apply (me1, me2, _) ->
line i ppf "Tmod_apply\n";

28
typing/rec_check.ml
View File

@ -854,7 +854,7 @@ and modexp : Typedtree.module_expr -> term_judg =
path pth
| Tmod_structure s ->
structure s
| Tmod_functor (_, _, _, e) ->
| Tmod_functor (_, e) ->
modexp e << Delay
| Tmod_apply (f, p, _) ->
join [
@ -984,15 +984,21 @@ and structure_item : Typedtree.structure_item -> bind_judg =
Env.join (modexp mexp m) (Env.remove_list included_ids env)
(* G |- module M = E : m -| G *)
and module_binding : (Ident.t * Typedtree.module_expr) -> bind_judg =
and module_binding : (Ident.t option * Typedtree.module_expr) -> bind_judg =
fun (id, mexp) m env ->
(*
GE |- E: m[mM + Guard]
-------------------------------------
GE + G |- module M = E : m -| M:mM, G
*)
let mM, env = Env.take id env in
let judg_E = modexp mexp << (Mode.join mM Guard) in
let judg_E, env =
match id with
| None -> modexp mexp << Ignore, env
| Some id ->
let mM, env = Env.take id env in
let judg_E = modexp mexp << (Mode.join mM Guard) in
judg_E, env
in
Env.join (judg_E m) env
and open_declaration : Typedtree.open_declaration -> bind_judg =
@ -1002,12 +1008,18 @@ and open_declaration : Typedtree.open_declaration -> bind_judg =
Env.join (judg_E m) (Env.remove_list bound_ids env)
and recursive_module_bindings
: (Ident.t * Typedtree.module_expr) list -> bind_judg =
: (Ident.t option * Typedtree.module_expr) list -> bind_judg =
fun m_bindings m env ->
let mids = List.map fst m_bindings in
let mids = List.filter_map fst m_bindings in
let binding (mid, mexp) m =
let mM = Env.find mid env in
Env.remove_list mids (modexp mexp Mode.(compose m (join mM Guard)))
let judg_E =
match mid with
| None -> modexp mexp << Ignore
| Some mid ->
let mM = Env.find mid env in
modexp mexp << (Mode.join mM Guard)
in
Env.remove_list mids (judg_E m)
in
Env.join (list binding m_bindings m) (Env.remove_list mids env)

10
typing/subst.ml
View File

@ -458,10 +458,14 @@ let rec modtype scoping s = function
end
| Mty_signature sg ->
Mty_signature(signature scoping s sg)
| Mty_functor(id, arg, res) ->
| Mty_functor(Unit, res) ->
Mty_functor(Unit, modtype scoping s res)
| Mty_functor(Named (None, arg), res) ->
Mty_functor(Named (None, (modtype scoping s) arg), modtype scoping s res)
| Mty_functor(Named (Some id, arg), res) ->
let id' = Ident.rename id in
Mty_functor(id', Option.map (modtype scoping s) arg,
modtype scoping (add_module id (Pident id') s) res)
Mty_functor(Named (Some id', (modtype scoping s) arg),
modtype scoping (add_module id (Pident id') s) res)
| Mty_alias p ->
Mty_alias (module_path s p)

12
typing/tast_iterator.ml
View File

@ -288,14 +288,18 @@ let signature_item sub {sig_desc; sig_env; _} =
let class_description sub x =
class_infos sub (sub.class_type sub) x
let functor_parameter sub = function
| Unit -> ()
| Named (_, _, mtype) -> sub.module_type sub mtype
let module_type sub {mty_desc; mty_env; _} =
sub.env sub mty_env;
match mty_desc with
| Tmty_ident _ -> ()
| Tmty_alias _ -> ()
| Tmty_signature sg -> sub.signature sub sg
| Tmty_functor (_, _, mtype1, mtype2) ->
Option.iter (sub.module_type sub) mtype1;
| Tmty_functor (arg, mtype2) ->
functor_parameter sub arg;
sub.module_type sub mtype2
| Tmty_with (mtype, list) ->
sub.module_type sub mtype;
@ -332,8 +336,8 @@ let module_expr sub {mod_desc; mod_env; _} =
match mod_desc with
| Tmod_ident _ -> ()
| Tmod_structure st -> sub.structure sub st
| Tmod_functor (_, _, mtype, mexpr) ->
Option.iter (sub.module_type sub) mtype;
| Tmod_functor (arg, mexpr) ->
functor_parameter sub arg;
sub.module_expr sub mexpr
| Tmod_apply (mexp1, mexp2, c) ->
sub.module_expr sub mexp1;

22
typing/tast_mapper.ml
View File

@ -426,6 +426,10 @@ let signature_item sub x =
let class_description sub x =
class_infos sub (sub.class_type sub) x
let functor_parameter sub = function
| Unit -> Unit
| Named (id, s, mtype) -> Named (id, s, sub.module_type sub mtype)
let module_type sub x =
let mty_env = sub.env sub x.mty_env in
let mty_desc =
@ -433,13 +437,8 @@ let module_type sub x =
| Tmty_ident _
| Tmty_alias _ as d -> d
| Tmty_signature sg -> Tmty_signature (sub.signature sub sg)
| Tmty_functor (id, s, mtype1, mtype2) ->
Tmty_functor (
id,
s,
Option.map (sub.module_type sub) mtype1,
sub.module_type sub mtype2
)
| Tmty_functor (arg, mtype2) ->
Tmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
| Tmty_with (mtype, list) ->
Tmty_with (
sub.module_type sub mtype,
@ -484,13 +483,8 @@ let module_expr sub x =
match x.mod_desc with
| Tmod_ident _ as d -> d
| Tmod_structure st -> Tmod_structure (sub.structure sub st)
| Tmod_functor (id, s, mtype, mexpr) ->
Tmod_functor (
id,
s,
Option.map (sub.module_type sub) mtype,
sub.module_expr sub mexpr
)
| Tmod_functor (arg, mexpr) ->
Tmod_functor (functor_parameter sub arg, sub.module_expr sub mexpr)
| Tmod_apply (mexp1, mexp2, c) ->
Tmod_apply (
sub.module_expr sub mexp1,

36
typing/typecore.ml
View File

@ -1068,14 +1068,26 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode
| Ppat_unpack name ->
assert (constrs = None);
let t = instance expected_ty in
let id = enter_variable loc name t ~is_module:true sp.ppat_attributes in
rp k {
pat_desc = Tpat_var (id, name);
pat_loc = sp.ppat_loc;
pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
pat_type = t;
pat_attributes = [];
pat_env = !env }
begin match name.txt with
| None ->
rp k {
pat_desc = Tpat_any;
pat_loc = sp.ppat_loc;
pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes];
pat_type = t;
pat_attributes = [];
pat_env = !env }
| Some s ->
let v = { name with txt = s } in
let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in
rp k {
pat_desc = Tpat_var (id, v);
pat_loc = sp.ppat_loc;
pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
pat_type = t;
pat_attributes = [];
pat_env = !env }
end
| Ppat_constraint(
{ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs},
({ptyp_desc=Ptyp_poly _} as sty)) ->
@ -1992,7 +2004,7 @@ let create_package_type loc env (p, l) =
(fun sexp (name, loc) ->
Exp.letmodule ~loc:{ sexp.pexp_loc with loc_ghost = true }
~attrs:[Attr.mk (mknoloc "#modulepat") (PStr [])]
name
{ name with txt = Some name.txt }
(Mod.unpack ~loc
(Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)
name.loc)))
@ -2983,7 +2995,11 @@ and type_expect_
{ md_type = modl.mod_type; md_attributes = []; md_loc = name.loc }
in
let (id, new_env) =
Env.enter_module_declaration ~scope name.txt pres md env
match name.txt with
| None -> None, env
| Some name ->
let id, env = Env.enter_module_declaration ~scope name pres md env in
Some id, env
in
Typetexp.widen context;
(* ideally, we should catch Expr_type_clash errors

19
typing/typedtree.ml
View File

@ -106,7 +106,8 @@ and expression_desc =
| Texp_setinstvar of Path.t * Path.t * string loc * expression
| Texp_override of Path.t * (Path.t * string loc * expression) list
| Texp_letmodule of
Ident.t * string loc * Types.module_presence * module_expr * expression
Ident.t option * string option loc * Types.module_presence * module_expr *
expression
| Texp_letexception of extension_constructor * expression
| Texp_assert of expression
| Texp_lazy of expression
@ -217,10 +218,14 @@ and module_type_constraint =
Tmodtype_implicit
| Tmodtype_explicit of module_type
and functor_parameter =
| Unit
| Named of Ident.t option * string option loc * module_type
and module_expr_desc =
Tmod_ident of Path.t * Longident.t loc
| Tmod_structure of structure
| Tmod_functor of Ident.t * string loc * module_type option * module_expr
| Tmod_functor of functor_parameter * module_expr
| Tmod_apply of module_expr * module_expr * module_coercion
| Tmod_constraint of
module_expr * Types.module_type * module_type_constraint * module_coercion
@ -256,8 +261,8 @@ and structure_item_desc =
and module_binding =
{
mb_id: Ident.t;
mb_name: string loc;
mb_id: Ident.t option;
mb_name: string option loc;
mb_presence: module_presence;
mb_expr: module_expr;
mb_attributes: attribute list;
@ -291,7 +296,7 @@ and module_type =
and module_type_desc =
Tmty_ident of Path.t * Longident.t loc
| Tmty_signature of signature
| Tmty_functor of Ident.t * string loc * module_type option * module_type
| Tmty_functor of functor_parameter * module_type
| Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
| Tmty_typeof of module_expr
| Tmty_alias of Path.t * Longident.t loc
@ -334,8 +339,8 @@ and signature_item_desc =
and module_declaration =
{
md_id: Ident.t;
md_name: string loc;
md_id: Ident.t option;
md_name: string option loc;
md_presence: module_presence;
md_type: module_type;
md_attributes: attribute list;

19
typing/typedtree.mli
View File

@ -221,7 +221,8 @@ and expression_desc =
| Texp_setinstvar of Path.t * Path.t * string loc * expression
| Texp_override of Path.t * (Path.t * string loc * expression) list
| Texp_letmodule of
Ident.t * string loc * Types.module_presence * module_expr * expression
Ident.t option * string option loc * Types.module_presence * module_expr *
expression
| Texp_letexception of extension_constructor * expression
| Texp_assert of expression
| Texp_lazy of expression
@ -338,10 +339,14 @@ and module_type_constraint =
| Tmodtype_explicit of module_type
(** The module type was in the source file. *)
and functor_parameter =
| Unit
| Named of Ident.t option * string option loc * module_type
and module_expr_desc =
Tmod_ident of Path.t * Longident.t loc
| Tmod_structure of structure
| Tmod_functor of Ident.t * string loc * module_type option * module_expr
| Tmod_functor of functor_parameter * module_expr
| Tmod_apply of module_expr * module_expr * module_coercion
| Tmod_constraint of
module_expr * Types.module_type * module_type_constraint * module_coercion
@ -380,8 +385,8 @@ and structure_item_desc =
and module_binding =
{
mb_id: Ident.t;
mb_name: string loc;
mb_id: Ident.t option;
mb_name: string option loc;
mb_presence: module_presence;
mb_expr: module_expr;
mb_attributes: attributes;
@ -415,7 +420,7 @@ and module_type =
and module_type_desc =
Tmty_ident of Path.t * Longident.t loc
| Tmty_signature of signature
| Tmty_functor of Ident.t * string loc * module_type option * module_type
| Tmty_functor of functor_parameter * module_type
| Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
| Tmty_typeof of module_expr
| Tmty_alias of Path.t * Longident.t loc
@ -457,8 +462,8 @@ and signature_item_desc =
and module_declaration =
{
md_id: Ident.t;
md_name: string loc;
md_id: Ident.t option;
md_name: string option loc;
md_presence: module_presence;
md_type: module_type;
md_attributes: attributes;

365
typing/typemod.ml
View File

@ -307,11 +307,18 @@ let iterator_with_env env =
env := env_before
);
Btype.it_module_type = (fun self -> function
| Mty_functor (param, mty_arg, mty_body) ->
Option.iter (self.Btype.it_module_type self) mty_arg;
| Mty_functor (param, mty_body) ->
let env_before = !env in
env := lazy (Env.add_module ~arg:true param Mp_present
(Btype.default_mty mty_arg) (Lazy.force env_before));
begin match param with
| Unit -> ()
| Named (param, mty_arg) ->
self.Btype.it_module_type self mty_arg;
match param with
| None -> ()
| Some id ->
env := lazy (Env.add_module ~arg:true id Mp_present
mty_arg (Lazy.force env_before))
end;
self.Btype.it_module_type self mty_body;
env := env_before;
| mty ->
@ -324,7 +331,7 @@ let retype_applicative_functor_type ~loc env funct arg =
let mty_arg = (Env.find_module arg env).md_type in
let mty_param =
match Env.scrape_alias env mty_functor with
| Mty_functor (_, Some mty_param, _) -> mty_param
| Mty_functor (Named (_, mty_param), _) -> mty_param
| _ -> assert false (* could trigger due to MPR#7611 *)
in
Includemod.check_modtype_inclusion ~loc env mty_arg arg mty_param
@ -685,16 +692,24 @@ let rec approx_modtype env smty =
Mty_alias(path)
| Pmty_signature ssg ->
Mty_signature(approx_sig env ssg)
| Pmty_functor(param, sarg, sres) ->
let arg = Option.map (approx_modtype env) sarg in
let rarg = Mtype.scrape_for_functor_arg env (Btype.default_mty arg) in
let scope = Ctype.create_scope () in
let (id, newenv) =
Env.enter_module ~scope ~arg:true param.txt
Mp_present rarg env
| Pmty_functor(param, sres) ->
let (param, newenv) =
match param with
| Unit -> Types.Unit, env
| Named (param, sarg) ->
let arg = approx_modtype env sarg in
match param.txt with
| None -> Types.Named (None, arg), env
| Some name ->
let rarg = Mtype.scrape_for_functor_arg env arg in
let scope = Ctype.create_scope () in
let (id, newenv) =
Env.enter_module ~scope ~arg:true name Mp_present rarg env
in
Types.Named (Some id, arg), newenv
in
let res = approx_modtype newenv sres in
Mty_functor(id, arg, res)
Mty_functor(param, res)
| Pmty_with(sbody, constraints) ->
let body = approx_modtype env sbody in
List.iter
@ -734,6 +749,8 @@ and approx_sig env ssg =
map_rec_type ~rec_flag
(fun rs (id, info) -> Sig_type(id, info, rs, Exported)) decls rem
| Psig_typesubst _ -> approx_sig env srem
| Psig_module { pmd_name = { txt = None; _ }; _ } ->
approx_sig env srem
| Psig_module pmd ->
let scope = Ctype.create_scope () in
let md = approx_module_declaration env pmd in
@ -743,7 +760,8 @@ and approx_sig env ssg =
| _ -> Mp_present
in
let id, newenv =
Env.enter_module_declaration ~scope pmd.pmd_name.txt pres md env
Env.enter_module_declaration ~scope (Option.get pmd.pmd_name.txt)
pres md env
in
Sig_module(id, pres, md, Trec_not, Exported) :: approx_sig newenv srem
| Psig_modsubst pms ->
@ -764,10 +782,12 @@ and approx_sig env ssg =
| Psig_recmodule sdecls ->
let scope = Ctype.create_scope () in
let decls =
List.map
List.filter_map
(fun pmd ->
(Ident.create_scoped ~scope pmd.pmd_name.txt,
approx_module_declaration env pmd)
Option.map (fun name ->
Ident.create_scoped ~scope name,
approx_module_declaration env pmd
) pmd.pmd_name.txt
)
sdecls
in
@ -1115,17 +1135,28 @@ and transl_modtype_aux env smty =
let sg = transl_signature env ssg in
mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
smty.pmty_attributes
| Pmty_functor(param, sarg, sres) ->
let arg = Option.map (transl_modtype_functor_arg env) sarg in
let ty_arg = Option.map (fun m -> m.mty_type) arg in
let scope = Ctype.create_scope () in
let (id, newenv) =
Env.enter_module ~scope ~arg:true
param.txt Mp_present (Btype.default_mty ty_arg) env
| Pmty_functor(sarg_opt, sres) ->
let t_arg, ty_arg, newenv =
match sarg_opt with
| Unit -> Unit, Types.Unit, env
| Named (param, sarg) ->
let arg = transl_modtype_functor_arg env sarg in
let (id, newenv) =
match param.txt with
| None -> None, env
| Some name ->
let scope = Ctype.create_scope () in
let id, newenv =
Env.enter_module ~scope ~arg:true name Mp_present arg.mty_type
env
in
Some id, newenv
in
Named (id, param, arg), Types.Named (id, arg.mty_type), newenv
in
let res = transl_modtype newenv sres in
mkmty (Tmty_functor (id, param, arg, res))
(Mty_functor(id, ty_arg, res.mty_type)) env loc
mkmty (Tmty_functor (t_arg, res))
(Mty_functor(ty_arg, res.mty_type)) env loc
smty.pmty_attributes
| Pmty_with(sbody, constraints) ->
let body = transl_modtype env sbody in
@ -1254,16 +1285,24 @@ and transl_signature env sg =
}
in
let id, newenv =
Env.enter_module_declaration ~scope pmd.pmd_name.txt pres md env
match pmd.pmd_name.txt with
| None -> None, env
| Some name ->
let id, newenv =
Env.enter_module_declaration ~scope name pres md env
in
Signature_names.check_module names pmd.pmd_name.loc id;
Some id, newenv
in
Signature_names.check_module names pmd.pmd_name.loc id;
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name;
md_presence=pres; md_type=tmty;
md_loc=pmd.pmd_loc;
md_attributes=pmd.pmd_attributes})
env loc :: trem,
Sig_module(id, pres, md, Trec_not, Exported) :: rem,
(match id with
| None -> rem
| Some id -> Sig_module(id, pres, md, Trec_not, Exported) :: rem),
final_env
| Psig_modsubst pms ->
let scope = Ctype.create_scope () in
@ -1301,19 +1340,26 @@ and transl_signature env sg =
rem,
final_env
| Psig_recmodule sdecls ->
let (decls, newenv) =
let (tdecls, newenv) =
transl_recmodule_modtypes env sdecls in
let decls =
List.filter_map (fun md ->
match md.md_id with
| None -> None
| Some id -> Some (id, md)
) tdecls
in
List.iter
(fun md -> Signature_names.check_module names md.md_loc md.md_id)
(fun (id, md) -> Signature_names.check_module names md.md_loc id)
decls;
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_recmodule decls) env loc :: trem,
map_rec (fun rs md ->
mksig (Tsig_recmodule tdecls) env loc :: trem,
map_rec (fun rs (id, md) ->
let d = {Types.md_type = md.md_type.mty_type;
md_attributes = md.md_attributes;
md_loc = md.md_loc;
} in
Sig_module(md.md_id, Mp_present, d, rs, Exported))
Sig_module(id, Mp_present, d, rs, Exported))
decls rem,
final_env
| Psig_modtype pmtd ->
@ -1459,12 +1505,16 @@ and transl_recmodule_modtypes env sdecls =
let make_env curr =
List.fold_left
(fun env (id, _, mty) ->
Env.add_module ~arg:true id Mp_present mty env)
Option.fold ~none:env
~some:(fun id -> Env.add_module ~arg:true id Mp_present mty env) id)
env curr in
let make_env2 curr =
List.fold_left
(fun env (id, _, mty) ->
Env.add_module ~arg:true id Mp_present mty.mty_type env)
Option.fold ~none:env
~some:(fun id ->
Env.add_module ~arg:true id Mp_present mty.mty_type env
) id)
env curr in
let transition env_c curr =
List.map2
@ -1475,22 +1525,27 @@ and transl_recmodule_modtypes env sdecls =
in
(id, id_loc, tmty))
sdecls curr in
let map_mtys = List.map
let map_mtys =
List.filter_map
(fun (id, _, mty) ->
(id, Types.{md_type = mty.mty_type;
md_loc = mty.mty_loc;
md_attributes = mty.mty_attributes})) in
Option.map (fun id ->
(id, Types.{md_type = mty.mty_type;
md_loc = mty.mty_loc;
md_attributes = mty.mty_attributes})
) id)
in
let scope = Ctype.create_scope () in
let ids =
List.map (fun x -> Ident.create_scoped ~scope x.pmd_name.txt) sdecls
List.map (fun x -> Option.map (Ident.create_scoped ~scope) x.pmd_name.txt)
sdecls
in
let approx_env =
List.fold_left
(fun env id ->
(* cf #5965 *)
Env.enter_unbound_module (Ident.name id)
Mod_unbound_illegal_recursion env
)
(fun env ->
Option.fold ~none:env ~some:(fun id -> (* cf #5965 *)
Env.enter_unbound_module (Ident.name id)
Mod_unbound_illegal_recursion env
))
env ids
in
let init =
@ -1550,9 +1605,13 @@ let rec closed_modtype env = function
| Mty_signature sg ->
let env = Env.add_signature sg env in
List.for_all (closed_signature_item env) sg
| Mty_functor(id, param, body) ->
| Mty_functor(arg_opt, body) ->
let env =
Env.add_module ~arg:true id Mp_present (Btype.default_mty param) env
match arg_opt with
| Unit
| Named (None, _) -> env
| Named (Some id, param) ->
Env.add_module ~arg:true id Mp_present param env
in
closed_modtype env body
@ -1577,9 +1636,14 @@ let check_nongen_schemes env sg =
(* Helpers for typing recursive modules *)
let anchor_submodule name anchor =
match anchor with None -> None | Some p -> Some(Pdot(p, name))
let anchor_recmodule id =
Some (Pident id)
match anchor, name with
| None, _
| _, None ->
None
| Some p, Some name ->
Some(Pdot(p, name))
let anchor_recmodule = Option.map (fun id -> Pident id)
let enrich_type_decls anchor decls oldenv newenv =
match anchor with
@ -1596,9 +1660,12 @@ let enrich_type_decls anchor decls oldenv newenv =
oldenv decls
let enrich_module_type anchor name mty env =
match anchor with
None -> mty
| Some p -> Mtype.enrich_modtype env (Pdot(p, name)) mty
match anchor, name with
| None, _
| _, None ->
mty
| Some p, Some name ->
Mtype.enrich_modtype env (Pdot(p, name)) mty
let check_recmodule_inclusion env bindings =
(* PR#4450, PR#4470: consider
@ -1622,8 +1689,13 @@ let check_recmodule_inclusion env bindings =
the number of mutually recursive declarations. *)
let subst_and_strengthen env scope s id mty =
Mtype.strengthen ~aliasable:false env (Subst.modtype (Rescope scope) s mty)
(Subst.module_path s (Pident id)) in
let mty = Subst.modtype (Rescope scope) s mty in
match id with
| None -> mty
| Some id ->
Mtype.strengthen ~aliasable:false env mty
(Subst.module_path s (Pident id))
in
let rec check_incl first_time n env s =
let scope = Ctype.create_scope () in
@ -1631,32 +1703,42 @@ let check_recmodule_inclusion env bindings =
(* Generate fresh names Y_i for the rec. bound module idents X_i *)
let bindings1 =
List.map
(fun (id, name, _mty_decl, _modl, mty_actual, _attrs, _loc) ->
(id, Ident.create_scoped ~scope name.txt, mty_actual))
(fun (id, _name, _mty_decl, _modl, mty_actual, _attrs, _loc) ->
let ids =
Option.map
(fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id
in
(ids, mty_actual))
bindings in
(* Enter the Y_i in the environment with their actual types substituted
by the input substitution s *)
let env' =
List.fold_left
(fun env (id, id', mty_actual) ->
let mty_actual' =
if first_time
then mty_actual
else subst_and_strengthen env scope s id mty_actual in
Env.add_module ~arg:false id' Mp_present mty_actual' env)
(fun env (ids, mty_actual) ->
match ids with
| None -> env
| Some (id, id') ->
let mty_actual' =
if first_time
then mty_actual
else subst_and_strengthen env scope s (Some id) mty_actual
in
Env.add_module ~arg:false id' Mp_present mty_actual' env)
env bindings1 in
(* Build the output substitution Y_i <- X_i *)
let s' =
List.fold_left
(fun s (id, id', _mty_actual) ->
Subst.add_module id (Pident id') s)
(fun s (ids, _mty_actual) ->
match ids with
| None -> s
| Some (id, id') -> Subst.add_module id (Pident id') s)
Subst.identity bindings1 in
(* Recurse with env' and s' *)
check_incl false (n-1) env' s'
end else begin
(* Base case: check inclusion of s(mty_actual) in s(mty_decl)
and insert coercion if needed *)
let check_inclusion (id, id_loc, mty_decl, modl, mty_actual, attrs, loc) =
let check_inclusion (id, name, mty_decl, modl, mty_actual, attrs, loc) =
let mty_decl' = Subst.modtype (Rescope scope) s mty_decl.mty_type
and mty_actual' = subst_and_strengthen env scope s id mty_actual in
let coercion =
@ -1674,7 +1756,7 @@ let check_recmodule_inclusion env bindings =
} in
{
mb_id = id;
mb_name = id_loc;
mb_name = name;
mb_presence = Mp_present;
mb_expr = modl';
mb_attributes = attrs;
@ -1807,20 +1889,28 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
if List.length sg' = List.length sg then md else
wrap_constraint env false md (Mty_signature sg')
Tmodtype_implicit
| Pmod_functor(name, smty, sbody) ->
let mty = Option.map (transl_modtype_functor_arg env) smty in
let ty_arg = Option.map (fun m -> m.mty_type) mty in
let scope = Ctype.create_scope () in
let (id, newenv), funct_body =
match ty_arg with
| None -> (Ident.create_scoped ~scope "*", env), false
| Some mty ->
Env.enter_module ~scope ~arg:true name.txt Mp_present mty env,
true
| Pmod_functor(arg_opt, sbody) ->
let t_arg, ty_arg, newenv, funct_body =
match arg_opt with
| Unit -> Unit, Types.Unit, env, false
| Named (name, smty) ->
let mty = transl_modtype_functor_arg env smty in
let scope = Ctype.create_scope () in
let (id, newenv) =
match name.txt with
| None -> None, env
| Some name ->
let id, newenv =
Env.enter_module ~scope ~arg:true name Mp_present mty.mty_type
env
in
Some id, newenv
in
Named (id, name, mty), Types.Named (id, mty.mty_type), newenv, true
in
let body = type_module sttn funct_body None newenv sbody in
rm { mod_desc = Tmod_functor(id, name, mty, body);
mod_type = Mty_functor(id, ty_arg, body.mod_type);
rm { mod_desc = Tmod_functor(t_arg, body);
mod_type = Mty_functor(ty_arg, body.mod_type);
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
@ -1830,15 +1920,17 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
let funct =
type_module (sttn && path <> None) funct_body None env sfunct in
begin match Env.scrape_alias env funct.mod_type with
Mty_functor(param, mty_param, mty_res) as mty_functor ->
let generative, mty_param =
(mty_param = None, Btype.default_mty mty_param) in
if generative then begin
if sarg.pmod_desc <> Pmod_structure [] then
raise (Error (sfunct.pmod_loc, env, Apply_generative));
if funct_body && Mtype.contains_type env funct.mod_type then
raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
end;
| Mty_functor (Unit, mty_res) ->
if sarg.pmod_desc <> Pmod_structure [] then
raise (Error (sfunct.pmod_loc, env, Apply_generative));
if funct_body && Mtype.contains_type env funct.mod_type then
raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
rm { mod_desc = Tmod_apply(funct, arg, Tcoerce_none);
mod_type = mty_res;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| Mty_functor (Named (param, mty_param), mty_res) as mty_functor ->
let coercion =
try
Includemod.modtypes ~loc:sarg.pmod_loc env arg.mod_type mty_param
@ -1846,23 +1938,29 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
raise(Error(sarg.pmod_loc, env, Not_included msg)) in
let mty_appl =
match path with
Some path ->
| Some path ->
let scope = Ctype.create_scope () in
Subst.modtype (Rescope scope)
(Subst.add_module param path Subst.identity)
mty_res
| None ->
if generative then mty_res else
let env =
Env.add_module ~arg:true param Mp_present arg.mod_type env
let subst =
match param with
| None -> Subst.identity
| Some p -> Subst.add_module p path Subst.identity
in
check_well_formed_module env smod.pmod_loc
"the signature of this functor application" mty_res;
let nondep_mty =
try Mtype.nondep_supertype env [param] mty_res
with Ctype.Nondep_cannot_erase _ ->
raise(Error(smod.pmod_loc, env,
Cannot_eliminate_dependency mty_functor))
Subst.modtype (Rescope scope) subst mty_res
| None ->
let env, nondep_mty =
match param with
| None -> env, mty_res
| Some param ->
let env =
Env.add_module ~arg:true param Mp_present arg.mod_type
env
in
check_well_formed_module env smod.pmod_loc
"the signature of this functor application" mty_res;
try env, Mtype.nondep_supertype env [param] mty_res
with Ctype.Nondep_cannot_erase _ ->
raise(Error(smod.pmod_loc, env,
Cannot_eliminate_dependency mty_functor))
in
begin match
Includemod.modtypes ~loc:smod.pmod_loc env mty_res nondep_mty
@ -2096,17 +2194,22 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
in
(*prerr_endline (Ident.unique_toplevel_name id);*)
Mtype.lower_nongen outer_scope md.md_type;
let id, newenv =
Env.enter_module_declaration ~scope name.txt pres md env
let id, newenv, sg =
match name.txt with
| None -> None, env, []
| Some name ->
let id, e = Env.enter_module_declaration ~scope name pres md env in
Signature_names.check_module names pmb_loc id;
Some id, e,
[Sig_module(id, pres,
{md_type = modl.mod_type;
md_attributes = attrs;
md_loc = pmb_loc;
}, Trec_not, Exported)]
in
Signature_names.check_module names pmb_loc id;
Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; },
[Sig_module(id, pres,
{md_type = modl.mod_type;
md_attributes = attrs;
md_loc = pmb_loc;
}, Trec_not, Exported)],
sg,
newenv
| Pstr_recmodule sbind ->
let sbind =
@ -2131,7 +2234,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
pmd_attributes=attrs; pmd_loc=loc}) sbind
) in
List.iter
Signature_names.(fun md -> check_module names md.md_loc md.md_id)
(fun md ->
Option.iter Signature_names.(check_module names md.md_loc) md.md_id)
decls;
let bindings1 =
List.map2
@ -2144,35 +2248,42 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
)
in
let mty' =
enrich_module_type anchor (Ident.name id) modl.mod_type newenv
enrich_module_type anchor name.txt modl.mod_type newenv
in
(id, name, mty, modl, mty', attrs, loc))
decls sbind in
let newenv = (* allow aliasing recursive modules from outside *)
List.fold_left
(fun env md ->
let mdecl =
{
md_type = md.md_type.mty_type;
md_attributes = md.md_attributes;
md_loc = md.md_loc;
}
in
Env.add_module_declaration ~check:true
md.md_id Mp_present mdecl env
match md.md_id with
| None -> env
| Some id ->
let mdecl =
{
md_type = md.md_type.mty_type;
md_attributes = md.md_attributes;
md_loc = md.md_loc;
}
in
Env.add_module_declaration ~check:true
id Mp_present mdecl env
)
env decls
in
let bindings2 =
check_recmodule_inclusion newenv bindings1 in
let mbs =
List.filter_map (fun mb -> Option.map (fun id -> id, mb) mb.mb_id)
bindings2
in
Tstr_recmodule bindings2,
map_rec (fun rs mb ->
Sig_module(mb.mb_id, Mp_present, {
map_rec (fun rs (id, mb) ->
Sig_module(id, Mp_present, {
md_type=mb.mb_expr.mod_type;
md_attributes=mb.mb_attributes;
md_loc=mb.mb_loc;
}, rs, Exported))
bindings2 [],
mbs [],
newenv
| Pstr_modtype pmtd ->
(* check that it is non-abstract *)
@ -2313,7 +2424,7 @@ let rec normalize_modtype env = function
Mty_ident _
| Mty_alias _ -> ()
| Mty_signature sg -> normalize_signature env sg
| Mty_functor(_id, _param, body) -> normalize_modtype env body
| Mty_functor(_param, body) -> normalize_modtype env body
and normalize_signature env = List.iter (normalize_signature_item env)

6
typing/types.ml
View File

@ -257,9 +257,13 @@ type visibility =
type module_type =
Mty_ident of Path.t
| Mty_signature of signature
| Mty_functor of Ident.t * module_type option * module_type
| Mty_functor of functor_parameter * module_type
| Mty_alias of Path.t
and functor_parameter =
| Unit
| Named of Ident.t option * module_type
and module_presence =
| Mp_present
| Mp_absent

6
typing/types.mli
View File

@ -412,9 +412,13 @@ type visibility =
type module_type =
Mty_ident of Path.t
| Mty_signature of signature
| Mty_functor of Ident.t * module_type option * module_type
| Mty_functor of functor_parameter * module_type
| Mty_alias of Path.t
and functor_parameter =
| Unit
| Named of Ident.t option * module_type
and module_presence =
| Mp_present
| Mp_absent

24
typing/untypeast.ml
View File

@ -296,8 +296,10 @@ let pattern sub pat =
let attrs = sub.attributes sub pat.pat_attributes in
let desc =
match pat with
{ pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
Ppat_unpack name
{ pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } ->
Ppat_unpack { txt = None; loc }
| { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
Ppat_unpack { name with txt = Some name.txt }
| { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
Ppat_type (map_loc sub lid)
| { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
@ -310,7 +312,7 @@ let pattern sub pat =
begin
match (Ident.name id).[0] with
'A'..'Z' ->
Ppat_unpack name
Ppat_unpack { name with txt = Some name.txt}
| _ ->
Ppat_var name
end
@ -599,6 +601,11 @@ let class_declaration sub = class_infos sub.class_expr sub
let class_description sub = class_infos sub.class_type sub
let class_type_declaration sub = class_infos sub.class_type sub
let functor_parameter sub : functor_parameter -> Parsetree.functor_parameter =
function
| Unit -> Unit
| Named (_, name, mtype) -> Named (name, sub.module_type sub mtype)
let module_type sub mty =
let loc = sub.location sub mty.mty_loc in
let attrs = sub.attributes sub mty.mty_attributes in
@ -606,9 +613,8 @@ let module_type sub mty =
Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid)
| Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid)
| Tmty_signature sg -> Pmty_signature (sub.signature sub sg)
| Tmty_functor (_id, name, mtype1, mtype2) ->
Pmty_functor (name, Option.map (sub.module_type sub) mtype1,
sub.module_type sub mtype2)
| Tmty_functor (arg, mtype2) ->
Pmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
| Tmty_with (mtype, list) ->
Pmty_with (sub.module_type sub mtype,
List.map (sub.with_constraint sub) list)
@ -638,9 +644,9 @@ let module_expr sub mexpr =
let desc = match mexpr.mod_desc with
Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid)
| Tmod_structure st -> Pmod_structure (sub.structure sub st)
| Tmod_functor (_id, name, mtype, mexpr) ->
Pmod_functor (name, Option.map (sub.module_type sub) mtype,
sub.module_expr sub mexpr)
| Tmod_functor (arg, mexpr) ->
Pmod_functor
(functor_parameter sub arg, sub.module_expr sub mexpr)
| Tmod_apply (mexp1, mexp2, _) ->
Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2)
| Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->