Index: boot/ocamlc =================================================================== Cannot display: file marked as a binary type. svn:mime-type = application/octet-stream Index: boot/ocamldep =================================================================== Cannot display: file marked as a binary type. svn:mime-type = application/octet-stream Index: boot/ocamllex =================================================================== Cannot display: file marked as a binary type. svn:mime-type = application/octet-stream Index: camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml =================================================================== --- camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml (revision 14301) +++ camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml (working copy) @@ -979,7 +979,7 @@ [ <:module_type@loc<>> -> error loc "abstract/nil module type not allowed here" | <:module_type@loc< $id:i$ >> -> mkmty loc (Pmty_ident (long_uident i)) | <:module_type@loc< functor ($n$ : $nt$) -> $mt$ >> -> - mkmty loc (Pmty_functor (with_loc n loc) (module_type nt) (module_type mt)) + mkmty loc (Pmty_functor (with_loc n loc) (Some (module_type nt)) (module_type mt)) | <:module_type@loc< '$_$ >> -> error loc "module type variable not allowed here" | <:module_type@loc< sig $sl$ end >> -> mkmty loc (Pmty_signature (sig_item sl [])) @@ -1051,7 +1051,7 @@ | <:module_expr@loc< $me1$ $me2$ >> -> mkmod loc (Pmod_apply (module_expr me1) (module_expr me2)) | <:module_expr@loc< functor ($n$ : $mt$) -> $me$ >> -> - mkmod loc (Pmod_functor (with_loc n loc) (module_type mt) (module_expr me)) + mkmod loc (Pmod_functor (with_loc n loc) (Some (module_type mt)) (module_expr me)) | <:module_expr@loc< struct $sl$ end >> -> mkmod loc (Pmod_structure (str_item sl [])) | <:module_expr@loc< ($me$ : $mt$) >> -> Index: camlp4/Camlp4Top/Rprint.ml =================================================================== --- camlp4/Camlp4Top/Rprint.ml (revision 14301) +++ camlp4/Camlp4Top/Rprint.ml (working copy) @@ -362,7 +362,10 @@ | Omty_signature sg -> fprintf ppf "@[sig@ %a@;<1 -2>end@]" Toploop.print_out_signature.val sg - | Omty_functor name mty_arg mty_res -> + | Omty_functor _ None mty_res -> + fprintf ppf "@[<2>functor@ () ->@ %a@]" + print_out_module_type mty_res + | Omty_functor name (Some mty_arg) mty_res -> fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name print_out_module_type mty_arg print_out_module_type mty_res | Omty_abstract -> () ] Index: camlp4/boot/Camlp4.ml =================================================================== --- camlp4/boot/Camlp4.ml (revision 14301) +++ camlp4/boot/Camlp4.ml (working copy) @@ -15633,7 +15633,7 @@ | Ast.MtId (loc, i) -> mkmty loc (Pmty_ident (long_uident i)) | Ast.MtFun (loc, n, nt, mt) -> mkmty loc - (Pmty_functor ((with_loc n loc), (module_type nt), + (Pmty_functor ((with_loc n loc), Some (module_type nt), (module_type mt))) | Ast.MtQuo (loc, _) -> error loc "module type variable not allowed here" @@ -15775,7 +15775,7 @@ (Pmod_apply ((module_expr me1), (module_expr me2))) | Ast.MeFun (loc, n, mt, me) -> mkmod loc - (Pmod_functor ((with_loc n loc), (module_type mt), + (Pmod_functor ((with_loc n loc), Some (module_type mt), (module_expr me))) | Ast.MeStr (loc, sl) -> mkmod loc (Pmod_structure (str_item sl [])) Index: ocamldoc/odoc_ast.ml =================================================================== --- ocamldoc/odoc_ast.ml (revision 14301) +++ ocamldoc/odoc_ast.ml (working copy) @@ -1606,18 +1606,25 @@ | (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2), Typedtree.Tmod_functor (ident, _, mtyp, tt_module_expr2)) -> - let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in - let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let loc = match pmodule_type with None -> Location.none + | Some pmty -> pmty.Parsetree.pmty_loc 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 = Sig.analyse_module_type_kind env - current_module_name pmodule_type mtyp.mty_type + 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 = Odoc_env.subst_module_type env mtyp.mty_type ; + mp_type = Misc.may_map + (fun m -> Odoc_env.subst_module_type env m.mty_type) mtyp ; mp_type_code = mp_type_code ; mp_kind = mp_kind ; } Index: ocamldoc/odoc_env.ml =================================================================== --- ocamldoc/odoc_env.ml (revision 14301) +++ ocamldoc/odoc_env.ml (working copy) @@ -223,7 +223,7 @@ | Types.Mty_signature _ -> t | Types.Mty_functor (id, mt1, mt2) -> - Types.Mty_functor (id, iter mt1, iter mt2) + Types.Mty_functor (id, Misc.may_map iter mt1, iter mt2) in iter t Index: ocamldoc/odoc_html.ml =================================================================== --- ocamldoc/odoc_html.ml (revision 14301) +++ ocamldoc/odoc_html.ml (working copy) @@ -1384,7 +1384,8 @@ (** Print html code to display the type of a module parameter.. *) method html_of_module_parameter_type b m_name p = - self#html_of_module_type b m_name ~code: p.mp_type_code p.mp_type + match p.mp_type with None -> bs b "()" + | Some mty -> self#html_of_module_type b m_name ~code: p.mp_type_code mty (** Generate a file containing the module type in the given file name. *) method output_module_type in_title file mtyp = Index: ocamldoc/odoc_info.mli =================================================================== --- ocamldoc/odoc_info.mli (revision 14301) +++ ocamldoc/odoc_info.mli (working copy) @@ -434,7 +434,7 @@ and module_parameter = Odoc_module.module_parameter = { mp_name : string ; (** the name *) - mp_type : Types.module_type ; (** the type *) + mp_type : Types.module_type option ; (** the type *) mp_type_code : string ; (** the original code *) mp_kind : module_type_kind ; (** the way the parameter was built *) } Index: ocamldoc/odoc_man.ml =================================================================== --- ocamldoc/odoc_man.ml (revision 14301) +++ ocamldoc/odoc_man.ml (working copy) @@ -612,7 +612,7 @@ (fun (p, desc_opt) -> bs b ".sp\n"; bs b ("\""^p.mp_name^"\"\n"); - self#man_of_module_type b m_name p.mp_type; + Misc.may (self#man_of_module_type b m_name) p.mp_type; bs b "\n"; ( match desc_opt with Index: ocamldoc/odoc_module.ml =================================================================== --- ocamldoc/odoc_module.ml (revision 14301) +++ ocamldoc/odoc_module.ml (working copy) @@ -46,7 +46,7 @@ and module_parameter = { mp_name : string ; (** the name *) - mp_type : Types.module_type ; (** the type *) + mp_type : Types.module_type option ; (** the type *) mp_type_code : string ; (** the original code *) mp_kind : module_type_kind ; (** the way the parameter was built *) } Index: ocamldoc/odoc_print.ml =================================================================== --- ocamldoc/odoc_print.ml (revision 14301) +++ ocamldoc/odoc_print.ml (working copy) @@ -62,7 +62,7 @@ | Some s -> raise (Use_code s) ) | Types.Mty_functor (id, mt1, mt2) -> - Types.Mty_functor (id, iter mt1, iter mt2) + Types.Mty_functor (id, Misc.may_map iter mt1, iter mt2) in iter t Index: ocamldoc/odoc_sig.ml =================================================================== --- ocamldoc/odoc_sig.ml (revision 14301) +++ ocamldoc/odoc_sig.ml (working copy) @@ -1082,19 +1082,26 @@ | Parsetree.Pmty_functor (_, pmodule_type2, module_type2) -> ( - let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in - let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let loc = match pmodule_type2 with None -> Location.none + | Some pmty -> pmty.Parsetree.pmty_loc 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); match sig_module_type with Types.Mty_functor (ident, param_module_type, body_module_type) -> - let mp_kind = analyse_module_type_kind env - current_module_name pmodule_type2 param_module_type + let mp_kind = + match pmodule_type2, param_module_type with + Some pmty, Some mty -> + analyse_module_type_kind env current_module_name pmty mty + | _ -> Module_type_struct [] in let param = { mp_name = Name.from_ident ident ; - mp_type = Odoc_env.subst_module_type env param_module_type ; + mp_type = + Misc.may_map (Odoc_env.subst_module_type env) + param_module_type; mp_type_code = mp_type_code ; mp_kind = mp_kind ; } @@ -1161,17 +1168,23 @@ ( match sig_module_type with Types.Mty_functor (ident, param_module_type, body_module_type) -> - let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in - let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in + let loc = match pmodule_type2 with None -> Location.none + | Some pmty -> pmty.Parsetree.pmty_loc 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_kind = analyse_module_type_kind env - current_module_name pmodule_type2 param_module_type + let mp_kind = + match pmodule_type2, param_module_type with + Some pmty, Some mty -> + analyse_module_type_kind env current_module_name pmty mty + | _ -> Module_type_struct [] in let param = { mp_name = Name.from_ident ident ; - mp_type = Odoc_env.subst_module_type env param_module_type ; + mp_type = Misc.may_map + (Odoc_env.subst_module_type env) param_module_type ; mp_type_code = mp_type_code ; mp_kind = mp_kind ; } Index: ocamldoc/odoc_to_text.ml =================================================================== --- ocamldoc/odoc_to_text.ml (revision 14301) +++ ocamldoc/odoc_to_text.ml (working copy) @@ -428,8 +428,11 @@ List (List.map (fun (p, desc_opt) -> - [Code (p.mp_name^" : ")] @ - (self#text_of_module_type p.mp_type) @ + begin match p.mp_type with None -> [Raw ""] + | Some mty -> + [Code (p.mp_name^" : ")] @ + (self#text_of_module_type mty) + end @ (match desc_opt with None -> [] | Some t -> (Raw " ") :: t) Index: parsing/ast_helper.mli =================================================================== --- parsing/ast_helper.mli (revision 14301) +++ parsing/ast_helper.mli (working copy) @@ -145,7 +145,8 @@ val ident: ?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 -> module_type -> module_type + val functor_: ?loc:loc -> ?attrs:attrs -> + str -> module_type option -> 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 val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type @@ -159,7 +160,8 @@ 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 -> module_expr -> module_expr + val functor_: ?loc:loc -> ?attrs:attrs -> + str -> module_type option -> 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 -> module_expr val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr Index: parsing/ast_mapper.ml =================================================================== --- parsing/ast_mapper.ml (revision 14301) +++ parsing/ast_mapper.ml (working copy) @@ -161,7 +161,8 @@ | Pmty_ident s -> ident ~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) (sub.module_type sub mt1) + functor_ ~loc ~attrs (map_loc sub s) + (Misc.may_map (sub.module_type sub) mt1) (sub.module_type sub mt2) | Pmty_with (mt, l) -> with_ ~loc ~attrs (sub.module_type sub mt) @@ -213,7 +214,8 @@ | 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) (sub.module_type sub arg_ty) + functor_ ~loc ~attrs (map_loc sub arg) + (Misc.may_map (sub.module_type sub) arg_ty) (sub.module_expr sub body) | Pmod_apply (m1, m2) -> apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) Index: parsing/parser.mly =================================================================== --- parsing/parser.mly (revision 14301) +++ parsing/parser.mly (working copy) @@ -541,9 +541,13 @@ | STRUCT structure error { unclosed "struct" 1 "end" 3 } | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr - { mkmod(Pmod_functor(mkrhs $3 3, $5, $8)) } + { mkmod(Pmod_functor(mkrhs $3 3, Some $5, $8)) } + | FUNCTOR LPAREN RPAREN MINUSGREATER module_expr + { mkmod(Pmod_functor(mkrhs "()" 3, None, $5)) } | module_expr LPAREN module_expr RPAREN { mkmod(Pmod_apply($1, $3)) } + | module_expr LPAREN RPAREN + { mkmod(Pmod_apply($1, mkmod (Pmod_structure []))) } | module_expr LPAREN module_expr error { unclosed "(" 2 ")" 4 } | LPAREN module_expr COLON module_type RPAREN @@ -640,7 +644,9 @@ | COLON module_type EQUAL module_expr { mkmod(Pmod_constraint($4, $2)) } | LPAREN UIDENT COLON module_type RPAREN module_binding_body - { mkmod(Pmod_functor(mkrhs $2 2, $4, $6)) } + { mkmod(Pmod_functor(mkrhs $2 2, Some $4, $6)) } + | LPAREN RPAREN module_binding_body + { mkmod(Pmod_functor(mkrhs "()" 1, None, $3)) } ; module_bindings: module_binding { [$1] } @@ -662,7 +668,10 @@ { unclosed "sig" 1 "end" 3 } | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type %prec below_WITH - { mkmty(Pmty_functor(mkrhs $3 3, $5, $8)) } + { mkmty(Pmty_functor(mkrhs $3 3, Some $5, $8)) } + | FUNCTOR LPAREN RPAREN MINUSGREATER module_type + %prec below_WITH + { mkmty(Pmty_functor(mkrhs "()" 2, None, $5)) } | module_type WITH with_constraints { mkmty(Pmty_with($1, List.rev $3)) } | MODULE TYPE OF module_expr %prec below_LBRACKETAT @@ -724,7 +733,9 @@ COLON module_type { $2 } | LPAREN UIDENT COLON module_type RPAREN module_declaration - { mkmty(Pmty_functor(mkrhs $2 2, $4, $6)) } + { mkmty(Pmty_functor(mkrhs $2 2, Some $4, $6)) } + | LPAREN RPAREN module_declaration + { mkmty(Pmty_functor(mkrhs "()" 1, None, $3)) } ; module_rec_declarations: module_rec_declaration { [$1] } Index: parsing/parsetree.mli =================================================================== --- parsing/parsetree.mli (revision 14301) +++ parsing/parsetree.mli (working copy) @@ -543,7 +543,7 @@ (* S *) | Pmty_signature of signature (* sig ... end *) - | Pmty_functor of string loc * module_type * module_type + | Pmty_functor of string loc * module_type option * module_type (* functor(X : MT1) -> MT2 *) | Pmty_with of module_type * with_constraint list (* MT with ... *) @@ -637,7 +637,7 @@ (* X *) | Pmod_structure of structure (* struct ... end *) - | Pmod_functor of string loc * module_type * module_expr + | Pmod_functor of string loc * module_type option * module_expr (* functor(X : MT1) -> ME *) | Pmod_apply of module_expr * module_expr (* ME1(ME2) *) Index: parsing/pprintast.ml =================================================================== --- parsing/pprintast.ml (revision 14301) +++ parsing/pprintast.ml (working copy) @@ -834,7 +834,9 @@ | Pmty_signature (s) -> pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) (self#list self#signature_item ) s (* FIXME wrong indentation*) - | Pmty_functor (s, mt1, mt2) -> + | Pmty_functor (_, None, mt2) -> + pp f "@[functor () ->@ %a@]" self#module_type mt2 + | Pmty_functor (s, Some mt1, mt2) -> pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt self#module_type mt1 self#module_type mt2 | Pmty_with (mt, l) -> @@ -940,7 +942,9 @@ self#module_type mt | Pmod_ident (li) -> pp f "%a" self#longident_loc li; - | Pmod_functor (s, mt, me) -> + | Pmod_functor (_, None, me) -> + pp f "functor ()@;->@;%a" self#module_expr me + | Pmod_functor (s, Some mt, me) -> pp f "functor@ (%s@ :@ %a)@;->@;%a" s.txt self#module_type mt self#module_expr me | Pmod_apply (me1, me2) -> @@ -1025,7 +1029,8 @@ | 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 ; + if mt = None then pp f "()" + else Misc.may (pp f "(%s:%a)" s.txt self#module_type) mt; module_helper me | _ -> me in pp f "@[module %s%a@]" Index: parsing/printast.ml =================================================================== --- parsing/printast.ml (revision 14301) +++ parsing/printast.ml (working copy) @@ -576,7 +576,7 @@ signature i ppf s; | Pmty_functor (s, mt1, mt2) -> line i ppf "Pmty_functor %a\n" fmt_string_loc s; - module_type i ppf mt1; + Misc.may (module_type i ppf) mt1; module_type i ppf mt2; | Pmty_with (mt, l) -> line i ppf "Pmty_with\n"; @@ -670,7 +670,7 @@ structure i ppf s; | Pmod_functor (s, mt, me) -> line i ppf "Pmod_functor %a\n" fmt_string_loc s; - module_type i ppf mt; + Misc.may (module_type i ppf) mt; module_expr i ppf me; | Pmod_apply (me1, me2) -> line i ppf "Pmod_apply\n"; Index: tools/depend.ml =================================================================== --- tools/depend.ml (revision 14301) +++ tools/depend.ml (working copy) @@ -201,7 +201,8 @@ Pmty_ident l -> add bv l | Pmty_signature s -> add_signature bv s | Pmty_functor(id, mty1, mty2) -> - add_modtype bv mty1; add_modtype (StringSet.add id.txt bv) mty2 + Misc.may (add_modtype bv) mty1; + add_modtype (StringSet.add id.txt bv) mty2 | Pmty_with(mty, cstrl) -> add_modtype bv mty; List.iter @@ -258,7 +259,7 @@ Pmod_ident l -> addmodule bv l | Pmod_structure s -> ignore (add_structure bv s) | Pmod_functor(id, mty, modl) -> - add_modtype bv mty; + Misc.may (add_modtype bv) mty; add_module (StringSet.add id.txt bv) modl | Pmod_apply(mod1, mod2) -> add_module bv mod1; add_module bv mod2 Index: tools/tast_iter.ml =================================================================== --- tools/tast_iter.ml (revision 14301) +++ tools/tast_iter.ml (working copy) @@ -193,7 +193,7 @@ | Tmty_ident (_path, _) -> () | Tmty_signature sg -> sub # signature sg | Tmty_functor (_id, _, mtype1, mtype2) -> - sub # module_type mtype1; sub # module_type mtype2 + Misc.may (sub # module_type) mtype1; sub # module_type mtype2 | Tmty_with (mtype, list) -> sub # module_type mtype; List.iter (fun (_, _, withc) -> sub # with_constraint withc) list @@ -212,7 +212,7 @@ | Tmod_ident (_p, _) -> () | Tmod_structure st -> sub # structure st | Tmod_functor (_id, _, mtype, mexpr) -> - sub # module_type mtype; + Misc.may (sub # module_type) mtype; sub # module_expr mexpr | Tmod_apply (mexp1, mexp2, _) -> sub # module_expr mexp1; Index: tools/untypeast.ml =================================================================== --- tools/untypeast.ml (revision 14301) +++ tools/untypeast.ml (working copy) @@ -376,7 +376,7 @@ Tmty_ident (_path, lid) -> Pmty_ident (lid) | Tmty_signature sg -> Pmty_signature (untype_signature sg) | Tmty_functor (_id, name, mtype1, mtype2) -> - Pmty_functor (name, untype_module_type mtype1, + Pmty_functor (name, Misc.may_map untype_module_type mtype1, untype_module_type mtype2) | Tmty_with (mtype, list) -> Pmty_with (untype_module_type mtype, @@ -405,7 +405,7 @@ Tmod_ident (_p, lid) -> Pmod_ident (lid) | Tmod_structure st -> Pmod_structure (untype_structure st) | Tmod_functor (_id, name, mtype, mexpr) -> - Pmod_functor (name, untype_module_type mtype, + Pmod_functor (name, Misc.may_map untype_module_type mtype, untype_module_expr mexpr) | Tmod_apply (mexp1, mexp2, _) -> Pmod_apply (untype_module_expr mexp1, untype_module_expr mexp2) Index: typing/btype.ml =================================================================== --- typing/btype.ml (revision 14301) +++ typing/btype.ml (working copy) @@ -56,6 +56,9 @@ let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false let dummy_method = "*dummy method*" +let default_mty = function + Some mty -> mty + | None -> Mty_signature [] (**** Representative of a type ****) Index: typing/btype.mli =================================================================== --- typing/btype.mli (revision 14301) +++ typing/btype.mli (working copy) @@ -39,9 +39,12 @@ (* Return a fresh marked generic variable *) *) +(**** Types ****) + val is_Tvar: type_expr -> bool val is_Tunivar: 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. *) Index: typing/env.ml =================================================================== --- typing/env.ml (revision 14301) +++ typing/env.ml (working copy) @@ -201,7 +201,7 @@ and functor_components = { fcomp_param: Ident.t; (* Formal parameter *) - fcomp_arg: module_type; (* Argument signature *) + fcomp_arg: module_type option; (* Argument signature *) fcomp_res: module_type; (* Result signature *) fcomp_env: t; (* Environment in which the result signature makes sense *) fcomp_subst: Subst.t; (* Prefixing substitution for the result signature *) @@ -522,7 +522,7 @@ let (p2, {md_type=mty2}) = lookup_module l2 env in begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> - !check_modtype_inclusion env mty2 p2 f.fcomp_arg; + Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg; (Papply(p1, p2), !components_of_functor_appl' f p1 p2) | Structure_comps c -> raise Not_found @@ -562,7 +562,7 @@ let p = Papply(p1, p2) in begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> - !check_modtype_inclusion env mty2 p2 f.fcomp_arg; + Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg; let mty = Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst) f.fcomp_res in @@ -1120,7 +1120,7 @@ fcomp_param = param; (* fcomp_arg must be prefixed eagerly, because it is interpreted in the outer environment, not in env *) - fcomp_arg = Subst.modtype sub ty_arg; + fcomp_arg = may_map (Subst.modtype sub) ty_arg; (* fcomp_res is prefixed lazily, because it is interpreted in env *) fcomp_res = ty_res; fcomp_env = env; Index: typing/includemod.ml =================================================================== --- typing/includemod.ml (revision 14301) +++ typing/includemod.ml (working copy) @@ -168,7 +168,13 @@ try_modtypes2 env cxt mty1 (Subst.modtype subst mty2) | (Mty_signature sig1, Mty_signature sig2) -> signatures env cxt subst sig1 sig2 - | (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) -> + | (Mty_functor(param1, None, res1), Mty_functor(param2, None, res2)) -> + begin match modtypes env (Body param1::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)) -> let arg2' = Subst.modtype subst arg2 in let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in let cc_res = Index: typing/mtype.ml =================================================================== --- typing/mtype.ml (revision 14301) +++ typing/mtype.ml (working copy) @@ -34,7 +34,8 @@ match scrape env mty with Mty_signature sg -> Mty_signature(strengthen_sig env sg p) - | Mty_functor(param, arg, res) when !Clflags.applicative_functors -> + | Mty_functor(param, arg, res) + when !Clflags.applicative_functors && Ident.name param <> "*" -> Mty_functor(param, arg, strengthen env res (Papply(p, Pident param))) | mty -> mty @@ -105,8 +106,9 @@ | Mty_functor(param, arg, res) -> let var_inv = match va with Co -> Contra | Contra -> Co | Strict -> Strict in - Mty_functor(param, nondep_mty env var_inv arg, - nondep_mty (Env.add_module param arg env) va res) + Mty_functor(param, Misc.may_map (nondep_mty env var_inv) arg, + nondep_mty + (Env.add_module param (Btype.default_mty arg) env) va res) and nondep_sig env va = function [] -> [] @@ -228,3 +230,34 @@ no_code_needed_sig env rem | (Sig_exception _ | Sig_class _) :: rem -> false + + +(* Check whether a module type may return types *) + +let rec contains_type env = function + Mty_ident path -> + (try Misc.may (contains_type env) (Env.find_modtype path env).mtd_type + with Not_found -> raise Exit) + | Mty_signature sg -> + contains_type_sig env sg + | Mty_functor (_, _, body) -> + contains_type env body + +and contains_type_sig env = List.iter (contains_type_item env) + +and contains_type_item env = function + Sig_type (_,({type_manifest = None} | + {type_kind = Type_abstract; type_private = Private}),_) + | Sig_modtype _ -> + raise Exit + | Sig_module (_, {md_type = mty}, _) -> + contains_type env mty + | Sig_value _ + | Sig_type _ + | Sig_exception _ + | Sig_class _ + | Sig_class_type _ -> + () + +let contains_type env mty = + try contains_type env mty; false with Exit -> true Index: typing/mtype.mli =================================================================== --- typing/mtype.mli (revision 14301) +++ typing/mtype.mli (working copy) @@ -36,3 +36,4 @@ val enrich_modtype: Env.t -> Path.t -> module_type -> module_type val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration val type_paths: Env.t -> Path.t -> module_type -> Path.t list +val contains_type: Env.t -> module_type -> bool Index: typing/oprint.ml =================================================================== --- typing/oprint.ml (revision 14301) +++ typing/oprint.ml (working copy) @@ -344,7 +344,9 @@ let rec print_out_module_type ppf = function Omty_abstract -> () - | Omty_functor (name, mty_arg, mty_res) -> + | Omty_functor (_, None, mty_res) -> + fprintf ppf "@[<2>functor@ () ->@ %a@]" print_out_module_type mty_res + | Omty_functor (name, Some mty_arg, mty_res) -> fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name print_out_module_type mty_arg print_out_module_type mty_res | Omty_ident id -> fprintf ppf "%a" print_ident id Index: typing/outcometree.mli =================================================================== --- typing/outcometree.mli (revision 14301) +++ typing/outcometree.mli (working copy) @@ -75,7 +75,7 @@ type out_module_type = | Omty_abstract - | Omty_functor of string * out_module_type * out_module_type + | Omty_functor of string * out_module_type option * out_module_type | Omty_ident of out_ident | Omty_signature of out_sig_item list and out_sig_item = Index: typing/printtyp.ml =================================================================== --- typing/printtyp.ml (revision 14301) +++ typing/printtyp.ml (working copy) @@ -1116,9 +1116,12 @@ | Mty_signature sg -> Omty_signature (tree_of_signature sg) | Mty_functor(param, ty_arg, ty_res) -> - Omty_functor - (Ident.name param, tree_of_modtype ty_arg, - wrap_env (Env.add_module param ty_arg) tree_of_modtype ty_res) + let res = + match ty_arg with None -> tree_of_modtype ty_res + | Some mty -> + wrap_env (Env.add_module param mty) tree_of_modtype ty_res + in + Omty_functor (Ident.name param, may_map tree_of_modtype ty_arg, res) and tree_of_signature sg = wrap_env (fun env -> env) (tree_of_signature_rec !printing_env) sg Index: typing/printtyped.ml =================================================================== --- typing/printtyped.ml (revision 14301) +++ typing/printtyped.ml (working copy) @@ -562,7 +562,7 @@ signature i ppf s; | Tmty_functor (s, _, mt1, mt2) -> line i ppf "Pmty_functor \"%a\"\n" fmt_ident s; - module_type i ppf mt1; + Misc.may (module_type i ppf) mt1; module_type i ppf mt2; | Tmty_with (mt, l) -> line i ppf "Pmty_with\n"; @@ -651,7 +651,7 @@ structure i ppf s; | Tmod_functor (s, _, mt, me) -> line i ppf "Pmod_functor \"%a\"\n" fmt_ident s; - module_type i ppf mt; + Misc.may (module_type i ppf) mt; module_expr i ppf me; | Tmod_apply (me1, me2, _) -> line i ppf "Pmod_apply\n"; Index: typing/subst.ml =================================================================== --- typing/subst.ml (revision 14301) +++ typing/subst.ml (working copy) @@ -327,8 +327,8 @@ Mty_signature(signature s sg) | Mty_functor(id, arg, res) -> let id' = Ident.rename id in - Mty_functor(id', modtype s arg, - modtype (add_module id (Pident id') s) res) + Mty_functor(id', may_map (modtype s) arg, + modtype (add_module id (Pident id') s) res) and signature s sg = (* Components of signature may be mutually recursive (e.g. type declarations Index: typing/typedtree.ml =================================================================== --- typing/typedtree.ml (revision 14301) +++ typing/typedtree.ml (working copy) @@ -187,7 +187,7 @@ 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 * module_expr + | Tmod_functor of Ident.t * string loc * module_type option * module_expr | Tmod_apply of module_expr * module_expr * module_coercion | Tmod_constraint of module_expr * Types.module_type * module_type_constraint * module_coercion @@ -253,7 +253,7 @@ 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 * module_type + | Tmty_functor of Ident.t * string loc * module_type option * module_type | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list | Tmty_typeof of module_expr Index: typing/typedtree.mli =================================================================== --- typing/typedtree.mli (revision 14301) +++ typing/typedtree.mli (working copy) @@ -186,7 +186,7 @@ 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 * module_expr + | Tmod_functor of Ident.t * string loc * module_type option * module_expr | Tmod_apply of module_expr * module_expr * module_coercion | Tmod_constraint of module_expr * Types.module_type * module_type_constraint * module_coercion @@ -252,7 +252,7 @@ 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 * module_type + | Tmty_functor of Ident.t * string loc * module_type option * module_type | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list | Tmty_typeof of module_expr Index: typing/typedtreeIter.ml =================================================================== --- typing/typedtreeIter.ml (revision 14301) +++ typing/typedtreeIter.ml (working copy) @@ -383,7 +383,7 @@ Tmty_ident (path, _) -> () | Tmty_signature sg -> iter_signature sg | Tmty_functor (id, _, mtype1, mtype2) -> - iter_module_type mtype1; iter_module_type mtype2 + Misc.may iter_module_type mtype1; iter_module_type mtype2 | Tmty_with (mtype, list) -> iter_module_type mtype; List.iter (fun (path, _, withc) -> @@ -412,7 +412,7 @@ Tmod_ident (p, _) -> () | Tmod_structure st -> iter_structure st | Tmod_functor (id, _, mtype, mexpr) -> - iter_module_type mtype; + Misc.may iter_module_type mtype; iter_module_expr mexpr | Tmod_apply (mexp1, mexp2, _) -> iter_module_expr mexp1; Index: typing/typedtreeMap.ml =================================================================== --- typing/typedtreeMap.ml (revision 14301) +++ typing/typedtreeMap.ml (working copy) @@ -426,7 +426,7 @@ Tmty_ident (path, lid) -> mty.mty_desc | Tmty_signature sg -> Tmty_signature (map_signature sg) | Tmty_functor (id, name, mtype1, mtype2) -> - Tmty_functor (id, name, map_module_type mtype1, + Tmty_functor (id, name, Misc.may_map map_module_type mtype1, map_module_type mtype2) | Tmty_with (mtype, list) -> Tmty_with (map_module_type mtype, @@ -456,7 +456,7 @@ Tmod_ident (p, lid) -> mexpr.mod_desc | Tmod_structure st -> Tmod_structure (map_structure st) | Tmod_functor (id, name, mtype, mexpr) -> - Tmod_functor (id, name, map_module_type mtype, + Tmod_functor (id, name, Misc.may_map map_module_type mtype, map_module_expr mexpr) | Tmod_apply (mexp1, mexp2, coercion) -> Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion) Index: typing/typemod.ml =================================================================== --- typing/typemod.ml (revision 14301) +++ typing/typemod.ml (working copy) @@ -39,6 +39,7 @@ | Scoping_pack of Longident.t * type_expr | Extension of string | Recursive_module_require_explicit_type + | Apply_generative exception Error of Location.t * Env.t * error @@ -299,8 +300,9 @@ | Pmty_signature ssg -> Mty_signature(approx_sig env ssg) | Pmty_functor(param, sarg, sres) -> - let arg = approx_modtype env sarg in - let (id, newenv) = Env.enter_module param.txt arg env in + let arg = may_map (approx_modtype env) sarg in + let (id, newenv) = + Env.enter_module param.txt (Btype.default_mty arg) env in let res = approx_modtype newenv sres in Mty_functor(id, arg, res) | Pmty_with(sbody, constraints) -> @@ -472,11 +474,13 @@ mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc smty.pmty_attributes | Pmty_functor(param, sarg, sres) -> - let arg = transl_modtype env sarg in - let (id, newenv) = Env.enter_module param.txt arg.mty_type env in + let arg = Misc.may_map (transl_modtype env) sarg in + let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in + let (id, newenv) = + Env.enter_module param.txt (Btype.default_mty ty_arg) env in let res = transl_modtype newenv sres in mkmty (Tmty_functor (id, param, arg, res)) - (Mty_functor(id, arg.mty_type, res.mty_type)) env loc + (Mty_functor(id, ty_arg, res.mty_type)) env loc smty.pmty_attributes | Pmty_with(sbody, constraints) -> let body = transl_modtype env sbody in @@ -949,11 +953,14 @@ mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc } | Pmod_functor(name, smty, sbody) -> - let mty = transl_modtype env smty in - let (id, newenv) = Env.enter_module name.txt mty.mty_type env in - let body = type_module sttn true None newenv sbody in + let mty = may_map (transl_modtype env) smty in + let ty_arg = may_map (fun m -> m.mty_type) mty in + let (id, newenv), funct_body = + match ty_arg with None -> (Ident.create "*", env), false + | Some mty -> Env.enter_module name.txt mty env, 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, mty.mty_type, body.mod_type); + mod_type = Mty_functor(id, ty_arg, body.mod_type); mod_env = env; mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc } @@ -964,6 +971,14 @@ type_module (sttn && path <> None) funct_body None env sfunct in begin match Mtype.scrape env funct.mod_type with Mty_functor(param, mty_param, mty_res) as mty_functor -> + let generative, mty_param = + (mty_param = None, Btype.default_mty mty_param) in + if generative then begin + if sarg.pmod_desc <> Pmod_structure [] then + raise (Error (sfunct.pmod_loc, env, Apply_generative)); + if funct_body && Mtype.contains_type env funct.mod_type then + raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); + end; let coercion = try Includemod.modtypes env arg.mod_type mty_param @@ -975,6 +990,7 @@ Subst.modtype (Subst.add_module param path Subst.identity) mty_res | None -> + if generative then mty_res else try Mtype.nondep_supertype (Env.add_module param arg.mod_type env) param mty_res @@ -999,8 +1015,6 @@ } | Pmod_unpack sexp -> - if funct_body then - raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); if !Clflags.principal then Ctype.begin_def (); let exp = Typecore.type_exp env sexp in if !Clflags.principal then begin @@ -1025,6 +1039,8 @@ | _ -> raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type)) in + if funct_body && Mtype.contains_type env mty then + raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); rm { mod_desc = Tmod_unpack(exp, mty); mod_type = mty; mod_env = env; @@ -1549,7 +1565,8 @@ Location.print_filename intf_name | Not_allowed_in_functor_body -> fprintf ppf - "This kind of expression is not allowed within the body of a functor." + "@[This expression creates fresh types.@ %s@]" + "It is not allowed inside applicative functors." | With_need_typeconstr -> fprintf ppf "Only type constructors with identical parameters can be substituted." @@ -1570,6 +1587,8 @@ fprintf ppf "Uninterpreted extension '%s'." s | Recursive_module_require_explicit_type -> fprintf ppf "Recursive modules require an explicit module type." + | Apply_generative -> + fprintf ppf "This is a generative functor. It can only be applied to ()" let report_error env ppf err = Printtyp.wrap_printing_env env (fun () -> report_error ppf err) Index: typing/typemod.mli =================================================================== --- typing/typemod.mli (revision 14301) +++ typing/typemod.mli (working copy) @@ -60,6 +60,7 @@ | Scoping_pack of Longident.t * type_expr | Extension of string | Recursive_module_require_explicit_type + | Apply_generative exception Error of Location.t * Env.t * error Index: typing/types.ml =================================================================== --- typing/types.ml (revision 14301) +++ typing/types.ml (working copy) @@ -264,7 +264,7 @@ type module_type = Mty_ident of Path.t | Mty_signature of signature - | Mty_functor of Ident.t * module_type * module_type + | Mty_functor of Ident.t * module_type option * module_type and signature = signature_item list Index: typing/types.mli =================================================================== --- typing/types.mli (revision 14301) +++ typing/types.mli (working copy) @@ -251,7 +251,7 @@ type module_type = Mty_ident of Path.t | Mty_signature of signature - | Mty_functor of Ident.t * module_type * module_type + | Mty_functor of Ident.t * module_type option * module_type and signature = signature_item list