a better representation for modules with no name (#8908)
parent
dbd717e817
commit
8e928caea7
7
Changes
7
Changes
|
@ -15,6 +15,8 @@ Working version
|
|||
use String_val as a char* instead of const char*
|
||||
(Kate Deplaix)
|
||||
|
||||
- #6662, #8908: Add "module _ = X" syntax
|
||||
(Thomas Refis, review by Gabriel Radanne)
|
||||
|
||||
### Internal/compiler-libs changes:
|
||||
|
||||
|
@ -70,6 +72,11 @@ Working version
|
|||
skipped lines/bytes into account
|
||||
(Gabriel Scherer, review by Sébastien Hinderer)
|
||||
|
||||
- #8908: Use an option instead of a string for module names ("_" becomes None),
|
||||
and a dedicated type for functor parameters: "()" maps to "Unit" (instead of
|
||||
"*").
|
||||
(Thomas Refis, review by Gabriel Radanne)
|
||||
|
||||
- #8928: Move contains_calls and num_stack_slots from Proc to Mach.fundecl
|
||||
(Greta Yorsh, review by Florian Angeletti and Vincent Laviron)
|
||||
|
||||
|
|
10270
boot/menhir/parser.ml
10270
boot/menhir/parser.ml
File diff suppressed because one or more lines are too long
BIN
boot/ocamlc
BIN
boot/ocamlc
Binary file not shown.
BIN
boot/ocamllex
BIN
boot/ocamllex
Binary file not shown.
|
@ -84,7 +84,7 @@ let extract_float = function
|
|||
|
||||
type binding =
|
||||
| Bind_value of value_binding list
|
||||
| Bind_module of Ident.t * string loc * module_presence * module_expr
|
||||
| Bind_module of Ident.t * string option loc * module_presence * module_expr
|
||||
|
||||
let rec push_defaults loc bindings cases partial =
|
||||
match cases with
|
||||
|
@ -105,7 +105,7 @@ let rec push_defaults loc bindings cases partial =
|
|||
| [{c_lhs=pat; c_guard=None;
|
||||
c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}];
|
||||
exp_desc = Texp_letmodule
|
||||
(id, name, pres, mexpr,
|
||||
(Some id, name, pres, mexpr,
|
||||
({exp_desc = Texp_function _} as e2))}}] ->
|
||||
push_defaults loc (Bind_module (id, name, pres, mexpr) :: bindings)
|
||||
[{c_lhs=pat;c_guard=None;c_rhs=e2}]
|
||||
|
@ -118,7 +118,7 @@ let rec push_defaults loc bindings cases partial =
|
|||
match binds with
|
||||
| Bind_value binds -> Texp_let(Nonrecursive, binds, exp)
|
||||
| Bind_module (id, name, pres, mexpr) ->
|
||||
Texp_letmodule (id, name, pres, mexpr, exp)})
|
||||
Texp_letmodule (Some id, name, pres, mexpr, exp)})
|
||||
case.c_rhs bindings
|
||||
in
|
||||
[{case with c_rhs=exp}]
|
||||
|
@ -465,7 +465,10 @@ and transl_exp0 e =
|
|||
(Lvar cpy) var expr, rem))
|
||||
modifs
|
||||
(Lvar cpy))
|
||||
| Texp_letmodule(id, loc, Mp_present, modl, body) ->
|
||||
| Texp_letmodule(None, loc, Mp_present, modl, body) ->
|
||||
let lam = !transl_module Tcoerce_none None modl in
|
||||
Lsequence(Lprim(Pignore, [lam], loc.loc), transl_exp body)
|
||||
| Texp_letmodule(Some id, loc, Mp_present, modl, body) ->
|
||||
let defining_expr =
|
||||
Levent (!transl_module Tcoerce_none None modl, {
|
||||
lev_loc = loc.loc;
|
||||
|
|
|
@ -32,13 +32,20 @@ type unsafe_component =
|
|||
| Unsafe_non_function
|
||||
| Unsafe_typext
|
||||
|
||||
type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t }
|
||||
type unsafe_info =
|
||||
| Unsafe of { reason:unsafe_component; loc:Location.t; subid:Ident.t }
|
||||
| Unnamed
|
||||
type error =
|
||||
Circular_dependency of (Ident.t * unsafe_info) list
|
||||
| Conflicting_inline_attributes
|
||||
|
||||
exception Error of Location.t * error
|
||||
|
||||
let cons_opt x_opt xs =
|
||||
match x_opt with
|
||||
| None -> xs
|
||||
| Some x -> x :: xs
|
||||
|
||||
(* Keep track of the root path (from the root of the namespace to the
|
||||
currently compiled module expression). Useful for naming extensions. *)
|
||||
|
||||
|
@ -218,12 +225,14 @@ let init_shape id modl =
|
|||
match Mtype.scrape env mty with
|
||||
Mty_ident _
|
||||
| Mty_alias _ ->
|
||||
raise (Initialization_failure {reason=Unsafe_module_binding;loc;subid})
|
||||
raise (Initialization_failure
|
||||
(Unsafe {reason=Unsafe_module_binding;loc;subid}))
|
||||
| Mty_signature sg ->
|
||||
Const_block(0, [Const_block(0, init_shape_struct env sg)])
|
||||
| Mty_functor _ ->
|
||||
(* can we do better? *)
|
||||
raise (Initialization_failure {reason=Unsafe_functor;loc;subid})
|
||||
raise (Initialization_failure
|
||||
(Unsafe {reason=Unsafe_functor;loc;subid}))
|
||||
and init_shape_struct env sg =
|
||||
match sg with
|
||||
[] -> []
|
||||
|
@ -235,7 +244,9 @@ let init_shape id modl =
|
|||
| {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t ->
|
||||
Const_pointer 1 (* camlinternalMod.Lazy *)
|
||||
| _ ->
|
||||
let not_a_function = {reason=Unsafe_non_function; loc; subid } in
|
||||
let not_a_function =
|
||||
Unsafe {reason=Unsafe_non_function; loc; subid }
|
||||
in
|
||||
raise (Initialization_failure not_a_function) in
|
||||
init_v :: init_shape_struct env rem
|
||||
| Sig_value(_, {val_kind=Val_prim _}, _) :: rem ->
|
||||
|
@ -245,7 +256,7 @@ let init_shape id modl =
|
|||
| Sig_type(id, tdecl, _, _) :: rem ->
|
||||
init_shape_struct (Env.add_type ~check:false id tdecl env) rem
|
||||
| Sig_typext (subid, {ext_loc=loc},_,_) :: _ ->
|
||||
raise (Initialization_failure {reason=Unsafe_typext; loc; subid})
|
||||
raise (Initialization_failure (Unsafe {reason=Unsafe_typext;loc;subid}))
|
||||
| Sig_module(id, Mp_present, md, _, _) :: rem ->
|
||||
init_shape_mod id md.md_loc env md.md_type ::
|
||||
init_shape_struct (Env.add_module_declaration ~check:false
|
||||
|
@ -274,9 +285,18 @@ type binding_status =
|
|||
| Inprogress of int option (** parent node *)
|
||||
| Defined
|
||||
|
||||
type id_or_ignore_loc =
|
||||
| Id of Ident.t
|
||||
| Ignore_loc of Location.t
|
||||
|
||||
let extract_unsafe_cycle id status init cycle_start =
|
||||
let info i = match init.(i) with
|
||||
| Result.Error r -> id.(i), r
|
||||
| Result.Error r ->
|
||||
begin match id.(i) with
|
||||
| Id id -> id, r
|
||||
| Ignore_loc _ ->
|
||||
assert false (* Can't refer to something without a name. *)
|
||||
end
|
||||
| Ok _ -> assert false in
|
||||
let rec collect stop l i = match status.(i) with
|
||||
| Inprogress None | Undefined | Defined -> assert false
|
||||
|
@ -310,7 +330,9 @@ let reorder_rec_bindings bindings =
|
|||
if is_unsafe i then begin
|
||||
status.(i) <- Inprogress parent;
|
||||
for j = 0 to num_bindings - 1 do
|
||||
if Ident.Set.mem id.(j) fv.(i) then emit_binding (Some i) j
|
||||
match id.(j) with
|
||||
| Id id when Ident.Set.mem id fv.(i) -> emit_binding (Some i) j
|
||||
| _ -> ()
|
||||
done
|
||||
end;
|
||||
res := (id.(i), init_res i, rhs.(i)) :: !res;
|
||||
|
@ -329,9 +351,10 @@ let eval_rec_bindings bindings cont =
|
|||
let rec bind_inits = function
|
||||
[] ->
|
||||
bind_strict bindings
|
||||
| (_id, None, _rhs) :: rem ->
|
||||
| (Ignore_loc _, _, _) :: rem
|
||||
| (_, None, _) :: rem ->
|
||||
bind_inits rem
|
||||
| (id, Some(loc, shape), _rhs) :: rem ->
|
||||
| (Id id, Some(loc, shape), _rhs) :: rem ->
|
||||
Llet(Strict, Pgenval, id,
|
||||
Lapply{ap_should_be_tailcall=false;
|
||||
ap_loc=Location.none;
|
||||
|
@ -343,16 +366,19 @@ let eval_rec_bindings bindings cont =
|
|||
and bind_strict = function
|
||||
[] ->
|
||||
patch_forwards bindings
|
||||
| (id, None, rhs) :: rem ->
|
||||
| (Ignore_loc loc, None, rhs) :: rem ->
|
||||
Lsequence(Lprim(Pignore, [rhs], loc), bind_strict rem)
|
||||
| (Id id, None, rhs) :: rem ->
|
||||
Llet(Strict, Pgenval, id, rhs, bind_strict rem)
|
||||
| (_id, Some _, _rhs) :: rem ->
|
||||
bind_strict rem
|
||||
and patch_forwards = function
|
||||
[] ->
|
||||
cont
|
||||
| (_id, None, _rhs) :: rem ->
|
||||
| (Ignore_loc _, _, _rhs) :: rem
|
||||
| (_, None, _rhs) :: rem ->
|
||||
patch_forwards rem
|
||||
| (id, Some(_loc, shape), rhs) :: rem ->
|
||||
| (Id id, Some(_loc, shape), rhs) :: rem ->
|
||||
Lsequence(Lapply{ap_should_be_tailcall=false;
|
||||
ap_loc=Location.none;
|
||||
ap_func=mod_prim "update_mod";
|
||||
|
@ -367,8 +393,13 @@ let compile_recmodule compile_rhs bindings cont =
|
|||
eval_rec_bindings
|
||||
(reorder_rec_bindings
|
||||
(List.map
|
||||
(fun {mb_id=id; mb_expr=modl; mb_loc=loc; _} ->
|
||||
(id, modl.mod_loc, init_shape id modl, compile_rhs id modl loc))
|
||||
(fun {mb_id=id; mb_name; mb_expr=modl; mb_loc=loc; _} ->
|
||||
let id_or_ignore_loc, shape =
|
||||
match id with
|
||||
| None -> Ignore_loc mb_name.loc, Result.Error Unnamed
|
||||
| Some id -> Id id, init_shape id modl
|
||||
in
|
||||
(id_or_ignore_loc, modl.mod_loc, shape, compile_rhs id modl loc))
|
||||
bindings))
|
||||
cont
|
||||
|
||||
|
@ -397,7 +428,7 @@ let merge_functors mexp coercion root_path =
|
|||
let rec merge mexp coercion path acc inline_attribute =
|
||||
let finished = acc, mexp, path, coercion, inline_attribute in
|
||||
match mexp.mod_desc with
|
||||
| Tmod_functor (param, _, _, body) ->
|
||||
| Tmod_functor (param, body) ->
|
||||
let inline_attribute' =
|
||||
Translattribute.get_inline_attribute mexp.mod_attributes
|
||||
in
|
||||
|
@ -409,7 +440,14 @@ let merge_functors mexp coercion root_path =
|
|||
| _ -> fatal_error "Translmod.merge_functors: bad coercion"
|
||||
in
|
||||
let loc = mexp.mod_loc in
|
||||
let path = functor_path path param in
|
||||
let path, param =
|
||||
match param with
|
||||
| Unit -> None, Ident.create_local "*"
|
||||
| Named (None, _, _) ->
|
||||
let id = Ident.create_local "_" in
|
||||
functor_path path id, id
|
||||
| Named (Some id, _, _) -> functor_path path id, id
|
||||
in
|
||||
let inline_attribute =
|
||||
merge_inline_attributes inline_attribute inline_attribute' loc
|
||||
in
|
||||
|
@ -582,7 +620,8 @@ and transl_structure loc fields cc rootpath final_env = function
|
|||
let id = mb.mb_id in
|
||||
(* Translate module first *)
|
||||
let module_body =
|
||||
transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr
|
||||
transl_module Tcoerce_none (Option.bind id (field_path rootpath))
|
||||
mb.mb_expr
|
||||
in
|
||||
let module_body =
|
||||
Translattribute.add_inline_attribute module_body mb.mb_loc
|
||||
|
@ -590,8 +629,13 @@ and transl_structure loc fields cc rootpath final_env = function
|
|||
in
|
||||
(* Translate remainder second *)
|
||||
let body, size =
|
||||
transl_structure loc (id :: fields) cc rootpath final_env rem
|
||||
transl_structure loc (cons_opt id fields) cc rootpath final_env rem
|
||||
in
|
||||
begin match id with
|
||||
| None ->
|
||||
Lsequence (Lprim(Pignore, [module_body], mb.mb_name.loc), body),
|
||||
size
|
||||
| Some id ->
|
||||
let module_body =
|
||||
Levent (module_body, {
|
||||
lev_loc = mb.mb_loc;
|
||||
|
@ -600,21 +644,23 @@ and transl_structure loc fields cc rootpath final_env = function
|
|||
lev_env = Env.empty;
|
||||
})
|
||||
in
|
||||
Llet(pure_module mb.mb_expr, Pgenval, id,
|
||||
module_body,
|
||||
body), size
|
||||
Llet(pure_module mb.mb_expr, Pgenval, id, module_body, body), size
|
||||
end
|
||||
| Tstr_module {mb_presence=Mp_absent} ->
|
||||
transl_structure loc fields cc rootpath final_env rem
|
||||
| Tstr_recmodule bindings ->
|
||||
let ext_fields =
|
||||
List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields
|
||||
List.rev_append (List.filter_map (fun mb -> mb.mb_id) bindings)
|
||||
fields
|
||||
in
|
||||
let body, size =
|
||||
transl_structure loc ext_fields cc rootpath final_env rem
|
||||
in
|
||||
let lam =
|
||||
compile_recmodule
|
||||
(fun id modl loc ->
|
||||
compile_recmodule (fun id modl loc ->
|
||||
match id with
|
||||
| None -> transl_module Tcoerce_none None modl
|
||||
| Some id ->
|
||||
let module_body =
|
||||
transl_module Tcoerce_none (field_path rootpath id) modl
|
||||
in
|
||||
|
@ -623,9 +669,8 @@ and transl_structure loc fields cc rootpath final_env = function
|
|||
lev_kind = Lev_module_definition id;
|
||||
lev_repr = None;
|
||||
lev_env = Env.empty;
|
||||
}))
|
||||
bindings
|
||||
body
|
||||
})
|
||||
) bindings body
|
||||
in
|
||||
lam, size
|
||||
| Tstr_class cl_list ->
|
||||
|
@ -768,10 +813,12 @@ let rec defined_idents = function
|
|||
List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
|
||||
@ defined_idents rem
|
||||
| Tstr_exception ext -> ext.tyexn_constructor.ext_id :: defined_idents rem
|
||||
| Tstr_module {mb_id; mb_presence=Mp_present} -> mb_id :: defined_idents rem
|
||||
| Tstr_module {mb_presence=Mp_absent} -> defined_idents rem
|
||||
| Tstr_module {mb_id = Some id; mb_presence=Mp_present} ->
|
||||
id :: defined_idents rem
|
||||
| Tstr_module ({mb_id = None}
|
||||
|{mb_presence=Mp_absent}) -> defined_idents rem
|
||||
| Tstr_recmodule decls ->
|
||||
List.map (fun mb -> mb.mb_id) decls @ defined_idents rem
|
||||
List.filter_map (fun mb -> mb.mb_id) decls @ defined_idents rem
|
||||
| Tstr_modtype _ -> defined_idents rem
|
||||
| Tstr_open od ->
|
||||
bound_value_identifiers od.open_bound_items @ defined_idents rem
|
||||
|
@ -833,7 +880,7 @@ and all_idents = function
|
|||
@ all_idents rem
|
||||
| Tstr_exception ext -> ext.tyexn_constructor.ext_id :: all_idents rem
|
||||
| Tstr_recmodule decls ->
|
||||
List.map (fun mb -> mb.mb_id) decls @ all_idents rem
|
||||
List.filter_map (fun mb -> mb.mb_id) decls @ all_idents rem
|
||||
| Tstr_modtype _ -> all_idents rem
|
||||
| Tstr_open od ->
|
||||
let rest = all_idents rem in
|
||||
|
@ -858,15 +905,19 @@ and all_idents = function
|
|||
bound_value_identifiers incl.incl_type @ all_idents rem
|
||||
|
||||
| Tstr_module
|
||||
{mb_id;mb_presence=Mp_present;mb_expr={mod_desc = Tmod_structure str}}
|
||||
{ mb_id = Some id;
|
||||
mb_presence=Mp_present;
|
||||
mb_expr={mod_desc = Tmod_structure str} }
|
||||
| Tstr_module
|
||||
{mb_id;mb_presence=Mp_present;
|
||||
mb_expr=
|
||||
{ mb_id = Some id;
|
||||
mb_presence = Mp_present;
|
||||
mb_expr =
|
||||
{mod_desc =
|
||||
Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} ->
|
||||
mb_id :: all_idents str.str_items @ all_idents rem
|
||||
| Tstr_module {mb_id;mb_presence=Mp_present} -> mb_id :: all_idents rem
|
||||
| Tstr_module {mb_presence=Mp_absent} -> all_idents rem
|
||||
id :: all_idents str.str_items @ all_idents rem
|
||||
| Tstr_module {mb_id = Some id;mb_presence=Mp_present} ->
|
||||
id :: all_idents rem
|
||||
| Tstr_module ({mb_id = None} | {mb_presence=Mp_absent}) -> all_idents rem
|
||||
| Tstr_attribute _ -> all_idents rem
|
||||
|
||||
|
||||
|
@ -951,7 +1002,17 @@ let transl_store_structure glob map prims aliases str =
|
|||
store_ident ext.tyexn_constructor.ext_loc id),
|
||||
transl_store rootpath
|
||||
(add_ident false id subst) cont rem)
|
||||
| Tstr_module{mb_id=id;mb_loc=loc;mb_presence=Mp_present;
|
||||
| Tstr_module
|
||||
{mb_id=None; mb_name; mb_presence=Mp_present; mb_expr=modl;
|
||||
mb_loc=loc; mb_attributes} ->
|
||||
let lam =
|
||||
Translattribute.add_inline_attribute
|
||||
(transl_module Tcoerce_none None modl)
|
||||
loc mb_attributes
|
||||
in
|
||||
Lsequence(Lprim(Pignore, [lam], mb_name.loc),
|
||||
transl_store rootpath subst cont rem)
|
||||
| Tstr_module{mb_id=Some id;mb_loc=loc;mb_presence=Mp_present;
|
||||
mb_expr={mod_desc = Tmod_structure str} as mexp;
|
||||
mb_attributes} ->
|
||||
List.iter (Translattribute.check_attribute_on_module mexp)
|
||||
|
@ -973,7 +1034,7 @@ let transl_store_structure glob map prims aliases str =
|
|||
(add_ident true id subst)
|
||||
cont rem)))
|
||||
| Tstr_module{
|
||||
mb_id=id;mb_loc=loc;mb_presence=Mp_present;
|
||||
mb_id=Some id;mb_loc=loc;mb_presence=Mp_present;
|
||||
mb_expr= {
|
||||
mod_desc = Tmod_constraint (
|
||||
{mod_desc = Tmod_structure str} as mexp, _, _,
|
||||
|
@ -1001,7 +1062,7 @@ let transl_store_structure glob map prims aliases str =
|
|||
(add_ident true id subst)
|
||||
cont rem)))
|
||||
| Tstr_module
|
||||
{mb_id=id; mb_presence=Mp_present; mb_expr=modl;
|
||||
{mb_id=Some id; mb_presence=Mp_present; mb_expr=modl;
|
||||
mb_loc=loc; mb_attributes} ->
|
||||
let lam =
|
||||
Translattribute.add_inline_attribute
|
||||
|
@ -1021,12 +1082,12 @@ let transl_store_structure glob map prims aliases str =
|
|||
| Tstr_module {mb_presence=Mp_absent} ->
|
||||
transl_store rootpath subst cont rem
|
||||
| Tstr_recmodule bindings ->
|
||||
let ids = List.map (fun mb -> mb.mb_id) bindings in
|
||||
let ids = List.filter_map (fun mb -> mb.mb_id) bindings in
|
||||
compile_recmodule
|
||||
(fun id modl _loc ->
|
||||
Lambda.subst no_env_update subst
|
||||
(transl_module Tcoerce_none
|
||||
(field_path rootpath id) modl))
|
||||
(Option.bind id (field_path rootpath)) modl))
|
||||
bindings
|
||||
(Lsequence(store_idents Location.none ids,
|
||||
transl_store rootpath (add_idents true ids subst)
|
||||
|
@ -1349,16 +1410,19 @@ let transl_toplevel_item item =
|
|||
set_toplevel_unique_name ext.tyexn_constructor.ext_id;
|
||||
toploop_setvalue ext.tyexn_constructor.ext_id
|
||||
(transl_extension_constructor item.str_env None ext.tyexn_constructor)
|
||||
| Tstr_module {mb_id=id; mb_presence=Mp_present; mb_expr=modl} ->
|
||||
| Tstr_module {mb_id=None; mb_presence=Mp_present; mb_expr=modl} ->
|
||||
transl_module Tcoerce_none None modl
|
||||
| Tstr_module {mb_id=Some id; mb_presence=Mp_present; mb_expr=modl} ->
|
||||
(* we need to use the unique name for the module because of issues
|
||||
with "open" (PR#8133) *)
|
||||
set_toplevel_unique_name id;
|
||||
let lam = transl_module Tcoerce_none (Some(Pident id)) modl in
|
||||
toploop_setvalue id lam
|
||||
| Tstr_recmodule bindings ->
|
||||
let idents = List.map (fun mb -> mb.mb_id) bindings in
|
||||
let idents = List.filter_map (fun mb -> mb.mb_id) bindings in
|
||||
compile_recmodule
|
||||
(fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl)
|
||||
(fun id modl _loc ->
|
||||
transl_module Tcoerce_none (Option.map (fun i -> Pident i) id) modl)
|
||||
bindings
|
||||
(make_sequence toploop_setvalue_id idents)
|
||||
| Tstr_class cl_list ->
|
||||
|
@ -1523,12 +1587,16 @@ let print_cycle ppf cycle =
|
|||
(Ident.name @@ fst @@ List.hd cycle)
|
||||
(* we repeat the first element to make the cycle more apparent *)
|
||||
|
||||
let explanation_submsg (id, {reason;loc;subid}) =
|
||||
let explanation_submsg (id, unsafe_info) =
|
||||
match unsafe_info with
|
||||
| Unnamed -> assert false (* can't be part of a cycle. *)
|
||||
| Unsafe {reason;loc;subid} ->
|
||||
let print fmt =
|
||||
let printer = Format.dprintf fmt (Ident.name id) (Ident.name subid) in
|
||||
Location.mkloc printer loc in
|
||||
match reason with
|
||||
| Unsafe_module_binding -> print "Module %s defines an unsafe module, %s ."
|
||||
| Unsafe_module_binding ->
|
||||
print "Module %s defines an unsafe module, %s ."
|
||||
| Unsafe_functor -> print "Module %s defines an unsafe functor, %s ."
|
||||
| Unsafe_typext ->
|
||||
print "Module %s defines an unsafe extension constructor, %s ."
|
||||
|
|
|
@ -48,7 +48,9 @@ type unsafe_component =
|
|||
| Unsafe_non_function
|
||||
| Unsafe_typext
|
||||
|
||||
type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t }
|
||||
type unsafe_info =
|
||||
| Unsafe of { reason:unsafe_component; loc:Location.t; subid:Ident.t }
|
||||
| Unnamed
|
||||
|
||||
type error =
|
||||
Circular_dependency of (Ident.t * unsafe_info) list
|
||||
|
|
|
@ -60,12 +60,15 @@ module Typedtree_search =
|
|||
let add_to_hashes table table_values tt =
|
||||
match tt with
|
||||
| Typedtree.Tstr_module mb ->
|
||||
Hashtbl.add table (M (Name.from_ident mb.mb_id)) tt
|
||||
Option.iter (fun id ->
|
||||
Hashtbl.add table (M (Name.from_ident id)) tt) mb.mb_id
|
||||
| Typedtree.Tstr_recmodule mods ->
|
||||
List.iter
|
||||
(fun mb ->
|
||||
Hashtbl.add table (M (Name.from_ident mb.mb_id))
|
||||
Option.iter (fun id ->
|
||||
Hashtbl.add table (M (Name.from_ident id))
|
||||
(Typedtree.Tstr_module mb)
|
||||
) mb.mb_id
|
||||
)
|
||||
mods
|
||||
| Typedtree.Tstr_modtype mtd ->
|
||||
|
@ -1395,15 +1398,18 @@ module Analyser =
|
|||
in
|
||||
(0, new_env, [ Element_exception new_ext ])
|
||||
|
||||
| Parsetree.Pstr_module {Parsetree.pmb_name=name; pmb_expr=module_expr} ->
|
||||
| Parsetree.Pstr_module {Parsetree.pmb_name={txt=None}} ->
|
||||
(0, env, [])
|
||||
|
||||
| Parsetree.Pstr_module {Parsetree.pmb_name={txt=Some name}; pmb_expr=module_expr} ->
|
||||
(
|
||||
(* of string * module_expr *)
|
||||
try
|
||||
let tt_module_expr = Typedtree_search.search_module table name.txt in
|
||||
let tt_module_expr = Typedtree_search.search_module table name in
|
||||
let new_module_pre = analyse_module
|
||||
env
|
||||
current_module_name
|
||||
name.txt
|
||||
name
|
||||
comment_opt
|
||||
module_expr
|
||||
tt_module_expr
|
||||
|
@ -1433,7 +1439,7 @@ module Analyser =
|
|||
(0, new_env2, [ Element_module new_module ])
|
||||
with
|
||||
Not_found ->
|
||||
let complete_name = Name.concat current_module_name name.txt in
|
||||
let complete_name = Name.concat current_module_name name in
|
||||
raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
|
||||
)
|
||||
|
||||
|
@ -1443,16 +1449,19 @@ module Analyser =
|
|||
let new_env =
|
||||
List.fold_left
|
||||
(fun acc_env {Parsetree.pmb_name=name;pmb_expr=mod_exp} ->
|
||||
let complete_name = Name.concat current_module_name name.txt in
|
||||
match name.txt with
|
||||
| None -> acc_env
|
||||
| Some name ->
|
||||
let complete_name = Name.concat current_module_name name in
|
||||
let e = Odoc_env.add_module acc_env complete_name in
|
||||
let tt_mod_exp =
|
||||
try Typedtree_search.search_module table name.txt
|
||||
try Typedtree_search.search_module table name
|
||||
with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
|
||||
in
|
||||
let new_module = analyse_module
|
||||
e
|
||||
current_module_name
|
||||
name.txt
|
||||
name
|
||||
None
|
||||
mod_exp
|
||||
tt_mod_exp
|
||||
|
@ -1470,12 +1479,23 @@ module Analyser =
|
|||
let rec f ?(first=false) last_pos name_mod_exp_list =
|
||||
match name_mod_exp_list with
|
||||
[] -> []
|
||||
| {Parsetree.pmb_name=name;pmb_expr=mod_exp} :: q ->
|
||||
let complete_name = Name.concat current_module_name name.txt in
|
||||
| {Parsetree.pmb_name={txt=None};pmb_expr=mod_exp} :: q ->
|
||||
let loc_start = mod_exp.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
|
||||
let loc_end = mod_exp.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
|
||||
let (_, ele_comments) = (* the comment for the first type was already retrieved *)
|
||||
if first then
|
||||
(None, [])
|
||||
else
|
||||
get_comments_in_module last_pos loc_start
|
||||
in
|
||||
let eles = f loc_end q in
|
||||
ele_comments @ eles
|
||||
| {Parsetree.pmb_name={txt=Some name};pmb_expr=mod_exp} :: q ->
|
||||
let complete_name = Name.concat current_module_name name in
|
||||
let loc_start = mod_exp.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
|
||||
let loc_end = mod_exp.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
|
||||
let tt_mod_exp =
|
||||
try Typedtree_search.search_module table name.txt
|
||||
try Typedtree_search.search_module table name
|
||||
with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
|
||||
in
|
||||
let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *)
|
||||
|
@ -1487,7 +1507,7 @@ module Analyser =
|
|||
let new_module = analyse_module
|
||||
new_env
|
||||
current_module_name
|
||||
name.txt
|
||||
name
|
||||
com_opt
|
||||
mod_exp
|
||||
tt_mod_exp
|
||||
|
@ -1709,29 +1729,33 @@ module Analyser =
|
|||
let elements2 = replace_dummy_included_modules elements included_modules_from_tt in
|
||||
{ m_base with m_kind = Module_struct elements2 }
|
||||
|
||||
| (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2),
|
||||
Typedtree.Tmod_functor (ident, _, mtyp, tt_module_expr2)) ->
|
||||
let loc = match pmodule_type with None -> Location.none
|
||||
| Some pmty -> pmty.Parsetree.pmty_loc in
|
||||
| (Parsetree.Pmod_functor (param2, p_module_expr2),
|
||||
Typedtree.Tmod_functor (param, tt_module_expr2)) ->
|
||||
let loc, mp_name, mp_kind, mp_type =
|
||||
match param2, param with
|
||||
| Parsetree.Unit, Typedtree.Unit ->
|
||||
Location.none, "*", Module_type_struct [], None
|
||||
| Parsetree.Named (_, pmty), Typedtree.Named (ident, _, mty) ->
|
||||
let loc = pmty.Parsetree.pmty_loc in
|
||||
let mp_name = Option.fold ~none:"*" ~some:Name.from_ident ident in
|
||||
let mp_kind =
|
||||
Sig.analyse_module_type_kind env current_module_name pmty
|
||||
mty.mty_type
|
||||
in
|
||||
let mp_type = Odoc_env.subst_module_type env mty.mty_type in
|
||||
loc, mp_name, mp_kind, Some mp_type
|
||||
| _, _ -> assert false
|
||||
in
|
||||
let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
|
||||
let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
|
||||
let mp_type_code = get_string_of_file loc_start loc_end in
|
||||
print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
|
||||
let mp_name = Name.from_ident ident in
|
||||
let mp_kind =
|
||||
match pmodule_type, mtyp with
|
||||
Some pmty, Some mty ->
|
||||
Sig.analyse_module_type_kind env current_module_name pmty
|
||||
mty.mty_type
|
||||
| _ -> Module_type_struct []
|
||||
in
|
||||
let param =
|
||||
{
|
||||
mp_name = mp_name ;
|
||||
mp_type = Option.map
|
||||
(fun m -> Odoc_env.subst_module_type env m.mty_type) mtyp ;
|
||||
mp_name ;
|
||||
mp_type ;
|
||||
mp_type_code = mp_type_code ;
|
||||
mp_kind = mp_kind ;
|
||||
mp_kind ;
|
||||
}
|
||||
in
|
||||
let dummy_complete_name = (*Name.concat "__"*) param.mp_name in
|
||||
|
|
|
@ -216,15 +216,17 @@ let subst_type env t =
|
|||
|
||||
let subst_module_type env t =
|
||||
let rec iter t =
|
||||
let open Types in
|
||||
match t with
|
||||
Types.Mty_ident p ->
|
||||
Mty_ident p ->
|
||||
let new_p = Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in
|
||||
Types.Mty_ident new_p
|
||||
| Types.Mty_alias _
|
||||
| Types.Mty_signature _ ->
|
||||
Mty_ident new_p
|
||||
| Mty_alias _
|
||||
| Mty_signature _ ->
|
||||
t
|
||||
| Types.Mty_functor (id, mt1, mt2) ->
|
||||
Types.Mty_functor (id, Option.map iter mt1, iter mt2)
|
||||
| Mty_functor (Unit, mt) -> Mty_functor (Unit, iter mt)
|
||||
| Mty_functor (Named (name, mt1), mt2) ->
|
||||
Mty_functor (Named (name, iter mt1), iter mt2)
|
||||
in
|
||||
iter t
|
||||
|
||||
|
|
|
@ -52,18 +52,20 @@ exception Use_code of string
|
|||
than the "emptied" type.
|
||||
*)
|
||||
let simpl_module_type ?code t =
|
||||
let open Types in
|
||||
let rec iter t =
|
||||
match t with
|
||||
Types.Mty_ident _
|
||||
| Types.Mty_alias _ -> t
|
||||
| Types.Mty_signature _ ->
|
||||
Mty_ident _
|
||||
| Mty_alias _ -> t
|
||||
| Mty_signature _ ->
|
||||
(
|
||||
match code with
|
||||
None -> Types.Mty_signature []
|
||||
None -> Mty_signature []
|
||||
| Some s -> raise (Use_code s)
|
||||
)
|
||||
| Types.Mty_functor (id, mt1, mt2) ->
|
||||
Types.Mty_functor (id, Option.map iter mt1, iter mt2)
|
||||
| Mty_functor (Unit, mt) -> Mty_functor (Unit, iter mt)
|
||||
| Mty_functor (Named (name, mt1), mt2) ->
|
||||
Mty_functor (Named (name, iter mt1), iter mt2)
|
||||
in
|
||||
iter t
|
||||
|
||||
|
|
|
@ -491,10 +491,11 @@ module Analyser =
|
|||
| [] -> acc
|
||||
| types -> take_item (Parsetree.Psig_type (rf, types)))
|
||||
| Parsetree.Psig_modsubst _ -> acc
|
||||
| Parsetree.Psig_module ({Parsetree.pmd_name=name;
|
||||
| Parsetree.Psig_module {Parsetree.pmd_name={ txt = None }} -> acc
|
||||
| Parsetree.Psig_module ({Parsetree.pmd_name={txt = Some name };
|
||||
pmd_type=module_type} as r)
|
||||
as m ->
|
||||
begin match Name.Map.find name.txt erased with
|
||||
begin match Name.Map.find name erased with
|
||||
| exception Not_found -> take_item m
|
||||
| `Removed -> acc
|
||||
| `Constrained constraints ->
|
||||
|
@ -507,7 +508,13 @@ module Analyser =
|
|||
| Parsetree.Psig_modtype {Parsetree.pmtd_name=name} as m ->
|
||||
if is_erased name.txt erased then acc else take_item m
|
||||
| Parsetree.Psig_recmodule mods ->
|
||||
(match List.filter (fun pmd -> not (is_erased pmd.Parsetree.pmd_name.txt erased)) mods with
|
||||
(match List.filter
|
||||
(fun pmd ->
|
||||
match pmd.Parsetree.pmd_name.txt with
|
||||
| None -> false
|
||||
| Some name -> not (is_erased name erased))
|
||||
mods
|
||||
with
|
||||
| [] -> acc
|
||||
| mods -> take_item (Parsetree.Psig_recmodule mods)))
|
||||
signature []
|
||||
|
@ -1141,13 +1148,16 @@ module Analyser =
|
|||
| Parsetree.Psig_modsubst _ -> (* FIXME *)
|
||||
(0, env, [])
|
||||
|
||||
| Parsetree.Psig_module {Parsetree.pmd_name=name; pmd_type=module_type} ->
|
||||
let complete_name = Name.concat current_module_name name.txt in
|
||||
| Parsetree.Psig_module {Parsetree.pmd_name={txt=None}} ->
|
||||
(0, env, [])
|
||||
|
||||
| Parsetree.Psig_module {Parsetree.pmd_name={txt=Some name}; pmd_type=module_type} ->
|
||||
let complete_name = Name.concat current_module_name name in
|
||||
(* get the module type in the signature by the module name *)
|
||||
let sig_module_type =
|
||||
try Signature_search.search_module table name.txt
|
||||
try Signature_search.search_module table name
|
||||
with Not_found ->
|
||||
raise (Failure (Odoc_messages.module_not_found current_module_name name.txt))
|
||||
raise (Failure (Odoc_messages.module_not_found current_module_name name))
|
||||
in
|
||||
let module_kind = analyse_module_kind env complete_name module_type sig_module_type in
|
||||
let code_intf =
|
||||
|
@ -1193,6 +1203,9 @@ module Analyser =
|
|||
let new_env =
|
||||
List.fold_left
|
||||
(fun acc_env {Parsetree.pmd_name={txt=name}} ->
|
||||
match name with
|
||||
| None -> acc_env
|
||||
| Some name ->
|
||||
let complete_name = Name.concat current_module_name name in
|
||||
let e = Odoc_env.add_module acc_env complete_name in
|
||||
(* get the information for the module in the signature *)
|
||||
|
@ -1216,8 +1229,34 @@ module Analyser =
|
|||
match name_mtype_list with
|
||||
[] ->
|
||||
(acc_maybe_more, [])
|
||||
| {Parsetree.pmd_name=name; pmd_type=modtype} :: q ->
|
||||
let complete_name = Name.concat current_module_name name.txt in
|
||||
| {Parsetree.pmd_name={txt = None}; pmd_type=modtype} :: q ->
|
||||
let loc = modtype.Parsetree.pmty_loc in
|
||||
let loc_start = Loc.start loc in
|
||||
let loc_end = Loc.end_ loc in
|
||||
let _, ele_comments =
|
||||
if first then (None, [])
|
||||
else get_comments_in_module last_pos loc_start
|
||||
in
|
||||
let pos_limit2 =
|
||||
match q with
|
||||
[] -> pos_limit
|
||||
| _ :: _ -> Loc.start loc
|
||||
in
|
||||
let (maybe_more, _) =
|
||||
My_ir.just_after_special
|
||||
!file_name
|
||||
(get_string_of_file loc_end pos_limit2)
|
||||
in
|
||||
|
||||
let (maybe_more2, eles) = f
|
||||
maybe_more
|
||||
(loc_end + maybe_more)
|
||||
q
|
||||
in
|
||||
(maybe_more2, ele_comments @ eles)
|
||||
|
||||
| {Parsetree.pmd_name={txt = Some name}; pmd_type=modtype} :: q ->
|
||||
let complete_name = Name.concat current_module_name name in
|
||||
let loc = modtype.Parsetree.pmty_loc in
|
||||
let loc_start = Loc.start loc in
|
||||
let loc_end = Loc.end_ loc in
|
||||
|
@ -1236,9 +1275,9 @@ module Analyser =
|
|||
in
|
||||
(* get the information for the module in the signature *)
|
||||
let sig_module_type =
|
||||
try Signature_search.search_module table name.txt
|
||||
try Signature_search.search_module table name
|
||||
with Not_found ->
|
||||
raise (Failure (Odoc_messages.module_not_found current_module_name name.txt))
|
||||
raise (Failure (Odoc_messages.module_not_found current_module_name name))
|
||||
in
|
||||
(* associate the comments to each constructor and build the [Type.t_type] *)
|
||||
let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in
|
||||
|
@ -1543,28 +1582,31 @@ module Analyser =
|
|||
raise (Failure "Parsetree.Pmty_signature signature but not Types.Mty_signature signat")
|
||||
)
|
||||
|
||||
| Parsetree.Pmty_functor (_, pmodule_type2, module_type2) ->
|
||||
| Parsetree.Pmty_functor (param2, module_type2) ->
|
||||
(
|
||||
let loc = match pmodule_type2 with None -> Location.none
|
||||
| Some pmty -> pmty.Parsetree.pmty_loc in
|
||||
let loc = match param2 with Parsetree.Unit -> Location.none
|
||||
| Parsetree.Named (_, pmty) -> pmty.Parsetree.pmty_loc in
|
||||
let loc_start = Loc.start loc in
|
||||
let loc_end = Loc.end_ loc in
|
||||
let mp_type_code = get_string_of_file loc_start loc_end in
|
||||
print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
|
||||
match sig_module_type with
|
||||
Types.Mty_functor (ident, param_module_type, body_module_type) ->
|
||||
let mp_kind =
|
||||
match pmodule_type2, param_module_type with
|
||||
Some pmty, Some mty ->
|
||||
Types.Mty_functor (param, body_module_type) ->
|
||||
let mp_name, mp_kind =
|
||||
match param2, param with
|
||||
Parsetree.Named (_, pmty), Types.Named (Some ident, mty) ->
|
||||
Name.from_ident ident,
|
||||
analyse_module_type_kind env current_module_name pmty mty
|
||||
| _ -> Module_type_struct []
|
||||
| _ -> "*", Module_type_struct []
|
||||
in
|
||||
let param =
|
||||
{
|
||||
mp_name = Name.from_ident ident ;
|
||||
mp_name = mp_name;
|
||||
mp_type =
|
||||
Option.map (Odoc_env.subst_module_type env)
|
||||
param_module_type;
|
||||
(match param with
|
||||
| Types.Unit -> None
|
||||
| Types.Named (_, mty) ->
|
||||
Some (Odoc_env.subst_module_type env mty));
|
||||
mp_type_code = mp_type_code ;
|
||||
mp_kind = mp_kind ;
|
||||
}
|
||||
|
@ -1638,27 +1680,30 @@ module Analyser =
|
|||
(* if we're here something's wrong *)
|
||||
raise (Failure "Parsetree.Pmty_signature signature but not Types.Mty_signature signat")
|
||||
)
|
||||
| Parsetree.Pmty_functor (_, pmodule_type2,module_type2) (* of string * module_type * module_type *) ->
|
||||
| Parsetree.Pmty_functor (param2,module_type2) (* of string * module_type * module_type *) ->
|
||||
(
|
||||
match sig_module_type with
|
||||
Types.Mty_functor (ident, param_module_type, body_module_type) ->
|
||||
let loc = match pmodule_type2 with None -> Location.none
|
||||
| Some pmty -> pmty.Parsetree.pmty_loc in
|
||||
Types.Mty_functor (param, body_module_type) ->
|
||||
let loc = match param2 with Parsetree.Unit -> Location.none
|
||||
| Parsetree.Named (_, pmty) -> pmty.Parsetree.pmty_loc in
|
||||
let loc_start = Loc.start loc in
|
||||
let loc_end = Loc.end_ loc in
|
||||
let mp_type_code = get_string_of_file loc_start loc_end in
|
||||
print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
|
||||
let mp_kind =
|
||||
match pmodule_type2, param_module_type with
|
||||
Some pmty, Some mty ->
|
||||
let mp_name, mp_kind =
|
||||
match param2, param with
|
||||
Parsetree.Named (_, pmty), Types.Named (Some ident, mty) ->
|
||||
Name.from_ident ident,
|
||||
analyse_module_type_kind env current_module_name pmty mty
|
||||
| _ -> Module_type_struct []
|
||||
| _ -> "*", Module_type_struct []
|
||||
in
|
||||
let param =
|
||||
{
|
||||
mp_name = Name.from_ident ident ;
|
||||
mp_type = Option.map
|
||||
(Odoc_env.subst_module_type env) param_module_type ;
|
||||
mp_name;
|
||||
mp_type =
|
||||
(match param with
|
||||
| Types.Unit -> None
|
||||
| Types.Named(_, mty) -> Some (Odoc_env.subst_module_type env mty));
|
||||
mp_type_code = mp_type_code ;
|
||||
mp_kind = mp_kind ;
|
||||
}
|
||||
|
|
|
@ -24,6 +24,7 @@ type loc = Location.t
|
|||
|
||||
type lid = Longident.t with_loc
|
||||
type str = string with_loc
|
||||
type str_opt = string option with_loc
|
||||
type attrs = attribute list
|
||||
|
||||
let default_loc = ref Location.none
|
||||
|
@ -236,7 +237,7 @@ module Mty = struct
|
|||
let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a)
|
||||
let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a)
|
||||
let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a)
|
||||
let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c))
|
||||
let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b))
|
||||
let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b))
|
||||
let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a)
|
||||
let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a)
|
||||
|
@ -249,8 +250,8 @@ let mk ?(loc = !default_loc) ?(attrs = []) d =
|
|||
|
||||
let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x)
|
||||
let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x)
|
||||
let functor_ ?loc ?attrs arg arg_ty body =
|
||||
mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body))
|
||||
let functor_ ?loc ?attrs arg body =
|
||||
mk ?loc ?attrs (Pmod_functor (arg, body))
|
||||
let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2))
|
||||
let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty))
|
||||
let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e)
|
||||
|
|
|
@ -29,6 +29,7 @@ type loc = Location.t
|
|||
|
||||
type lid = Longident.t with_loc
|
||||
type str = string with_loc
|
||||
type str_opt = string option with_loc
|
||||
type attrs = attribute list
|
||||
|
||||
(** {1 Default locations} *)
|
||||
|
@ -116,7 +117,7 @@ module Pat:
|
|||
val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern
|
||||
val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
|
||||
val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
|
||||
val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern
|
||||
val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern
|
||||
val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern
|
||||
val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
|
||||
val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
|
||||
|
@ -168,8 +169,8 @@ module Exp:
|
|||
val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
|
||||
val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list
|
||||
-> expression
|
||||
val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression
|
||||
-> expression
|
||||
val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr
|
||||
-> expression -> expression
|
||||
val letexception:
|
||||
?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
|
||||
-> expression
|
||||
|
@ -246,7 +247,7 @@ module Mty:
|
|||
val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type
|
||||
val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
|
||||
val functor_: ?loc:loc -> ?attrs:attrs ->
|
||||
str -> module_type option -> module_type -> module_type
|
||||
functor_parameter -> module_type -> module_type
|
||||
val with_: ?loc:loc -> ?attrs:attrs -> module_type ->
|
||||
with_constraint list -> module_type
|
||||
val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type
|
||||
|
@ -262,7 +263,7 @@ module Mod:
|
|||
val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr
|
||||
val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr
|
||||
val functor_: ?loc:loc -> ?attrs:attrs ->
|
||||
str -> module_type option -> module_expr -> module_expr
|
||||
functor_parameter -> module_expr -> module_expr
|
||||
val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr ->
|
||||
module_expr
|
||||
val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type ->
|
||||
|
@ -321,7 +322,7 @@ module Str:
|
|||
module Md:
|
||||
sig
|
||||
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
|
||||
str -> module_type -> module_declaration
|
||||
str_opt -> module_type -> module_declaration
|
||||
end
|
||||
|
||||
(** Module substitutions *)
|
||||
|
@ -342,7 +343,7 @@ module Mtd:
|
|||
module Mb:
|
||||
sig
|
||||
val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->
|
||||
str -> module_expr -> module_binding
|
||||
str_opt -> module_expr -> module_binding
|
||||
end
|
||||
|
||||
(** Opens *)
|
||||
|
|
|
@ -233,6 +233,12 @@ module CT = struct
|
|||
List.iter (sub.class_type_field sub) pcsig_fields
|
||||
end
|
||||
|
||||
let iter_functor_param sub = function
|
||||
| Unit -> ()
|
||||
| Named (name, mty) ->
|
||||
iter_loc sub name;
|
||||
sub.module_type sub mty
|
||||
|
||||
module MT = struct
|
||||
(* Type expressions for the module language *)
|
||||
|
||||
|
@ -243,9 +249,8 @@ module MT = struct
|
|||
| Pmty_ident s -> iter_loc sub s
|
||||
| Pmty_alias s -> iter_loc sub s
|
||||
| Pmty_signature sg -> sub.signature sub sg
|
||||
| Pmty_functor (s, mt1, mt2) ->
|
||||
iter_loc sub s;
|
||||
iter_opt (sub.module_type sub) mt1;
|
||||
| Pmty_functor (param, mt2) ->
|
||||
iter_functor_param sub param;
|
||||
sub.module_type sub mt2
|
||||
| Pmty_with (mt, l) ->
|
||||
sub.module_type sub mt;
|
||||
|
@ -298,9 +303,8 @@ module M = struct
|
|||
match desc with
|
||||
| Pmod_ident x -> iter_loc sub x
|
||||
| Pmod_structure str -> sub.structure sub str
|
||||
| Pmod_functor (arg, arg_ty, body) ->
|
||||
iter_loc sub arg;
|
||||
iter_opt (sub.module_type sub) arg_ty;
|
||||
| Pmod_functor (param, body) ->
|
||||
iter_functor_param sub param;
|
||||
sub.module_expr sub body
|
||||
| Pmod_apply (m1, m2) ->
|
||||
sub.module_expr sub m1; sub.module_expr sub m2
|
||||
|
|
|
@ -249,6 +249,10 @@ module CT = struct
|
|||
(List.map (sub.class_type_field sub) pcsig_fields)
|
||||
end
|
||||
|
||||
let map_functor_param sub = function
|
||||
| Unit -> Unit
|
||||
| Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt)
|
||||
|
||||
module MT = struct
|
||||
(* Type expressions for the module language *)
|
||||
|
||||
|
@ -260,10 +264,10 @@ module MT = struct
|
|||
| Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
|
||||
| Pmty_alias s -> alias ~loc ~attrs (map_loc sub s)
|
||||
| Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg)
|
||||
| Pmty_functor (s, mt1, mt2) ->
|
||||
functor_ ~loc ~attrs (map_loc sub s)
|
||||
(Option.map (sub.module_type sub) mt1)
|
||||
(sub.module_type sub mt2)
|
||||
| Pmty_functor (param, mt) ->
|
||||
functor_ ~loc ~attrs
|
||||
(map_functor_param sub param)
|
||||
(sub.module_type sub mt)
|
||||
| Pmty_with (mt, l) ->
|
||||
with_ ~loc ~attrs (sub.module_type sub mt)
|
||||
(List.map (sub.with_constraint sub) l)
|
||||
|
@ -318,9 +322,9 @@ module M = struct
|
|||
match desc with
|
||||
| Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
|
||||
| Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str)
|
||||
| Pmod_functor (arg, arg_ty, body) ->
|
||||
functor_ ~loc ~attrs (map_loc sub arg)
|
||||
(Option.map (sub.module_type sub) arg_ty)
|
||||
| Pmod_functor (param, body) ->
|
||||
functor_ ~loc ~attrs
|
||||
(map_functor_param sub param)
|
||||
(sub.module_expr sub body)
|
||||
| Pmod_apply (m1, m2) ->
|
||||
apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2)
|
||||
|
|
|
@ -182,7 +182,9 @@ let rec add_pattern bv pat =
|
|||
| Ppat_variant(_, op) -> add_opt add_pattern bv op
|
||||
| Ppat_type li -> add bv li
|
||||
| Ppat_lazy p -> add_pattern bv p
|
||||
| Ppat_unpack id -> pattern_bv := String.Map.add id.txt bound !pattern_bv
|
||||
| Ppat_unpack id ->
|
||||
Option.iter
|
||||
(fun name -> pattern_bv := String.Map.add name bound !pattern_bv) id.txt
|
||||
| Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p
|
||||
| Ppat_exception p -> add_pattern bv p
|
||||
| Ppat_extension e -> handle_extension e
|
||||
|
@ -234,7 +236,12 @@ let rec add_expr bv exp =
|
|||
| Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
|
||||
| Pexp_letmodule(id, m, e) ->
|
||||
let b = add_module_binding bv m in
|
||||
add_expr (String.Map.add id.txt b bv) e
|
||||
let bv =
|
||||
match id.txt with
|
||||
| None -> bv
|
||||
| Some id -> String.Map.add id b bv
|
||||
in
|
||||
add_expr bv e
|
||||
| Pexp_letexception(_, e) -> add_expr bv e
|
||||
| Pexp_assert (e) -> add_expr bv e
|
||||
| Pexp_lazy (e) -> add_expr bv e
|
||||
|
@ -283,9 +290,17 @@ and add_modtype bv mty =
|
|||
Pmty_ident l -> add bv l
|
||||
| Pmty_alias l -> add_module_path bv l
|
||||
| Pmty_signature s -> add_signature bv s
|
||||
| Pmty_functor(id, mty1, mty2) ->
|
||||
Option.iter (add_modtype bv) mty1;
|
||||
add_modtype (String.Map.add id.txt bound bv) mty2
|
||||
| Pmty_functor(param, mty2) ->
|
||||
let bv =
|
||||
match param with
|
||||
| Unit -> bv
|
||||
| Named (id, mty1) ->
|
||||
add_modtype bv mty1;
|
||||
match id.txt with
|
||||
| None -> bv
|
||||
| Some name -> String.Map.add name bound bv
|
||||
in
|
||||
add_modtype bv mty2
|
||||
| Pmty_with(mty, cstrl) ->
|
||||
add_modtype bv mty;
|
||||
List.iter
|
||||
|
@ -340,7 +355,11 @@ and add_sig_item (bv, m) item =
|
|||
add_type_exception bv te; (bv, m)
|
||||
| Psig_module pmd ->
|
||||
let m' = add_modtype_binding bv pmd.pmd_type in
|
||||
let add = String.Map.add pmd.pmd_name.txt m' in
|
||||
let add map =
|
||||
match pmd.pmd_name.txt with
|
||||
| None -> map
|
||||
| Some name -> String.Map.add name m' map
|
||||
in
|
||||
(add bv, add m)
|
||||
| Psig_modsubst pms ->
|
||||
let m' = add_module_alias bv pms.pms_manifest in
|
||||
|
@ -348,8 +367,11 @@ and add_sig_item (bv, m) item =
|
|||
(add bv, add m)
|
||||
| Psig_recmodule decls ->
|
||||
let add =
|
||||
List.fold_right (fun pmd -> String.Map.add pmd.pmd_name.txt bound)
|
||||
decls
|
||||
List.fold_right (fun pmd map ->
|
||||
match pmd.pmd_name.txt with
|
||||
| None -> map
|
||||
| Some name -> String.Map.add name bound map
|
||||
) decls
|
||||
in
|
||||
let bv' = add bv and m' = add m in
|
||||
List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
|
||||
|
@ -397,9 +419,17 @@ and add_module_expr bv modl =
|
|||
match modl.pmod_desc with
|
||||
Pmod_ident l -> add_module_path bv l
|
||||
| Pmod_structure s -> ignore (add_structure bv s)
|
||||
| Pmod_functor(id, mty, modl) ->
|
||||
Option.iter (add_modtype bv) mty;
|
||||
add_module_expr (String.Map.add id.txt bound bv) modl
|
||||
| Pmod_functor(param, modl) ->
|
||||
let bv =
|
||||
match param with
|
||||
| Unit -> bv
|
||||
| Named (id, mty) ->
|
||||
add_modtype bv mty;
|
||||
match id.txt with
|
||||
| None -> bv
|
||||
| Some name -> String.Map.add name bound bv
|
||||
in
|
||||
add_module_expr bv modl
|
||||
| Pmod_apply(mod1, mod2) ->
|
||||
add_module_expr bv mod1; add_module_expr bv mod2
|
||||
| Pmod_constraint(modl, mty) ->
|
||||
|
@ -463,11 +493,19 @@ and add_struct_item (bv, m) item : _ String.Map.t * _ String.Map.t =
|
|||
(bv, m)
|
||||
| Pstr_module x ->
|
||||
let b = add_module_binding bv x.pmb_expr in
|
||||
let add = String.Map.add x.pmb_name.txt b in
|
||||
let add map =
|
||||
match x.pmb_name.txt with
|
||||
| None -> map
|
||||
| Some name -> String.Map.add name b map
|
||||
in
|
||||
(add bv, add m)
|
||||
| Pstr_recmodule bindings ->
|
||||
let add =
|
||||
List.fold_right (fun x -> String.Map.add x.pmb_name.txt bound) bindings
|
||||
List.fold_right (fun x map ->
|
||||
match x.pmb_name.txt with
|
||||
| None -> map
|
||||
| Some name -> String.Map.add name bound map
|
||||
) bindings
|
||||
in
|
||||
let bv' = add bv and m = add m in
|
||||
List.iter
|
||||
|
|
|
@ -1132,20 +1132,20 @@ parse_pattern:
|
|||
|
||||
functor_arg:
|
||||
(* An anonymous and untyped argument. *)
|
||||
x = mkrhs(LPAREN RPAREN {"*"})
|
||||
{ x, None }
|
||||
LPAREN RPAREN
|
||||
{ Unit }
|
||||
| (* An argument accompanied with an explicit type. *)
|
||||
LPAREN x = mkrhs(functor_arg_name) COLON mty = module_type RPAREN
|
||||
{ x, Some mty }
|
||||
LPAREN x = mkrhs(module_name) COLON mty = module_type RPAREN
|
||||
{ Named (x, mty) }
|
||||
;
|
||||
|
||||
functor_arg_name:
|
||||
module_name:
|
||||
(* A named argument. *)
|
||||
x = UIDENT
|
||||
{ x }
|
||||
{ Some x }
|
||||
| (* An anonymous argument. *)
|
||||
UNDERSCORE
|
||||
{ "_" }
|
||||
{ None }
|
||||
;
|
||||
|
||||
(* -------------------------------------------------------------------------- *)
|
||||
|
@ -1164,8 +1164,8 @@ module_expr:
|
|||
{ unclosed "struct" $loc($1) "end" $loc($4) }
|
||||
| FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr
|
||||
{ wrap_mod_attrs ~loc:$sloc attrs (
|
||||
List.fold_left (fun acc (x, mty) ->
|
||||
mkmod ~loc:$sloc (Pmod_functor (x, mty, acc))
|
||||
List.fold_left (fun acc arg ->
|
||||
mkmod ~loc:$sloc (Pmod_functor (arg, acc))
|
||||
) me args
|
||||
) }
|
||||
| me = paren_module_expr
|
||||
|
@ -1307,13 +1307,13 @@ structure_item:
|
|||
%inline module_binding:
|
||||
MODULE
|
||||
ext = ext attrs1 = attributes
|
||||
uid = mkrhs(UIDENT)
|
||||
name = mkrhs(module_name)
|
||||
body = module_binding_body
|
||||
attrs2 = post_item_attributes
|
||||
{ let docs = symbol_docs $sloc in
|
||||
let loc = make_loc $sloc in
|
||||
let attrs = attrs1 @ attrs2 in
|
||||
let body = Mb.mk uid body ~attrs ~loc ~docs in
|
||||
let body = Mb.mk name body ~attrs ~loc ~docs in
|
||||
Pstr_module body, ext }
|
||||
;
|
||||
|
||||
|
@ -1325,8 +1325,7 @@ module_binding_body:
|
|||
COLON mty = module_type EQUAL me = module_expr
|
||||
{ Pmod_constraint(me, mty) }
|
||||
| arg = functor_arg body = module_binding_body
|
||||
{ let (x, mty) = arg in
|
||||
Pmod_functor(x, mty, body) }
|
||||
{ Pmod_functor(arg, body) }
|
||||
) { $1 }
|
||||
;
|
||||
|
||||
|
@ -1342,7 +1341,7 @@ module_binding_body:
|
|||
ext = ext
|
||||
attrs1 = attributes
|
||||
REC
|
||||
uid = mkrhs(UIDENT)
|
||||
name = mkrhs(module_name)
|
||||
body = module_binding_body
|
||||
attrs2 = post_item_attributes
|
||||
{
|
||||
|
@ -1350,7 +1349,7 @@ module_binding_body:
|
|||
let attrs = attrs1 @ attrs2 in
|
||||
let docs = symbol_docs $sloc in
|
||||
ext,
|
||||
Mb.mk uid body ~attrs ~loc ~docs
|
||||
Mb.mk name body ~attrs ~loc ~docs
|
||||
}
|
||||
;
|
||||
|
||||
|
@ -1358,7 +1357,7 @@ module_binding_body:
|
|||
%inline and_module_binding:
|
||||
AND
|
||||
attrs1 = attributes
|
||||
uid = mkrhs(UIDENT)
|
||||
name = mkrhs(module_name)
|
||||
body = module_binding_body
|
||||
attrs2 = post_item_attributes
|
||||
{
|
||||
|
@ -1366,7 +1365,7 @@ module_binding_body:
|
|||
let attrs = attrs1 @ attrs2 in
|
||||
let docs = symbol_docs $sloc in
|
||||
let text = symbol_text $symbolstartpos in
|
||||
Mb.mk uid body ~attrs ~loc ~text ~docs
|
||||
Mb.mk name body ~attrs ~loc ~text ~docs
|
||||
}
|
||||
;
|
||||
|
||||
|
@ -1459,8 +1458,8 @@ module_type:
|
|||
MINUSGREATER mty = module_type
|
||||
%prec below_WITH
|
||||
{ wrap_mty_attrs ~loc:$sloc attrs (
|
||||
List.fold_left (fun acc (x, mty) ->
|
||||
mkmty ~loc:$sloc (Pmty_functor (x, mty, acc))
|
||||
List.fold_left (fun acc arg ->
|
||||
mkmty ~loc:$sloc (Pmty_functor (arg, acc))
|
||||
) mty args
|
||||
) }
|
||||
| MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT
|
||||
|
@ -1476,7 +1475,7 @@ module_type:
|
|||
{ Pmty_ident $1 }
|
||||
| module_type MINUSGREATER module_type
|
||||
%prec below_WITH
|
||||
{ Pmty_functor(mknoloc "_", Some $1, $3) }
|
||||
{ Pmty_functor(Named (mknoloc None, $1), $3) }
|
||||
| module_type WITH separated_nonempty_llist(AND, with_constraint)
|
||||
{ Pmty_with($1, $3) }
|
||||
/* | LPAREN MODULE mkrhs(mod_longident) RPAREN
|
||||
|
@ -1550,14 +1549,14 @@ signature_item:
|
|||
%inline module_declaration:
|
||||
MODULE
|
||||
ext = ext attrs1 = attributes
|
||||
uid = mkrhs(UIDENT)
|
||||
name = mkrhs(module_name)
|
||||
body = module_declaration_body
|
||||
attrs2 = post_item_attributes
|
||||
{
|
||||
let attrs = attrs1 @ attrs2 in
|
||||
let loc = make_loc $sloc in
|
||||
let docs = symbol_docs $sloc in
|
||||
Md.mk uid body ~attrs ~loc ~docs, ext
|
||||
Md.mk name body ~attrs ~loc ~docs, ext
|
||||
}
|
||||
;
|
||||
|
||||
|
@ -1567,8 +1566,7 @@ module_declaration_body:
|
|||
{ mty }
|
||||
| mkmty(
|
||||
arg = functor_arg body = module_declaration_body
|
||||
{ let (x, mty) = arg in
|
||||
Pmty_functor(x, mty, body) }
|
||||
{ Pmty_functor(arg, body) }
|
||||
)
|
||||
{ $1 }
|
||||
;
|
||||
|
@ -1577,7 +1575,7 @@ module_declaration_body:
|
|||
%inline module_alias:
|
||||
MODULE
|
||||
ext = ext attrs1 = attributes
|
||||
uid = mkrhs(UIDENT)
|
||||
name = mkrhs(module_name)
|
||||
EQUAL
|
||||
body = module_expr_alias
|
||||
attrs2 = post_item_attributes
|
||||
|
@ -1585,7 +1583,7 @@ module_declaration_body:
|
|||
let attrs = attrs1 @ attrs2 in
|
||||
let loc = make_loc $sloc in
|
||||
let docs = symbol_docs $sloc in
|
||||
Md.mk uid body ~attrs ~loc ~docs, ext
|
||||
Md.mk name body ~attrs ~loc ~docs, ext
|
||||
}
|
||||
;
|
||||
%inline module_expr_alias:
|
||||
|
@ -1620,7 +1618,7 @@ module_subst:
|
|||
ext = ext
|
||||
attrs1 = attributes
|
||||
REC
|
||||
uid = mkrhs(UIDENT)
|
||||
name = mkrhs(module_name)
|
||||
COLON
|
||||
mty = module_type
|
||||
attrs2 = post_item_attributes
|
||||
|
@ -1628,13 +1626,13 @@ module_subst:
|
|||
let attrs = attrs1 @ attrs2 in
|
||||
let loc = make_loc $sloc in
|
||||
let docs = symbol_docs $sloc in
|
||||
ext, Md.mk uid mty ~attrs ~loc ~docs
|
||||
ext, Md.mk name mty ~attrs ~loc ~docs
|
||||
}
|
||||
;
|
||||
%inline and_module_declaration:
|
||||
AND
|
||||
attrs1 = attributes
|
||||
uid = mkrhs(UIDENT)
|
||||
name = mkrhs(module_name)
|
||||
COLON
|
||||
mty = module_type
|
||||
attrs2 = post_item_attributes
|
||||
|
@ -1643,7 +1641,7 @@ module_subst:
|
|||
let docs = symbol_docs $sloc in
|
||||
let loc = make_loc $sloc in
|
||||
let text = symbol_text $symbolstartpos in
|
||||
Md.mk uid mty ~attrs ~loc ~text ~docs
|
||||
Md.mk name mty ~attrs ~loc ~text ~docs
|
||||
}
|
||||
;
|
||||
|
||||
|
@ -2131,7 +2129,7 @@ expr:
|
|||
{ not_expecting $loc($1) "wildcard \"_\"" }
|
||||
;
|
||||
%inline expr_attrs:
|
||||
| LET MODULE ext_attributes mkrhs(UIDENT) module_binding_body IN seq_expr
|
||||
| LET MODULE ext_attributes mkrhs(module_name) module_binding_body IN seq_expr
|
||||
{ Pexp_letmodule($4, $5, $7), $3 }
|
||||
| LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr
|
||||
{ Pexp_letexception($4, $6), $3 }
|
||||
|
@ -2625,9 +2623,9 @@ simple_pattern_not_ident:
|
|||
{ reloc_pat ~loc:$sloc $2 }
|
||||
| simple_delimited_pattern
|
||||
{ $1 }
|
||||
| LPAREN MODULE ext_attributes mkrhs(UIDENT) RPAREN
|
||||
| LPAREN MODULE ext_attributes mkrhs(module_name) RPAREN
|
||||
{ mkpat_attrs ~loc:$sloc (Ppat_unpack $4) $3 }
|
||||
| LPAREN MODULE ext_attributes mkrhs(UIDENT) COLON package_type RPAREN
|
||||
| LPAREN MODULE ext_attributes mkrhs(module_name) COLON package_type RPAREN
|
||||
{ mkpat_attrs ~loc:$sloc
|
||||
(Ppat_constraint(mkpat ~loc:$sloc (Ppat_unpack $4), $6))
|
||||
$3 }
|
||||
|
@ -2667,7 +2665,7 @@ simple_pattern_not_ident:
|
|||
{ unclosed "(" $loc($1) ")" $loc($5) }
|
||||
| LPAREN pattern COLON error
|
||||
{ expecting $loc($4) "type" }
|
||||
| LPAREN MODULE ext_attributes UIDENT COLON package_type
|
||||
| LPAREN MODULE ext_attributes module_name COLON package_type
|
||||
error
|
||||
{ unclosed "(" $loc($1) ")" $loc($7) }
|
||||
| extension
|
||||
|
|
|
@ -238,8 +238,10 @@ and pattern_desc =
|
|||
(* #tconst *)
|
||||
| Ppat_lazy of pattern
|
||||
(* lazy P *)
|
||||
| Ppat_unpack of string loc
|
||||
(* (module P)
|
||||
| Ppat_unpack of string option loc
|
||||
(* (module P) Some "P"
|
||||
(module _) None
|
||||
|
||||
Note: (module P : S) is represented as
|
||||
Ppat_constraint(Ppat_unpack, Ptyp_package)
|
||||
*)
|
||||
|
@ -346,7 +348,7 @@ and expression_desc =
|
|||
(* x <- 2 *)
|
||||
| Pexp_override of (label loc * expression) list
|
||||
(* {< x1 = E1; ...; Xn = En >} *)
|
||||
| Pexp_letmodule of string loc * module_expr * expression
|
||||
| Pexp_letmodule of string option loc * module_expr * expression
|
||||
(* let module M = ME in E *)
|
||||
| Pexp_letexception of extension_constructor * expression
|
||||
(* let exception C in E *)
|
||||
|
@ -713,7 +715,7 @@ and module_type_desc =
|
|||
(* S *)
|
||||
| Pmty_signature of signature
|
||||
(* sig ... end *)
|
||||
| Pmty_functor of string loc * module_type option * module_type
|
||||
| Pmty_functor of functor_parameter * module_type
|
||||
(* functor(X : MT1) -> MT2 *)
|
||||
| Pmty_with of module_type * with_constraint list
|
||||
(* MT with ... *)
|
||||
|
@ -724,6 +726,13 @@ and module_type_desc =
|
|||
| Pmty_alias of Longident.t loc
|
||||
(* (module M) *)
|
||||
|
||||
and functor_parameter =
|
||||
| Unit
|
||||
(* () *)
|
||||
| Named of string option loc * module_type
|
||||
(* (X : MT) Some X, MT
|
||||
(_ : MT) None, MT *)
|
||||
|
||||
and signature = signature_item list
|
||||
|
||||
and signature_item =
|
||||
|
@ -771,7 +780,7 @@ and signature_item_desc =
|
|||
|
||||
and module_declaration =
|
||||
{
|
||||
pmd_name: string loc;
|
||||
pmd_name: string option loc;
|
||||
pmd_type: module_type;
|
||||
pmd_attributes: attributes; (* ... [@@id1] [@@id2] *)
|
||||
pmd_loc: Location.t;
|
||||
|
@ -858,7 +867,7 @@ and module_expr_desc =
|
|||
(* X *)
|
||||
| Pmod_structure of structure
|
||||
(* struct ... end *)
|
||||
| Pmod_functor of string loc * module_type option * module_expr
|
||||
| Pmod_functor of functor_parameter * module_expr
|
||||
(* functor(X : MT1) -> ME *)
|
||||
| Pmod_apply of module_expr * module_expr
|
||||
(* ME1(ME2) *)
|
||||
|
@ -923,7 +932,7 @@ and value_binding =
|
|||
|
||||
and module_binding =
|
||||
{
|
||||
pmb_name: string loc;
|
||||
pmb_name: string option loc;
|
||||
pmb_expr: module_expr;
|
||||
pmb_attributes: attributes;
|
||||
pmb_loc: Location.t;
|
||||
|
|
|
@ -442,8 +442,10 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
|
|||
| Ppat_var ({txt = txt;_}) -> protect_ident f txt
|
||||
| Ppat_array l ->
|
||||
pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l
|
||||
| Ppat_unpack (s) ->
|
||||
pp f "(module@ %s)@ " s.txt
|
||||
| Ppat_unpack { txt = None } ->
|
||||
pp f "(module@ _)@ "
|
||||
| Ppat_unpack { txt = Some s } ->
|
||||
pp f "(module@ %s)@ " s
|
||||
| Ppat_type li ->
|
||||
pp f "#%a" longident_loc li
|
||||
| Ppat_record (l, closed) ->
|
||||
|
@ -704,7 +706,8 @@ and expression ctxt f x =
|
|||
pp f "@[<hov2>{<%a>}@]"
|
||||
(list string_x_expression ~sep:";" ) l;
|
||||
| Pexp_letmodule (s, me, e) ->
|
||||
pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]" s.txt
|
||||
pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]"
|
||||
(Option.value s.txt ~default:"_")
|
||||
(module_expr reset_ctxt) me (expression ctxt) e
|
||||
| Pexp_letexception (cd, e) ->
|
||||
pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
|
||||
|
@ -1025,15 +1028,17 @@ and module_type ctxt f x =
|
|||
(attributes ctxt) x.pmty_attributes
|
||||
end else
|
||||
match x.pmty_desc with
|
||||
| Pmty_functor (_, None, mt2) ->
|
||||
| Pmty_functor (Unit, mt2) ->
|
||||
pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
|
||||
| Pmty_functor (s, Some mt1, mt2) ->
|
||||
if s.txt = "_" then
|
||||
| Pmty_functor (Named (s, mt1), mt2) ->
|
||||
begin match s.txt with
|
||||
| None ->
|
||||
pp f "@[<hov2>%a@ ->@ %a@]"
|
||||
(module_type1 ctxt) mt1 (module_type ctxt) mt2
|
||||
else
|
||||
pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
|
||||
| Some name ->
|
||||
pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" name
|
||||
(module_type ctxt) mt1 (module_type ctxt) mt2
|
||||
end
|
||||
| Pmty_with (mt, []) -> module_type ctxt f mt
|
||||
| Pmty_with (mt, l) ->
|
||||
let with_constraint f = function
|
||||
|
@ -1107,12 +1112,13 @@ and signature_item ctxt f x : unit =
|
|||
end
|
||||
| Psig_module ({pmd_type={pmty_desc=Pmty_alias alias;
|
||||
pmty_attributes=[]; _};_} as pmd) ->
|
||||
pp f "@[<hov>module@ %s@ =@ %a@]%a" pmd.pmd_name.txt
|
||||
pp f "@[<hov>module@ %s@ =@ %a@]%a"
|
||||
(Option.value pmd.pmd_name.txt ~default:"_")
|
||||
longident_loc alias
|
||||
(item_attributes ctxt) pmd.pmd_attributes
|
||||
| Psig_module pmd ->
|
||||
pp f "@[<hov>module@ %s@ :@ %a@]%a"
|
||||
pmd.pmd_name.txt
|
||||
(Option.value pmd.pmd_name.txt ~default:"_")
|
||||
(module_type ctxt) pmd.pmd_type
|
||||
(item_attributes ctxt) pmd.pmd_attributes
|
||||
| Psig_modsubst pms ->
|
||||
|
@ -1145,11 +1151,13 @@ and signature_item ctxt f x : unit =
|
|||
| [] -> () ;
|
||||
| pmd :: tl ->
|
||||
if not first then
|
||||
pp f "@ @[<hov2>and@ %s:@ %a@]%a" pmd.pmd_name.txt
|
||||
pp f "@ @[<hov2>and@ %s:@ %a@]%a"
|
||||
(Option.value pmd.pmd_name.txt ~default:"_")
|
||||
(module_type1 ctxt) pmd.pmd_type
|
||||
(item_attributes ctxt) pmd.pmd_attributes
|
||||
else
|
||||
pp f "@[<hov2>module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt
|
||||
pp f "@[<hov2>module@ rec@ %s:@ %a@]%a"
|
||||
(Option.value pmd.pmd_name.txt ~default:"_")
|
||||
(module_type1 ctxt) pmd.pmd_type
|
||||
(item_attributes ctxt) pmd.pmd_attributes;
|
||||
string_x_module_type_list f ~first:false tl
|
||||
|
@ -1174,11 +1182,12 @@ and module_expr ctxt f x =
|
|||
(module_type ctxt) mt
|
||||
| Pmod_ident (li) ->
|
||||
pp f "%a" longident_loc li;
|
||||
| Pmod_functor (_, None, me) ->
|
||||
| Pmod_functor (Unit, me) ->
|
||||
pp f "functor ()@;->@;%a" (module_expr ctxt) me
|
||||
| Pmod_functor (s, Some mt, me) ->
|
||||
| Pmod_functor (Named (s, mt), me) ->
|
||||
pp f "functor@ (%s@ :@ %a)@;->@;%a"
|
||||
s.txt (module_type ctxt) mt (module_expr ctxt) me
|
||||
(Option.value s.txt ~default:"_")
|
||||
(module_type ctxt) mt (module_expr ctxt) me
|
||||
| Pmod_apply (me1, me2) ->
|
||||
pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
|
||||
(* Cf: #7200 *)
|
||||
|
@ -1303,14 +1312,18 @@ and structure_item ctxt f x =
|
|||
| Pstr_exception ed -> exception_declaration ctxt f ed
|
||||
| Pstr_module x ->
|
||||
let rec module_helper = function
|
||||
| {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} ->
|
||||
if mt = None then pp f "()"
|
||||
else Option.iter (pp f "(%s:%a)" s.txt (module_type ctxt)) mt;
|
||||
| {pmod_desc=Pmod_functor(arg_opt,me'); pmod_attributes = []} ->
|
||||
begin match arg_opt with
|
||||
| Unit -> pp f "()"
|
||||
| Named (s, mt) ->
|
||||
pp f "(%s:%a)" (Option.value s.txt ~default:"_")
|
||||
(module_type ctxt) mt
|
||||
end;
|
||||
module_helper me'
|
||||
| me -> me
|
||||
in
|
||||
pp f "@[<hov2>module %s%a@]%a"
|
||||
x.pmb_name.txt
|
||||
(Option.value x.pmb_name.txt ~default:"_")
|
||||
(fun f me ->
|
||||
let me = module_helper me in
|
||||
match me with
|
||||
|
@ -1389,26 +1402,28 @@ and structure_item ctxt f x =
|
|||
| Pstr_recmodule decls -> (* 3.07 *)
|
||||
let aux f = function
|
||||
| ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
|
||||
pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt
|
||||
pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a"
|
||||
(Option.value pmb.pmb_name.txt ~default:"_")
|
||||
(module_type ctxt) typ
|
||||
(module_expr ctxt) expr
|
||||
(item_attributes ctxt) pmb.pmb_attributes
|
||||
| pmb ->
|
||||
pp f "@[<hov2>@ and@ %s@ =@ %a@]%a" pmb.pmb_name.txt
|
||||
pp f "@[<hov2>@ and@ %s@ =@ %a@]%a"
|
||||
(Option.value pmb.pmb_name.txt ~default:"_")
|
||||
(module_expr ctxt) pmb.pmb_expr
|
||||
(item_attributes ctxt) pmb.pmb_attributes
|
||||
in
|
||||
begin match decls with
|
||||
| ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
|
||||
pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
|
||||
pmb.pmb_name.txt
|
||||
(Option.value pmb.pmb_name.txt ~default:"_")
|
||||
(module_type ctxt) typ
|
||||
(module_expr ctxt) expr
|
||||
(item_attributes ctxt) pmb.pmb_attributes
|
||||
(fun f l2 -> List.iter (aux f) l2) l2
|
||||
| pmb :: l2 ->
|
||||
pp f "@[<hv>@[<hov2>module@ rec@ %s@ =@ %a@]%a@ %a@]"
|
||||
pmb.pmb_name.txt
|
||||
(Option.value pmb.pmb_name.txt ~default:"_")
|
||||
(module_expr ctxt) pmb.pmb_expr
|
||||
(item_attributes ctxt) pmb.pmb_attributes
|
||||
(fun f l2 -> List.iter (aux f) l2) l2
|
||||
|
|
|
@ -52,6 +52,10 @@ let fmt_string_loc f (x : string loc) =
|
|||
fprintf f "\"%s\" %a" x.txt fmt_location x.loc;
|
||||
;;
|
||||
|
||||
let fmt_str_opt_loc f (x : string option loc) =
|
||||
fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc;
|
||||
;;
|
||||
|
||||
let fmt_char_option f = function
|
||||
| None -> fprintf f "None"
|
||||
| Some c -> fprintf f "Some %c" c
|
||||
|
@ -132,6 +136,7 @@ let option i f ppf x =
|
|||
let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;;
|
||||
let string i ppf s = line i ppf "\"%s\"\n" s;;
|
||||
let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;;
|
||||
let str_opt_loc i ppf s = line i ppf "%a\n" fmt_str_opt_loc s;;
|
||||
let arg_label i ppf = function
|
||||
| Nolabel -> line i ppf "Nolabel\n"
|
||||
| Optional s -> line i ppf "Optional \"%s\"\n" s
|
||||
|
@ -240,7 +245,7 @@ and pattern i ppf x =
|
|||
line i ppf "Ppat_type\n";
|
||||
longident_loc i ppf li
|
||||
| Ppat_unpack s ->
|
||||
line i ppf "Ppat_unpack %a\n" fmt_string_loc s;
|
||||
line i ppf "Ppat_unpack %a\n" fmt_str_opt_loc s;
|
||||
| Ppat_exception p ->
|
||||
line i ppf "Ppat_exception\n";
|
||||
pattern i ppf p
|
||||
|
@ -347,7 +352,7 @@ and expression i ppf x =
|
|||
line i ppf "Pexp_override\n";
|
||||
list i string_x_expression ppf l;
|
||||
| Pexp_letmodule (s, me, e) ->
|
||||
line i ppf "Pexp_letmodule %a\n" fmt_string_loc s;
|
||||
line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s;
|
||||
module_expr i ppf me;
|
||||
expression i ppf e;
|
||||
| Pexp_letexception (cd, e) ->
|
||||
|
@ -662,9 +667,12 @@ and module_type i ppf x =
|
|||
| Pmty_signature (s) ->
|
||||
line i ppf "Pmty_signature\n";
|
||||
signature i ppf s;
|
||||
| Pmty_functor (s, mt1, mt2) ->
|
||||
line i ppf "Pmty_functor %a\n" fmt_string_loc s;
|
||||
Option.iter (module_type i ppf) mt1;
|
||||
| Pmty_functor (Unit, mt2) ->
|
||||
line i ppf "Pmty_functor ()\n";
|
||||
module_type i ppf mt2;
|
||||
| Pmty_functor (Named (s, mt1), mt2) ->
|
||||
line i ppf "Pmty_functor %a\n" fmt_str_opt_loc s;
|
||||
module_type i ppf mt1;
|
||||
module_type i ppf mt2;
|
||||
| Pmty_with (mt, l) ->
|
||||
line i ppf "Pmty_with\n";
|
||||
|
@ -699,7 +707,7 @@ and signature_item i ppf x =
|
|||
line i ppf "Psig_exception\n";
|
||||
type_exception i ppf te
|
||||
| Psig_module pmd ->
|
||||
line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name;
|
||||
line i ppf "Psig_module %a\n" fmt_str_opt_loc pmd.pmd_name;
|
||||
attributes i ppf pmd.pmd_attributes;
|
||||
module_type i ppf pmd.pmd_type
|
||||
| Psig_modsubst pms ->
|
||||
|
@ -765,9 +773,12 @@ and module_expr i ppf x =
|
|||
| Pmod_structure (s) ->
|
||||
line i ppf "Pmod_structure\n";
|
||||
structure i ppf s;
|
||||
| Pmod_functor (s, mt, me) ->
|
||||
line i ppf "Pmod_functor %a\n" fmt_string_loc s;
|
||||
Option.iter (module_type i ppf) mt;
|
||||
| Pmod_functor (Unit, me) ->
|
||||
line i ppf "Pmod_functor ()\n";
|
||||
module_expr i ppf me;
|
||||
| Pmod_functor (Named (s, mt), me) ->
|
||||
line i ppf "Pmod_functor %a\n" fmt_str_opt_loc s;
|
||||
module_type i ppf mt;
|
||||
module_expr i ppf me;
|
||||
| Pmod_apply (me1, me2) ->
|
||||
line i ppf "Pmod_apply\n";
|
||||
|
@ -841,12 +852,12 @@ and structure_item i ppf x =
|
|||
attribute i ppf "Pstr_attribute" a
|
||||
|
||||
and module_declaration i ppf pmd =
|
||||
string_loc i ppf pmd.pmd_name;
|
||||
str_opt_loc i ppf pmd.pmd_name;
|
||||
attributes i ppf pmd.pmd_attributes;
|
||||
module_type (i+1) ppf pmd.pmd_type;
|
||||
|
||||
and module_binding i ppf x =
|
||||
string_loc i ppf x.pmb_name;
|
||||
str_opt_loc i ppf x.pmb_name;
|
||||
attributes i ppf x.pmb_attributes;
|
||||
module_expr (i+1) ppf x.pmb_expr
|
||||
|
||||
|
|
|
@ -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) = ()
|
|
@ -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))))))
|
|
@ -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)))))
|
|
@ -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)))
|
|
@ -181,7 +181,7 @@ end
|
|||
Line 4, characters 2-11:
|
||||
4 | include S
|
||||
^^^^^^^^^
|
||||
Error: Illegal shadowing of included module type T/317 by T/335
|
||||
Error: Illegal shadowing of included module type T/317 by T/334
|
||||
Line 2, characters 2-11:
|
||||
Module type T/317 came from this include
|
||||
Line 3, characters 2-39:
|
||||
|
@ -198,11 +198,11 @@ end
|
|||
Line 4, characters 2-11:
|
||||
4 | include S
|
||||
^^^^^^^^^
|
||||
Error: Illegal shadowing of included type ext/353 by ext/370
|
||||
Error: Illegal shadowing of included type ext/352 by ext/369
|
||||
Line 2, characters 2-11:
|
||||
Type ext/353 came from this include
|
||||
Type ext/352 came from this include
|
||||
Line 3, characters 14-16:
|
||||
The extension constructor C2 has no valid type if ext/353 is shadowed
|
||||
The extension constructor C2 has no valid type if ext/352 is shadowed
|
||||
|}]
|
||||
|
||||
module type Class = sig
|
||||
|
|
|
@ -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>
|
||||
|}]
|
|
@ -57,7 +57,7 @@ let bind_cases l =
|
|||
let record_module_binding scope mb =
|
||||
Stypes.record (Stypes.An_ident
|
||||
(mb.mb_name.loc,
|
||||
mb.mb_name.txt,
|
||||
Option.value mb.mb_name.txt ~default:"_",
|
||||
Annot.Idef scope))
|
||||
|
||||
let rec iterator ~scope rebuild_env =
|
||||
|
@ -106,7 +106,8 @@ let rec iterator ~scope rebuild_env =
|
|||
bind_cases f
|
||||
| Texp_letmodule (_, modname, _, _, body ) ->
|
||||
Stypes.record (Stypes.An_ident
|
||||
(modname.loc,modname.txt,Annot.Idef body.exp_loc))
|
||||
(modname.loc,Option.value ~default:"_" modname.txt,
|
||||
Annot.Idef body.exp_loc))
|
||||
| _ -> ()
|
||||
end;
|
||||
Stypes.record (Stypes.Ti_expr exp);
|
||||
|
|
|
@ -385,7 +385,7 @@ and rewrite_mod iflag smod =
|
|||
match smod.pmod_desc with
|
||||
Pmod_ident _ -> ()
|
||||
| Pmod_structure sstr -> List.iter (rewrite_str_item iflag) sstr
|
||||
| Pmod_functor(_param, _smty, sbody) -> rewrite_mod iflag sbody
|
||||
| Pmod_functor(_param, sbody) -> rewrite_mod iflag sbody
|
||||
| Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
|
||||
| Pmod_constraint(smod, _smty) -> rewrite_mod iflag smod
|
||||
| Pmod_unpack(sexp) -> rewrite_exp iflag sexp
|
||||
|
|
|
@ -187,7 +187,7 @@ let parse_mod_use_file name lb =
|
|||
[ Ptop_def
|
||||
[ Str.module_
|
||||
(Mb.mk
|
||||
(Location.mknoloc modname)
|
||||
(Location.mknoloc (Some modname))
|
||||
(Mod.structure items)
|
||||
)
|
||||
]
|
||||
|
|
|
@ -151,7 +151,7 @@ let parse_mod_use_file name lb =
|
|||
[ Ptop_def
|
||||
[ Str.module_
|
||||
(Mb.mk
|
||||
(Location.mknoloc modname)
|
||||
(Location.mknoloc (Some modname))
|
||||
(Mod.structure items)
|
||||
)
|
||||
]
|
||||
|
|
|
@ -61,9 +61,6 @@ let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
|
|||
let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false
|
||||
|
||||
let dummy_method = "*dummy method*"
|
||||
let default_mty = function
|
||||
Some mty -> mty
|
||||
| None -> Mty_signature []
|
||||
|
||||
(**** Definitions for backtracking ****)
|
||||
|
||||
|
@ -333,6 +330,7 @@ type type_iterators =
|
|||
it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
|
||||
it_class_declaration: type_iterators -> class_declaration -> unit;
|
||||
it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
|
||||
it_functor_param: type_iterators -> functor_parameter -> unit;
|
||||
it_module_type: type_iterators -> module_type -> unit;
|
||||
it_class_type: type_iterators -> class_type -> unit;
|
||||
it_type_kind: type_iterators -> type_kind -> unit;
|
||||
|
@ -399,12 +397,15 @@ let type_iterators =
|
|||
List.iter (it.it_type_expr it) ctd.clty_params;
|
||||
it.it_class_type it ctd.clty_type;
|
||||
it.it_path ctd.clty_path
|
||||
and it_functor_param it = function
|
||||
| Unit -> ()
|
||||
| Named (_, mt) -> it.it_module_type it mt
|
||||
and it_module_type it = function
|
||||
Mty_ident p
|
||||
| Mty_alias p -> it.it_path p
|
||||
| Mty_signature sg -> it.it_signature it sg
|
||||
| Mty_functor (_, mto, mt) ->
|
||||
Option.iter (it.it_module_type it) mto;
|
||||
| Mty_functor (p, mt) ->
|
||||
it.it_functor_param it p;
|
||||
it.it_module_type it mt
|
||||
and it_class_type it = function
|
||||
Cty_constr (p, tyl, cty) ->
|
||||
|
@ -435,7 +436,7 @@ let type_iterators =
|
|||
and it_path _p = ()
|
||||
in
|
||||
{ it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
|
||||
it_type_kind; it_class_type; it_module_type;
|
||||
it_type_kind; it_class_type; it_functor_param; it_module_type;
|
||||
it_signature; it_class_type_declaration; it_class_declaration;
|
||||
it_modtype_declaration; it_module_declaration; it_extension_constructor;
|
||||
it_type_declaration; it_value_description; it_signature_item; }
|
||||
|
|
|
@ -48,7 +48,6 @@ val is_Tvar: type_expr -> bool
|
|||
val is_Tunivar: type_expr -> bool
|
||||
val is_Tconstr: type_expr -> bool
|
||||
val dummy_method: label
|
||||
val default_mty: module_type option -> module_type
|
||||
|
||||
val repr: type_expr -> type_expr
|
||||
(* Return the canonical representative of a type. *)
|
||||
|
@ -122,6 +121,7 @@ type type_iterators =
|
|||
it_modtype_declaration: type_iterators -> modtype_declaration -> unit;
|
||||
it_class_declaration: type_iterators -> class_declaration -> unit;
|
||||
it_class_type_declaration: type_iterators -> class_type_declaration -> unit;
|
||||
it_functor_param: type_iterators -> functor_parameter -> unit;
|
||||
it_module_type: type_iterators -> module_type -> unit;
|
||||
it_class_type: type_iterators -> class_type -> unit;
|
||||
it_type_kind: type_iterators -> type_kind -> unit;
|
||||
|
|
|
@ -443,8 +443,8 @@ and structure_components = {
|
|||
}
|
||||
|
||||
and functor_components = {
|
||||
fcomp_param: Ident.t; (* Formal parameter *)
|
||||
fcomp_arg: module_type option; (* Argument signature *)
|
||||
fcomp_arg: functor_parameter;
|
||||
(* Formal parameter and argument signature *)
|
||||
fcomp_res: module_type; (* Result signature *)
|
||||
fcomp_cache: (Path.t, module_components) Hashtbl.t; (* For memoization *)
|
||||
fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
|
||||
|
@ -821,9 +821,13 @@ let modtype_of_functor_appl fcomp p1 p2 =
|
|||
with Not_found ->
|
||||
let scope = Path.scope (Papply(p1, p2)) in
|
||||
let mty =
|
||||
Subst.modtype (Rescope scope)
|
||||
(Subst.add_module fcomp.fcomp_param p2 Subst.identity)
|
||||
mty
|
||||
let subst =
|
||||
match fcomp.fcomp_arg with
|
||||
| Unit
|
||||
| Named (None, _) -> Subst.identity
|
||||
| Named (Some param, _) -> Subst.add_module param p2 Subst.identity
|
||||
in
|
||||
Subst.modtype (Rescope scope) subst mty
|
||||
in
|
||||
Hashtbl.add fcomp.fcomp_subst_cache p2 mty;
|
||||
mty
|
||||
|
@ -1577,16 +1581,19 @@ let rec components_of_module_maker
|
|||
NameMap.add (Ident.name id) decl' c.comp_cltypes)
|
||||
items_and_paths;
|
||||
Ok (Structure_comps c)
|
||||
| Mty_functor(param, ty_arg, ty_res) ->
|
||||
| Mty_functor(arg, ty_res) ->
|
||||
let sub =
|
||||
may_subst Subst.compose cm_freshening_subst cm_prefixing_subst
|
||||
in
|
||||
let scoping = Subst.Rescope (Path.scope cm_path) in
|
||||
Ok (Functor_comps {
|
||||
fcomp_param = param;
|
||||
(* fcomp_arg and fcomp_res must be prefixed eagerly, because
|
||||
they are interpreted in the outer environment *)
|
||||
fcomp_arg = Option.map (Subst.modtype scoping sub) ty_arg;
|
||||
fcomp_arg =
|
||||
(match arg with
|
||||
| Unit -> Unit
|
||||
| Named (param, ty_arg) ->
|
||||
Named (param, Subst.modtype scoping sub ty_arg));
|
||||
fcomp_res = Subst.modtype scoping sub ty_res;
|
||||
fcomp_cache = Hashtbl.create 17;
|
||||
fcomp_subst_cache = Hashtbl.create 17 })
|
||||
|
@ -1762,7 +1769,12 @@ let components_of_functor_appl ~loc f env p1 p2 =
|
|||
Hashtbl.find f.fcomp_cache p2
|
||||
with Not_found ->
|
||||
let p = Papply(p1, p2) in
|
||||
let sub = Subst.add_module f.fcomp_param p2 Subst.identity in
|
||||
let sub =
|
||||
match f.fcomp_arg with
|
||||
| Unit
|
||||
| Named (None, _) -> Subst.identity
|
||||
| Named (Some param, _) -> Subst.add_module param p2 Subst.identity
|
||||
in
|
||||
(* we have to apply eagerly instead of passing sub to [components_of_module]
|
||||
because of the call to [check_well_formed_module]. *)
|
||||
let mty = Subst.modtype (Rescope (Path.scope p)) sub f.fcomp_res in
|
||||
|
@ -2409,9 +2421,9 @@ and lookup_functor_components ~errors ~use ~loc lid env =
|
|||
match get_components_res comps with
|
||||
| Ok (Functor_comps fcomps) -> begin
|
||||
match fcomps.fcomp_arg with
|
||||
| None -> (* PR#7611 *)
|
||||
| Unit -> (* PR#7611 *)
|
||||
may_lookup_error errors loc env (Generative_used_as_applicative lid)
|
||||
| Some arg -> path, fcomps, arg
|
||||
| Named (_, arg) -> path, fcomps, arg
|
||||
end
|
||||
| Ok (Structure_comps _) ->
|
||||
may_lookup_error errors loc env (Structure_used_as_functor lid)
|
||||
|
|
|
@ -41,7 +41,10 @@ type symptom =
|
|||
| Invalid_module_alias of Path.t
|
||||
|
||||
type pos =
|
||||
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
|
||||
| Module of Ident.t
|
||||
| Modtype of Ident.t
|
||||
| Arg of functor_parameter
|
||||
| Body of functor_parameter
|
||||
type error = pos list * Env.t * symptom
|
||||
|
||||
exception Error of error list
|
||||
|
@ -294,25 +297,32 @@ and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
|
|||
try_modtypes2 ~loc env ~mark cxt mty1 (Subst.modtype Keep subst mty2)
|
||||
| (Mty_signature sig1, Mty_signature sig2) ->
|
||||
signatures ~loc env ~mark cxt subst sig1 sig2
|
||||
| (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) ->
|
||||
| (Mty_functor(Unit, res1), Mty_functor(Unit, res2)) ->
|
||||
begin
|
||||
match modtypes ~loc env ~mark (Body param1::cxt) subst res1 res2 with
|
||||
match modtypes ~loc env ~mark (Body Unit::cxt) subst res1 res2 with
|
||||
| Tcoerce_none -> Tcoerce_none
|
||||
| cc -> Tcoerce_functor (Tcoerce_none, cc)
|
||||
end
|
||||
| (Mty_functor(param1, Some arg1, res1),
|
||||
Mty_functor(param2, Some arg2, res2)) ->
|
||||
| (Mty_functor(Named (param1, arg1) as arg, res1),
|
||||
Mty_functor(Named (param2, arg2), res2)) ->
|
||||
let arg2' = Subst.modtype Keep subst arg2 in
|
||||
let cc_arg =
|
||||
modtypes ~loc env ~mark:(negate_mark mark)
|
||||
(Arg param1::cxt) Subst.identity arg2' arg1
|
||||
(Arg arg::cxt) Subst.identity arg2' arg1
|
||||
in
|
||||
let cc_res =
|
||||
modtypes ~loc (Env.add_module param1 Mp_present arg2' env) ~mark
|
||||
(Body param1::cxt)
|
||||
(Subst.add_module param2 (Path.Pident param1) subst)
|
||||
res1 res2
|
||||
let env, subst =
|
||||
match param1, param2 with
|
||||
| Some p1, Some p2 ->
|
||||
Env.add_module p1 Mp_present arg2' env,
|
||||
Subst.add_module p2 (Path.Pident p1) subst
|
||||
| None, Some p2 ->
|
||||
Env.add_module p2 Mp_present arg2' env, subst
|
||||
| Some p1, None ->
|
||||
Env.add_module p1 Mp_present arg2' env, subst
|
||||
| None, None ->
|
||||
env, subst
|
||||
in
|
||||
let cc_res = modtypes ~loc env ~mark (Body arg::cxt) subst res1 res2 in
|
||||
begin match (cc_arg, cc_res) with
|
||||
(Tcoerce_none, Tcoerce_none) -> Tcoerce_none
|
||||
| _ -> Tcoerce_functor(cc_arg, cc_res)
|
||||
|
@ -661,8 +671,10 @@ module Illegal_permutation = struct
|
|||
| Sig_module (id, _, md,_,_) -> find env (Module id :: ctx) q md.md_type
|
||||
| _ -> raise Not_found
|
||||
end
|
||||
| Mty_functor(x,Some mt,_), InArg :: q -> find env (Arg x :: ctx) q mt
|
||||
| Mty_functor(x,_,mt), InBody :: q -> find env (Body x :: ctx) q mt
|
||||
| Mty_functor(Named (_,mt) as arg,_), InArg :: q ->
|
||||
find env (Arg arg :: ctx) q mt
|
||||
| Mty_functor(arg, mt), InBody :: q ->
|
||||
find env (Body arg :: ctx) q mt
|
||||
| _ -> raise Not_found
|
||||
|
||||
let find env path mt = find env [] path mt
|
||||
|
@ -716,7 +728,7 @@ let rec context ppf = function
|
|||
| Body x :: rem ->
|
||||
fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
|
||||
| Arg x :: rem ->
|
||||
fprintf ppf "functor (%a : %a) -> ..." Printtyp.ident x context_mty rem
|
||||
fprintf ppf "functor (%s : %a) -> ..." (argname x) context_mty rem
|
||||
| [] ->
|
||||
fprintf ppf "<here>"
|
||||
and context_mty ppf = function
|
||||
|
@ -727,12 +739,13 @@ and args ppf = function
|
|||
Body x :: rem ->
|
||||
fprintf ppf "(%s)%a" (argname x) args rem
|
||||
| Arg x :: rem ->
|
||||
fprintf ppf "(%a :@ %a) : ..." Printtyp.ident x context_mty rem
|
||||
fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem
|
||||
| cxt ->
|
||||
fprintf ppf " :@ %a" context_mty cxt
|
||||
and argname x =
|
||||
let s = Ident.name x in
|
||||
if s = "*" then "" else s
|
||||
and argname = function
|
||||
| Unit -> ""
|
||||
| Named (None, _) -> "_"
|
||||
| Named (Some id, _) -> Ident.name id
|
||||
|
||||
let alt_context ppf cxt =
|
||||
if cxt = [] then () else
|
||||
|
|
|
@ -77,7 +77,10 @@ type symptom =
|
|||
| Invalid_module_alias of Path.t
|
||||
|
||||
type pos =
|
||||
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
|
||||
| Module of Ident.t
|
||||
| Modtype of Ident.t
|
||||
| Arg of functor_parameter
|
||||
| Body of functor_parameter
|
||||
type error = pos list * Env.t * symptom
|
||||
|
||||
exception Error of error list
|
||||
|
|
|
@ -37,9 +37,14 @@ let rec strengthen ~aliasable env mty p =
|
|||
match scrape env mty with
|
||||
Mty_signature sg ->
|
||||
Mty_signature(strengthen_sig ~aliasable env sg p)
|
||||
| Mty_functor(param, arg, res)
|
||||
when !Clflags.applicative_functors && Ident.name param <> "*" ->
|
||||
Mty_functor(param, arg,
|
||||
| Mty_functor(Named (Some param, arg), res)
|
||||
when !Clflags.applicative_functors ->
|
||||
Mty_functor(Named (Some param, arg),
|
||||
strengthen ~aliasable:false env res (Papply(p, Pident param)))
|
||||
| Mty_functor(Named (None, arg), res)
|
||||
when !Clflags.applicative_functors ->
|
||||
let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in
|
||||
Mty_functor(Named (Some param, arg),
|
||||
strengthen ~aliasable:false env res (Papply(p, Pident param)))
|
||||
| mty ->
|
||||
mty
|
||||
|
@ -107,9 +112,9 @@ let rec make_aliases_absent pres mty =
|
|||
| Mty_alias _ -> Mp_absent, mty
|
||||
| Mty_signature sg ->
|
||||
pres, Mty_signature(make_aliases_absent_sig sg)
|
||||
| Mty_functor(param, arg, res) ->
|
||||
| Mty_functor(arg, res) ->
|
||||
let _, res = make_aliases_absent Mp_present res in
|
||||
pres, Mty_functor(param, arg, res)
|
||||
pres, Mty_functor(arg, res)
|
||||
| mty ->
|
||||
pres, mty
|
||||
|
||||
|
@ -171,14 +176,19 @@ let rec nondep_mty_with_presence env va ids pres mty =
|
|||
| Mty_signature sg ->
|
||||
let mty = Mty_signature(nondep_sig env va ids sg) in
|
||||
pres, mty
|
||||
| Mty_functor(param, arg, res) ->
|
||||
| Mty_functor(Unit, res) ->
|
||||
pres, Mty_functor(Unit, nondep_mty env va ids res)
|
||||
| Mty_functor(Named (param, arg), res) ->
|
||||
let var_inv =
|
||||
match va with Co -> Contra | Contra -> Co | Strict -> Strict in
|
||||
let res_env =
|
||||
match param with
|
||||
| None -> env
|
||||
| Some param -> Env.add_module ~arg:true param Mp_present arg env
|
||||
in
|
||||
let mty =
|
||||
Mty_functor(param, Option.map (nondep_mty env var_inv ids) arg,
|
||||
nondep_mty
|
||||
(Env.add_module ~arg:true param Mp_present
|
||||
(Btype.default_mty arg) env) va ids res)
|
||||
Mty_functor(Named (param, nondep_mty env var_inv ids arg),
|
||||
nondep_mty res_env va ids res)
|
||||
in
|
||||
pres, mty
|
||||
|
||||
|
@ -335,7 +345,7 @@ let rec contains_type env = function
|
|||
end
|
||||
| Mty_signature sg ->
|
||||
contains_type_sig env sg
|
||||
| Mty_functor (_, _, body) ->
|
||||
| Mty_functor (_, body) ->
|
||||
contains_type env body
|
||||
| Mty_alias _ ->
|
||||
()
|
||||
|
|
|
@ -484,14 +484,15 @@ let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension")
|
|||
that should be printed in long form. *)
|
||||
let collect_functor_arguments mty =
|
||||
let rec collect_args acc = function
|
||||
| Omty_functor (name, mty_arg, mty_res) ->
|
||||
collect_args ((name, mty_arg) :: acc) mty_res
|
||||
| Omty_functor (param, mty_res) ->
|
||||
collect_args (param :: acc) mty_res
|
||||
| non_functor -> (acc, non_functor)
|
||||
in
|
||||
let rec uncollect_anonymous_suffix acc rest = match acc with
|
||||
| ("_", mty_arg) :: acc ->
|
||||
uncollect_anonymous_suffix acc (Omty_functor ("_", mty_arg, rest))
|
||||
| (_, _) :: _ | [] ->
|
||||
| Some (None, mty_arg) :: acc ->
|
||||
uncollect_anonymous_suffix acc
|
||||
(Omty_functor (Some (None, mty_arg), rest))
|
||||
| _ :: _ | [] ->
|
||||
(acc, rest)
|
||||
in
|
||||
let (acc, non_functor) = collect_args [] mty in
|
||||
|
@ -503,18 +504,18 @@ let rec print_out_module_type ppf mty =
|
|||
and print_out_functor ppf = function
|
||||
| Omty_functor _ as t ->
|
||||
let rec print_functor ppf = function
|
||||
| Omty_functor ("_", Some mty_arg, mty_res) ->
|
||||
| Omty_functor (Some (None, mty_arg), mty_res) ->
|
||||
fprintf ppf "%a ->@ %a"
|
||||
print_simple_out_module_type mty_arg
|
||||
print_functor mty_res
|
||||
| Omty_functor _ as non_anonymous_functor ->
|
||||
let (args, rest) = collect_functor_arguments non_anonymous_functor in
|
||||
let print_arg ppf = function
|
||||
| (_, None) ->
|
||||
| None ->
|
||||
fprintf ppf "()"
|
||||
| (name, Some mty) ->
|
||||
| Some (param, mty) ->
|
||||
fprintf ppf "(%s : %a)"
|
||||
name
|
||||
(Option.value param ~default:"_")
|
||||
print_out_module_type mty
|
||||
in
|
||||
fprintf ppf "@[<2>functor@ %a@]@ ->@ %a"
|
||||
|
|
|
@ -91,7 +91,7 @@ and out_class_sig_item =
|
|||
|
||||
type out_module_type =
|
||||
| Omty_abstract
|
||||
| Omty_functor of string * out_module_type option * out_module_type
|
||||
| Omty_functor of (string option * out_module_type) option * out_module_type
|
||||
| Omty_ident of out_ident
|
||||
| Omty_signature of out_sig_item list
|
||||
| Omty_alias of out_ident
|
||||
|
|
|
@ -2598,8 +2598,10 @@ let all_rhs_idents exp =
|
|||
Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
|
||||
_) ->
|
||||
assert (Ident.Set.mem id_exp !ids) ;
|
||||
if not (Ident.Set.mem id_mod !ids) then begin
|
||||
begin match id_mod with
|
||||
| Some id_mod when not (Ident.Set.mem id_mod !ids) ->
|
||||
ids := Ident.Set.remove id_exp !ids
|
||||
| _ -> ()
|
||||
end
|
||||
| _ -> assert false
|
||||
end
|
||||
|
|
|
@ -1622,15 +1622,22 @@ let rec tree_of_modtype ?(ellipsis=false) = function
|
|||
| Mty_signature sg ->
|
||||
Omty_signature (if ellipsis then [Osig_ellipsis]
|
||||
else tree_of_signature sg)
|
||||
| Mty_functor(param, ty_arg, ty_res) ->
|
||||
let res =
|
||||
match ty_arg with None -> tree_of_modtype ~ellipsis ty_res
|
||||
| Some mty ->
|
||||
wrap_env (Env.add_module ~arg:true param Mp_present mty)
|
||||
(tree_of_modtype ~ellipsis) ty_res
|
||||
| Mty_functor(param, ty_res) ->
|
||||
let param, res =
|
||||
match param with
|
||||
| Unit -> None, tree_of_modtype ~ellipsis ty_res
|
||||
| Named (param, ty_arg) ->
|
||||
let name, env =
|
||||
match param with
|
||||
| None -> None, fun env -> env
|
||||
| Some id ->
|
||||
Some (Ident.name id),
|
||||
Env.add_module ~arg:true id Mp_present ty_arg
|
||||
in
|
||||
Omty_functor (Ident.name param,
|
||||
Option.map (tree_of_modtype ~ellipsis:false) ty_arg, res)
|
||||
Some (name, tree_of_modtype ~ellipsis:false ty_arg),
|
||||
wrap_env env (tree_of_modtype ~ellipsis) ty_res
|
||||
in
|
||||
Omty_functor (param, res)
|
||||
| Mty_alias p ->
|
||||
Omty_alias (tree_of_path Module p)
|
||||
|
||||
|
|
|
@ -43,6 +43,10 @@ let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;;
|
|||
|
||||
let fmt_ident = Ident.print
|
||||
|
||||
let fmt_modname f = function
|
||||
| None -> fprintf f "_";
|
||||
| Some id -> Ident.print f id
|
||||
|
||||
let rec fmt_path_aux f x =
|
||||
match x with
|
||||
| Path.Pident (s) -> fprintf f "%a" fmt_ident s;
|
||||
|
@ -389,7 +393,7 @@ and expression i ppf x =
|
|||
line i ppf "Texp_override\n";
|
||||
list i string_x_expression ppf l;
|
||||
| Texp_letmodule (s, _, _, me, e) ->
|
||||
line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s;
|
||||
line i ppf "Texp_letmodule \"%a\"\n" fmt_modname s;
|
||||
module_expr i ppf me;
|
||||
expression i ppf e;
|
||||
| Texp_letexception (cd, e) ->
|
||||
|
@ -668,9 +672,12 @@ and module_type i ppf x =
|
|||
| Tmty_signature (s) ->
|
||||
line i ppf "Tmty_signature\n";
|
||||
signature i ppf s;
|
||||
| Tmty_functor (s, _, mt1, mt2) ->
|
||||
line i ppf "Tmty_functor \"%a\"\n" fmt_ident s;
|
||||
Option.iter (module_type i ppf) mt1;
|
||||
| Tmty_functor (Unit, mt2) ->
|
||||
line i ppf "Tmty_functor ()\n";
|
||||
module_type i ppf mt2;
|
||||
| Tmty_functor (Named (s, _, mt1), mt2) ->
|
||||
line i ppf "Tmty_functor \"%a\"\n" fmt_modname s;
|
||||
module_type i ppf mt1;
|
||||
module_type i ppf mt2;
|
||||
| Tmty_with (mt, l) ->
|
||||
line i ppf "Tmty_with\n";
|
||||
|
@ -702,7 +709,7 @@ and signature_item i ppf x =
|
|||
line i ppf "Tsig_exception\n";
|
||||
type_exception i ppf ext
|
||||
| Tsig_module md ->
|
||||
line i ppf "Tsig_module \"%a\"\n" fmt_ident md.md_id;
|
||||
line i ppf "Tsig_module \"%a\"\n" fmt_modname md.md_id;
|
||||
attributes i ppf md.md_attributes;
|
||||
module_type i ppf md.md_type
|
||||
| Tsig_modsubst ms ->
|
||||
|
@ -735,12 +742,12 @@ and signature_item i ppf x =
|
|||
attribute i ppf "Tsig_attribute" a
|
||||
|
||||
and module_declaration i ppf md =
|
||||
line i ppf "%a" fmt_ident md.md_id;
|
||||
line i ppf "%a" fmt_modname md.md_id;
|
||||
attributes i ppf md.md_attributes;
|
||||
module_type (i+1) ppf md.md_type;
|
||||
|
||||
and module_binding i ppf x =
|
||||
line i ppf "%a\n" fmt_ident x.mb_id;
|
||||
line i ppf "%a\n" fmt_modname x.mb_id;
|
||||
attributes i ppf x.mb_attributes;
|
||||
module_expr (i+1) ppf x.mb_expr
|
||||
|
||||
|
@ -768,9 +775,12 @@ and module_expr i ppf x =
|
|||
| Tmod_structure (s) ->
|
||||
line i ppf "Tmod_structure\n";
|
||||
structure i ppf s;
|
||||
| Tmod_functor (s, _, mt, me) ->
|
||||
line i ppf "Tmod_functor \"%a\"\n" fmt_ident s;
|
||||
Option.iter (module_type i ppf) mt;
|
||||
| Tmod_functor (Unit, me) ->
|
||||
line i ppf "Tmod_functor ()\n";
|
||||
module_expr i ppf me;
|
||||
| Tmod_functor (Named (s, _, mt), me) ->
|
||||
line i ppf "Tmod_functor \"%a\"\n" fmt_modname s;
|
||||
module_type i ppf mt;
|
||||
module_expr i ppf me;
|
||||
| Tmod_apply (me1, me2, _) ->
|
||||
line i ppf "Tmod_apply\n";
|
||||
|
|
|
@ -854,7 +854,7 @@ and modexp : Typedtree.module_expr -> term_judg =
|
|||
path pth
|
||||
| Tmod_structure s ->
|
||||
structure s
|
||||
| Tmod_functor (_, _, _, e) ->
|
||||
| Tmod_functor (_, e) ->
|
||||
modexp e << Delay
|
||||
| Tmod_apply (f, p, _) ->
|
||||
join [
|
||||
|
@ -984,15 +984,21 @@ and structure_item : Typedtree.structure_item -> bind_judg =
|
|||
Env.join (modexp mexp m) (Env.remove_list included_ids env)
|
||||
|
||||
(* G |- module M = E : m -| G *)
|
||||
and module_binding : (Ident.t * Typedtree.module_expr) -> bind_judg =
|
||||
and module_binding : (Ident.t option * Typedtree.module_expr) -> bind_judg =
|
||||
fun (id, mexp) m env ->
|
||||
(*
|
||||
GE |- E: m[mM + Guard]
|
||||
-------------------------------------
|
||||
GE + G |- module M = E : m -| M:mM, G
|
||||
*)
|
||||
let judg_E, env =
|
||||
match id with
|
||||
| None -> modexp mexp << Ignore, env
|
||||
| Some id ->
|
||||
let mM, env = Env.take id env in
|
||||
let judg_E = modexp mexp << (Mode.join mM Guard) in
|
||||
judg_E, env
|
||||
in
|
||||
Env.join (judg_E m) env
|
||||
|
||||
and open_declaration : Typedtree.open_declaration -> bind_judg =
|
||||
|
@ -1002,12 +1008,18 @@ and open_declaration : Typedtree.open_declaration -> bind_judg =
|
|||
Env.join (judg_E m) (Env.remove_list bound_ids env)
|
||||
|
||||
and recursive_module_bindings
|
||||
: (Ident.t * Typedtree.module_expr) list -> bind_judg =
|
||||
: (Ident.t option * Typedtree.module_expr) list -> bind_judg =
|
||||
fun m_bindings m env ->
|
||||
let mids = List.map fst m_bindings in
|
||||
let mids = List.filter_map fst m_bindings in
|
||||
let binding (mid, mexp) m =
|
||||
let judg_E =
|
||||
match mid with
|
||||
| None -> modexp mexp << Ignore
|
||||
| Some mid ->
|
||||
let mM = Env.find mid env in
|
||||
Env.remove_list mids (modexp mexp Mode.(compose m (join mM Guard)))
|
||||
modexp mexp << (Mode.join mM Guard)
|
||||
in
|
||||
Env.remove_list mids (judg_E m)
|
||||
in
|
||||
Env.join (list binding m_bindings m) (Env.remove_list mids env)
|
||||
|
||||
|
|
|
@ -458,9 +458,13 @@ let rec modtype scoping s = function
|
|||
end
|
||||
| Mty_signature sg ->
|
||||
Mty_signature(signature scoping s sg)
|
||||
| Mty_functor(id, arg, res) ->
|
||||
| Mty_functor(Unit, res) ->
|
||||
Mty_functor(Unit, modtype scoping s res)
|
||||
| Mty_functor(Named (None, arg), res) ->
|
||||
Mty_functor(Named (None, (modtype scoping s) arg), modtype scoping s res)
|
||||
| Mty_functor(Named (Some id, arg), res) ->
|
||||
let id' = Ident.rename id in
|
||||
Mty_functor(id', Option.map (modtype scoping s) arg,
|
||||
Mty_functor(Named (Some id', (modtype scoping s) arg),
|
||||
modtype scoping (add_module id (Pident id') s) res)
|
||||
| Mty_alias p ->
|
||||
Mty_alias (module_path s p)
|
||||
|
|
|
@ -288,14 +288,18 @@ let signature_item sub {sig_desc; sig_env; _} =
|
|||
let class_description sub x =
|
||||
class_infos sub (sub.class_type sub) x
|
||||
|
||||
let functor_parameter sub = function
|
||||
| Unit -> ()
|
||||
| Named (_, _, mtype) -> sub.module_type sub mtype
|
||||
|
||||
let module_type sub {mty_desc; mty_env; _} =
|
||||
sub.env sub mty_env;
|
||||
match mty_desc with
|
||||
| Tmty_ident _ -> ()
|
||||
| Tmty_alias _ -> ()
|
||||
| Tmty_signature sg -> sub.signature sub sg
|
||||
| Tmty_functor (_, _, mtype1, mtype2) ->
|
||||
Option.iter (sub.module_type sub) mtype1;
|
||||
| Tmty_functor (arg, mtype2) ->
|
||||
functor_parameter sub arg;
|
||||
sub.module_type sub mtype2
|
||||
| Tmty_with (mtype, list) ->
|
||||
sub.module_type sub mtype;
|
||||
|
@ -332,8 +336,8 @@ let module_expr sub {mod_desc; mod_env; _} =
|
|||
match mod_desc with
|
||||
| Tmod_ident _ -> ()
|
||||
| Tmod_structure st -> sub.structure sub st
|
||||
| Tmod_functor (_, _, mtype, mexpr) ->
|
||||
Option.iter (sub.module_type sub) mtype;
|
||||
| Tmod_functor (arg, mexpr) ->
|
||||
functor_parameter sub arg;
|
||||
sub.module_expr sub mexpr
|
||||
| Tmod_apply (mexp1, mexp2, c) ->
|
||||
sub.module_expr sub mexp1;
|
||||
|
|
|
@ -426,6 +426,10 @@ let signature_item sub x =
|
|||
let class_description sub x =
|
||||
class_infos sub (sub.class_type sub) x
|
||||
|
||||
let functor_parameter sub = function
|
||||
| Unit -> Unit
|
||||
| Named (id, s, mtype) -> Named (id, s, sub.module_type sub mtype)
|
||||
|
||||
let module_type sub x =
|
||||
let mty_env = sub.env sub x.mty_env in
|
||||
let mty_desc =
|
||||
|
@ -433,13 +437,8 @@ let module_type sub x =
|
|||
| Tmty_ident _
|
||||
| Tmty_alias _ as d -> d
|
||||
| Tmty_signature sg -> Tmty_signature (sub.signature sub sg)
|
||||
| Tmty_functor (id, s, mtype1, mtype2) ->
|
||||
Tmty_functor (
|
||||
id,
|
||||
s,
|
||||
Option.map (sub.module_type sub) mtype1,
|
||||
sub.module_type sub mtype2
|
||||
)
|
||||
| Tmty_functor (arg, mtype2) ->
|
||||
Tmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
|
||||
| Tmty_with (mtype, list) ->
|
||||
Tmty_with (
|
||||
sub.module_type sub mtype,
|
||||
|
@ -484,13 +483,8 @@ let module_expr sub x =
|
|||
match x.mod_desc with
|
||||
| Tmod_ident _ as d -> d
|
||||
| Tmod_structure st -> Tmod_structure (sub.structure sub st)
|
||||
| Tmod_functor (id, s, mtype, mexpr) ->
|
||||
Tmod_functor (
|
||||
id,
|
||||
s,
|
||||
Option.map (sub.module_type sub) mtype,
|
||||
sub.module_expr sub mexpr
|
||||
)
|
||||
| Tmod_functor (arg, mexpr) ->
|
||||
Tmod_functor (functor_parameter sub arg, sub.module_expr sub mexpr)
|
||||
| Tmod_apply (mexp1, mexp2, c) ->
|
||||
Tmod_apply (
|
||||
sub.module_expr sub mexp1,
|
||||
|
|
|
@ -1068,14 +1068,26 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode
|
|||
| Ppat_unpack name ->
|
||||
assert (constrs = None);
|
||||
let t = instance expected_ty in
|
||||
let id = enter_variable loc name t ~is_module:true sp.ppat_attributes in
|
||||
begin match name.txt with
|
||||
| None ->
|
||||
rp k {
|
||||
pat_desc = Tpat_var (id, name);
|
||||
pat_desc = Tpat_any;
|
||||
pat_loc = sp.ppat_loc;
|
||||
pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes];
|
||||
pat_type = t;
|
||||
pat_attributes = [];
|
||||
pat_env = !env }
|
||||
| Some s ->
|
||||
let v = { name with txt = s } in
|
||||
let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in
|
||||
rp k {
|
||||
pat_desc = Tpat_var (id, v);
|
||||
pat_loc = sp.ppat_loc;
|
||||
pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
|
||||
pat_type = t;
|
||||
pat_attributes = [];
|
||||
pat_env = !env }
|
||||
end
|
||||
| Ppat_constraint(
|
||||
{ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs},
|
||||
({ptyp_desc=Ptyp_poly _} as sty)) ->
|
||||
|
@ -1992,7 +2004,7 @@ let create_package_type loc env (p, l) =
|
|||
(fun sexp (name, loc) ->
|
||||
Exp.letmodule ~loc:{ sexp.pexp_loc with loc_ghost = true }
|
||||
~attrs:[Attr.mk (mknoloc "#modulepat") (PStr [])]
|
||||
name
|
||||
{ name with txt = Some name.txt }
|
||||
(Mod.unpack ~loc
|
||||
(Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)
|
||||
name.loc)))
|
||||
|
@ -2983,7 +2995,11 @@ and type_expect_
|
|||
{ md_type = modl.mod_type; md_attributes = []; md_loc = name.loc }
|
||||
in
|
||||
let (id, new_env) =
|
||||
Env.enter_module_declaration ~scope name.txt pres md env
|
||||
match name.txt with
|
||||
| None -> None, env
|
||||
| Some name ->
|
||||
let id, env = Env.enter_module_declaration ~scope name pres md env in
|
||||
Some id, env
|
||||
in
|
||||
Typetexp.widen context;
|
||||
(* ideally, we should catch Expr_type_clash errors
|
||||
|
|
|
@ -106,7 +106,8 @@ and expression_desc =
|
|||
| Texp_setinstvar of Path.t * Path.t * string loc * expression
|
||||
| Texp_override of Path.t * (Path.t * string loc * expression) list
|
||||
| Texp_letmodule of
|
||||
Ident.t * string loc * Types.module_presence * module_expr * expression
|
||||
Ident.t option * string option loc * Types.module_presence * module_expr *
|
||||
expression
|
||||
| Texp_letexception of extension_constructor * expression
|
||||
| Texp_assert of expression
|
||||
| Texp_lazy of expression
|
||||
|
@ -217,10 +218,14 @@ and module_type_constraint =
|
|||
Tmodtype_implicit
|
||||
| Tmodtype_explicit of module_type
|
||||
|
||||
and functor_parameter =
|
||||
| Unit
|
||||
| Named of Ident.t option * string option loc * module_type
|
||||
|
||||
and module_expr_desc =
|
||||
Tmod_ident of Path.t * Longident.t loc
|
||||
| Tmod_structure of structure
|
||||
| Tmod_functor of Ident.t * string loc * module_type option * module_expr
|
||||
| Tmod_functor of functor_parameter * module_expr
|
||||
| Tmod_apply of module_expr * module_expr * module_coercion
|
||||
| Tmod_constraint of
|
||||
module_expr * Types.module_type * module_type_constraint * module_coercion
|
||||
|
@ -256,8 +261,8 @@ and structure_item_desc =
|
|||
|
||||
and module_binding =
|
||||
{
|
||||
mb_id: Ident.t;
|
||||
mb_name: string loc;
|
||||
mb_id: Ident.t option;
|
||||
mb_name: string option loc;
|
||||
mb_presence: module_presence;
|
||||
mb_expr: module_expr;
|
||||
mb_attributes: attribute list;
|
||||
|
@ -291,7 +296,7 @@ and module_type =
|
|||
and module_type_desc =
|
||||
Tmty_ident of Path.t * Longident.t loc
|
||||
| Tmty_signature of signature
|
||||
| Tmty_functor of Ident.t * string loc * module_type option * module_type
|
||||
| Tmty_functor of functor_parameter * module_type
|
||||
| Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
|
||||
| Tmty_typeof of module_expr
|
||||
| Tmty_alias of Path.t * Longident.t loc
|
||||
|
@ -334,8 +339,8 @@ and signature_item_desc =
|
|||
|
||||
and module_declaration =
|
||||
{
|
||||
md_id: Ident.t;
|
||||
md_name: string loc;
|
||||
md_id: Ident.t option;
|
||||
md_name: string option loc;
|
||||
md_presence: module_presence;
|
||||
md_type: module_type;
|
||||
md_attributes: attribute list;
|
||||
|
|
|
@ -221,7 +221,8 @@ and expression_desc =
|
|||
| Texp_setinstvar of Path.t * Path.t * string loc * expression
|
||||
| Texp_override of Path.t * (Path.t * string loc * expression) list
|
||||
| Texp_letmodule of
|
||||
Ident.t * string loc * Types.module_presence * module_expr * expression
|
||||
Ident.t option * string option loc * Types.module_presence * module_expr *
|
||||
expression
|
||||
| Texp_letexception of extension_constructor * expression
|
||||
| Texp_assert of expression
|
||||
| Texp_lazy of expression
|
||||
|
@ -338,10 +339,14 @@ and module_type_constraint =
|
|||
| Tmodtype_explicit of module_type
|
||||
(** The module type was in the source file. *)
|
||||
|
||||
and functor_parameter =
|
||||
| Unit
|
||||
| Named of Ident.t option * string option loc * module_type
|
||||
|
||||
and module_expr_desc =
|
||||
Tmod_ident of Path.t * Longident.t loc
|
||||
| Tmod_structure of structure
|
||||
| Tmod_functor of Ident.t * string loc * module_type option * module_expr
|
||||
| Tmod_functor of functor_parameter * module_expr
|
||||
| Tmod_apply of module_expr * module_expr * module_coercion
|
||||
| Tmod_constraint of
|
||||
module_expr * Types.module_type * module_type_constraint * module_coercion
|
||||
|
@ -380,8 +385,8 @@ and structure_item_desc =
|
|||
|
||||
and module_binding =
|
||||
{
|
||||
mb_id: Ident.t;
|
||||
mb_name: string loc;
|
||||
mb_id: Ident.t option;
|
||||
mb_name: string option loc;
|
||||
mb_presence: module_presence;
|
||||
mb_expr: module_expr;
|
||||
mb_attributes: attributes;
|
||||
|
@ -415,7 +420,7 @@ and module_type =
|
|||
and module_type_desc =
|
||||
Tmty_ident of Path.t * Longident.t loc
|
||||
| Tmty_signature of signature
|
||||
| Tmty_functor of Ident.t * string loc * module_type option * module_type
|
||||
| Tmty_functor of functor_parameter * module_type
|
||||
| Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list
|
||||
| Tmty_typeof of module_expr
|
||||
| Tmty_alias of Path.t * Longident.t loc
|
||||
|
@ -457,8 +462,8 @@ and signature_item_desc =
|
|||
|
||||
and module_declaration =
|
||||
{
|
||||
md_id: Ident.t;
|
||||
md_name: string loc;
|
||||
md_id: Ident.t option;
|
||||
md_name: string option loc;
|
||||
md_presence: module_presence;
|
||||
md_type: module_type;
|
||||
md_attributes: attributes;
|
||||
|
|
|
@ -307,11 +307,18 @@ let iterator_with_env env =
|
|||
env := env_before
|
||||
);
|
||||
Btype.it_module_type = (fun self -> function
|
||||
| Mty_functor (param, mty_arg, mty_body) ->
|
||||
Option.iter (self.Btype.it_module_type self) mty_arg;
|
||||
| Mty_functor (param, mty_body) ->
|
||||
let env_before = !env in
|
||||
env := lazy (Env.add_module ~arg:true param Mp_present
|
||||
(Btype.default_mty mty_arg) (Lazy.force env_before));
|
||||
begin match param with
|
||||
| Unit -> ()
|
||||
| Named (param, mty_arg) ->
|
||||
self.Btype.it_module_type self mty_arg;
|
||||
match param with
|
||||
| None -> ()
|
||||
| Some id ->
|
||||
env := lazy (Env.add_module ~arg:true id Mp_present
|
||||
mty_arg (Lazy.force env_before))
|
||||
end;
|
||||
self.Btype.it_module_type self mty_body;
|
||||
env := env_before;
|
||||
| mty ->
|
||||
|
@ -324,7 +331,7 @@ let retype_applicative_functor_type ~loc env funct arg =
|
|||
let mty_arg = (Env.find_module arg env).md_type in
|
||||
let mty_param =
|
||||
match Env.scrape_alias env mty_functor with
|
||||
| Mty_functor (_, Some mty_param, _) -> mty_param
|
||||
| Mty_functor (Named (_, mty_param), _) -> mty_param
|
||||
| _ -> assert false (* could trigger due to MPR#7611 *)
|
||||
in
|
||||
Includemod.check_modtype_inclusion ~loc env mty_arg arg mty_param
|
||||
|
@ -685,16 +692,24 @@ let rec approx_modtype env smty =
|
|||
Mty_alias(path)
|
||||
| Pmty_signature ssg ->
|
||||
Mty_signature(approx_sig env ssg)
|
||||
| Pmty_functor(param, sarg, sres) ->
|
||||
let arg = Option.map (approx_modtype env) sarg in
|
||||
let rarg = Mtype.scrape_for_functor_arg env (Btype.default_mty arg) in
|
||||
| Pmty_functor(param, sres) ->
|
||||
let (param, newenv) =
|
||||
match param with
|
||||
| Unit -> Types.Unit, env
|
||||
| Named (param, sarg) ->
|
||||
let arg = approx_modtype env sarg in
|
||||
match param.txt with
|
||||
| None -> Types.Named (None, arg), env
|
||||
| Some name ->
|
||||
let rarg = Mtype.scrape_for_functor_arg env arg in
|
||||
let scope = Ctype.create_scope () in
|
||||
let (id, newenv) =
|
||||
Env.enter_module ~scope ~arg:true param.txt
|
||||
Mp_present rarg env
|
||||
Env.enter_module ~scope ~arg:true name Mp_present rarg env
|
||||
in
|
||||
Types.Named (Some id, arg), newenv
|
||||
in
|
||||
let res = approx_modtype newenv sres in
|
||||
Mty_functor(id, arg, res)
|
||||
Mty_functor(param, res)
|
||||
| Pmty_with(sbody, constraints) ->
|
||||
let body = approx_modtype env sbody in
|
||||
List.iter
|
||||
|
@ -734,6 +749,8 @@ and approx_sig env ssg =
|
|||
map_rec_type ~rec_flag
|
||||
(fun rs (id, info) -> Sig_type(id, info, rs, Exported)) decls rem
|
||||
| Psig_typesubst _ -> approx_sig env srem
|
||||
| Psig_module { pmd_name = { txt = None; _ }; _ } ->
|
||||
approx_sig env srem
|
||||
| Psig_module pmd ->
|
||||
let scope = Ctype.create_scope () in
|
||||
let md = approx_module_declaration env pmd in
|
||||
|
@ -743,7 +760,8 @@ and approx_sig env ssg =
|
|||
| _ -> Mp_present
|
||||
in
|
||||
let id, newenv =
|
||||
Env.enter_module_declaration ~scope pmd.pmd_name.txt pres md env
|
||||
Env.enter_module_declaration ~scope (Option.get pmd.pmd_name.txt)
|
||||
pres md env
|
||||
in
|
||||
Sig_module(id, pres, md, Trec_not, Exported) :: approx_sig newenv srem
|
||||
| Psig_modsubst pms ->
|
||||
|
@ -764,10 +782,12 @@ and approx_sig env ssg =
|
|||
| Psig_recmodule sdecls ->
|
||||
let scope = Ctype.create_scope () in
|
||||
let decls =
|
||||
List.map
|
||||
List.filter_map
|
||||
(fun pmd ->
|
||||
(Ident.create_scoped ~scope pmd.pmd_name.txt,
|
||||
approx_module_declaration env pmd)
|
||||
Option.map (fun name ->
|
||||
Ident.create_scoped ~scope name,
|
||||
approx_module_declaration env pmd
|
||||
) pmd.pmd_name.txt
|
||||
)
|
||||
sdecls
|
||||
in
|
||||
|
@ -1115,17 +1135,28 @@ and transl_modtype_aux env smty =
|
|||
let sg = transl_signature env ssg in
|
||||
mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
|
||||
smty.pmty_attributes
|
||||
| Pmty_functor(param, sarg, sres) ->
|
||||
let arg = Option.map (transl_modtype_functor_arg env) sarg in
|
||||
let ty_arg = Option.map (fun m -> m.mty_type) arg in
|
||||
let scope = Ctype.create_scope () in
|
||||
| Pmty_functor(sarg_opt, sres) ->
|
||||
let t_arg, ty_arg, newenv =
|
||||
match sarg_opt with
|
||||
| Unit -> Unit, Types.Unit, env
|
||||
| Named (param, sarg) ->
|
||||
let arg = transl_modtype_functor_arg env sarg in
|
||||
let (id, newenv) =
|
||||
Env.enter_module ~scope ~arg:true
|
||||
param.txt Mp_present (Btype.default_mty ty_arg) env
|
||||
match param.txt with
|
||||
| None -> None, env
|
||||
| Some name ->
|
||||
let scope = Ctype.create_scope () in
|
||||
let id, newenv =
|
||||
Env.enter_module ~scope ~arg:true name Mp_present arg.mty_type
|
||||
env
|
||||
in
|
||||
Some id, newenv
|
||||
in
|
||||
Named (id, param, arg), Types.Named (id, arg.mty_type), newenv
|
||||
in
|
||||
let res = transl_modtype newenv sres in
|
||||
mkmty (Tmty_functor (id, param, arg, res))
|
||||
(Mty_functor(id, ty_arg, res.mty_type)) env loc
|
||||
mkmty (Tmty_functor (t_arg, res))
|
||||
(Mty_functor(ty_arg, res.mty_type)) env loc
|
||||
smty.pmty_attributes
|
||||
| Pmty_with(sbody, constraints) ->
|
||||
let body = transl_modtype env sbody in
|
||||
|
@ -1254,16 +1285,24 @@ and transl_signature env sg =
|
|||
}
|
||||
in
|
||||
let id, newenv =
|
||||
Env.enter_module_declaration ~scope pmd.pmd_name.txt pres md env
|
||||
match pmd.pmd_name.txt with
|
||||
| None -> None, env
|
||||
| Some name ->
|
||||
let id, newenv =
|
||||
Env.enter_module_declaration ~scope name pres md env
|
||||
in
|
||||
Signature_names.check_module names pmd.pmd_name.loc id;
|
||||
Some id, newenv
|
||||
in
|
||||
let (trem, rem, final_env) = transl_sig newenv srem in
|
||||
mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name;
|
||||
md_presence=pres; md_type=tmty;
|
||||
md_loc=pmd.pmd_loc;
|
||||
md_attributes=pmd.pmd_attributes})
|
||||
env loc :: trem,
|
||||
Sig_module(id, pres, md, Trec_not, Exported) :: rem,
|
||||
(match id with
|
||||
| None -> rem
|
||||
| Some id -> Sig_module(id, pres, md, Trec_not, Exported) :: rem),
|
||||
final_env
|
||||
| Psig_modsubst pms ->
|
||||
let scope = Ctype.create_scope () in
|
||||
|
@ -1301,19 +1340,26 @@ and transl_signature env sg =
|
|||
rem,
|
||||
final_env
|
||||
| Psig_recmodule sdecls ->
|
||||
let (decls, newenv) =
|
||||
let (tdecls, newenv) =
|
||||
transl_recmodule_modtypes env sdecls in
|
||||
let decls =
|
||||
List.filter_map (fun md ->
|
||||
match md.md_id with
|
||||
| None -> None
|
||||
| Some id -> Some (id, md)
|
||||
) tdecls
|
||||
in
|
||||
List.iter
|
||||
(fun md -> Signature_names.check_module names md.md_loc md.md_id)
|
||||
(fun (id, md) -> Signature_names.check_module names md.md_loc id)
|
||||
decls;
|
||||
let (trem, rem, final_env) = transl_sig newenv srem in
|
||||
mksig (Tsig_recmodule decls) env loc :: trem,
|
||||
map_rec (fun rs md ->
|
||||
mksig (Tsig_recmodule tdecls) env loc :: trem,
|
||||
map_rec (fun rs (id, md) ->
|
||||
let d = {Types.md_type = md.md_type.mty_type;
|
||||
md_attributes = md.md_attributes;
|
||||
md_loc = md.md_loc;
|
||||
} in
|
||||
Sig_module(md.md_id, Mp_present, d, rs, Exported))
|
||||
Sig_module(id, Mp_present, d, rs, Exported))
|
||||
decls rem,
|
||||
final_env
|
||||
| Psig_modtype pmtd ->
|
||||
|
@ -1459,12 +1505,16 @@ and transl_recmodule_modtypes env sdecls =
|
|||
let make_env curr =
|
||||
List.fold_left
|
||||
(fun env (id, _, mty) ->
|
||||
Env.add_module ~arg:true id Mp_present mty env)
|
||||
Option.fold ~none:env
|
||||
~some:(fun id -> Env.add_module ~arg:true id Mp_present mty env) id)
|
||||
env curr in
|
||||
let make_env2 curr =
|
||||
List.fold_left
|
||||
(fun env (id, _, mty) ->
|
||||
Env.add_module ~arg:true id Mp_present mty.mty_type env)
|
||||
Option.fold ~none:env
|
||||
~some:(fun id ->
|
||||
Env.add_module ~arg:true id Mp_present mty.mty_type env
|
||||
) id)
|
||||
env curr in
|
||||
let transition env_c curr =
|
||||
List.map2
|
||||
|
@ -1475,22 +1525,27 @@ and transl_recmodule_modtypes env sdecls =
|
|||
in
|
||||
(id, id_loc, tmty))
|
||||
sdecls curr in
|
||||
let map_mtys = List.map
|
||||
let map_mtys =
|
||||
List.filter_map
|
||||
(fun (id, _, mty) ->
|
||||
Option.map (fun id ->
|
||||
(id, Types.{md_type = mty.mty_type;
|
||||
md_loc = mty.mty_loc;
|
||||
md_attributes = mty.mty_attributes})) in
|
||||
md_attributes = mty.mty_attributes})
|
||||
) id)
|
||||
in
|
||||
let scope = Ctype.create_scope () in
|
||||
let ids =
|
||||
List.map (fun x -> Ident.create_scoped ~scope x.pmd_name.txt) sdecls
|
||||
List.map (fun x -> Option.map (Ident.create_scoped ~scope) x.pmd_name.txt)
|
||||
sdecls
|
||||
in
|
||||
let approx_env =
|
||||
List.fold_left
|
||||
(fun env id ->
|
||||
(* cf #5965 *)
|
||||
(fun env ->
|
||||
Option.fold ~none:env ~some:(fun id -> (* cf #5965 *)
|
||||
Env.enter_unbound_module (Ident.name id)
|
||||
Mod_unbound_illegal_recursion env
|
||||
)
|
||||
))
|
||||
env ids
|
||||
in
|
||||
let init =
|
||||
|
@ -1550,9 +1605,13 @@ let rec closed_modtype env = function
|
|||
| Mty_signature sg ->
|
||||
let env = Env.add_signature sg env in
|
||||
List.for_all (closed_signature_item env) sg
|
||||
| Mty_functor(id, param, body) ->
|
||||
| Mty_functor(arg_opt, body) ->
|
||||
let env =
|
||||
Env.add_module ~arg:true id Mp_present (Btype.default_mty param) env
|
||||
match arg_opt with
|
||||
| Unit
|
||||
| Named (None, _) -> env
|
||||
| Named (Some id, param) ->
|
||||
Env.add_module ~arg:true id Mp_present param env
|
||||
in
|
||||
closed_modtype env body
|
||||
|
||||
|
@ -1577,9 +1636,14 @@ let check_nongen_schemes env sg =
|
|||
(* Helpers for typing recursive modules *)
|
||||
|
||||
let anchor_submodule name anchor =
|
||||
match anchor with None -> None | Some p -> Some(Pdot(p, name))
|
||||
let anchor_recmodule id =
|
||||
Some (Pident id)
|
||||
match anchor, name with
|
||||
| None, _
|
||||
| _, None ->
|
||||
None
|
||||
| Some p, Some name ->
|
||||
Some(Pdot(p, name))
|
||||
|
||||
let anchor_recmodule = Option.map (fun id -> Pident id)
|
||||
|
||||
let enrich_type_decls anchor decls oldenv newenv =
|
||||
match anchor with
|
||||
|
@ -1596,9 +1660,12 @@ let enrich_type_decls anchor decls oldenv newenv =
|
|||
oldenv decls
|
||||
|
||||
let enrich_module_type anchor name mty env =
|
||||
match anchor with
|
||||
None -> mty
|
||||
| Some p -> Mtype.enrich_modtype env (Pdot(p, name)) mty
|
||||
match anchor, name with
|
||||
| None, _
|
||||
| _, None ->
|
||||
mty
|
||||
| Some p, Some name ->
|
||||
Mtype.enrich_modtype env (Pdot(p, name)) mty
|
||||
|
||||
let check_recmodule_inclusion env bindings =
|
||||
(* PR#4450, PR#4470: consider
|
||||
|
@ -1622,8 +1689,13 @@ let check_recmodule_inclusion env bindings =
|
|||
the number of mutually recursive declarations. *)
|
||||
|
||||
let subst_and_strengthen env scope s id mty =
|
||||
Mtype.strengthen ~aliasable:false env (Subst.modtype (Rescope scope) s mty)
|
||||
(Subst.module_path s (Pident id)) in
|
||||
let mty = Subst.modtype (Rescope scope) s mty in
|
||||
match id with
|
||||
| None -> mty
|
||||
| Some id ->
|
||||
Mtype.strengthen ~aliasable:false env mty
|
||||
(Subst.module_path s (Pident id))
|
||||
in
|
||||
|
||||
let rec check_incl first_time n env s =
|
||||
let scope = Ctype.create_scope () in
|
||||
|
@ -1631,32 +1703,42 @@ let check_recmodule_inclusion env bindings =
|
|||
(* Generate fresh names Y_i for the rec. bound module idents X_i *)
|
||||
let bindings1 =
|
||||
List.map
|
||||
(fun (id, name, _mty_decl, _modl, mty_actual, _attrs, _loc) ->
|
||||
(id, Ident.create_scoped ~scope name.txt, mty_actual))
|
||||
(fun (id, _name, _mty_decl, _modl, mty_actual, _attrs, _loc) ->
|
||||
let ids =
|
||||
Option.map
|
||||
(fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id
|
||||
in
|
||||
(ids, mty_actual))
|
||||
bindings in
|
||||
(* Enter the Y_i in the environment with their actual types substituted
|
||||
by the input substitution s *)
|
||||
let env' =
|
||||
List.fold_left
|
||||
(fun env (id, id', mty_actual) ->
|
||||
(fun env (ids, mty_actual) ->
|
||||
match ids with
|
||||
| None -> env
|
||||
| Some (id, id') ->
|
||||
let mty_actual' =
|
||||
if first_time
|
||||
then mty_actual
|
||||
else subst_and_strengthen env scope s id mty_actual in
|
||||
else subst_and_strengthen env scope s (Some id) mty_actual
|
||||
in
|
||||
Env.add_module ~arg:false id' Mp_present mty_actual' env)
|
||||
env bindings1 in
|
||||
(* Build the output substitution Y_i <- X_i *)
|
||||
let s' =
|
||||
List.fold_left
|
||||
(fun s (id, id', _mty_actual) ->
|
||||
Subst.add_module id (Pident id') s)
|
||||
(fun s (ids, _mty_actual) ->
|
||||
match ids with
|
||||
| None -> s
|
||||
| Some (id, id') -> Subst.add_module id (Pident id') s)
|
||||
Subst.identity bindings1 in
|
||||
(* Recurse with env' and s' *)
|
||||
check_incl false (n-1) env' s'
|
||||
end else begin
|
||||
(* Base case: check inclusion of s(mty_actual) in s(mty_decl)
|
||||
and insert coercion if needed *)
|
||||
let check_inclusion (id, id_loc, mty_decl, modl, mty_actual, attrs, loc) =
|
||||
let check_inclusion (id, name, mty_decl, modl, mty_actual, attrs, loc) =
|
||||
let mty_decl' = Subst.modtype (Rescope scope) s mty_decl.mty_type
|
||||
and mty_actual' = subst_and_strengthen env scope s id mty_actual in
|
||||
let coercion =
|
||||
|
@ -1674,7 +1756,7 @@ let check_recmodule_inclusion env bindings =
|
|||
} in
|
||||
{
|
||||
mb_id = id;
|
||||
mb_name = id_loc;
|
||||
mb_name = name;
|
||||
mb_presence = Mp_present;
|
||||
mb_expr = modl';
|
||||
mb_attributes = attrs;
|
||||
|
@ -1807,20 +1889,28 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
|
|||
if List.length sg' = List.length sg then md else
|
||||
wrap_constraint env false md (Mty_signature sg')
|
||||
Tmodtype_implicit
|
||||
| Pmod_functor(name, smty, sbody) ->
|
||||
let mty = Option.map (transl_modtype_functor_arg env) smty in
|
||||
let ty_arg = Option.map (fun m -> m.mty_type) mty in
|
||||
| Pmod_functor(arg_opt, sbody) ->
|
||||
let t_arg, ty_arg, newenv, funct_body =
|
||||
match arg_opt with
|
||||
| Unit -> Unit, Types.Unit, env, false
|
||||
| Named (name, smty) ->
|
||||
let mty = transl_modtype_functor_arg env smty in
|
||||
let scope = Ctype.create_scope () in
|
||||
let (id, newenv), funct_body =
|
||||
match ty_arg with
|
||||
| None -> (Ident.create_scoped ~scope "*", env), false
|
||||
| Some mty ->
|
||||
Env.enter_module ~scope ~arg:true name.txt Mp_present mty env,
|
||||
true
|
||||
let (id, newenv) =
|
||||
match name.txt with
|
||||
| None -> None, env
|
||||
| Some name ->
|
||||
let id, newenv =
|
||||
Env.enter_module ~scope ~arg:true name Mp_present mty.mty_type
|
||||
env
|
||||
in
|
||||
Some id, newenv
|
||||
in
|
||||
Named (id, name, mty), Types.Named (id, mty.mty_type), newenv, true
|
||||
in
|
||||
let body = type_module sttn funct_body None newenv sbody in
|
||||
rm { mod_desc = Tmod_functor(id, name, mty, body);
|
||||
mod_type = Mty_functor(id, ty_arg, body.mod_type);
|
||||
rm { mod_desc = Tmod_functor(t_arg, body);
|
||||
mod_type = Mty_functor(ty_arg, body.mod_type);
|
||||
mod_env = env;
|
||||
mod_attributes = smod.pmod_attributes;
|
||||
mod_loc = smod.pmod_loc }
|
||||
|
@ -1830,15 +1920,17 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
|
|||
let funct =
|
||||
type_module (sttn && path <> None) funct_body None env sfunct in
|
||||
begin match Env.scrape_alias env funct.mod_type with
|
||||
Mty_functor(param, mty_param, mty_res) as mty_functor ->
|
||||
let generative, mty_param =
|
||||
(mty_param = None, Btype.default_mty mty_param) in
|
||||
if generative then begin
|
||||
| Mty_functor (Unit, mty_res) ->
|
||||
if sarg.pmod_desc <> Pmod_structure [] then
|
||||
raise (Error (sfunct.pmod_loc, env, Apply_generative));
|
||||
if funct_body && Mtype.contains_type env funct.mod_type then
|
||||
raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
|
||||
end;
|
||||
rm { mod_desc = Tmod_apply(funct, arg, Tcoerce_none);
|
||||
mod_type = mty_res;
|
||||
mod_env = env;
|
||||
mod_attributes = smod.pmod_attributes;
|
||||
mod_loc = smod.pmod_loc }
|
||||
| Mty_functor (Named (param, mty_param), mty_res) as mty_functor ->
|
||||
let coercion =
|
||||
try
|
||||
Includemod.modtypes ~loc:sarg.pmod_loc env arg.mod_type mty_param
|
||||
|
@ -1846,20 +1938,26 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
|
|||
raise(Error(sarg.pmod_loc, env, Not_included msg)) in
|
||||
let mty_appl =
|
||||
match path with
|
||||
Some path ->
|
||||
| Some path ->
|
||||
let scope = Ctype.create_scope () in
|
||||
Subst.modtype (Rescope scope)
|
||||
(Subst.add_module param path Subst.identity)
|
||||
mty_res
|
||||
let subst =
|
||||
match param with
|
||||
| None -> Subst.identity
|
||||
| Some p -> Subst.add_module p path Subst.identity
|
||||
in
|
||||
Subst.modtype (Rescope scope) subst mty_res
|
||||
| None ->
|
||||
if generative then mty_res else
|
||||
let env, nondep_mty =
|
||||
match param with
|
||||
| None -> env, mty_res
|
||||
| Some param ->
|
||||
let env =
|
||||
Env.add_module ~arg:true param Mp_present arg.mod_type env
|
||||
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;
|
||||
let nondep_mty =
|
||||
try Mtype.nondep_supertype env [param] 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))
|
||||
|
@ -2096,17 +2194,22 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
|
|||
in
|
||||
(*prerr_endline (Ident.unique_toplevel_name id);*)
|
||||
Mtype.lower_nongen outer_scope md.md_type;
|
||||
let id, newenv =
|
||||
Env.enter_module_declaration ~scope name.txt pres md env
|
||||
in
|
||||
let id, newenv, sg =
|
||||
match name.txt with
|
||||
| None -> None, env, []
|
||||
| Some name ->
|
||||
let id, e = Env.enter_module_declaration ~scope name pres md env in
|
||||
Signature_names.check_module names pmb_loc id;
|
||||
Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
|
||||
mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; },
|
||||
Some id, e,
|
||||
[Sig_module(id, pres,
|
||||
{md_type = modl.mod_type;
|
||||
md_attributes = attrs;
|
||||
md_loc = pmb_loc;
|
||||
}, Trec_not, Exported)],
|
||||
}, Trec_not, Exported)]
|
||||
in
|
||||
Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
|
||||
mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; },
|
||||
sg,
|
||||
newenv
|
||||
| Pstr_recmodule sbind ->
|
||||
let sbind =
|
||||
|
@ -2131,7 +2234,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
|
|||
pmd_attributes=attrs; pmd_loc=loc}) sbind
|
||||
) in
|
||||
List.iter
|
||||
Signature_names.(fun md -> check_module names md.md_loc md.md_id)
|
||||
(fun md ->
|
||||
Option.iter Signature_names.(check_module names md.md_loc) md.md_id)
|
||||
decls;
|
||||
let bindings1 =
|
||||
List.map2
|
||||
|
@ -2144,13 +2248,16 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
|
|||
)
|
||||
in
|
||||
let mty' =
|
||||
enrich_module_type anchor (Ident.name id) modl.mod_type newenv
|
||||
enrich_module_type anchor name.txt modl.mod_type newenv
|
||||
in
|
||||
(id, name, mty, modl, mty', attrs, loc))
|
||||
decls sbind in
|
||||
let newenv = (* allow aliasing recursive modules from outside *)
|
||||
List.fold_left
|
||||
(fun env md ->
|
||||
match md.md_id with
|
||||
| None -> env
|
||||
| Some id ->
|
||||
let mdecl =
|
||||
{
|
||||
md_type = md.md_type.mty_type;
|
||||
|
@ -2159,20 +2266,24 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
|
|||
}
|
||||
in
|
||||
Env.add_module_declaration ~check:true
|
||||
md.md_id Mp_present mdecl env
|
||||
id Mp_present mdecl env
|
||||
)
|
||||
env decls
|
||||
in
|
||||
let bindings2 =
|
||||
check_recmodule_inclusion newenv bindings1 in
|
||||
let mbs =
|
||||
List.filter_map (fun mb -> Option.map (fun id -> id, mb) mb.mb_id)
|
||||
bindings2
|
||||
in
|
||||
Tstr_recmodule bindings2,
|
||||
map_rec (fun rs mb ->
|
||||
Sig_module(mb.mb_id, Mp_present, {
|
||||
map_rec (fun rs (id, mb) ->
|
||||
Sig_module(id, Mp_present, {
|
||||
md_type=mb.mb_expr.mod_type;
|
||||
md_attributes=mb.mb_attributes;
|
||||
md_loc=mb.mb_loc;
|
||||
}, rs, Exported))
|
||||
bindings2 [],
|
||||
mbs [],
|
||||
newenv
|
||||
| Pstr_modtype pmtd ->
|
||||
(* check that it is non-abstract *)
|
||||
|
@ -2313,7 +2424,7 @@ let rec normalize_modtype env = function
|
|||
Mty_ident _
|
||||
| Mty_alias _ -> ()
|
||||
| Mty_signature sg -> normalize_signature env sg
|
||||
| Mty_functor(_id, _param, body) -> normalize_modtype env body
|
||||
| Mty_functor(_param, body) -> normalize_modtype env body
|
||||
|
||||
and normalize_signature env = List.iter (normalize_signature_item env)
|
||||
|
||||
|
|
|
@ -257,9 +257,13 @@ type visibility =
|
|||
type module_type =
|
||||
Mty_ident of Path.t
|
||||
| Mty_signature of signature
|
||||
| Mty_functor of Ident.t * module_type option * module_type
|
||||
| Mty_functor of functor_parameter * module_type
|
||||
| Mty_alias of Path.t
|
||||
|
||||
and functor_parameter =
|
||||
| Unit
|
||||
| Named of Ident.t option * module_type
|
||||
|
||||
and module_presence =
|
||||
| Mp_present
|
||||
| Mp_absent
|
||||
|
|
|
@ -412,9 +412,13 @@ type visibility =
|
|||
type module_type =
|
||||
Mty_ident of Path.t
|
||||
| Mty_signature of signature
|
||||
| Mty_functor of Ident.t * module_type option * module_type
|
||||
| Mty_functor of functor_parameter * module_type
|
||||
| Mty_alias of Path.t
|
||||
|
||||
and functor_parameter =
|
||||
| Unit
|
||||
| Named of Ident.t option * module_type
|
||||
|
||||
and module_presence =
|
||||
| Mp_present
|
||||
| Mp_absent
|
||||
|
|
|
@ -296,8 +296,10 @@ let pattern sub pat =
|
|||
let attrs = sub.attributes sub pat.pat_attributes in
|
||||
let desc =
|
||||
match pat with
|
||||
{ pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
|
||||
Ppat_unpack name
|
||||
{ pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } ->
|
||||
Ppat_unpack { txt = None; loc }
|
||||
| { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
|
||||
Ppat_unpack { name with txt = Some name.txt }
|
||||
| { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
|
||||
Ppat_type (map_loc sub lid)
|
||||
| { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
|
||||
|
@ -310,7 +312,7 @@ let pattern sub pat =
|
|||
begin
|
||||
match (Ident.name id).[0] with
|
||||
'A'..'Z' ->
|
||||
Ppat_unpack name
|
||||
Ppat_unpack { name with txt = Some name.txt}
|
||||
| _ ->
|
||||
Ppat_var name
|
||||
end
|
||||
|
@ -599,6 +601,11 @@ let class_declaration sub = class_infos sub.class_expr sub
|
|||
let class_description sub = class_infos sub.class_type sub
|
||||
let class_type_declaration sub = class_infos sub.class_type sub
|
||||
|
||||
let functor_parameter sub : functor_parameter -> Parsetree.functor_parameter =
|
||||
function
|
||||
| Unit -> Unit
|
||||
| Named (_, name, mtype) -> Named (name, sub.module_type sub mtype)
|
||||
|
||||
let module_type sub mty =
|
||||
let loc = sub.location sub mty.mty_loc in
|
||||
let attrs = sub.attributes sub mty.mty_attributes in
|
||||
|
@ -606,9 +613,8 @@ let module_type sub mty =
|
|||
Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid)
|
||||
| Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid)
|
||||
| Tmty_signature sg -> Pmty_signature (sub.signature sub sg)
|
||||
| Tmty_functor (_id, name, mtype1, mtype2) ->
|
||||
Pmty_functor (name, Option.map (sub.module_type sub) mtype1,
|
||||
sub.module_type sub mtype2)
|
||||
| Tmty_functor (arg, mtype2) ->
|
||||
Pmty_functor (functor_parameter sub arg, sub.module_type sub mtype2)
|
||||
| Tmty_with (mtype, list) ->
|
||||
Pmty_with (sub.module_type sub mtype,
|
||||
List.map (sub.with_constraint sub) list)
|
||||
|
@ -638,9 +644,9 @@ let module_expr sub mexpr =
|
|||
let desc = match mexpr.mod_desc with
|
||||
Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid)
|
||||
| Tmod_structure st -> Pmod_structure (sub.structure sub st)
|
||||
| Tmod_functor (_id, name, mtype, mexpr) ->
|
||||
Pmod_functor (name, Option.map (sub.module_type sub) mtype,
|
||||
sub.module_expr sub mexpr)
|
||||
| Tmod_functor (arg, mexpr) ->
|
||||
Pmod_functor
|
||||
(functor_parameter sub arg, sub.module_expr sub mexpr)
|
||||
| Tmod_apply (mexp1, mexp2, _) ->
|
||||
Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2)
|
||||
| Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
|
||||
|
|
Loading…
Reference in New Issue