Extending OCaml's open

driver/compmisc.ml

@@ -43,9 +43,10 @@ let init_path ?(dir="") native =
 
 let open_implicit_module m env =
   let open Asttypes in
-  let lid = {loc = Location.in_file "command line";
-             txt = Longident.parse m } in
-  snd (Typemod.type_open_ Override env lid.loc lid)
+  let loc = Location.in_file "command line" in
+  let lid = {loc; txt = Longident.parse m } in
+  let me = Parsetree.({pmod_desc=Pmod_ident lid; pmod_loc=loc; pmod_attributes=[]}) in
+  snd (Typemod.type_open_ ?toplevel:None false Override env lid.loc me)
 
 let initial_env () =
   Ident.reinit();

ocamldoc/odoc_analyse.ml

@@ -39,9 +39,11 @@ let initial_env () =
   in
   let open_mod env m =
     let open Asttypes in
-    let lid = {loc = Location.in_file "ocamldoc command line";
-               txt = Longident.parse m } in
-    snd (Typemod.type_open_ Override env lid.loc lid) in
+    let loc = Location.in_file "ocamldoc command line" in
+    let lid = {loc; txt = Longident.parse m } in
+    let me = Parsetree.({pmod_desc=Pmod_ident lid;
+                         pmod_loc=loc; pmod_attributes=[]}) in
+    snd (Typemod.type_open_ ?toplevel:None false Override env lid.loc me) in
   (* Open the list of modules given as arguments of the "-open" flag
      The list is reversed to open the modules in the left-to-right order *)
   let to_open = List.rev !Clflags.open_modules in

parsing/ast_helper.ml

@@ -407,9 +407,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

@@ -169,8 +169,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 -> lid
+              -> expression -> expression
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression
     val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression
 
@@ -323,7 +323,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 *)

parsing/ast_invariants.ml

@@ -117,7 +117,7 @@ let iterator =
   in
   let open_description self opn =
     super.open_description self opn;
-    simple_longident opn.popen_lid
+    super.module_expr self opn.popen_expr
   in
   let with_constraint self wc =
     super.with_constraint self wc;

parsing/ast_iterator.ml

@@ -526,8 +526,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

@@ -561,8 +561,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

@@ -363,7 +363,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;
@@ -454,7 +457,10 @@ 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 ->

parsing/parser.mly

@@ -917,9 +917,9 @@ signature_item:
         mksig(Psig_attribute $1) }
 ;
 open_statement:
-  | OPEN override_flag ext_attributes mod_longident post_item_attributes
+  | OPEN override_flag ext_attributes module_expr post_item_attributes
       { let (ext, attrs) = $3 in
-        Opn.mk (mkrhs $4 4) ~override:$2 ~attrs:(attrs@$5)
+        Opn.mk $4 ~override:$2 ~attrs:(attrs@$5)
           ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
       , ext}
 ;

parsing/parsetree.mli

@@ -727,7 +727,7 @@ and module_type_declaration =
 
 and open_description =
     {
-     popen_lid: Longident.t loc;
+     popen_expr: module_expr;
      popen_override: override_flag;
      popen_loc: Location.t;
      popen_attributes: attributes;

parsing/pprintast.ml

@@ -989,7 +989,7 @@ and signature_item ctxt f x : unit =
   | Psig_open od ->
       pp f "@[<hov2>open%s@ %a@]%a"
         (override od.popen_override)
-        longident_loc od.popen_lid
+        (module_expr ctxt) od.popen_expr
         (item_attributes ctxt) od.popen_attributes
   | Psig_include incl ->
       pp f "@[<hov2>include@ %a@]%a"
@@ -1187,7 +1187,7 @@ and structure_item ctxt f x =
   | Pstr_open od ->
       pp f "@[<2>open%s@;%a@]%a"
         (override od.popen_override)
-        longident_loc od.popen_lid
+        (module_expr ctxt) od.popen_expr
         (item_attributes ctxt) od.popen_attributes
   | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
       pp f "@[<hov2>module@ type@ %s%a@]%a"

parsing/printast.ml

@@ -680,9 +680,9 @@ and signature_item i ppf x =
       attributes i ppf x.pmtd_attributes;
       modtype_declaration i ppf x.pmtd_type
   | Psig_open od ->
-      line i ppf "Psig_open %a %a\n"
+      line i ppf "Psig_open %a\n%a\n"
         fmt_override_flag od.popen_override
-        fmt_longident_loc od.popen_lid;
+        (module_expr i) od.popen_expr;
       attributes i ppf od.popen_attributes
   | Psig_include incl ->
       line i ppf "Psig_include\n";
@@ -787,9 +787,9 @@ and structure_item i ppf x =
       attributes i ppf x.pmtd_attributes;
       modtype_declaration i ppf x.pmtd_type
   | Pstr_open od ->
-      line i ppf "Pstr_open %a %a\n"
+      line i ppf "Pstr_open %a\n%a\n"
         fmt_override_flag od.popen_override
-        fmt_longident_loc od.popen_lid;
+        (module_expr i) od.popen_expr;
       attributes i ppf od.popen_attributes
   | Pstr_class (l) ->
       line i ppf "Pstr_class\n";

testsuite/tests/parsing/shortcut_ext_attr.ml.reference

@@ -756,7 +756,10 @@
     Pstr_extension "foo"
     [
       structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16])
-        Pstr_open Fresh "M" (shortcut_ext_attr.ml[88,1754+15]..[88,1754+16])
+        Pstr_open Fresh
+        module_expr (shortcut_ext_attr.ml[88,1754+15]..[88,1754+16])
+          Pmod_ident "M" (shortcut_ext_attr.ml[88,1754+15]..[88,1754+16])
+
           attribute "foo"
             []
     ]
@@ -929,7 +932,10 @@
             Psig_extension "foo"
             [
               signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18])
-                Psig_open Fresh "M" (shortcut_ext_attr.ml[109,2116+17]..[109,2116+18])
+                Psig_open Fresh
+                module_expr (shortcut_ext_attr.ml[109,2116+17]..[109,2116+18])
+                  Pmod_ident "M" (shortcut_ext_attr.ml[109,2116+17]..[109,2116+18])
+
                   attribute "foo"
                     []
             ]

testsuite/tests/typing-modules/open-struct.ml

@@ -0,0 +1,101 @@
+type t = A
+
+module M = struct
+    open struct type t' = t end
+    type t = B of t * t' | C
+end
+
+(* test *)
+include struct
+  open M
+  let test = B (B (C, A), A)
+end
+[%%expect{|
+type t = A
+module M : sig type t = B of t * t | C end
+val test : M.t = M.B (M.B (M.C, A), A)
+|}];;
+
+include struct
+  open struct let aux x y = x / y end
+  let f x = aux x 2
+  let g y = aux 3 y
+end
+[%%expect{|
+val f : int -> int = <fun>
+val g : int -> int = <fun>
+|}];;
+
+include struct
+  open struct exception Interrupt end
+  let run () =
+    raise Interrupt
+  let () =
+    match run() with exception Interrupt -> () | _ -> assert false
+end
+[%%expect{|
+val run : unit -> 'a = <fun>
+|}];;
+
+module type S = sig
+  open struct
+    open struct
+      type t' = char
+    end
+    type t = t' -> int end
+  val x : t
+end
+
+module M : S = struct
+  let x = Char.code
+end
+[%%expect{|
+module type S = sig val x : char -> int end
+module M : S
+|}];;
+
+open struct
+  open struct let counter = ref 0 end
+  let inc () = incr counter
+  let dec () = decr counter
+  let current () = !counter
+end
+
+let () =
+  inc(); inc(); dec ();
+  assert (current () = 1)
+[%%expect{|
+|}];;
+
+include struct open struct type t = T end let x = T end
+[%%expect{|
+Line _, characters 15-41:
+Error: The module identifier M#7 cannot be eliminated from val x : M#7.t
+|}];;
+
+module type S = sig open struct assert false end end;;
+[%%expect{|
+module type S = sig  end
+|}];;
+
+module type S = sig open struct type t = int end val x : t end;;
+[%%expect{|
+module type S = sig val x : int end
+|}];;
+
+module type S = sig
+  open struct type t = int end
+  type s = t
+end
+[%%expect{|
+module type S = sig type s = int end
+|}]
+
+module type T = sig type s = int end
+module F(X:S) : T = X
+module G(X:T) : S = X
+[%%expect{|
+module type T = sig type s = int end
+module F : functor (X : S) -> T
+module G : functor (X : T) -> S
+|}]

typing/printtyped.ml

@@ -224,8 +224,8 @@ and pattern i ppf x =
         line i ppf "Tpat_type %a\n" fmt_path id;
         attributes i ppf attrs;
         pattern i ppf { x with pat_extra = rem }
-    | (Tpat_open (id,_,_), _, attrs)::rem ->
-        line i ppf "Tpat_open \"%a\"\n" fmt_path id;
+    | (Tpat_open (id,_), _, attrs)::rem ->
+        line i ppf "Tpat_open \"%a\"\n" fmt_longident id;
         attributes i ppf attrs;
         pattern i ppf { x with pat_extra = rem }
     | [] ->
@@ -270,8 +270,8 @@ and expression_extra i ppf x attrs =
       attributes i ppf attrs;
       option i core_type ppf cto1;
       core_type i ppf cto2;
-  | Texp_open (ovf, m, _, _) ->
-      line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
+  | Texp_open (ovf, lid, _) ->
+      line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_longident lid;
       attributes i ppf attrs;
   | Texp_poly cto ->
       line i ppf "Texp_poly\n";
@@ -662,9 +662,8 @@ and signature_item i ppf x =
       attributes i ppf x.mtd_attributes;
       modtype_declaration i ppf x.mtd_type
   | Tsig_open od ->
-      line i ppf "Tsig_open %a %a\n"
-           fmt_override_flag od.open_override
-           fmt_path od.open_path;
+      line i ppf "Tsig_open %a\n"
+        fmt_override_flag od.open_override;
       attributes i ppf od.open_attributes
   | Tsig_include incl ->
       line i ppf "Tsig_include\n";
@@ -767,9 +766,8 @@ and structure_item i ppf x =
       attributes i ppf x.mtd_attributes;
       modtype_declaration i ppf x.mtd_type
   | Tstr_open od ->
-      line i ppf "Tstr_open %a %a\n"
-           fmt_override_flag od.open_override
-           fmt_path od.open_path;
+      line i ppf "Tstr_open %a\n"
+        fmt_override_flag od.open_override;
       attributes i ppf od.open_attributes
   | Tstr_class (l) ->
       line i ppf "Tstr_class\n";

typing/tast_mapper.ml

@@ -124,7 +124,8 @@ let structure_item sub {str_desc; str_loc; str_env} =
           (List.map (tuple3 id id (sub.class_type_declaration sub)) list)
     | Tstr_include incl ->
         Tstr_include (include_infos (sub.module_expr sub) incl)
-    | Tstr_open _
+    | Tstr_open od ->
+        Tstr_open {od with open_expr = sub.module_expr sub od.open_expr}
     | Tstr_attribute _ as d -> d
   in
   {str_desc; str_env; str_loc}
@@ -186,7 +187,7 @@ let pat sub x =
   let extra = function
     | Tpat_type _
     | Tpat_unpack as d -> d
-    | Tpat_open (path,loc,env) ->  Tpat_open (path, loc, sub.env sub env)
+    | Tpat_open (loc,env) ->  Tpat_open (loc, sub.env sub env)
     | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct)
   in
   let pat_env = sub.env sub x.pat_env in
@@ -216,8 +217,8 @@ let expr sub x =
         Texp_constraint (sub.typ sub cty)
     | Texp_coerce (cty1, cty2) ->
         Texp_coerce (opt (sub.typ sub) cty1, sub.typ sub cty2)
-    | Texp_open (ovf, path, loc, env) ->
-        Texp_open (ovf, path, loc, sub.env sub env)
+    | Texp_open (ovf, loc, env) ->
+        Texp_open (ovf, loc, sub.env sub env)
     | Texp_newtype _ as d -> d
     | Texp_poly cto -> Texp_poly (opt (sub.typ sub) cto)
   in
@@ -387,7 +388,8 @@ let signature_item sub x =
     | Tsig_class_type list ->
         Tsig_class_type
           (List.map (sub.class_type_declaration sub) list)
-    | Tsig_open _
+    | Tsig_open od ->
+        Tsig_open {od with open_expr = sub.module_expr sub od.open_expr}
     | Tsig_attribute _ as d -> d
   in
   {x with sig_desc; sig_env}