open-struct working branch

Changes

@@ -13,6 +13,9 @@ Working version
   (Nicolás Ojeda Bär, review by Gabriel Radanne, Damien Doligez, Gabriel
   Scherer)
 
+- GPR#1506: Extending `open` to accept arbitrary module expression
+  (Runhang Li, review by Alain Frisch, Florian Angeletti, Jeremy Yallop)
+
 - GPR#1546: Allow empty variants
   (Runhang Li, review by Gabriel Radanne and Jacques Garrigue)
 

bytecomp/translclass.ml

@@ -195,7 +195,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
 
@@ -387,7 +387,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 =
@@ -407,7 +407,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
 
 (*
@@ -453,7 +453,7 @@ let rec transl_class_rebind obj_init cl vf =
       in
       check_constraint cl.cl_type;
       (path, obj_init)
-  | Tcl_open (_, _, _, _, cl) ->
+  | Tcl_open (_,  cl) ->
       transl_class_rebind obj_init cl vf
 
 let rec transl_class_rebind_0 self obj_init cl vf =

parsing/ast_helper.ml

@@ -414,9 +414,9 @@ end
 
 module Opn = struct
   let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs)
-        ?(override = Fresh) lid =
+        ?(override = Fresh) expr =
     {
-     popen_lid = lid;
+     popen_expr = expr;
      popen_override = override;
      popen_loc = loc;
      popen_attributes = add_docs_attrs docs attrs;

parsing/ast_helper.mli

@@ -168,8 +168,8 @@ module Exp:
     val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression
     val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression
     val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression
-    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression
-               -> expression
+    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> module_expr
+              -> expression -> expression
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
     val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression
 
@@ -322,7 +322,7 @@ module Mb:
 module Opn:
   sig
     val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs ->
-      ?override:override_flag -> lid -> open_description
+      ?override:override_flag -> module_expr -> open_description
   end
 
 (** Includes *)
@@ -352,7 +352,7 @@ module Cty:
     val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type ->
       class_type -> class_type
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
-    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type
+    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> module_expr -> class_type
                -> class_type
   end
 
@@ -392,7 +392,7 @@ module Cl:
     val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type ->
       class_expr
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
-    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr
+    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> module_expr -> class_expr
                -> class_expr
   end
 

parsing/ast_invariants.ml

@@ -67,6 +67,7 @@ let iterator =
     | Ppat_construct (id, _) -> simple_longident id
     | Ppat_record (fields, _) ->
       List.iter (fun (id, _) -> simple_longident id) fields
+    | Ppat_open (id, _) -> simple_longident id
     | _ -> ()
   in
   let expr self exp =
@@ -87,8 +88,7 @@ let iterator =
     | Pexp_construct (id, _)
     | Pexp_field (_, id)
     | Pexp_setfield (_, id, _)
-    | Pexp_new id
-    | Pexp_open (_, id, _) -> simple_longident id
+    | Pexp_new id -> simple_longident id
     | Pexp_record (fields, _) ->
       List.iter (fun (id, _) -> simple_longident id) fields
     | _ -> ()
@@ -114,8 +114,7 @@ let iterator =
     | _ -> ()
   in
   let open_description self opn =
-    super.open_description self opn;
-    simple_longident opn.popen_lid
+    super.open_description self opn
   in
   let with_constraint self wc =
     super.with_constraint self wc;

parsing/ast_iterator.ml

@@ -186,8 +186,8 @@ module CT = struct
     | Pcty_arrow (_lab, t, ct) ->
         sub.typ sub t; sub.class_type sub ct
     | Pcty_extension x -> sub.extension sub x
-    | Pcty_open (_ovf, lid, e) ->
-        iter_loc sub lid; sub.class_type sub e
+    | Pcty_open (_ovf, me, e) ->
+        sub.module_expr sub me; sub.class_type sub e
 
   let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
     =
@@ -372,8 +372,8 @@ module E = struct
     | Pexp_object cls -> sub.class_structure sub cls
     | Pexp_newtype (_s, e) -> sub.expr sub e
     | Pexp_pack me -> sub.module_expr sub me
-    | Pexp_open (_ovf, lid, e) ->
-        iter_loc sub lid; sub.expr sub e
+    | Pexp_open (_ovf, me, e) ->
+        sub.module_expr sub me; sub.expr sub e
     | Pexp_extension x -> sub.extension sub x
     | Pexp_unreachable -> ()
 end
@@ -434,8 +434,8 @@ module CE = struct
     | Pcl_constraint (ce, ct) ->
         sub.class_expr sub ce; sub.class_type sub ct
     | Pcl_extension x -> sub.extension sub x
-    | Pcl_open (_ovf, lid, e) ->
-        iter_loc sub lid; sub.class_expr sub e
+    | Pcl_open (_ovf, me, e) ->
+        sub.module_expr sub me; sub.class_expr sub e
 
   let iter_kind sub = function
     | Cfk_concrete (_o, e) -> sub.expr sub e
@@ -535,8 +535,8 @@ let default_iterator =
 
 
     open_description =
-      (fun this {popen_lid; popen_override = _; popen_attributes; popen_loc} ->
-         iter_loc this popen_lid;
+      (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} ->
+         this.module_expr this popen_expr;
          this.location this popen_loc;
          this.attributes this popen_attributes
       );

parsing/ast_mapper.ml

@@ -195,8 +195,8 @@ module CT = struct
     | Pcty_arrow (lab, t, ct) ->
         arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
     | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
-    | Pcty_open (ovf, lid, ct) ->
-        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct)
+    | Pcty_open (ovf, me, ct) ->
+        open_ ~loc ~attrs ovf (sub.module_expr sub me) (sub.class_type sub ct)
 
   let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
     =
@@ -394,8 +394,8 @@ module E = struct
     | Pexp_newtype (s, e) ->
         newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)
     | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me)
-    | Pexp_open (ovf, lid, e) ->
-        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e)
+    | Pexp_open (ovf, me, e) ->
+        open_ ~loc ~attrs ovf (sub.module_expr sub me) (sub.expr sub e)
     | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x)
     | Pexp_unreachable -> unreachable ~loc ~attrs ()
 end
@@ -458,8 +458,8 @@ module CE = struct
     | Pcl_constraint (ce, ct) ->
         constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
     | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
-    | Pcl_open (ovf, lid, ce) ->
-        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce)
+    | Pcl_open (ovf, me, ce) ->
+        open_ ~loc ~attrs ovf (sub.module_expr sub me) (sub.class_expr sub ce)
 
   let map_kind sub = function
     | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
@@ -570,8 +570,8 @@ let default_mapper =
 
 
     open_description =
-      (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
-         Opn.mk (map_loc this popen_lid)
+      (fun this {popen_expr; popen_override; popen_attributes; popen_loc} ->
+         Opn.mk (this.module_expr this popen_expr)
            ~override:popen_override
            ~loc:(this.location this popen_loc)
            ~attrs:(this.attributes this popen_attributes)

parsing/depend.ml

@@ -160,32 +160,6 @@ let add_type_extension bv te =
   add bv te.ptyext_path;
   List.iter (add_extension_constructor bv) te.ptyext_constructors
 
-let rec add_class_type bv cty =
-  match cty.pcty_desc with
-    Pcty_constr(l, tyl) ->
-      add bv l; List.iter (add_type bv) tyl
-  | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } ->
-      add_type bv ty;
-      List.iter (add_class_type_field bv) fieldl
-  | Pcty_arrow(_, ty1, cty2) ->
-      add_type bv ty1; add_class_type bv cty2
-  | Pcty_extension e -> handle_extension e
-  | Pcty_open (_ovf, m, e) ->
-      let bv = open_module bv m.txt in add_class_type bv e
-
-and add_class_type_field bv pctf =
-  match pctf.pctf_desc with
-    Pctf_inherit cty -> add_class_type bv cty
-  | Pctf_val(_, _, _, ty) -> add_type bv ty
-  | Pctf_method(_, _, _, ty) -> add_type bv ty
-  | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
-  | Pctf_attribute _ -> ()
-  | Pctf_extension e -> handle_extension e
-
-let add_class_description bv infos =
-  add_class_type bv infos.pci_expr
-
-let add_class_type_declaration = add_class_description
 
 let pattern_bv = ref StringMap.empty
 
@@ -268,7 +242,10 @@ let rec add_expr bv exp =
   | Pexp_newtype (_, e) -> add_expr bv e
   | Pexp_pack m -> add_module_expr bv m
   | Pexp_open (_ovf, m, e) ->
-      let bv = open_module bv m.txt in add_expr bv e
+      let Node(s, m') = add_module_binding bv m in
+      add_names s;
+      let bv = StringMap.fold StringMap.add m' bv in
+      add_expr bv e
   | Pexp_extension (({ txt = ("ocaml.extension_constructor"|
                               "extension_constructor"); _ },
                      PStr [item]) as e) ->
@@ -371,7 +348,10 @@ and add_sig_item (bv, m) item =
       end;
       (bv, m)
   | Psig_open od ->
-      (open_module bv od.popen_lid.txt, m)
+      let Node (s, m') = add_module_binding bv od.popen_expr in
+      add_names s;
+      let add = StringMap.fold StringMap.add m' in
+      (add bv, add m)
   | Psig_include incl ->
       let Node (s, m') = add_modtype_binding bv incl.pincl_mod in
       add_names s;
@@ -380,7 +360,7 @@ and add_sig_item (bv, m) item =
   | Psig_class cdl ->
       List.iter (add_class_description bv) cdl; (bv, m)
   | Psig_class_type cdtl ->
-      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
+      List.iter (add_class_type_declaration () bv) cdtl; (bv, m)
   | Psig_attribute _ -> (bv, m)
   | Psig_extension (e, _) ->
       handle_extension e;
@@ -409,6 +389,36 @@ and add_module_expr bv modl =
   | Pmod_extension e ->
       handle_extension e
 
+and add_class_type bv cty =
+  match cty.pcty_desc with
+    Pcty_constr(l, tyl) ->
+      add bv l; List.iter (add_type bv) tyl
+  | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } ->
+      add_type bv ty;
+      List.iter (add_class_type_field bv) fieldl
+  | Pcty_arrow(_, ty1, cty2) ->
+      add_type bv ty1; add_class_type bv cty2
+  | Pcty_extension e -> handle_extension e
+  | Pcty_open (_ovf, m, e) ->
+      let Node(s, m') = add_module_binding bv m in
+      add_names s;
+      let bv = StringMap.fold StringMap.add m' bv in
+      add_class_type bv e
+
+and add_class_type_field bv pctf =
+  match pctf.pctf_desc with
+    Pctf_inherit cty -> add_class_type bv cty
+  | Pctf_val(_, _, _, ty) -> add_type bv ty
+  | Pctf_method(_, _, _, ty) -> add_type bv ty
+  | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+  | Pctf_attribute _ -> ()
+  | Pctf_extension e -> handle_extension e
+
+and add_class_description bv infos =
+  add_class_type bv infos.pci_expr
+
+and add_class_type_declaration () = add_class_description
+
 and add_structure bv item_list =
   let (bv, m) = add_structure_binding bv item_list in
   add_names (collect_free (make_node m));
@@ -452,11 +462,14 @@ and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t =
       end;
       (bv, m)
   | Pstr_open od ->
-      (open_module bv od.popen_lid.txt, m)
+      let Node (s, m') = add_module_binding bv od.popen_expr in
+      add_names s;
+      let add = StringMap.fold StringMap.add m' in
+      (add bv, add m)
   | Pstr_class cdl ->
       List.iter (add_class_declaration bv) cdl; (bv, m)
   | Pstr_class_type cdtl ->
-      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
+      List.iter (add_class_type_declaration () bv) cdtl; (bv, m)
   | Pstr_include incl ->
       let Node (s, m') as n = add_module_binding bv incl.pincl_mod in
       if !Clflags.transparent_modules then
@@ -502,7 +515,10 @@ and add_class_expr bv ce =
       add_class_expr bv ce; add_class_type bv ct
   | Pcl_extension e -> handle_extension e
   | Pcl_open (_ovf, m, e) ->
-      let bv = open_module bv m.txt in add_class_expr bv e
+      let Node(s, m') = add_module_binding bv m in
+      add_names s;
+      let bv = StringMap.fold StringMap.add m' bv in
+      add_class_expr bv e
 
 and add_class_field bv pcf =
   match pcf.pcf_desc with