summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--parsing/ast_mapper.ml12
-rw-r--r--parsing/ast_mapper.mli5
-rw-r--r--parsing/parser.mly6
-rw-r--r--parsing/parsetree.mli11
-rw-r--r--parsing/pprintast.ml25
-rw-r--r--parsing/printast.ml16
-rw-r--r--toplevel/toploop.ml9
-rw-r--r--typing/typecore.ml4
-rw-r--r--typing/typemod.ml15
-rw-r--r--typing/typemod.mli1
10 files changed, 69 insertions, 35 deletions
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index e859ea6dfe..97044345f7 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -256,7 +256,7 @@ module M = struct
let type_ ?loc a = mk_item ?loc (Pstr_type a)
let exception_ ?loc a = mk_item ?loc (Pstr_exception a)
let exn_rebind ?loc ?(attributes = []) a b = mk_item ?loc (Pstr_exn_rebind (a, b, attributes))
- let module_ ?loc a b = mk_item ?loc (Pstr_module (a, b))
+ let module_ ?loc a = mk_item ?loc (Pstr_module a)
let rec_module ?loc a = mk_item ?loc (Pstr_recmodule a)
let modtype ?loc a b = mk_item ?loc (Pstr_modtype (a, b))
let open_ ?loc ?(attributes = []) a = mk_item ?loc (Pstr_open (a, attributes))
@@ -274,8 +274,8 @@ module M = struct
| Pstr_type l -> type_ ~loc (List.map (map_tuple (map_loc sub) (sub # type_declaration)) l)
| Pstr_exception ed -> exception_ ~loc (sub # exception_declaration ed)
| Pstr_exn_rebind (s, lid, attrs) -> exn_rebind ~loc (map_loc sub s) (map_loc sub lid) ~attributes:(map_attributes sub attrs)
- | Pstr_module (s, m) -> module_ ~loc (map_loc sub s) (sub # module_expr m)
- | Pstr_recmodule l -> rec_module ~loc (List.map (fun (s, mty, me) -> (map_loc sub s, sub # module_type mty, sub # module_expr me)) l)
+ | Pstr_module x -> module_ ~loc (sub # module_binding x)
+ | Pstr_recmodule l -> rec_module ~loc (List.map (sub # module_binding) l)
| Pstr_modtype (s, mty) -> modtype ~loc (map_loc sub s) (sub # module_type mty)
| Pstr_open (lid, attrs) -> open_ ~loc ~attributes:(map_attributes sub attrs) (map_loc sub lid)
| Pstr_class l -> class_ ~loc (List.map (sub # class_declaration) l)
@@ -539,6 +539,12 @@ class mapper =
pmd_type = this # module_type pmd.pmd_type;
pmd_attributes = map_attributes this pmd.pmd_attributes;
}
+ method module_binding x =
+ {
+ pmb_name = map_loc this x.pmb_name;
+ pmb_expr = this # module_expr x.pmb_expr;
+ pmb_attributes = map_attributes this x.pmb_attributes;
+ }
method location l = l
diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli
index 4856475501..7bed0e3624 100644
--- a/parsing/ast_mapper.mli
+++ b/parsing/ast_mapper.mli
@@ -33,6 +33,7 @@ class mapper:
method implementation: string -> structure -> string * structure
method interface: string -> signature -> string * signature
method location: Location.t -> Location.t
+ method module_binding: module_binding -> module_binding
method module_declaration: module_declaration -> module_declaration
method module_expr: module_expr -> module_expr
method module_type: module_type -> module_type
@@ -174,8 +175,8 @@ module M:
val type_: ?loc:Location.t -> (string loc * type_declaration) list -> structure_item
val exception_: ?loc:Location.t -> exception_declaration -> structure_item
val exn_rebind: ?loc:Location.t -> ?attributes:attribute list -> string loc -> Longident.t loc -> structure_item
- val module_: ?loc:Location.t -> string loc -> module_expr -> structure_item
- val rec_module: ?loc:Location.t -> (string loc * module_type * module_expr) list -> structure_item
+ val module_: ?loc:Location.t -> module_binding -> structure_item
+ val rec_module: ?loc:Location.t -> module_binding list -> structure_item
val modtype: ?loc:Location.t -> string loc -> module_type -> structure_item
val open_: ?loc:Location.t -> ?attributes:attribute list -> Longident.t loc -> structure_item
val class_: ?loc:Location.t -> class_declaration list -> structure_item
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 57262c1142..34fd653552 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -624,8 +624,8 @@ structure_item:
| pre_item_attributes EXCEPTION UIDENT EQUAL constr_longident post_item_attributes
{ mkstr(Pstr_exn_rebind(mkrhs $3 3, mkloc $5 (rhs_loc 5), $1 @ $6)) }
| pre_item_attributes MODULE UIDENT module_binding post_item_attributes
- { mkstr(Pstr_module(mkrhs $3 3, $4)) (* keep attrs *) }
- | pre_item_attributes MODULE REC module_rec_bindings post_item_attributes
+ { mkstr(Pstr_module{pmb_name=mkrhs $3 3; pmb_expr=$4; pmb_attributes=$1 @ $5}) }
+ | pre_item_attributes MODULE REC module_rec_bindings
{ mkstr(Pstr_recmodule(List.rev $4)) (* keep attrs *) }
| pre_item_attributes MODULE TYPE ident EQUAL module_type post_item_attributes
{ mkstr(Pstr_modtype(mkrhs $4 4, $6)) (* keep attrs *) }
@@ -659,7 +659,7 @@ module_rec_bindings:
| module_rec_bindings AND module_rec_binding { $3 :: $1 }
;
module_rec_binding:
- UIDENT COLON module_type EQUAL module_expr { (mkrhs $1 1, $3, $5) }
+ UIDENT module_binding { {pmb_name=mkrhs $1 1; pmb_expr=$2; pmb_attributes=[]} (* todo: attrs *) }
;
/* Module types */
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d358be839c..1eb14fa47b 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -325,8 +325,8 @@ and structure_item_desc =
| Pstr_type of (string loc * type_declaration) list
| Pstr_exception of exception_declaration
| Pstr_exn_rebind of string loc * Longident.t loc * attribute list
- | Pstr_module of string loc * module_expr
- | Pstr_recmodule of (string loc * module_type * module_expr) list
+ | Pstr_module of module_binding
+ | Pstr_recmodule of module_binding list
| Pstr_modtype of string loc * module_type
| Pstr_open of Longident.t loc * attribute list
| Pstr_class of class_declaration list
@@ -334,6 +334,13 @@ and structure_item_desc =
| Pstr_include of module_expr * attribute list
| Pstr_extension of extension * attribute list
+and module_binding =
+ {
+ pmb_name: string loc;
+ pmb_expr: module_expr;
+ pmb_attributes: attribute list;
+ }
+
(* Toplevel phrases *)
type toplevel_phrase =
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 86a27b18ef..e7aa4ac1c4 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -1010,14 +1010,14 @@ class printer ()= object(self:'self)
| Pstr_value (rf, l) -> (* pp f "@[<hov2>let %a%a@]" self#rec_flag rf self#bindings l *)
pp f "@[<2>%a@]" self#bindings (rf,l)
| Pstr_exception ed -> self#exception_declaration f ed
- | Pstr_module (s, me) ->
+ | Pstr_module x ->
let rec module_helper me = match me.pmod_desc with
| Pmod_functor(s,mt,me) ->
pp f "(%s:%a)" s.txt self#module_type mt ;
module_helper me
| _ -> me in
pp f "@[<hov2>module %s%a@]"
- s.txt
+ x.pmb_name.txt
(fun f me ->
let me = module_helper me in
(match me.pmod_desc with
@@ -1028,7 +1028,7 @@ class printer ()= object(self:'self)
pp f " :@;%a@;=@;%a@;" self#module_type mt self#module_expr me
| _ ->
pp f " =@ %a" self#module_expr me
- )) me
+ )) x.pmb_expr
| Pstr_open (li, _attrs) ->
pp f "@[<2>open@;%a@]" self#longident_loc li;
| Pstr_modtype (s, mt) ->
@@ -1083,16 +1083,19 @@ class printer ()= object(self:'self)
| Pstr_exn_rebind (s, li, _attrs) -> (* todo: check this *)
pp f "@[<hov2>exception@ %s@ =@ %a@]" s.txt self#longident_loc li
| Pstr_recmodule decls -> (* 3.07 *)
- let text_x_modtype_x_module f (s, mt, me) =
- pp f "@[<hov2>and@ %s:%a@ =@ %a@]"
- s.txt self#module_type mt self#module_expr me
- in begin match decls with
- | (s,mt,me):: l2 ->
+ let aux f = function
+ | {pmb_name = s; pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} ->
+ pp f "@[<hov2>and@ %s:%a@ =@ %a@]"
+ s.txt self#module_type typ self#module_expr expr
+ | _ -> assert false
+ in
+ begin match decls with
+ | {pmb_name = s; pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} :: l2 ->
pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]@ %a@]"
s.txt
- self#module_type mt
- self#module_expr me
- (fun f l2 -> List.iter (text_x_modtype_x_module f) l2) l2
+ self#module_type typ
+ self#module_expr expr
+ (fun f l2 -> List.iter (aux f) l2) l2
| _ -> assert false
end
| Pstr_extension _ -> assert false
diff --git a/parsing/printast.ml b/parsing/printast.ml
index c4449fae52..4b907b9739 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -694,12 +694,12 @@ and structure_item i ppf x =
line (i+1) ppf "%a\n" fmt_string_loc s;
line (i+1) ppf "%a\n" fmt_longident_loc li;
attributes (i+1) ppf attrs
- | Pstr_module (s, me) ->
- line i ppf "Pstr_module %a\n" fmt_string_loc s;
- module_expr i ppf me;
+ | Pstr_module x ->
+ line i ppf "Pstr_module\n";
+ module_binding i ppf x
| Pstr_recmodule bindings ->
line i ppf "Pstr_recmodule\n";
- list i string_x_modtype_x_module ppf bindings;
+ list i module_binding ppf bindings;
| Pstr_modtype (s, mt) ->
line i ppf "Pstr_modtype %a\n" fmt_string_loc s;
module_type i ppf mt;
@@ -730,10 +730,10 @@ and module_declaration i ppf pmd =
module_type (i+1) ppf pmd.pmd_type;
attributes (i+1) ppf pmd.pmd_attributes
-and string_x_modtype_x_module i ppf (s, mty, modl) =
- string_loc i ppf s;
- module_type (i+1) ppf mty;
- module_expr (i+1) ppf modl;
+and module_binding i ppf x =
+ string_loc i ppf x.pmb_name;
+ module_expr (i+1) ppf x.pmb_expr;
+ attributes (i+1) ppf x.pmb_attributes
and longident_x_with_constraint i ppf (li, wc) =
line i ppf "%a\n" fmt_longident_loc li;
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index f1ded5e05d..29f6f5e28f 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -114,9 +114,12 @@ let parse_mod_use_file name lb =
in
[ Ptop_def
[ { pstr_desc =
- Pstr_module ( Location.mknoloc modname ,
- { pmod_desc = Pmod_structure items;
- pmod_loc = Location.none } );
+ Pstr_module ( {pmb_name =Location.mknoloc modname;
+ pmb_expr =
+ { pmod_desc = Pmod_structure items;
+ pmod_loc = Location.none };
+ pmb_attributes = []}
+ );
pstr_loc = Location.none } ] ]
(* Hooks for initialization *)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index d86b4a413a..5069699aa1 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -179,8 +179,8 @@ let iter_expression f e =
| Pstr_extension _
| Pstr_exn_rebind _ -> ()
| Pstr_include (me, _)
- | Pstr_module (_, me) -> module_expr me
- | Pstr_recmodule l -> List.iter (fun (_, _, me) -> module_expr me) l
+ | Pstr_module {pmb_expr = me} -> module_expr me
+ | Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l
| Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl
and class_expr ce =
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 37854a83a8..1bc86f76c5 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -38,6 +38,7 @@ type error =
| Incomplete_packed_module of type_expr
| Scoping_pack of Longident.t * type_expr
| Extension of string
+ | Recursive_module_require_explicit_type
exception Error of Location.t * Env.t * error
@@ -1010,7 +1011,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
(item :: str_rem,
Sig_exception(id, arg) :: sig_rem,
final_env)
- | Pstr_module(name, smodl) ->
+ | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = _} ->
check "module" loc module_names name.txt;
let modl =
type_module true funct_body (anchor_submodule name.txt anchor) env
@@ -1023,6 +1024,16 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
Sig_module(id, modl.mod_type, Trec_not) :: sig_rem,
final_env)
| Pstr_recmodule sbind ->
+ let sbind =
+ List.map
+ (function
+ | {pmb_name = name; pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; pmb_attributes = _} ->
+ name, typ, expr
+ | mb ->
+ raise (Error (mb.pmb_expr.pmod_loc, env, Recursive_module_require_explicit_type))
+ )
+ sbind
+ in
List.iter
(fun (name, _, _) -> check "module" loc module_names name.txt)
sbind;
@@ -1473,6 +1484,8 @@ let report_error ppf = function
"Its type contains local dependencies:@ %a" type_expr ty
| Extension s ->
fprintf ppf "Uninterpreted extension '%s'." s
+ | Recursive_module_require_explicit_type ->
+ fprintf ppf "Recursive modules require an explicit module type."
let report_error env ppf err =
Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
diff --git a/typing/typemod.mli b/typing/typemod.mli
index 81655cffb0..6e7433792c 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -61,6 +61,7 @@ type error =
| Incomplete_packed_module of type_expr
| Scoping_pack of Longident.t * type_expr
| Extension of string
+ | Recursive_module_require_explicit_type
exception Error of Location.t * Env.t * error
View Lorry Controller Status