Source

compiler-libs-hack / ocaml / experimental / garrigue / impure-functors.diff

Full commit
Index: parsing/pprintast.ml
===================================================================
--- parsing/pprintast.ml	(revision 13286)
+++ parsing/pprintast.ml	(working copy)
@@ -821,6 +821,8 @@
     | 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 ({txt="*"}, mt1, mt2) ->
+        pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2 
     | Pmty_functor (s, mt1, mt2) ->
         pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
           self#module_type mt1  self#module_type mt2 
@@ -922,6 +924,8 @@
           self#module_type mt
     | Pmod_ident (li) ->
         pp f "%a" self#longident_loc li;
+    | Pmod_functor ({txt="*"}, mt, me) ->
+        pp f "functor ()@;->@;%a" self#module_expr me
     | Pmod_functor (s, mt, me) ->
         pp f "functor@ (%s@ :@ %a)@;->@;%a"
           s.txt  self#module_type mt  self#module_expr me
@@ -1001,7 +1005,8 @@
     | Pstr_module (s, me) ->
         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 s.txt = "*" then pp f "()"
+            else pp f "(%s:%a)"  s.txt  self#module_type mt ;
             module_helper me
         | _ -> me in 
         pp f "@[<hov2>module %s%a@]"
Index: parsing/parser.mly
===================================================================
--- parsing/parser.mly	(revision 13286)
+++ parsing/parser.mly	(working copy)
@@ -532,8 +532,12 @@
       { unclosed "struct" 1 "end" 3 }
   | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr
       { mkmod(Pmod_functor(mkrhs $3 3, $5, $8)) }
+  | FUNCTOR LPAREN RPAREN MINUSGREATER module_expr
+      { mkmod(Pmod_functor(mkrhs "*" 3, mkmty (Pmty_signature []), $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
@@ -610,6 +614,8 @@
       { mkmod(Pmod_constraint($4, $2)) }
   | LPAREN UIDENT COLON module_type RPAREN module_binding
       { mkmod(Pmod_functor(mkrhs $2 2, $4, $6)) }
+  | LPAREN RPAREN module_binding
+      { mkmod(Pmod_functor(mkrhs "*" 1, mkmty(Pmty_signature []), $3)) }
 ;
 module_rec_bindings:
     module_rec_binding                            { [$1] }
@@ -631,6 +637,9 @@
   | FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type
       %prec below_WITH
       { mkmty(Pmty_functor(mkrhs $3 3, $5, $8)) }
+  | FUNCTOR LPAREN RPAREN MINUSGREATER module_type
+      %prec below_WITH
+      { mkmty(Pmty_functor(mkrhs "*" 2, mkmty(Pmty_signature []), $5)) }
   | module_type WITH with_constraints
       { mkmty(Pmty_with($1, List.rev $3)) }
   | MODULE TYPE OF module_expr
@@ -679,6 +688,8 @@
       { $2 }
   | LPAREN UIDENT COLON module_type RPAREN module_declaration
       { mkmty(Pmty_functor(mkrhs $2 2, $4, $6)) }
+  | LPAREN RPAREN module_declaration
+      { mkmty(Pmty_functor(mkrhs "*" 1, mkmty (Pmty_signature []), $3)) }
 ;
 module_rec_declarations:
     module_rec_declaration                              { [$1] }
Index: typing/typemod.ml
===================================================================
--- typing/typemod.ml	(revision 13286)
+++ typing/typemod.ml	(working copy)
@@ -37,6 +37,7 @@
   | Not_a_packed_module of type_expr
   | Incomplete_packed_module of type_expr
   | Scoping_pack of Longident.t * type_expr
+  | Apply_impure
 
 exception Error of Location.t * error
 
@@ -832,8 +833,10 @@
            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 (id, newenv), funct_body =
+	if name.txt = "*" then (Ident.create "*", env), false else 
+	Env.enter_module name.txt mty.mty_type 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_env = env;
@@ -845,6 +848,13 @@
         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 impure = Ident.name param = "*" in
+          if impure then begin
+            if sarg.pmod_desc <> Pmod_structure [] then
+              raise (Error (sfunct.pmod_loc, Apply_impure));
+            if funct_body then
+              raise (Error (smod.pmod_loc, Not_allowed_in_functor_body));
+          end;
           let coercion =
             try
               Includemod.modtypes env arg.mod_type mty_param
@@ -856,6 +866,7 @@
                 Subst.modtype (Subst.add_module param path Subst.identity)
                               mty_res
             | None ->
+                if impure then mty_res else
                 try
                   Mtype.nondep_supertype
                     (Env.add_module param arg.mod_type env) param mty_res
@@ -1429,7 +1440,7 @@
         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 kind of expression is only allowed inside impure functors."
   | With_need_typeconstr ->
       fprintf ppf
         "Only type constructors with identical parameters can be substituted."
@@ -1446,3 +1457,5 @@
         "The type %a in this module cannot be exported.@ " longident lid;
       fprintf ppf
         "Its type contains local dependencies:@ %a" type_expr ty
+  | Apply_impure ->
+      fprintf ppf "This functor is impure. It can only be applied to ()"
Index: typing/typemod.mli
===================================================================
--- typing/typemod.mli	(revision 13286)
+++ typing/typemod.mli	(working copy)
@@ -60,6 +60,7 @@
   | Not_a_packed_module of type_expr
   | Incomplete_packed_module of type_expr
   | Scoping_pack of Longident.t * type_expr
+  | Apply_impure
 
 exception Error of Location.t * error
 
Index: typing/oprint.ml
===================================================================
--- typing/oprint.ml	(revision 13286)
+++ typing/oprint.ml	(working copy)
@@ -343,6 +343,8 @@
 let rec print_out_module_type ppf =
   function
     Omty_abstract -> ()
+  | Omty_functor ("*", _, mty_res) ->
+      fprintf ppf "@[<2>functor@ () ->@ %a@]" print_out_module_type mty_res
   | Omty_functor (name, mty_arg, mty_res) ->
       fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
         print_out_module_type mty_arg print_out_module_type mty_res
Index: typing/includemod.ml
===================================================================
--- typing/includemod.ml	(revision 13286)
+++ typing/includemod.ml	(working copy)
@@ -35,6 +35,7 @@
       Ident.t * class_declaration * class_declaration *
       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
+  | Impure_functor
 
 type pos =
     Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
@@ -153,6 +154,8 @@
   | (Mty_signature sig1, Mty_signature sig2) ->
       signatures env cxt subst sig1 sig2
   | (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) ->
+      if Ident.name param1 = "*" && Ident.name param2 <> "*" then
+        raise (Error [cxt, Impure_functor]);
       let arg2' = Subst.modtype subst arg2 in
       let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
       let cc_res =
@@ -404,6 +407,8 @@
       Includeclass.report_error reason
   | Unbound_modtype_path path ->
       fprintf ppf "Unbound module type %a" Printtyp.path path
+  | Impure_functor ->
+      fprintf ppf "An impure functor cannot be made applicative"
 
 let rec context ppf = function
     Module id :: rem ->
Index: typing/includemod.mli
===================================================================
--- typing/includemod.mli	(revision 13286)
+++ typing/includemod.mli	(working copy)
@@ -40,6 +40,7 @@
       Ident.t * class_declaration * class_declaration *
       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
+  | Impure_functor
 
 type pos =
     Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
Index: typing/mtype.ml
===================================================================
--- typing/mtype.ml	(revision 13286)
+++ 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