merge generative functors

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14365 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Changes

@@ -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)

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 = match pmodule_type with None -> Location.none
-           let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
+                     | 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
+           let mp_kind =
-               current_module_name pmodule_type mtyp.mty_type
+             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 ;
              }

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
 

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 =

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 *)
       }

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

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 *)
   }

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
 

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 = match pmodule_type2 with None -> Location.none
-           let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
+                     | 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
+               let mp_kind =
-                   current_module_name pmodule_type2 param_module_type
+                 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 = match pmodule_type2 with None -> Location.none
-               let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
+                     | 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
+               let mp_kind =
-                   current_module_name pmodule_type2 param_module_type
+                 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 ;
                  }

ocamldoc/odoc_to_text.ml

@@ -428,8 +428,11 @@ class virtual to_text =
             List
               (List.map
                  (fun (p, desc_opt) ->
-                   [Code (p.mp_name^" : ")] @
+                   begin match p.mp_type with None -> [Raw ""]
-                   (self#text_of_module_type p.mp_type) @
+                   | Some mty ->
+                       [Code (p.mp_name^" : ")] @
+                       (self#text_of_module_type mty)
+                   end @
                    (match desc_opt with
                      None -> []
                    | Some t -> (Raw " ") :: t)

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

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)

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] }

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) *)

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@]"

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";

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 *)

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
+# 

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

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;

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)

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 ****)
 

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. *)

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;

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 =

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,
+        Mty_functor(param, Misc.may_map (nondep_mty env var_inv) arg,
-                     nondep_mty (Env.add_module param arg env) va res)
+                    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

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

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

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 =

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
+      let res =
-        (Ident.name param, tree_of_modtype ty_arg,
+        match ty_arg with None -> tree_of_modtype ty_res
-         wrap_env (Env.add_module param ty_arg) 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

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";

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,
+      Mty_functor(id', may_map (modtype s) arg,
-                        modtype (add_module id (Pident id') s) res)
+                       modtype (add_module id (Pident id') s) res)
 
 and signature s sg =
   (* Components of signature may be mutually recursive (e.g. type declarations

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
 

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
 

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;

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)

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 arg = may_map (approx_modtype env) sarg in
-      let (id, newenv) = Env.enter_module param.txt arg env 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 arg = Misc.may_map (transl_modtype env) sarg in
-      let (id, newenv) = Env.enter_module param.txt arg.mty_type env 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 mty = may_map (transl_modtype env) smty in
-      let (id, newenv) = Env.enter_module name.txt mty.mty_type env in
+      let ty_arg = may_map (fun m -> m.mty_type) mty in
-      let body = type_module sttn true None newenv sbody 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)

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
 

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
 

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