Extend open to arbritrary module expressions in structures and to

applicative module paths in signatures

Author: objmagic

.depend

@@ -244,13 +244,15 @@ typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi \
     typing/oprint.cmi typing/mtype.cmi utils/misc.cmi parsing/location.cmi \
     typing/includecore.cmi typing/includeclass.cmi typing/ident.cmi \
     typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi utils/clflags.cmi \
-    parsing/builtin_attributes.cmi typing/btype.cmi typing/includemod.cmi
+    parsing/builtin_attributes.cmi typing/btype.cmi parsing/asttypes.cmi \
+    typing/includemod.cmi
 typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx \
     typing/subst.cmx typing/printtyp.cmx typing/primitive.cmx typing/path.cmx \
     typing/oprint.cmx typing/mtype.cmx utils/misc.cmx parsing/location.cmx \
     typing/includecore.cmx typing/includeclass.cmx typing/ident.cmx \
     typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \
-    parsing/builtin_attributes.cmx typing/btype.cmx typing/includemod.cmi
+    parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \
+    typing/includemod.cmi
 typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \
     typing/path.cmi parsing/location.cmi typing/includecore.cmi \
     typing/ident.cmi typing/env.cmi typing/ctype.cmi
@@ -513,8 +515,7 @@ typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
 typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \
     typing/typedecl.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/includemod.cmi \
-    typing/ident.cmi typing/env.cmi typing/cmi_format.cmi \
-    parsing/asttypes.cmi
+    typing/ident.cmi typing/env.cmi typing/cmi_format.cmi
 typing/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \
     typing/typedecl.cmi typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi \
     typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \

Changes

@@ -9,6 +9,11 @@ Working version
   (Thomas Refis, with help and review from Alain Frisch, Gabriel Scherer, Jeremy
   Yallop, Leo White and Luc Maranget)
 
+- GPR#1506, GPR#XXXX: Extended open to arbitrary module expression in
+  structures and to applicative paths in signatures
+  (Runhang Li, review by Alain Frisch, Florian Angeletti, Jeremy Yallop and
+  Thomas Refis)
+
 - GPR#1705: Allow @@attributes on exceptions.
   (Hugo Heuzard, review by Gabriel Radanne and Thomas Refis)
 

boot/menhir/parser.ml

@@ -193,7 +193,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
         build_object_init cl_table obj (vals @ params) inh_init obj_init cl
       in
       (inh_init, Translcore.transl_let rec_flag defs obj_init)
-  | Tcl_open (_, _, _, _, cl)
+  | Tcl_open (_, cl)
   | Tcl_constraint (cl, _, _, _, _) ->
       build_object_init cl_table obj params inh_init obj_init cl
 
@@ -383,7 +383,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
            Lsequence(mkappl (oo_prim "narrow", narrow_args),
                      cl_init))
       end
-  | Tcl_open (_, _, _, _, cl) ->
+  | Tcl_open (_, cl) ->
       build_class_init cla cstr super inh_init cl_init msubst top cl
 
 let rec build_class_lets cl =
@@ -403,7 +403,7 @@ let rec get_class_meths cl =
   | Tcl_fun (_, _, _, cl, _)
   | Tcl_let (_, _, _, cl)
   | Tcl_apply (cl, _)
-  | Tcl_open (_, _, _, _, cl)
+  | Tcl_open (_, cl)
   | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl
 
 (*
@@ -451,7 +451,7 @@ let rec transl_class_rebind obj_init cl vf =
       in
       check_constraint cl.cl_type;
       (path, path_lam, obj_init)
-  | Tcl_open (_, _, _, _, cl) ->
+  | Tcl_open (_, cl) ->
       transl_class_rebind obj_init cl vf
 
 let rec transl_class_rebind_0 (self:Ident.t) obj_init cl vf =

bytecomp/translclass.ml

@@ -538,6 +538,32 @@ and transl_exp0 e =
          }
   | Texp_unreachable ->
       raise (Error (e.exp_loc, Unreachable_reached))
+  | Texp_open (od, e) ->
+      let pure = pure_module od.open_expr in
+      (* this optimization shouldn't be needed because Simplif would
+          actually remove the [Llet] when it's not used.
+          But since [scan_used_globals] runs before Simplif, we need to
+          do it. *)
+      begin match od.open_bound_items with
+      | [] when pure = Alias -> transl_exp e
+      | _ ->
+          let oid = Ident.create_local "open" in
+          let body, _ =
+            List.fold_left (fun (body, pos) id ->
+              Llet(Alias, Pgenval, id,
+                   Lprim(Pfield pos, [Lvar oid], od.open_loc), body),
+              pos + 1
+            ) (transl_exp e, 0) (bound_value_identifiers od.open_bound_items)
+          in
+          Llet(pure, Pgenval, oid,
+               !transl_module Tcoerce_none None od.open_expr, body)
+      end
+
+and pure_module m =
+  match m.mod_desc with
+    Tmod_ident _ -> Alias
+  | Tmod_constraint (m,_,_,_) -> pure_module m
+  | _ -> Strict
 
 and transl_list expr_list =
   List.map transl_exp expr_list

bytecomp/translcore.ml

@@ -20,6 +20,8 @@ open Asttypes
 open Typedtree
 open Lambda
 
+val pure_module : module_expr -> let_kind
+
 val transl_exp: expression -> lambda
 val transl_apply: ?should_be_tailcall:bool
                   -> ?inlined:inline_attribute

bytecomp/translcore.mli

@@ -231,7 +231,7 @@ let init_shape id modl =
   and init_shape_struct env sg =
     match sg with
       [] -> []
-    | Sig_value(subid, {val_kind=Val_reg; val_type=ty; val_loc=loc}) :: rem ->
+    | Sig_value(subid, {val_kind=Val_reg; val_type=ty; val_loc=loc},_) :: rem ->
         let init_v =
           match Ctype.expand_head env ty with
             {desc = Tarrow(_,_,_,_)} ->
@@ -242,23 +242,23 @@ let init_shape id modl =
               let not_a_function = {reason=Unsafe_non_function; loc; subid } in
               raise (Initialization_failure not_a_function) in
         init_v :: init_shape_struct env rem
-    | Sig_value(_, {val_kind=Val_prim _}) :: rem ->
+    | Sig_value(_, {val_kind=Val_prim _}, _) :: rem ->
         init_shape_struct env rem
     | Sig_value _ :: _rem ->
         assert false
-    | Sig_type(id, tdecl, _) :: rem ->
+    | Sig_type(id, tdecl, _, _) :: rem ->
         init_shape_struct (Env.add_type ~check:false id tdecl env) rem
-    | Sig_typext (subid, {ext_loc=loc},_) :: _ ->
+    | Sig_typext (subid, {ext_loc=loc},_,_) :: _ ->
         raise (Initialization_failure {reason=Unsafe_typext; loc; subid})
-    | Sig_module(id, Mp_present, md, _) :: rem ->
+    | Sig_module(id, Mp_present, md, _, _) :: rem ->
         init_shape_mod id md.md_loc env md.md_type ::
         init_shape_struct (Env.add_module_declaration ~check:false
                              id Mp_present md env) rem
-    | Sig_module(id, Mp_absent, md, _) :: rem ->
+    | Sig_module(id, Mp_absent, md, _, _) :: rem ->
         init_shape_struct
           (Env.add_module_declaration ~check:false
                              id Mp_absent md env) rem
-    | Sig_modtype(id, minfo) :: rem ->
+    | Sig_modtype(id, minfo, _) :: rem ->
         init_shape_struct (Env.add_modtype id minfo env) rem
     | Sig_class _ :: rem ->
         Const_pointer 2 (* camlinternalMod.Class *)
@@ -376,22 +376,6 @@ let compile_recmodule compile_rhs bindings cont =
           bindings))
     cont
 
-(* Extract the list of "value" identifiers bound by a signature.
-   "Value" identifiers are identifiers for signature components that
-   correspond to a run-time value: values, extensions, modules, classes.
-   Note: manifest primitives do not correspond to a run-time value! *)
-
-let rec bound_value_identifiers = function
-    [] -> []
-  | Sig_value(id, {val_kind = Val_reg}) :: rem ->
-      id :: bound_value_identifiers rem
-  | Sig_typext(id, _, _) :: rem -> id :: bound_value_identifiers rem
-  | Sig_module(id, Mp_present, _, _) :: rem ->
-      id :: bound_value_identifiers rem
-  | Sig_class(id, _, _) :: rem -> id :: bound_value_identifiers rem
-  | _ :: rem -> bound_value_identifiers rem
-
-
 (* Code to translate class entries in a structure *)
 
 let transl_class_bindings cl_list =
@@ -673,18 +657,38 @@ and transl_structure loc fields cc rootpath final_env = function
                transl_module Tcoerce_none None modl, body),
           size
 
+      | Tstr_open od ->
+          let pure = pure_module od.open_expr in
+          (* this optimization shouldn't be needed because Simplif would
+             actually remove the [Llet] when it's not used.
+             But since [scan_used_globals] runs before Simplif, we need to do
+             it. *)
+          begin match od.open_bound_items with
+          | [] when pure = Alias ->
+              transl_structure loc fields cc rootpath final_env rem
+          | _ ->
+              let ids = bound_value_identifiers od.open_bound_items in
+              let mid = Ident.create_local "open" in
+              let rec rebind_idents pos newfields = function
+                  [] ->
+                  transl_structure loc newfields cc rootpath final_env rem
+                | id :: ids ->
+                  let body, size =
+                    rebind_idents (pos + 1) (id :: newfields) ids
+                  in
+                  Llet(Alias, Pgenval, id,
+                      Lprim(Pfield pos, [Lvar mid], od.open_loc), body),
+                  size
+              in
+              let body, size = rebind_idents 0 fields ids in
+              Llet(pure, Pgenval, mid,
+                    transl_module Tcoerce_none None od.open_expr, body), size
+          end
       | Tstr_modtype _
-      | Tstr_open _
       | Tstr_class_type _
       | Tstr_attribute _ ->
           transl_structure loc fields cc rootpath final_env rem
 
-and pure_module m =
-  match m.mod_desc with
-    Tmod_ident _ -> Alias
-  | Tmod_constraint (m,_,_,_) -> pure_module m
-  | _ -> Strict
-
 (* Update forward declaration in Translcore *)
 let _ =
   Translcore.transl_module := transl_module
@@ -771,7 +775,8 @@ let rec defined_idents = function
     | Tstr_recmodule decls ->
       List.map (fun mb -> mb.mb_id) decls @ defined_idents rem
     | Tstr_modtype _ -> defined_idents rem
-    | Tstr_open _ -> defined_idents rem
+    | Tstr_open od ->
+      bound_value_identifiers od.open_bound_items @ defined_idents rem
     | Tstr_class cl_list ->
       List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem
     | Tstr_class_type _ -> defined_idents rem
@@ -793,7 +798,12 @@ let rec more_idents = function
     | Tstr_exception _ -> more_idents rem
     | Tstr_recmodule _ -> more_idents rem
     | Tstr_modtype _ -> more_idents rem
-    | Tstr_open _ -> more_idents rem
+    | Tstr_open od ->
+        let rest = more_idents rem in
+        begin match od.open_expr.mod_desc with
+        | Tmod_structure str -> all_idents str.str_items @ rest
+        | _ -> rest
+        end
     | Tstr_class _ -> more_idents rem
     | Tstr_class_type _ -> more_idents rem
     | Tstr_include{incl_mod={mod_desc =
@@ -827,7 +837,15 @@ and all_idents = function
     | Tstr_recmodule decls ->
       List.map (fun mb -> mb.mb_id) decls @ all_idents rem
     | Tstr_modtype _ -> all_idents rem
-    | Tstr_open _ -> all_idents rem
+    | Tstr_open od ->
+        let rest = all_idents rem in
+        begin match od.open_expr.mod_desc with
+        | Tmod_structure str ->
+          bound_value_identifiers od.open_bound_items
+          @ all_idents str.str_items
+          @ rest
+        | _ -> bound_value_identifiers od.open_bound_items @ rest
+        end
     | Tstr_class cl_list ->
       List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem
     | Tstr_class_type _ -> all_idents rem
@@ -1076,8 +1094,52 @@ let transl_store_structure glob map prims aliases str =
                  Lambda.subst no_env_update subst
                    (transl_module Tcoerce_none None modl),
                  store_idents 0 ids)
+        | Tstr_open od ->
+            begin match od.open_expr.mod_desc with
+            | Tmod_structure str ->
+                let lam =
+                  transl_store rootpath subst lambda_unit str.str_items
+                in
+                let ids = Array.of_list (defined_idents str.str_items) in
+                let ids0 = bound_value_identifiers od.open_bound_items in
+                let subst = !transl_store_subst in
+                let rec store_idents pos = function
+                  | [] -> transl_store rootpath subst cont rem
+                  | id :: idl ->
+                      Llet(Alias, Pgenval, id, Lvar ids.(pos),
+                           Lsequence(store_ident od.open_loc id,
+                                     store_idents (pos + 1) idl))
+                in
+                Lsequence(lam, Lambda.subst no_env_update subst
+                                 (store_idents 0 ids0))
+            | _ ->
+                let pure = pure_module od.open_expr in
+                (* this optimization shouldn't be needed because Simplif would
+                   actually remove the [Llet] when it's not used.
+                   But since [scan_used_globals] runs before Simplif, we need to
+                   do it. *)
+                match od.open_bound_items with
+                | [] when pure = Alias -> transl_store rootpath subst cont rem
+                | _ ->
+                    let ids = bound_value_identifiers od.open_bound_items in
+                    let mid = Ident.create_local "open" in
+                    let loc = od.open_loc in
+                    let rec store_idents pos = function
+                        [] ->
+                          transl_store rootpath (add_idents true ids subst) cont
+                            rem
+                      | id :: idl ->
+                          Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid],
+                                                         loc),
+                               Lsequence(store_ident loc id,
+                                         store_idents (pos + 1) idl))
+                    in
+                    Llet(pure, Pgenval, mid,
+                         Lambda.subst no_env_update subst
+                           (transl_module Tcoerce_none None od.open_expr),
+                         store_idents 0 ids)
+          end
         | Tstr_modtype _
-        | Tstr_open _
         | Tstr_class_type _
         | Tstr_attribute _ ->
             transl_store rootpath subst cont rem
@@ -1319,8 +1381,29 @@ let transl_toplevel_item item =
   | Tstr_primitive descr ->
       record_primitive descr.val_val;
       lambda_unit
+  | Tstr_open od ->
+      let pure = pure_module od.open_expr in
+      (* this optimization shouldn't be needed because Simplif would
+          actually remove the [Llet] when it's not used.
+          But since [scan_used_globals] runs before Simplif, we need to do
+          it. *)
+      begin match od.open_bound_items with
+      | [] when pure = Alias -> lambda_unit
+      | _ ->
+          let ids = bound_value_identifiers od.open_bound_items in
+          let mid = Ident.create_local "open" in
+          let rec set_idents pos = function
+              [] ->
+                lambda_unit
+            | id :: ids ->
+                Lsequence(toploop_setvalue id
+                            (Lprim(Pfield pos, [Lvar mid], Location.none)),
+                          set_idents (pos + 1) ids)
+          in
+          Llet(pure, Pgenval, mid,
+               transl_module Tcoerce_none None od.open_expr, set_idents 0 ids)
+      end
   | Tstr_modtype _
-  | Tstr_open _
   | Tstr_module {mb_presence=Mp_absent}
   | Tstr_type _
   | Tstr_class_type _