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* use String_val as a char* instead of const char*
(Kate Deplaix) (Kate Deplaix)
- #6662, #8908: Add "module _ = X" syntax
(Thomas Refis, review by Gabriel Radanne)
### Internal/compiler-libs changes: ### Internal/compiler-libs changes:
@ -70,6 +72,11 @@ Working version
skipped lines/bytes into account skipped lines/bytes into account
(Gabriel Scherer, review by Sébastien Hinderer) (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 - #8928: Move contains_calls and num_stack_slots from Proc to Mach.fundecl
(Greta Yorsh, review by Florian Angeletti and Vincent Laviron) (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 = type binding =
| Bind_value of value_binding list | 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 = let rec push_defaults loc bindings cases partial =
match cases with match cases with
@ -105,7 +105,7 @@ let rec push_defaults loc bindings cases partial =
| [{c_lhs=pat; c_guard=None; | [{c_lhs=pat; c_guard=None;
c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}]; c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}];
exp_desc = Texp_letmodule exp_desc = Texp_letmodule
(id, name, pres, mexpr, (Some id, name, pres, mexpr,
({exp_desc = Texp_function _} as e2))}}] -> ({exp_desc = Texp_function _} as e2))}}] ->
push_defaults loc (Bind_module (id, name, pres, mexpr) :: bindings) push_defaults loc (Bind_module (id, name, pres, mexpr) :: bindings)
[{c_lhs=pat;c_guard=None;c_rhs=e2}] [{c_lhs=pat;c_guard=None;c_rhs=e2}]
@ -118,7 +118,7 @@ let rec push_defaults loc bindings cases partial =
match binds with match binds with
| Bind_value binds -> Texp_let(Nonrecursive, binds, exp) | Bind_value binds -> Texp_let(Nonrecursive, binds, exp)
| Bind_module (id, name, pres, mexpr) -> | 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 case.c_rhs bindings
in in
[{case with c_rhs=exp}] [{case with c_rhs=exp}]
@ -465,7 +465,10 @@ and transl_exp0 e =
(Lvar cpy) var expr, rem)) (Lvar cpy) var expr, rem))
modifs modifs
(Lvar cpy)) (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 = let defining_expr =
Levent (!transl_module Tcoerce_none None modl, { Levent (!transl_module Tcoerce_none None modl, {
lev_loc = loc.loc; lev_loc = loc.loc;

214
lambda/translmod.ml
View File

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

4
lambda/translmod.mli
View File

@ -48,7 +48,9 @@ type unsafe_component =
| Unsafe_non_function | Unsafe_non_function
| Unsafe_typext | 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 = type error =
Circular_dependency of (Ident.t * unsafe_info) list 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 = let add_to_hashes table table_values tt =
match tt with match tt with
| Typedtree.Tstr_module mb -> | 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 -> | Typedtree.Tstr_recmodule mods ->
List.iter List.iter
(fun mb -> (fun mb ->
Hashtbl.add table (M (Name.from_ident mb.mb_id)) Option.iter (fun id ->
(Typedtree.Tstr_module mb) Hashtbl.add table (M (Name.from_ident id))
(Typedtree.Tstr_module mb)
) mb.mb_id
) )
mods mods
| Typedtree.Tstr_modtype mtd -> | Typedtree.Tstr_modtype mtd ->
@ -1395,15 +1398,18 @@ module Analyser =
in in
(0, new_env, [ Element_exception new_ext ]) (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 *) (* of string * module_expr *)
try 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 let new_module_pre = analyse_module
env env
current_module_name current_module_name
name.txt name
comment_opt comment_opt
module_expr module_expr
tt_module_expr tt_module_expr
@ -1433,7 +1439,7 @@ module Analyser =
(0, new_env2, [ Element_module new_module ]) (0, new_env2, [ Element_module new_module ])
with with
Not_found -> 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)) raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
) )
@ -1443,26 +1449,29 @@ module Analyser =
let new_env = let new_env =
List.fold_left List.fold_left
(fun acc_env {Parsetree.pmb_name=name;pmb_expr=mod_exp} -> (fun acc_env {Parsetree.pmb_name=name;pmb_expr=mod_exp} ->
let complete_name = Name.concat current_module_name name.txt in match name.txt with
let e = Odoc_env.add_module acc_env complete_name in | None -> acc_env
let tt_mod_exp = | Some name ->
try Typedtree_search.search_module table name.txt let complete_name = Name.concat current_module_name name in
with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name)) let e = Odoc_env.add_module acc_env complete_name in
in let tt_mod_exp =
let new_module = analyse_module try Typedtree_search.search_module table name
e with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
current_module_name in
name.txt let new_module = analyse_module
None e
mod_exp current_module_name
tt_mod_exp name
in None
match new_module.m_type with mod_exp
Types.Mty_signature s -> tt_mod_exp
Odoc_env.add_signature e new_module.m_name in
~rel: (Name.simple new_module.m_name) s match new_module.m_type with
| _ -> Types.Mty_signature s ->
e Odoc_env.add_signature e new_module.m_name
~rel: (Name.simple new_module.m_name) s
| _ ->
e
) )
env env
mods mods
@ -1470,12 +1479,23 @@ module Analyser =
let rec f ?(first=false) last_pos name_mod_exp_list = let rec f ?(first=false) last_pos name_mod_exp_list =
match name_mod_exp_list with match name_mod_exp_list with
[] -> [] [] -> []
| {Parsetree.pmb_name=name;pmb_expr=mod_exp} :: q -> | {Parsetree.pmb_name={txt=None};pmb_expr=mod_exp} :: q ->
let complete_name = Name.concat current_module_name name.txt 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 (_, 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_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 loc_end = mod_exp.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
let tt_mod_exp = 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)) with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
in in
let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *) 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 let new_module = analyse_module
new_env new_env
current_module_name current_module_name
name.txt name
com_opt com_opt
mod_exp mod_exp
tt_mod_exp tt_mod_exp
@ -1709,29 +1729,33 @@ module Analyser =
let elements2 = replace_dummy_included_modules elements included_modules_from_tt in let elements2 = replace_dummy_included_modules elements included_modules_from_tt in
{ m_base with m_kind = Module_struct elements2 } { m_base with m_kind = Module_struct elements2 }
| (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2), | (Parsetree.Pmod_functor (param2, p_module_expr2),
Typedtree.Tmod_functor (ident, _, mtyp, tt_module_expr2)) -> Typedtree.Tmod_functor (param, tt_module_expr2)) ->
let loc = match pmodule_type with None -> Location.none let loc, mp_name, mp_kind, mp_type =
| Some pmty -> pmty.Parsetree.pmty_loc in 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_start = loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = loc.Location.loc_end.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 let mp_type_code = get_string_of_file loc_start loc_end in
print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); 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 = let param =
{ {
mp_name = mp_name ; mp_name ;
mp_type = Option.map mp_type ;
(fun m -> Odoc_env.subst_module_type env m.mty_type) mtyp ;
mp_type_code = mp_type_code ; mp_type_code = mp_type_code ;
mp_kind = mp_kind ; mp_kind ;
} }
in in
let dummy_complete_name = (*Name.concat "__"*) param.mp_name 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 subst_module_type env t =
let rec iter t = let rec iter t =
let open Types in
match t with 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 let new_p = Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in
Types.Mty_ident new_p Mty_ident new_p
| Types.Mty_alias _ | Mty_alias _
| Types.Mty_signature _ -> | Mty_signature _ ->
t t
| Types.Mty_functor (id, mt1, mt2) -> | Mty_functor (Unit, mt) -> Mty_functor (Unit, iter mt)
Types.Mty_functor (id, Option.map iter mt1, iter mt2) | Mty_functor (Named (name, mt1), mt2) ->
Mty_functor (Named (name, iter mt1), iter mt2)
in in
iter t iter t

14
ocamldoc/odoc_print.ml
View File

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

151
ocamldoc/odoc_sig.ml
View File

@ -491,10 +491,11 @@ module Analyser =
| [] -> acc | [] -> acc
| types -> take_item (Parsetree.Psig_type (rf, types))) | types -> take_item (Parsetree.Psig_type (rf, types)))
| Parsetree.Psig_modsubst _ -> acc | 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) pmd_type=module_type} as r)
as m -> 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 | exception Not_found -> take_item m
| `Removed -> acc | `Removed -> acc
| `Constrained constraints -> | `Constrained constraints ->
@ -507,9 +508,15 @@ module Analyser =
| Parsetree.Psig_modtype {Parsetree.pmtd_name=name} as m -> | Parsetree.Psig_modtype {Parsetree.pmtd_name=name} as m ->
if is_erased name.txt erased then acc else take_item m if is_erased name.txt erased then acc else take_item m
| Parsetree.Psig_recmodule mods -> | Parsetree.Psig_recmodule mods ->
(match List.filter (fun pmd -> not (is_erased pmd.Parsetree.pmd_name.txt erased)) mods with (match List.filter
| [] -> acc (fun pmd ->
| mods -> take_item (Parsetree.Psig_recmodule mods))) 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 [] signature []
(** Analysis of the elements of a class, from the information in the parsetree and in the class (** 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 *) | Parsetree.Psig_modsubst _ -> (* FIXME *)
(0, env, []) (0, env, [])
| Parsetree.Psig_module {Parsetree.pmd_name=name; pmd_type=module_type} -> | Parsetree.Psig_module {Parsetree.pmd_name={txt=None}} ->
let complete_name = Name.concat current_module_name name.txt in (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 *) (* get the module type in the signature by the module name *)
let sig_module_type = let sig_module_type =
try Signature_search.search_module table name.txt try Signature_search.search_module table name
with Not_found -> 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 in
let module_kind = analyse_module_kind env complete_name module_type sig_module_type in let module_kind = analyse_module_kind env complete_name module_type sig_module_type in
let code_intf = let code_intf =
@ -1193,31 +1203,60 @@ module Analyser =
let new_env = let new_env =
List.fold_left List.fold_left
(fun acc_env {Parsetree.pmd_name={txt=name}} -> (fun acc_env {Parsetree.pmd_name={txt=name}} ->
let complete_name = Name.concat current_module_name name in match name with
let e = Odoc_env.add_module acc_env complete_name in | None -> acc_env
(* get the information for the module in the signature *) | Some name ->
let sig_module_type = let complete_name = Name.concat current_module_name name in
try Signature_search.search_module table name let e = Odoc_env.add_module acc_env complete_name in
with Not_found -> (* get the information for the module in the signature *)
raise (Failure (Odoc_messages.module_not_found current_module_name name)) let sig_module_type =
in try Signature_search.search_module table name
match sig_module_type with with Not_found ->
(* FIXME : can this be a Tmty_ident? in this case, we wouldn't have the signature *) raise (Failure (Odoc_messages.module_not_found current_module_name name))
Types.Mty_signature s -> in
Odoc_env.add_signature e complete_name ~rel: name s match sig_module_type with
| _ -> (* FIXME : can this be a Tmty_ident? in this case, we wouldn't have the signature *)
print_DEBUG "not a Tmty_signature"; Types.Mty_signature s ->
e Odoc_env.add_signature e complete_name ~rel: name s
) | _ ->
env print_DEBUG "not a Tmty_signature";
decls e
)
env
decls
in in
let rec f ?(first=false) acc_maybe_more last_pos name_mtype_list = let rec f ?(first=false) acc_maybe_more last_pos name_mtype_list =
match name_mtype_list with match name_mtype_list with
[] -> [] ->
(acc_maybe_more, []) (acc_maybe_more, [])
| {Parsetree.pmd_name=name; pmd_type=modtype} :: q -> | {Parsetree.pmd_name={txt = None}; pmd_type=modtype} :: q ->
let complete_name = Name.concat current_module_name name.txt in 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 = modtype.Parsetree.pmty_loc in
let loc_start = Loc.start loc in let loc_start = Loc.start loc in
let loc_end = Loc.end_ loc in let loc_end = Loc.end_ loc in
@ -1236,9 +1275,9 @@ module Analyser =
in in
(* get the information for the module in the signature *) (* get the information for the module in the signature *)
let sig_module_type = let sig_module_type =
try Signature_search.search_module table name.txt try Signature_search.search_module table name
with Not_found -> 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 in
(* associate the comments to each constructor and build the [Type.t_type] *) (* 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 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") 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 let loc = match param2 with Parsetree.Unit -> Location.none
| Some pmty -> pmty.Parsetree.pmty_loc in | Parsetree.Named (_, pmty) -> pmty.Parsetree.pmty_loc in
let loc_start = Loc.start loc in let loc_start = Loc.start loc in
let loc_end = Loc.end_ loc in let loc_end = Loc.end_ loc in
let mp_type_code = get_string_of_file loc_start loc_end 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); print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
match sig_module_type with match sig_module_type with
Types.Mty_functor (ident, param_module_type, body_module_type) -> Types.Mty_functor (param, body_module_type) ->
let mp_kind = let mp_name, mp_kind =
match pmodule_type2, param_module_type with match param2, param with
Some pmty, Some mty -> Parsetree.Named (_, pmty), Types.Named (Some ident, mty) ->
Name.from_ident ident,
analyse_module_type_kind env current_module_name pmty mty analyse_module_type_kind env current_module_name pmty mty
| _ -> Module_type_struct [] | _ -> "*", Module_type_struct []
in in
let param = let param =
{ {
mp_name = Name.from_ident ident ; mp_name = mp_name;
mp_type = mp_type =
Option.map (Odoc_env.subst_module_type env) (match param with
param_module_type; | Types.Unit -> None
| Types.Named (_, mty) ->
Some (Odoc_env.subst_module_type env mty));
mp_type_code = mp_type_code ; mp_type_code = mp_type_code ;
mp_kind = mp_kind ; mp_kind = mp_kind ;
} }
@ -1638,27 +1680,30 @@ module Analyser =
(* if we're here something's wrong *) (* if we're here something's wrong *)
raise (Failure "Parsetree.Pmty_signature signature but not Types.Mty_signature signat") 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 match sig_module_type with
Types.Mty_functor (ident, param_module_type, body_module_type) -> Types.Mty_functor (param, body_module_type) ->
let loc = match pmodule_type2 with None -> Location.none let loc = match param2 with Parsetree.Unit -> Location.none
| Some pmty -> pmty.Parsetree.pmty_loc in | Parsetree.Named (_, pmty) -> pmty.Parsetree.pmty_loc in
let loc_start = Loc.start loc in let loc_start = Loc.start loc in
let loc_end = Loc.end_ loc in let loc_end = Loc.end_ loc in
let mp_type_code = get_string_of_file loc_start loc_end 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); print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
let mp_kind = let mp_name, mp_kind =
match pmodule_type2, param_module_type with match param2, param with
Some pmty, Some mty -> Parsetree.Named (_, pmty), Types.Named (Some ident, mty) ->
Name.from_ident ident,
analyse_module_type_kind env current_module_name pmty mty analyse_module_type_kind env current_module_name pmty mty
| _ -> Module_type_struct [] | _ -> "*", Module_type_struct []
in in
let param = let param =
{ {
mp_name = Name.from_ident ident ; mp_name;
mp_type = Option.map mp_type =
(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_type_code = mp_type_code ;
mp_kind = mp_kind ; 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 lid = Longident.t with_loc
type str = string with_loc type str = string with_loc
type str_opt = string option with_loc
type attrs = attribute list type attrs = attribute list
let default_loc = ref Location.none 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 ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a)
let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a)
let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature 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 with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b))
let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a)
let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension 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 ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x)
let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x)
let functor_ ?loc ?attrs arg arg_ty body = let functor_ ?loc ?attrs arg body =
mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) mk ?loc ?attrs (Pmod_functor (arg, body))
let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) 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 constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty))
let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) 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 lid = Longident.t with_loc
type str = string with_loc type str = string with_loc
type str_opt = string option with_loc
type attrs = attribute list type attrs = attribute list
(** {1 Default locations} *) (** {1 Default locations} *)
@ -116,7 +117,7 @@ module Pat:
val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern
val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> 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 open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern
val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
val extension: ?loc:loc -> ?attrs:attrs -> extension -> 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 setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list
-> expression -> expression
val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr
-> expression -> expression -> expression
val letexception: val letexception:
?loc:loc -> ?attrs:attrs -> extension_constructor -> expression ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
-> expression -> expression
@ -246,7 +247,7 @@ module Mty:
val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type
val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
val functor_: ?loc:loc -> ?attrs:attrs -> 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 -> val with_: ?loc:loc -> ?attrs:attrs -> module_type ->
with_constraint list -> module_type with_constraint list -> module_type
val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> 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 ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr
val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr
val functor_: ?loc:loc -> ?attrs:attrs -> 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 -> val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr ->
module_expr module_expr
val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type ->
@ -321,7 +322,7 @@ module Str:
module Md: module Md:
sig sig
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
str -> module_type -> module_declaration str_opt -> module_type -> module_declaration
end end
(** Module substitutions *) (** Module substitutions *)
@ -342,7 +343,7 @@ module Mtd:
module Mb: module Mb:
sig sig
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
str -> module_expr -> module_binding str_opt -> module_expr -> module_binding
end end
(** Opens *) (** Opens *)

16
parsing/ast_iterator.ml
View File

@ -233,6 +233,12 @@ module CT = struct
List.iter (sub.class_type_field sub) pcsig_fields List.iter (sub.class_type_field sub) pcsig_fields
end end
let iter_functor_param sub = function
| Unit -> ()
| Named (name, mty) ->
iter_loc sub name;
sub.module_type sub mty
module MT = struct module MT = struct
(* Type expressions for the module language *) (* Type expressions for the module language *)
@ -243,9 +249,8 @@ module MT = struct
| Pmty_ident s -> iter_loc sub s | Pmty_ident s -> iter_loc sub s
| Pmty_alias s -> iter_loc sub s | Pmty_alias s -> iter_loc sub s
| Pmty_signature sg -> sub.signature sub sg | Pmty_signature sg -> sub.signature sub sg
| Pmty_functor (s, mt1, mt2) -> | Pmty_functor (param, mt2) ->
iter_loc sub s; iter_functor_param sub param;
iter_opt (sub.module_type sub) mt1;
sub.module_type sub mt2 sub.module_type sub mt2
| Pmty_with (mt, l) -> | Pmty_with (mt, l) ->
sub.module_type sub mt; sub.module_type sub mt;
@ -298,9 +303,8 @@ module M = struct
match desc with match desc with
| Pmod_ident x -> iter_loc sub x | Pmod_ident x -> iter_loc sub x
| Pmod_structure str -> sub.structure sub str | Pmod_structure str -> sub.structure sub str
| Pmod_functor (arg, arg_ty, body) -> | Pmod_functor (param, body) ->
iter_loc sub arg; iter_functor_param sub param;
iter_opt (sub.module_type sub) arg_ty;
sub.module_expr sub body sub.module_expr sub body
| Pmod_apply (m1, m2) -> | Pmod_apply (m1, m2) ->
sub.module_expr sub m1; sub.module_expr sub 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) (List.map (sub.class_type_field sub) pcsig_fields)
end 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 module MT = struct
(* Type expressions for the module language *) (* Type expressions for the module language *)
@ -260,10 +264,10 @@ module MT = struct
| Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
| Pmty_alias s -> alias ~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_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
| Pmty_functor (s, mt1, mt2) -> | Pmty_functor (param, mt) ->
functor_ ~loc ~attrs (map_loc sub s) functor_ ~loc ~attrs
(Option.map (sub.module_type sub) mt1) (map_functor_param sub param)
(sub.module_type sub mt2) (sub.module_type sub mt)
| Pmty_with (mt, l) -> | Pmty_with (mt, l) ->
with_ ~loc ~attrs (sub.module_type sub mt) with_ ~loc ~attrs (sub.module_type sub mt)
(List.map (sub.with_constraint sub) l) (List.map (sub.with_constraint sub) l)
@ -318,9 +322,9 @@ module M = struct
match desc with match desc with
| Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
| Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
| Pmod_functor (arg, arg_ty, body) -> | Pmod_functor (param, body) ->
functor_ ~loc ~attrs (map_loc sub arg) functor_ ~loc ~attrs
(Option.map (sub.module_type sub) arg_ty) (map_functor_param sub param)
(sub.module_expr sub body) (sub.module_expr sub body)
| Pmod_apply (m1, m2) -> | Pmod_apply (m1, m2) ->
apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub 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_variant(_, op) -> add_opt add_pattern bv op
| Ppat_type li -> add bv li | Ppat_type li -> add bv li
| Ppat_lazy p -> add_pattern bv p | 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_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p
| Ppat_exception p -> add_pattern bv p | Ppat_exception p -> add_pattern bv p
| Ppat_extension e -> handle_extension e | 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_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
| Pexp_letmodule(id, m, e) -> | Pexp_letmodule(id, m, e) ->
let b = add_module_binding bv m in 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_letexception(_, e) -> add_expr bv e
| Pexp_assert (e) -> add_expr bv e | Pexp_assert (e) -> add_expr bv e
| Pexp_lazy (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_ident l -> add bv l
| Pmty_alias l -> add_module_path bv l | Pmty_alias l -> add_module_path bv l
| Pmty_signature s -> add_signature bv s | Pmty_signature s -> add_signature bv s
| Pmty_functor(id, mty1, mty2) -> | Pmty_functor(param, mty2) ->
Option.iter (add_modtype bv) mty1; let bv =
add_modtype (String.Map.add id.txt bound bv) mty2 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) -> | Pmty_with(mty, cstrl) ->
add_modtype bv mty; add_modtype bv mty;
List.iter List.iter
@ -340,7 +355,11 @@ and add_sig_item (bv, m) item =
add_type_exception bv te; (bv, m) add_type_exception bv te; (bv, m)
| Psig_module pmd -> | Psig_module pmd ->
let m' = add_modtype_binding bv pmd.pmd_type in 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) (add bv, add m)
| Psig_modsubst pms -> | Psig_modsubst pms ->
let m' = add_module_alias bv pms.pms_manifest in 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) (add bv, add m)
| Psig_recmodule decls -> | Psig_recmodule decls ->
let add = let add =
List.fold_right (fun pmd -> String.Map.add pmd.pmd_name.txt bound) List.fold_right (fun pmd map ->
decls match pmd.pmd_name.txt with
| None -> map
| Some name -> String.Map.add name bound map
) decls
in in
let bv' = add bv and m' = add m in let bv' = add bv and m' = add m in
List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls; 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 match modl.pmod_desc with
Pmod_ident l -> add_module_path bv l Pmod_ident l -> add_module_path bv l
| Pmod_structure s -> ignore (add_structure bv s) | Pmod_structure s -> ignore (add_structure bv s)
| Pmod_functor(id, mty, modl) -> | Pmod_functor(param, modl) ->
Option.iter (add_modtype bv) mty; let bv =
add_module_expr (String.Map.add id.txt bound bv) modl 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) -> | Pmod_apply(mod1, mod2) ->
add_module_expr bv mod1; add_module_expr bv mod2 add_module_expr bv mod1; add_module_expr bv mod2
| Pmod_constraint(modl, mty) -> | Pmod_constraint(modl, mty) ->
@ -463,11 +493,19 @@ and add_struct_item (bv, m) item : _ String.Map.t * _ String.Map.t =
(bv, m) (bv, m)
| Pstr_module x -> | Pstr_module x ->
let b = add_module_binding bv x.pmb_expr in 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) (add bv, add m)
| Pstr_recmodule bindings -> | Pstr_recmodule bindings ->
let add = 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 in
let bv' = add bv and m = add m in let bv' = add bv and m = add m in
List.iter List.iter

66
parsing/parser.mly
View File

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

23
parsing/parsetree.mli
View File

@ -238,8 +238,10 @@ and pattern_desc =
(* #tconst *) (* #tconst *)
| Ppat_lazy of pattern | Ppat_lazy of pattern
(* lazy P *) (* lazy P *)
| Ppat_unpack of string loc | Ppat_unpack of string option loc
(* (module P) (* (module P) Some "P"
(module _) None
Note: (module P : S) is represented as Note: (module P : S) is represented as
Ppat_constraint(Ppat_unpack, Ptyp_package) Ppat_constraint(Ppat_unpack, Ptyp_package)
*) *)
@ -346,7 +348,7 @@ and expression_desc =
(* x <- 2 *) (* x <- 2 *)
| Pexp_override of (label loc * expression) list | Pexp_override of (label loc * expression) list
(* {< x1 = E1; ...; Xn = En >} *) (* {< 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 *) (* let module M = ME in E *)
| Pexp_letexception of extension_constructor * expression | Pexp_letexception of extension_constructor * expression
(* let exception C in E *) (* let exception C in E *)
@ -713,7 +715,7 @@ and module_type_desc =
(* S *) (* S *)
| Pmty_signature of signature | Pmty_signature of signature
(* sig ... end *) (* sig ... end *)
| Pmty_functor of string loc * module_type option * module_type | Pmty_functor of functor_parameter * module_type
(* functor(X : MT1) -> MT2 *) (* functor(X : MT1) -> MT2 *)
| Pmty_with of module_type * with_constraint list | Pmty_with of module_type * with_constraint list
(* MT with ... *) (* MT with ... *)
@ -724,6 +726,13 @@ and module_type_desc =
| Pmty_alias of Longident.t loc | Pmty_alias of Longident.t loc
(* (module M) *) (* (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 = signature_item list
and signature_item = and signature_item =
@ -771,7 +780,7 @@ and signature_item_desc =
and module_declaration = and module_declaration =
{ {
pmd_name: string loc; pmd_name: string option loc;
pmd_type: module_type; pmd_type: module_type;
pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
pmd_loc: Location.t; pmd_loc: Location.t;
@ -858,7 +867,7 @@ and module_expr_desc =
(* X *) (* X *)
| Pmod_structure of structure | Pmod_structure of structure
(* struct ... end *) (* struct ... end *)
| Pmod_functor of string loc * module_type option * module_expr | Pmod_functor of functor_parameter * module_expr
(* functor(X : MT1) -> ME *) (* functor(X : MT1) -> ME *)
| Pmod_apply of module_expr * module_expr | Pmod_apply of module_expr * module_expr
(* ME1(ME2) *) (* ME1(ME2) *)
@ -923,7 +932,7 @@ and value_binding =
and module_binding = and module_binding =
{ {
pmb_name: string loc; pmb_name: string option loc;
pmb_expr: module_expr; pmb_expr: module_expr;
pmb_attributes: attributes; pmb_attributes: attributes;
pmb_loc: Location.t; 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_var ({txt = txt;_}) -> protect_ident f txt
| Ppat_array l -> | Ppat_array l ->
pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l
| Ppat_unpack (s) -> | Ppat_unpack { txt = None } ->
pp f "(module@ %s)@ " s.txt pp f "(module@ _)@ "
| Ppat_unpack { txt = Some s } ->
pp f "(module@ %s)@ " s
| Ppat_type li -> | Ppat_type li ->
pp f "#%a" longident_loc li pp f "#%a" longident_loc li
| Ppat_record (l, closed) -> | Ppat_record (l, closed) ->
@ -704,7 +706,8 @@ and expression ctxt f x =
pp f "@[<hov2>{<%a>}@]" pp f "@[<hov2>{<%a>}@]"
(list string_x_expression ~sep:";" ) l; (list string_x_expression ~sep:";" ) l;
| Pexp_letmodule (s, me, e) -> | 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 (module_expr reset_ctxt) me (expression ctxt) e
| Pexp_letexception (cd, e) -> | Pexp_letexception (cd, e) ->
pp f "@[<hov2>let@ exception@ %a@ in@ %a@]" pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
@ -1025,15 +1028,17 @@ and module_type ctxt f x =
(attributes ctxt) x.pmty_attributes (attributes ctxt) x.pmty_attributes
end else end else
match x.pmty_desc with match x.pmty_desc with
| Pmty_functor (_, None, mt2) -> | Pmty_functor (Unit, mt2) ->
pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2 pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
| Pmty_functor (s, Some mt1, mt2) -> | Pmty_functor (Named (s, mt1), mt2) ->
if s.txt = "_" then begin match s.txt with
pp f "@[<hov2>%a@ ->@ %a@]" | None ->
(module_type1 ctxt) mt1 (module_type ctxt) mt2 pp f "@[<hov2>%a@ ->@ %a@]"
else (module_type1 ctxt) mt1 (module_type ctxt) mt2
pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt | Some name ->
(module_type ctxt) mt1 (module_type ctxt) mt2 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, []) -> module_type ctxt f mt
| Pmty_with (mt, l) -> | Pmty_with (mt, l) ->
let with_constraint f = function let with_constraint f = function
@ -1107,12 +1112,13 @@ and signature_item ctxt f x : unit =
end end
| Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias;
pmty_attributes=[]; _};_} as pmd) -> 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 longident_loc alias
(item_attributes ctxt) pmd.pmd_attributes (item_attributes ctxt) pmd.pmd_attributes
| Psig_module pmd -> | Psig_module pmd ->
pp f "@[<hov>module@ %s@ :@ %a@]%a" pp f "@[<hov>module@ %s@ :@ %a@]%a"
pmd.pmd_name.txt (Option.value pmd.pmd_name.txt ~default:"_")
(module_type ctxt) pmd.pmd_type (module_type ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes (item_attributes ctxt) pmd.pmd_attributes
| Psig_modsubst pms -> | Psig_modsubst pms ->
@ -1145,11 +1151,13 @@ and signature_item ctxt f x : unit =
| [] -> () ; | [] -> () ;
| pmd :: tl -> | pmd :: tl ->
if not first then 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 (module_type1 ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes (item_attributes ctxt) pmd.pmd_attributes
else 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 (module_type1 ctxt) pmd.pmd_type
(item_attributes ctxt) pmd.pmd_attributes; (item_attributes ctxt) pmd.pmd_attributes;
string_x_module_type_list f ~first:false tl string_x_module_type_list f ~first:false tl
@ -1174,11 +1182,12 @@ and module_expr ctxt f x =
(module_type ctxt) mt (module_type ctxt) mt
| Pmod_ident (li) -> | Pmod_ident (li) ->
pp f "%a" longident_loc li; pp f "%a" longident_loc li;
| Pmod_functor (_, None, me) -> | Pmod_functor (Unit, me) ->
pp f "functor ()@;->@;%a" (module_expr ctxt) 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" 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) -> | Pmod_apply (me1, me2) ->
pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
(* Cf: #7200 *) (* Cf: #7200 *)
@ -1303,14 +1312,18 @@ and structure_item ctxt f x =
| Pstr_exception ed -> exception_declaration ctxt f ed | Pstr_exception ed -> exception_declaration ctxt f ed
| Pstr_module x -> | Pstr_module x ->
let rec module_helper = function let rec module_helper = function
| {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} -> | {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} ->
if mt = None then pp f "()" begin match arg_opt with
else Option.iter (pp f "(%s:%a)" s.txt (module_type ctxt)) mt; | Unit -> pp f "()"
| Named (s, mt) ->
pp f "(%s:%a)" (Option.value s.txt ~default:"_")
(module_type ctxt) mt
end;
module_helper me' module_helper me'
| me -> me | me -> me
in in
pp f "@[<hov2>module %s%a@]%a" pp f "@[<hov2>module %s%a@]%a"
x.pmb_name.txt (Option.value x.pmb_name.txt ~default:"_")
(fun f me -> (fun f me ->
let me = module_helper me in let me = module_helper me in
match me with match me with
@ -1389,26 +1402,28 @@ and structure_item ctxt f x =
| Pstr_recmodule decls -> (* 3.07 *) | Pstr_recmodule decls -> (* 3.07 *)
let aux f = function let aux f = function
| ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> | ({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_type ctxt) typ
(module_expr ctxt) expr (module_expr ctxt) expr
(item_attributes ctxt) pmb.pmb_attributes (item_attributes ctxt) pmb.pmb_attributes
| pmb -> | 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 (module_expr ctxt) pmb.pmb_expr
(item_attributes ctxt) pmb.pmb_attributes (item_attributes ctxt) pmb.pmb_attributes
in in
begin match decls with begin match decls with
| ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" 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_type ctxt) typ
(module_expr ctxt) expr (module_expr ctxt) expr
(item_attributes ctxt) pmb.pmb_attributes (item_attributes ctxt) pmb.pmb_attributes
(fun f l2 -> List.iter (aux f) l2) l2 (fun f l2 -> List.iter (aux f) l2) l2
| pmb :: l2 -> | pmb :: l2 ->
pp f "@[<hv>@[<hov2>module@ rec@ %s@ =@ %a@]%a@ %a@]" 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 (module_expr ctxt) pmb.pmb_expr
(item_attributes ctxt) pmb.pmb_attributes (item_attributes ctxt) pmb.pmb_attributes
(fun f l2 -> List.iter (aux f) l2) l2 (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; 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 let fmt_char_option f = function
| None -> fprintf f "None" | None -> fprintf f "None"
| Some c -> fprintf f "Some %c" c | 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 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 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 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 let arg_label i ppf = function
| Nolabel -> line i ppf "Nolabel\n" | Nolabel -> line i ppf "Nolabel\n"
| Optional s -> line i ppf "Optional \"%s\"\n" s | Optional s -> line i ppf "Optional \"%s\"\n" s
@ -240,7 +245,7 @@ and pattern i ppf x =
line i ppf "Ppat_type\n"; line i ppf "Ppat_type\n";
longident_loc i ppf li longident_loc i ppf li
| Ppat_unpack s -> | 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 -> | Ppat_exception p ->
line i ppf "Ppat_exception\n"; line i ppf "Ppat_exception\n";
pattern i ppf p pattern i ppf p
@ -347,7 +352,7 @@ and expression i ppf x =
line i ppf "Pexp_override\n"; line i ppf "Pexp_override\n";
list i string_x_expression ppf l; list i string_x_expression ppf l;
| Pexp_letmodule (s, me, e) -> | 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; module_expr i ppf me;
expression i ppf e; expression i ppf e;
| Pexp_letexception (cd, e) -> | Pexp_letexception (cd, e) ->
@ -662,9 +667,12 @@ and module_type i ppf x =
| Pmty_signature (s) -> | Pmty_signature (s) ->
line i ppf "Pmty_signature\n"; line i ppf "Pmty_signature\n";
signature i ppf s; signature i ppf s;
| Pmty_functor (s, mt1, mt2) -> | Pmty_functor (Unit, mt2) ->
line i ppf "Pmty_functor %a\n" fmt_string_loc s; line i ppf "Pmty_functor ()\n";
Option.iter (module_type i ppf) mt1; 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; module_type i ppf mt2;
| Pmty_with (mt, l) -> | Pmty_with (mt, l) ->
line i ppf "Pmty_with\n"; line i ppf "Pmty_with\n";
@ -699,7 +707,7 @@ and signature_item i ppf x =
line i ppf "Psig_exception\n"; line i ppf "Psig_exception\n";
type_exception i ppf te type_exception i ppf te
| Psig_module pmd -> | 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; attributes i ppf pmd.pmd_attributes;
module_type i ppf pmd.pmd_type module_type i ppf pmd.pmd_type
| Psig_modsubst pms -> | Psig_modsubst pms ->
@ -765,9 +773,12 @@ and module_expr i ppf x =
| Pmod_structure (s) -> | Pmod_structure (s) ->
line i ppf "Pmod_structure\n"; line i ppf "Pmod_structure\n";
structure i ppf s; structure i ppf s;
| Pmod_functor (s, mt, me) -> | Pmod_functor (Unit, me) ->
line i ppf "Pmod_functor %a\n" fmt_string_loc s; line i ppf "Pmod_functor ()\n";
Option.iter (module_type i ppf) mt; 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; module_expr i ppf me;
| Pmod_apply (me1, me2) -> | Pmod_apply (me1, me2) ->
line i ppf "Pmod_apply\n"; line i ppf "Pmod_apply\n";
@ -841,12 +852,12 @@ and structure_item i ppf x =
attribute i ppf "Pstr_attribute" a attribute i ppf "Pstr_attribute" a
and module_declaration i ppf pmd = 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; attributes i ppf pmd.pmd_attributes;
module_type (i+1) ppf pmd.pmd_type; module_type (i+1) ppf pmd.pmd_type;
and module_binding i ppf x = 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; attributes i ppf x.pmb_attributes;
module_expr (i+1) ppf x.pmb_expr 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: Line 4, characters 2-11:
4 | include S 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: Line 2, characters 2-11:
Module type T/317 came from this include Module type T/317 came from this include
Line 3, characters 2-39: Line 3, characters 2-39:
@ -198,11 +198,11 @@ end
Line 4, characters 2-11: Line 4, characters 2-11:
4 | include S 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: Line 2, characters 2-11:
Type ext/353 came from this include Type ext/352 came from this include
Line 3, characters 14-16: 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 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 = let record_module_binding scope mb =
Stypes.record (Stypes.An_ident Stypes.record (Stypes.An_ident
(mb.mb_name.loc, (mb.mb_name.loc,
mb.mb_name.txt, Option.value mb.mb_name.txt ~default:"_",
Annot.Idef scope)) Annot.Idef scope))
let rec iterator ~scope rebuild_env = let rec iterator ~scope rebuild_env =
@ -106,7 +106,8 @@ let rec iterator ~scope rebuild_env =
bind_cases f bind_cases f
| Texp_letmodule (_, modname, _, _, body ) -> | Texp_letmodule (_, modname, _, _, body ) ->
Stypes.record (Stypes.An_ident 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; end;
Stypes.record (Stypes.Ti_expr exp); 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 match smod.pmod_desc with
Pmod_ident _ -> () Pmod_ident _ -> ()
| Pmod_structure sstr -> List.iter (rewrite_str_item iflag) sstr | 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_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
| Pmod_constraint(smod, _smty) -> rewrite_mod iflag smod | Pmod_constraint(smod, _smty) -> rewrite_mod iflag smod
| Pmod_unpack(sexp) -> rewrite_exp iflag sexp | 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 [ Ptop_def
[ Str.module_ [ Str.module_
(Mb.mk (Mb.mk
(Location.mknoloc modname) (Location.mknoloc (Some modname))
(Mod.structure items) (Mod.structure items)
) )
] ]

2
toplevel/toploop.ml
View File

@ -151,7 +151,7 @@ let parse_mod_use_file name lb =
[ Ptop_def [ Ptop_def
[ Str.module_ [ Str.module_
(Mb.mk (Mb.mk
(Location.mknoloc modname) (Location.mknoloc (Some modname))
(Mod.structure items) (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 is_Tconstr = function {desc=Tconstr _} -> true | _ -> false
let dummy_method = "*dummy method*" let dummy_method = "*dummy method*"
let default_mty = function
Some mty -> mty
| None -> Mty_signature []
(**** Definitions for backtracking ****) (**** Definitions for backtracking ****)
@ -333,6 +330,7 @@ type type_iterators =
it_modtype_declaration: type_iterators -> modtype_declaration -> unit; it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
it_class_declaration: type_iterators -> class_declaration -> unit; it_class_declaration: type_iterators -> class_declaration -> unit;
it_class_type_declaration: type_iterators -> class_type_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_module_type: type_iterators -> module_type -> unit;
it_class_type: type_iterators -> class_type -> unit; it_class_type: type_iterators -> class_type -> unit;
it_type_kind: type_iterators -> type_kind -> 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; List.iter (it.it_type_expr it) ctd.clty_params;
it.it_class_type it ctd.clty_type; it.it_class_type it ctd.clty_type;
it.it_path ctd.clty_path 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 and it_module_type it = function
Mty_ident p Mty_ident p
| Mty_alias p -> it.it_path p | Mty_alias p -> it.it_path p
| Mty_signature sg -> it.it_signature it sg | Mty_signature sg -> it.it_signature it sg
| Mty_functor (_, mto, mt) -> | Mty_functor (p, mt) ->
Option.iter (it.it_module_type it) mto; it.it_functor_param it p;
it.it_module_type it mt it.it_module_type it mt
and it_class_type it = function and it_class_type it = function
Cty_constr (p, tyl, cty) -> Cty_constr (p, tyl, cty) ->
@ -435,7 +436,7 @@ let type_iterators =
and it_path _p = () and it_path _p = ()
in in
{ it_path; it_type_expr = it_do_type_expr; it_do_type_expr; { 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_signature; it_class_type_declaration; it_class_declaration;
it_modtype_declaration; it_module_declaration; it_extension_constructor; it_modtype_declaration; it_module_declaration; it_extension_constructor;
it_type_declaration; it_value_description; it_signature_item; } 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_Tunivar: type_expr -> bool
val is_Tconstr: type_expr -> bool val is_Tconstr: type_expr -> bool
val dummy_method: label val dummy_method: label
val default_mty: module_type option -> module_type
val repr: type_expr -> type_expr val repr: type_expr -> type_expr
(* Return the canonical representative of a type. *) (* Return the canonical representative of a type. *)
@ -122,6 +121,7 @@ type type_iterators =
it_modtype_declaration: type_iterators -> modtype_declaration -> unit; it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
it_class_declaration: type_iterators -> class_declaration -> unit; it_class_declaration: type_iterators -> class_declaration -> unit;
it_class_type_declaration: type_iterators -> class_type_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_module_type: type_iterators -> module_type -> unit;
it_class_type: type_iterators -> class_type -> unit; it_class_type: type_iterators -> class_type -> unit;
it_type_kind: type_iterators -> type_kind -> 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 = { and functor_components = {
fcomp_param: Ident.t; (* Formal parameter *) fcomp_arg: functor_parameter;
fcomp_arg: module_type option; (* Argument signature *) (* Formal parameter and argument signature *)
fcomp_res: module_type; (* Result signature *) fcomp_res: module_type; (* Result signature *)
fcomp_cache: (Path.t, module_components) Hashtbl.t; (* For memoization *) fcomp_cache: (Path.t, module_components) Hashtbl.t; (* For memoization *)
fcomp_subst_cache: (Path.t, module_type) Hashtbl.t fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
@ -821,9 +821,13 @@ let modtype_of_functor_appl fcomp p1 p2 =
with Not_found -> with Not_found ->
let scope = Path.scope (Papply(p1, p2)) in let scope = Path.scope (Papply(p1, p2)) in
let mty = let mty =
Subst.modtype (Rescope scope) let subst =
(Subst.add_module fcomp.fcomp_param p2 Subst.identity) match fcomp.fcomp_arg with
mty | Unit
| Named (None, _) -> Subst.identity
| Named (Some param, _) -> Subst.add_module param p2 Subst.identity
in
Subst.modtype (Rescope scope) subst mty
in in
Hashtbl.add fcomp.fcomp_subst_cache p2 mty; Hashtbl.add fcomp.fcomp_subst_cache p2 mty;
mty mty
@ -1577,16 +1581,19 @@ let rec components_of_module_maker
NameMap.add (Ident.name id) decl' c.comp_cltypes) NameMap.add (Ident.name id) decl' c.comp_cltypes)
items_and_paths; items_and_paths;
Ok (Structure_comps c) Ok (Structure_comps c)
| Mty_functor(param, ty_arg, ty_res) -> | Mty_functor(arg, ty_res) ->
let sub = let sub =
may_subst Subst.compose cm_freshening_subst cm_prefixing_subst may_subst Subst.compose cm_freshening_subst cm_prefixing_subst
in in
let scoping = Subst.Rescope (Path.scope cm_path) in let scoping = Subst.Rescope (Path.scope cm_path) in
Ok (Functor_comps { Ok (Functor_comps {
fcomp_param = param;
(* fcomp_arg and fcomp_res must be prefixed eagerly, because (* fcomp_arg and fcomp_res must be prefixed eagerly, because
they are interpreted in the outer environment *) 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_res = Subst.modtype scoping sub ty_res;
fcomp_cache = Hashtbl.create 17; fcomp_cache = Hashtbl.create 17;
fcomp_subst_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 Hashtbl.find f.fcomp_cache p2
with Not_found -> with Not_found ->
let p = Papply(p1, p2) in 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] (* we have to apply eagerly instead of passing sub to [components_of_module]
because of the call to [check_well_formed_module]. *) because of the call to [check_well_formed_module]. *)
let mty = Subst.modtype (Rescope (Path.scope p)) sub f.fcomp_res in 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 match get_components_res comps with
| Ok (Functor_comps fcomps) -> begin | Ok (Functor_comps fcomps) -> begin
match fcomps.fcomp_arg with match fcomps.fcomp_arg with
| None -> (* PR#7611 *) | Unit -> (* PR#7611 *)
may_lookup_error errors loc env (Generative_used_as_applicative lid) may_lookup_error errors loc env (Generative_used_as_applicative lid)
| Some arg -> path, fcomps, arg | Named (_, arg) -> path, fcomps, arg
end end
| Ok (Structure_comps _) -> | Ok (Structure_comps _) ->
may_lookup_error errors loc env (Structure_used_as_functor lid) 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 | Invalid_module_alias of Path.t
type pos = 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 type error = pos list * Env.t * symptom
exception Error of error list 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) try_modtypes2 ~loc env ~mark cxt mty1 (Subst.modtype Keep subst mty2)
| (Mty_signature sig1, Mty_signature sig2) -> | (Mty_signature sig1, Mty_signature sig2) ->
signatures ~loc env ~mark cxt subst sig1 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 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 | Tcoerce_none -> Tcoerce_none
| cc -> Tcoerce_functor (Tcoerce_none, cc) | cc -> Tcoerce_functor (Tcoerce_none, cc)
end end
| (Mty_functor(param1, Some arg1, res1), | (Mty_functor(Named (param1, arg1) as arg, res1),
Mty_functor(param2, Some arg2, res2)) -> Mty_functor(Named (param2, arg2), res2)) ->
let arg2' = Subst.modtype Keep subst arg2 in let arg2' = Subst.modtype Keep subst arg2 in
let cc_arg = let cc_arg =
modtypes ~loc env ~mark:(negate_mark mark) modtypes ~loc env ~mark:(negate_mark mark)
(Arg param1::cxt) Subst.identity arg2' arg1 (Arg arg::cxt) Subst.identity arg2' arg1
in in
let cc_res = let env, subst =
modtypes ~loc (Env.add_module param1 Mp_present arg2' env) ~mark match param1, param2 with
(Body param1::cxt) | Some p1, Some p2 ->
(Subst.add_module param2 (Path.Pident param1) subst) Env.add_module p1 Mp_present arg2' env,
res1 res2 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 in
let cc_res = modtypes ~loc env ~mark (Body arg::cxt) subst res1 res2 in
begin match (cc_arg, cc_res) with begin match (cc_arg, cc_res) with
(Tcoerce_none, Tcoerce_none) -> Tcoerce_none (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
| _ -> Tcoerce_functor(cc_arg, cc_res) | _ -> 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 | Sig_module (id, _, md,_,_) -> find env (Module id :: ctx) q md.md_type
| _ -> raise Not_found | _ -> raise Not_found
end end
| Mty_functor(x,Some mt,_), InArg :: q -> find env (Arg x :: ctx) q mt | Mty_functor(Named (_,mt) as arg,_), InArg :: q ->
| Mty_functor(x,_,mt), InBody :: q -> find env (Body x :: ctx) q mt find env (Arg arg :: ctx) q mt
| Mty_functor(arg, mt), InBody :: q ->
find env (Body arg :: ctx) q mt
| _ -> raise Not_found | _ -> raise Not_found
let find env path mt = find env [] path mt let find env path mt = find env [] path mt
@ -716,7 +728,7 @@ let rec context ppf = function
| Body x :: rem -> | Body x :: rem ->
fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
| Arg x :: 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>" fprintf ppf "<here>"
and context_mty ppf = function and context_mty ppf = function
@ -727,12 +739,13 @@ and args ppf = function
Body x :: rem -> Body x :: rem ->
fprintf ppf "(%s)%a" (argname x) args rem fprintf ppf "(%s)%a" (argname x) args rem
| Arg x :: rem -> | Arg x :: rem ->
fprintf ppf "(%a :@ %a) : ..." Printtyp.ident x context_mty rem fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem
| cxt -> | cxt ->
fprintf ppf " :@ %a" context_mty cxt fprintf ppf " :@ %a" context_mty cxt
and argname x = and argname = function
let s = Ident.name x in | Unit -> ""
if s = "*" then "" else s | Named (None, _) -> "_"
| Named (Some id, _) -> Ident.name id
let alt_context ppf cxt = let alt_context ppf cxt =
if cxt = [] then () else if cxt = [] then () else

5
typing/includemod.mli
View File

@ -77,7 +77,10 @@ type symptom =
| Invalid_module_alias of Path.t | Invalid_module_alias of Path.t
type pos = 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 type error = pos list * Env.t * symptom
exception Error of error list 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 match scrape env mty with
Mty_signature sg -> Mty_signature sg ->
Mty_signature(strengthen_sig ~aliasable env sg p) Mty_signature(strengthen_sig ~aliasable env sg p)
| Mty_functor(param, arg, res) | Mty_functor(Named (Some param, arg), res)
when !Clflags.applicative_functors && Ident.name param <> "*" -> when !Clflags.applicative_functors ->
Mty_functor(param, arg, 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))) strengthen ~aliasable:false env res (Papply(p, Pident param)))
| mty -> | mty ->
mty mty
@ -107,9 +112,9 @@ let rec make_aliases_absent pres mty =
| Mty_alias _ -> Mp_absent, mty | Mty_alias _ -> Mp_absent, mty
| Mty_signature sg -> | Mty_signature sg ->
pres, Mty_signature(make_aliases_absent_sig 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 let _, res = make_aliases_absent Mp_present res in
pres, Mty_functor(param, arg, res) pres, Mty_functor(arg, res)
| mty -> | mty ->
pres, mty pres, mty
@ -171,14 +176,19 @@ let rec nondep_mty_with_presence env va ids pres mty =
| Mty_signature sg -> | Mty_signature sg ->
let mty = Mty_signature(nondep_sig env va ids sg) in let mty = Mty_signature(nondep_sig env va ids sg) in
pres, mty 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 = let var_inv =
match va with Co -> Contra | Contra -> Co | Strict -> Strict in 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 = let mty =
Mty_functor(param, Option.map (nondep_mty env var_inv ids) arg, Mty_functor(Named (param, nondep_mty env var_inv ids arg),
nondep_mty nondep_mty res_env va ids res)
(Env.add_module ~arg:true param Mp_present
(Btype.default_mty arg) env) va ids res)
in in
pres, mty pres, mty
@ -335,7 +345,7 @@ let rec contains_type env = function
end end
| Mty_signature sg -> | Mty_signature sg ->
contains_type_sig env sg contains_type_sig env sg
| Mty_functor (_, _, body) -> | Mty_functor (_, body) ->
contains_type env body contains_type env body
| Mty_alias _ -> | 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. *) that should be printed in long form. *)
let collect_functor_arguments mty = let collect_functor_arguments mty =
let rec collect_args acc = function let rec collect_args acc = function
| Omty_functor (name, mty_arg, mty_res) -> | Omty_functor (param, mty_res) ->
collect_args ((name, mty_arg) :: acc) mty_res collect_args (param :: acc) mty_res
| non_functor -> (acc, non_functor) | non_functor -> (acc, non_functor)
in in
let rec uncollect_anonymous_suffix acc rest = match acc with let rec uncollect_anonymous_suffix acc rest = match acc with
| ("_", mty_arg) :: acc -> | Some (None, mty_arg) :: acc ->
uncollect_anonymous_suffix acc (Omty_functor ("_", mty_arg, rest)) uncollect_anonymous_suffix acc
| (_, _) :: _ | [] -> (Omty_functor (Some (None, mty_arg), rest))
| _ :: _ | [] ->
(acc, rest) (acc, rest)
in in
let (acc, non_functor) = collect_args [] mty 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 and print_out_functor ppf = function
| Omty_functor _ as t -> | Omty_functor _ as t ->
let rec print_functor ppf = function 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" fprintf ppf "%a ->@ %a"
print_simple_out_module_type mty_arg print_simple_out_module_type mty_arg
print_functor mty_res print_functor mty_res
| Omty_functor _ as non_anonymous_functor -> | Omty_functor _ as non_anonymous_functor ->
let (args, rest) = collect_functor_arguments non_anonymous_functor in let (args, rest) = collect_functor_arguments non_anonymous_functor in
let print_arg ppf = function let print_arg ppf = function
| (_, None) -> | None ->
fprintf ppf "()" fprintf ppf "()"
| (name, Some mty) -> | Some (param, mty) ->
fprintf ppf "(%s : %a)" fprintf ppf "(%s : %a)"
name (Option.value param ~default:"_")
print_out_module_type mty print_out_module_type mty
in in
fprintf ppf "@[<2>functor@ %a@]@ ->@ %a" 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 = type out_module_type =
| Omty_abstract | 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_ident of out_ident
| Omty_signature of out_sig_item list | Omty_signature of out_sig_item list
| Omty_alias of out_ident | 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,_,_)},_)}, Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
_) -> _) ->
assert (Ident.Set.mem id_exp !ids) ; 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 ids := Ident.Set.remove id_exp !ids
| _ -> ()
end end
| _ -> assert false | _ -> assert false
end end

23
typing/printtyp.ml
View File

@ -1622,15 +1622,22 @@ let rec tree_of_modtype ?(ellipsis=false) = function
| Mty_signature sg -> | Mty_signature sg ->
Omty_signature (if ellipsis then [Osig_ellipsis] Omty_signature (if ellipsis then [Osig_ellipsis]
else tree_of_signature sg) else tree_of_signature sg)
| Mty_functor(param, ty_arg, ty_res) -> | Mty_functor(param, ty_res) ->
let res = let param, res =
match ty_arg with None -> tree_of_modtype ~ellipsis ty_res match param with
| Some mty -> | Unit -> None, tree_of_modtype ~ellipsis ty_res
wrap_env (Env.add_module ~arg:true param Mp_present mty) | Named (param, ty_arg) ->
(tree_of_modtype ~ellipsis) ty_res 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 in
Omty_functor (Ident.name param, Omty_functor (param, res)
Option.map (tree_of_modtype ~ellipsis:false) ty_arg, res)
| Mty_alias p -> | Mty_alias p ->
Omty_alias (tree_of_path Module 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_ident = Ident.print
let fmt_modname f = function
| None -> fprintf f "_";
| Some id -> Ident.print f id
let rec fmt_path_aux f x = let rec fmt_path_aux f x =
match x with match x with
| Path.Pident (s) -> fprintf f "%a" fmt_ident s; | Path.Pident (s) -> fprintf f "%a" fmt_ident s;
@ -389,7 +393,7 @@ and expression i ppf x =
line i ppf "Texp_override\n"; line i ppf "Texp_override\n";
list i string_x_expression ppf l; list i string_x_expression ppf l;
| Texp_letmodule (s, _, _, me, e) -> | 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; module_expr i ppf me;
expression i ppf e; expression i ppf e;
| Texp_letexception (cd, e) -> | Texp_letexception (cd, e) ->
@ -668,9 +672,12 @@ and module_type i ppf x =
| Tmty_signature (s) -> | Tmty_signature (s) ->
line i ppf "Tmty_signature\n"; line i ppf "Tmty_signature\n";
signature i ppf s; signature i ppf s;
| Tmty_functor (s, _, mt1, mt2) -> | Tmty_functor (Unit, mt2) ->
line i ppf "Tmty_functor \"%a\"\n" fmt_ident s; line i ppf "Tmty_functor ()\n";
Option.iter (module_type i ppf) mt1; 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; module_type i ppf mt2;
| Tmty_with (mt, l) -> | Tmty_with (mt, l) ->
line i ppf "Tmty_with\n"; line i ppf "Tmty_with\n";
@ -702,7 +709,7 @@ and signature_item i ppf x =
line i ppf "Tsig_exception\n"; line i ppf "Tsig_exception\n";
type_exception i ppf ext type_exception i ppf ext
| Tsig_module md -> | 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; attributes i ppf md.md_attributes;
module_type i ppf md.md_type module_type i ppf md.md_type
| Tsig_modsubst ms -> | Tsig_modsubst ms ->
@ -735,12 +742,12 @@ and signature_item i ppf x =
attribute i ppf "Tsig_attribute" a attribute i ppf "Tsig_attribute" a
and module_declaration i ppf md = 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; attributes i ppf md.md_attributes;
module_type (i+1) ppf md.md_type; module_type (i+1) ppf md.md_type;
and module_binding i ppf x = 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; attributes i ppf x.mb_attributes;
module_expr (i+1) ppf x.mb_expr module_expr (i+1) ppf x.mb_expr
@ -768,9 +775,12 @@ and module_expr i ppf x =
| Tmod_structure (s) -> | Tmod_structure (s) ->
line i ppf "Tmod_structure\n"; line i ppf "Tmod_structure\n";
structure i ppf s; structure i ppf s;
| Tmod_functor (s, _, mt, me) -> | Tmod_functor (Unit, me) ->
line i ppf "Tmod_functor \"%a\"\n" fmt_ident s; line i ppf "Tmod_functor ()\n";
Option.iter (module_type i ppf) mt; 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; module_expr i ppf me;
| Tmod_apply (me1, me2, _) -> | Tmod_apply (me1, me2, _) ->
line i ppf "Tmod_apply\n"; 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 path pth
| Tmod_structure s -> | Tmod_structure s ->
structure s structure s
| Tmod_functor (_, _, _, e) -> | Tmod_functor (_, e) ->
modexp e << Delay modexp e << Delay
| Tmod_apply (f, p, _) -> | Tmod_apply (f, p, _) ->
join [ join [
@ -984,15 +984,21 @@ and structure_item : Typedtree.structure_item -> bind_judg =
Env.join (modexp mexp m) (Env.remove_list included_ids env) Env.join (modexp mexp m) (Env.remove_list included_ids env)
(* G |- module M = E : m -| G *) (* 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 -> fun (id, mexp) m env ->
(* (*
GE |- E: m[mM + Guard] GE |- E: m[mM + Guard]
------------------------------------- -------------------------------------
GE + G |- module M = E : m -| M:mM, G GE + G |- module M = E : m -| M:mM, G
*) *)
let mM, env = Env.take id env in let judg_E, env =
let judg_E = modexp mexp << (Mode.join mM Guard) in 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 Env.join (judg_E m) env
and open_declaration : Typedtree.open_declaration -> bind_judg = 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) Env.join (judg_E m) (Env.remove_list bound_ids env)
and recursive_module_bindings 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 -> 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 binding (mid, mexp) m =
let mM = Env.find mid env in let judg_E =
Env.remove_list mids (modexp mexp Mode.(compose m (join mM Guard))) 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 in
Env.join (list binding m_bindings m) (Env.remove_list mids env) 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 end
| Mty_signature sg -> | Mty_signature sg ->
Mty_signature(signature scoping s 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 let id' = Ident.rename id in
Mty_functor(id', Option.map (modtype scoping s) arg, Mty_functor(Named (Some id', (modtype scoping s) arg),
modtype scoping (add_module id (Pident id') s) res) modtype scoping (add_module id (Pident id') s) res)
| Mty_alias p -> | Mty_alias p ->
Mty_alias (module_path s 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 = let class_description sub x =
class_infos sub (sub.class_type 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; _} = let module_type sub {mty_desc; mty_env; _} =
sub.env sub mty_env; sub.env sub mty_env;
match mty_desc with match mty_desc with
| Tmty_ident _ -> () | Tmty_ident _ -> ()
| Tmty_alias _ -> () | Tmty_alias _ -> ()
| Tmty_signature sg -> sub.signature sub sg | Tmty_signature sg -> sub.signature sub sg
| Tmty_functor (_, _, mtype1, mtype2) -> | Tmty_functor (arg, mtype2) ->
Option.iter (sub.module_type sub) mtype1; functor_parameter sub arg;
sub.module_type sub mtype2 sub.module_type sub mtype2
| Tmty_with (mtype, list) -> | Tmty_with (mtype, list) ->
sub.module_type sub mtype; sub.module_type sub mtype;
@ -332,8 +336,8 @@ let module_expr sub {mod_desc; mod_env; _} =
match mod_desc with match mod_desc with
| Tmod_ident _ -> () | Tmod_ident _ -> ()
| Tmod_structure st -> sub.structure sub st | Tmod_structure st -> sub.structure sub st
| Tmod_functor (_, _, mtype, mexpr) -> | Tmod_functor (arg, mexpr) ->
Option.iter (sub.module_type sub) mtype; functor_parameter sub arg;
sub.module_expr sub mexpr sub.module_expr sub mexpr
| Tmod_apply (mexp1, mexp2, c) -> | Tmod_apply (mexp1, mexp2, c) ->
sub.module_expr sub mexp1; 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 = let class_description sub x =
class_infos sub (sub.class_type 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 module_type sub x =
let mty_env = sub.env sub x.mty_env in let mty_env = sub.env sub x.mty_env in
let mty_desc = let mty_desc =
@ -433,13 +437,8 @@ let module_type sub x =
| Tmty_ident _ | Tmty_ident _
| Tmty_alias _ as d -> d | Tmty_alias _ as d -> d
| Tmty_signature sg -> Tmty_signature (sub.signature sub sg) | Tmty_signature sg -> Tmty_signature (sub.signature sub sg)
| Tmty_functor (id, s, mtype1, mtype2) -> | Tmty_functor (arg, mtype2) ->
Tmty_functor ( Tmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
id,
s,
Option.map (sub.module_type sub) mtype1,
sub.module_type sub mtype2
)
| Tmty_with (mtype, list) -> | Tmty_with (mtype, list) ->
Tmty_with ( Tmty_with (
sub.module_type sub mtype, sub.module_type sub mtype,
@ -484,13 +483,8 @@ let module_expr sub x =
match x.mod_desc with match x.mod_desc with
| Tmod_ident _ as d -> d | Tmod_ident _ as d -> d
| Tmod_structure st -> Tmod_structure (sub.structure sub st) | Tmod_structure st -> Tmod_structure (sub.structure sub st)
| Tmod_functor (id, s, mtype, mexpr) -> | Tmod_functor (arg, mexpr) ->
Tmod_functor ( Tmod_functor (functor_parameter sub arg, sub.module_expr sub mexpr)
id,
s,
Option.map (sub.module_type sub) mtype,
sub.module_expr sub mexpr
)
| Tmod_apply (mexp1, mexp2, c) -> | Tmod_apply (mexp1, mexp2, c) ->
Tmod_apply ( Tmod_apply (
sub.module_expr sub mexp1, 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 -> | Ppat_unpack name ->
assert (constrs = None); assert (constrs = None);
let t = instance expected_ty in let t = instance expected_ty in
let id = enter_variable loc name t ~is_module:true sp.ppat_attributes in begin match name.txt with
rp k { | None ->
pat_desc = Tpat_var (id, name); rp k {
pat_loc = sp.ppat_loc; pat_desc = Tpat_any;
pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; pat_loc = sp.ppat_loc;
pat_type = t; pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes];
pat_attributes = []; pat_type = t;
pat_env = !env } 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_constraint(
{ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs}, {ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs},
({ptyp_desc=Ptyp_poly _} as sty)) -> ({ptyp_desc=Ptyp_poly _} as sty)) ->
@ -1992,7 +2004,7 @@ let create_package_type loc env (p, l) =
(fun sexp (name, loc) -> (fun sexp (name, loc) ->
Exp.letmodule ~loc:{ sexp.pexp_loc with loc_ghost = true } Exp.letmodule ~loc:{ sexp.pexp_loc with loc_ghost = true }
~attrs:[Attr.mk (mknoloc "#modulepat") (PStr [])] ~attrs:[Attr.mk (mknoloc "#modulepat") (PStr [])]
name { name with txt = Some name.txt }
(Mod.unpack ~loc (Mod.unpack ~loc
(Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt) (Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)
name.loc))) name.loc)))
@ -2983,7 +2995,11 @@ and type_expect_
{ md_type = modl.mod_type; md_attributes = []; md_loc = name.loc } { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc }
in in
let (id, new_env) = 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 in
Typetexp.widen context; Typetexp.widen context;
(* ideally, we should catch Expr_type_clash errors (* 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_setinstvar of Path.t * Path.t * string loc * expression
| Texp_override of Path.t * (Path.t * string loc * expression) list | Texp_override of Path.t * (Path.t * string loc * expression) list
| Texp_letmodule of | 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_letexception of extension_constructor * expression
| Texp_assert of expression | Texp_assert of expression
| Texp_lazy of expression | Texp_lazy of expression
@ -217,10 +218,14 @@ and module_type_constraint =
Tmodtype_implicit Tmodtype_implicit
| Tmodtype_explicit of module_type | Tmodtype_explicit of module_type
and functor_parameter =
| Unit
| Named of Ident.t option * string option loc * module_type
and module_expr_desc = and module_expr_desc =
Tmod_ident of Path.t * Longident.t loc Tmod_ident of Path.t * Longident.t loc
| Tmod_structure of structure | 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_apply of module_expr * module_expr * module_coercion
| Tmod_constraint of | Tmod_constraint of
module_expr * Types.module_type * module_type_constraint * module_coercion module_expr * Types.module_type * module_type_constraint * module_coercion
@ -256,8 +261,8 @@ and structure_item_desc =
and module_binding = and module_binding =
{ {
mb_id: Ident.t; mb_id: Ident.t option;
mb_name: string loc; mb_name: string option loc;
mb_presence: module_presence; mb_presence: module_presence;
mb_expr: module_expr; mb_expr: module_expr;
mb_attributes: attribute list; mb_attributes: attribute list;
@ -291,7 +296,7 @@ and module_type =
and module_type_desc = and module_type_desc =
Tmty_ident of Path.t * Longident.t loc Tmty_ident of Path.t * Longident.t loc
| Tmty_signature of signature | 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_with of module_type * (Path.t * Longident.t loc * with_constraint) list
| Tmty_typeof of module_expr | Tmty_typeof of module_expr
| Tmty_alias of Path.t * Longident.t loc | Tmty_alias of Path.t * Longident.t loc
@ -334,8 +339,8 @@ and signature_item_desc =
and module_declaration = and module_declaration =
{ {
md_id: Ident.t; md_id: Ident.t option;
md_name: string loc; md_name: string option loc;
md_presence: module_presence; md_presence: module_presence;
md_type: module_type; md_type: module_type;
md_attributes: attribute list; 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_setinstvar of Path.t * Path.t * string loc * expression
| Texp_override of Path.t * (Path.t * string loc * expression) list | Texp_override of Path.t * (Path.t * string loc * expression) list
| Texp_letmodule of | 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_letexception of extension_constructor * expression
| Texp_assert of expression | Texp_assert of expression
| Texp_lazy of expression | Texp_lazy of expression
@ -338,10 +339,14 @@ and module_type_constraint =
| Tmodtype_explicit of module_type | Tmodtype_explicit of module_type
(** The module type was in the source file. *) (** 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 = and module_expr_desc =
Tmod_ident of Path.t * Longident.t loc Tmod_ident of Path.t * Longident.t loc
| Tmod_structure of structure | 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_apply of module_expr * module_expr * module_coercion
| Tmod_constraint of | Tmod_constraint of
module_expr * Types.module_type * module_type_constraint * module_coercion module_expr * Types.module_type * module_type_constraint * module_coercion
@ -380,8 +385,8 @@ and structure_item_desc =
and module_binding = and module_binding =
{ {
mb_id: Ident.t; mb_id: Ident.t option;
mb_name: string loc; mb_name: string option loc;
mb_presence: module_presence; mb_presence: module_presence;
mb_expr: module_expr; mb_expr: module_expr;
mb_attributes: attributes; mb_attributes: attributes;
@ -415,7 +420,7 @@ and module_type =
and module_type_desc = and module_type_desc =
Tmty_ident of Path.t * Longident.t loc Tmty_ident of Path.t * Longident.t loc
| Tmty_signature of signature | 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_with of module_type * (Path.t * Longident.t loc * with_constraint) list
| Tmty_typeof of module_expr | Tmty_typeof of module_expr
| Tmty_alias of Path.t * Longident.t loc | Tmty_alias of Path.t * Longident.t loc
@ -457,8 +462,8 @@ and signature_item_desc =
and module_declaration = and module_declaration =
{ {
md_id: Ident.t; md_id: Ident.t option;
md_name: string loc; md_name: string option loc;
md_presence: module_presence; md_presence: module_presence;
md_type: module_type; md_type: module_type;
md_attributes: attributes; md_attributes: attributes;

365
typing/typemod.ml
View File

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

6
typing/types.mli
View File

@ -412,9 +412,13 @@ type visibility =
type module_type = type module_type =
Mty_ident of Path.t Mty_ident of Path.t
| Mty_signature of signature | 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 | Mty_alias of Path.t
and functor_parameter =
| Unit
| Named of Ident.t option * module_type
and module_presence = and module_presence =
| Mp_present | Mp_present
| Mp_absent | 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 attrs = sub.attributes sub pat.pat_attributes in
let desc = let desc =
match pat with match pat with
{ pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } ->
Ppat_unpack name 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]; _ } -> | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
Ppat_type (map_loc sub lid) Ppat_type (map_loc sub lid)
| { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } -> | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
@ -310,7 +312,7 @@ let pattern sub pat =
begin begin
match (Ident.name id).[0] with match (Ident.name id).[0] with
'A'..'Z' -> 'A'..'Z' ->
Ppat_unpack name Ppat_unpack { name with txt = Some name.txt}
| _ -> | _ ->
Ppat_var name Ppat_var name
end 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_description sub = class_infos sub.class_type sub
let class_type_declaration 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 module_type sub mty =
let loc = sub.location sub mty.mty_loc in let loc = sub.location sub mty.mty_loc in
let attrs = sub.attributes sub mty.mty_attributes 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_ident (_path, lid) -> Pmty_ident (map_loc sub lid)
| Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid) | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid)
| Tmty_signature sg -> Pmty_signature (sub.signature sub sg) | Tmty_signature sg -> Pmty_signature (sub.signature sub sg)
| Tmty_functor (_id, name, mtype1, mtype2) -> | Tmty_functor (arg, mtype2) ->
Pmty_functor (name, Option.map (sub.module_type sub) mtype1, Pmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
sub.module_type sub mtype2)
| Tmty_with (mtype, list) -> | Tmty_with (mtype, list) ->
Pmty_with (sub.module_type sub mtype, Pmty_with (sub.module_type sub mtype,
List.map (sub.with_constraint sub) list) List.map (sub.with_constraint sub) list)
@ -638,9 +644,9 @@ let module_expr sub mexpr =
let desc = match mexpr.mod_desc with let desc = match mexpr.mod_desc with
Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid) Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid)
| Tmod_structure st -> Pmod_structure (sub.structure sub st) | Tmod_structure st -> Pmod_structure (sub.structure sub st)
| Tmod_functor (_id, name, mtype, mexpr) -> | Tmod_functor (arg, mexpr) ->
Pmod_functor (name, Option.map (sub.module_type sub) mtype, Pmod_functor
sub.module_expr sub mexpr) (functor_parameter sub arg, sub.module_expr sub mexpr)
| Tmod_apply (mexp1, mexp2, _) -> | Tmod_apply (mexp1, mexp2, _) ->
Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2) Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2)
| Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->