diff options
43 files changed, 269 insertions, 83 deletions
@@ -13,9 +13,13 @@ Type system: * Keep typing of pattern cases independent in principal mode (i.e. information from previous cases is no longer used when typing patterns; cf. PR6235' in typing-warnings/records.ml) +- Allow opening a first-class module or applying a generative functor + in the body of a generative functor. Allow it also in the body of + an applicative functor if no types are created Language features: - Attributes and extension nodes +- Generative functors Compilers: - Experimental native code generator for AArch64 (ARM 64 bits) diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 96bd4ced6..56df7508f 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 2e31e4c6e..5f151ef18 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 88da8bab4..03b7d3d21 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 6f0a8d572..18e474a79 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -1606,18 +1606,25 @@ module Analyser = | (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 ; } diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index 5fd1f0508..d55ace84c 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -223,7 +223,7 @@ let subst_module_type env t = | 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 diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index db7d82ce1..3bee9838b 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -1384,7 +1384,8 @@ class html = (** 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 "<code>()</code>" + | 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 = diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli index bf4d33b6f..76e28df64 100644 --- a/ocamldoc/odoc_info.mli +++ b/ocamldoc/odoc_info.mli @@ -434,7 +434,7 @@ module Module : 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 *) } diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index 808136968..8a252d631 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -637,7 +637,7 @@ class man = (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 diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml index 216f1cfb3..b1bedfa77 100644 --- a/ocamldoc/odoc_module.ml +++ b/ocamldoc/odoc_module.ml @@ -46,7 +46,7 @@ and module_alias = { 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 *) } diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml index aa6dea128..d6b56f395 100644 --- a/ocamldoc/odoc_print.ml +++ b/ocamldoc/odoc_print.ml @@ -62,7 +62,7 @@ let simpl_module_type ?code t = | 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 diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 422b35507..93f0193e5 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -1076,19 +1076,26 @@ module Analyser = | 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 ; } @@ -1155,17 +1162,23 @@ module Analyser = ( 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 ; } diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml index 7b08417e7..c91387570 100644 --- a/ocamldoc/odoc_to_text.ml +++ b/ocamldoc/odoc_to_text.ml @@ -428,8 +428,11 @@ class virtual to_text = 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) diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 995b1ca64..441e420d1 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -145,7 +145,8 @@ module Mty: 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 @@ 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 -> 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 diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index f6edb55f4..dac9cbe28 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -161,7 +161,8 @@ module MT = struct | 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 @@ module M = struct | 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) diff --git a/parsing/parser.mly b/parsing/parser.mly index f08afc21d..7f23730f3 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -541,9 +541,13 @@ module_expr: | 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 @@ module_binding_body: | 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 @@ module_type: { 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 @@ module_declaration: 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] } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index df0dd47ab..57f4ae7f3 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -543,7 +543,7 @@ and module_type_desc = (* 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 @@ and module_expr_desc = (* 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) *) diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index cf218f2a8..050c9fe1c 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -834,7 +834,9 @@ class printer ()= object(self:'self) | Pmty_signature (s) -> pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *) (self#list self#signature_item ) s (* FIXME wrong indentation*) - | Pmty_functor (s, mt1, mt2) -> + | Pmty_functor (_, None, mt2) -> + pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2 + | Pmty_functor (s, Some mt1, mt2) -> pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt self#module_type mt1 self#module_type mt2 | Pmty_with (mt, l) -> @@ -940,7 +942,9 @@ class printer ()= object(self:'self) 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 @@ class printer ()= object(self:'self) | 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 "@[<hov2>module %s%a@]" diff --git a/parsing/printast.ml b/parsing/printast.ml index 7c6fd9a22..5f396e784 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -577,7 +577,7 @@ and module_type i ppf x = 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"; @@ -671,7 +671,7 @@ and module_expr i ppf x = 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"; diff --git a/testsuite/tests/typing-modules/generative.ml b/testsuite/tests/typing-modules/generative.ml new file mode 100644 index 000000000..8463c0a8c --- /dev/null +++ b/testsuite/tests/typing-modules/generative.ml @@ -0,0 +1,26 @@ +(* Using generative functors *) + +(* Without type *) +module type S = sig val x : int end;; +let v = (module struct let x = 3 end : S);; +module F() = (val v);; (* ok *) +module G (X : sig end) : S = F ();; (* ok *) +module H (X : sig end) = (val v);; (* ok *) + +(* With type *) +module type S = sig type t val x : t end;; +let v = (module struct type t = int let x = 3 end : S);; +module F() = (val v);; (* ok *) +module G (X : sig end) : S = F ();; (* fail *) +module H() = F();; (* ok *) + +(* Alias *) +module U = struct end;; +module M = F(struct end);; (* ok *) +module M = F(U);; (* fail *) + +(* Cannot coerce between applicative and generative *) +module F1 (X : sig end) = struct end;; +module F2 : functor () -> sig end = F1;; (* fail *) +module F3 () = struct end;; +module F4 : functor (X : sig end) -> sig end = F3;; (* fail *) diff --git a/testsuite/tests/typing-modules/generative.ml.reference b/testsuite/tests/typing-modules/generative.ml.reference new file mode 100644 index 000000000..d9d0f1a9c --- /dev/null +++ b/testsuite/tests/typing-modules/generative.ml.reference @@ -0,0 +1,40 @@ + +# module type S = sig val x : int end +# val v : (module S) = <module> +# module F : functor () -> S +# module G : functor (X : sig end) -> S +# module H : functor (X : sig end) -> S +# module type S = sig type t val x : t end +# val v : (module S) = <module> +# module F : functor () -> S +# Characters 29-33: + module G (X : sig end) : S = F ();; (* fail *) + ^^^^ +Error: This expression creates fresh types. + It is not allowed inside applicative functors. +# module H : functor () -> S +# module U : sig end +# module M : S +# Characters 11-12: + module M = F(U);; (* fail *) + ^ +Error: This is a generative functor. It can only be applied to () +# module F1 : functor (X : sig end) -> sig end +# Characters 36-38: + module F2 : functor () -> sig end = F1;; (* fail *) + ^^ +Error: Signature mismatch: + Modules do not match: + functor (X : sig end) -> sig end + is not included in + functor () -> sig end +# module F3 : functor () -> sig end +# Characters 47-49: + module F4 : functor (X : sig end) -> sig end = F3;; (* fail *) + ^^ +Error: Signature mismatch: + Modules do not match: + functor () -> sig end + is not included in + functor (X : sig end) -> sig end +# diff --git a/tools/depend.ml b/tools/depend.ml index a1b851e24..4c3a94320 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -201,7 +201,8 @@ and add_modtype bv mty = 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 @@ and add_module bv modl = 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 diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml index 776e33522..b6a27a958 100644 --- a/tools/tast_iter.ml +++ b/tools/tast_iter.ml @@ -193,7 +193,7 @@ let module_type sub mty = | 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 @@ let module_expr sub mexpr = | 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; diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 75f7ebdec..74ffb92c9 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -376,7 +376,7 @@ and untype_module_type mty = 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 @@ and untype_module_expr mexpr = 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) diff --git a/typing/btype.ml b/typing/btype.ml index c76639d56..e27045582 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -56,6 +56,9 @@ let is_Tvar = function {desc=Tvar _} -> true | _ -> false 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 ****) diff --git a/typing/btype.mli b/typing/btype.mli index 88019ff29..290c8f02c 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -39,9 +39,12 @@ val newmarkedgenvar: unit -> type_expr (* 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. *) diff --git a/typing/env.ml b/typing/env.ml index beee7a17d..6cfd62c4e 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -201,7 +201,7 @@ and structure_components = { 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 rec lookup_module_descr lid env = 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 @@ and lookup_module lid env : Path.t * module_declaration = 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 @@ and components_of_module_maker (env, sub, path, mty) = 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; diff --git a/typing/includemod.ml b/typing/includemod.ml index 11caabe2f..321c0b1ac 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -168,7 +168,13 @@ and try_modtypes env cxt subst mty1 mty2 = 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 = diff --git a/typing/mtype.ml b/typing/mtype.ml index 53850d962..67f912585 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -34,7 +34,8 @@ let rec strengthen env mty p = 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 @@ let nondep_supertype env mid mty = | 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 @@ and no_code_needed_sig env sg = 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 diff --git a/typing/mtype.mli b/typing/mtype.mli index fe824731a..9afaed312 100644 --- a/typing/mtype.mli +++ b/typing/mtype.mli @@ -36,3 +36,4 @@ val no_code_needed_sig: Env.t -> signature -> bool 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 diff --git a/typing/oprint.ml b/typing/oprint.ml index 7475c1243..8414fe84f 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -344,7 +344,9 @@ let out_signature = ref (fun _ -> failwith "Oprint.out_signature") 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 diff --git a/typing/outcometree.mli b/typing/outcometree.mli index 19fc1c744..2a725a009 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -75,7 +75,7 @@ and out_class_sig_item = 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 = diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 1f7e50198..62be2486d 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1116,9 +1116,12 @@ let rec tree_of_modtype = function | 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 diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 7861361b8..e7e0d30bb 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -562,7 +562,7 @@ and module_type i ppf x = 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 @@ and module_expr i ppf x = 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"; diff --git a/typing/subst.ml b/typing/subst.ml index 6acf9323d..a8a25de07 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -327,8 +327,8 @@ let rec modtype s = function 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 diff --git a/typing/typedtree.ml b/typing/typedtree.ml index d923084f8..c271f5706 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -187,7 +187,7 @@ and module_type_constraint = 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 = 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 diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 3bb4d7177..9daf448e9 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -186,7 +186,7 @@ and module_type_constraint = 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 = 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 diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index edb558798..9be5ed9b1 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -383,7 +383,7 @@ module MakeIterator(Iter : IteratorArgument) : sig 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 @@ module MakeIterator(Iter : IteratorArgument) : sig 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; diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index 5c9229950..669fd2eac 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -426,7 +426,7 @@ module MakeMap(Map : MapArgument) = struct 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 @@ module MakeMap(Map : MapArgument) = struct 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) diff --git a/typing/typemod.ml b/typing/typemod.ml index ec63ae8ca..fc380610b 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -39,6 +39,7 @@ type error = | 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 @@ let rec approx_modtype env smty = | 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 @@ let rec transl_modtype env smty = 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 @@ let rec type_module sttn funct_body anchor env smod = 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 @@ let rec type_module sttn funct_body anchor env smod = 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 @@ let rec type_module sttn funct_body anchor env smod = 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 @@ let rec type_module sttn funct_body anchor env smod = } | 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 @@ let rec type_module sttn funct_body anchor env smod = | _ -> 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 @@ let report_error ppf = function 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 @@ let report_error ppf = function 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) diff --git a/typing/typemod.mli b/typing/typemod.mli index 20868d33f..051a28360 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -60,6 +60,7 @@ type error = | 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 diff --git a/typing/types.ml b/typing/types.ml index 20fa3836e..b28801c2a 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -264,7 +264,7 @@ type class_type_declaration = 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 diff --git a/typing/types.mli b/typing/types.mli index 30ea7a8e1..c38c928a8 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -251,7 +251,7 @@ type class_type_declaration = 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 |