WIP: add projections to module expr to handle open F(X).Y

lib/ast_converter.mlp

@@ -8,6 +8,7 @@ module Arg = M.Arg
 
 let from_lid = Longident_converter.from_lid
 let txt x= x.Location.txt
+let me_from_lid lid =  Longident_converter.me_from_lid (txt lid)
 
 # oo, 4.10
   let bound_name x = Some x
@@ -870,10 +871,10 @@ and matched_patt_expr x y =
   | _, _ -> pattern x, expr y
 # oo, 4.08
 and local_open_arg o = Ident (npath o)
-and ident_open o = do_open o.popen_loc (Ident (npath o.popen_lid))
+and ident_open o = do_open o.popen_loc (me_from_lid o.popen_lid))
 and simple_open o = ident_open o
 # 4.08, oo
 and local_open_arg o = module_expr o.popen_expr
-and ident_open o = do_open o.popen_loc (Ident (npath o.popen_expr))
+and ident_open o = do_open o.popen_loc (me_from_lid o.popen_expr)
 and simple_open o = do_open o.popen_loc (module_expr o.popen_expr)
 #end

lib/longident_converter.ml

@@ -11,3 +11,17 @@ let from_lid x =
     | L.Lapply (f,x) ->
       app (pathlike [] f) (pathlike [] x) (proj acc) in
   pathlike [] x
+
+let me_from_lid x =
+  let open M2l in
+  let rec pathlike acc l : module_expr =
+    match l with
+    | L.Lident s -> Ident (List.rev (s::acc))
+    | L.Ldot (lid,s) -> pathlike (s::acc) lid
+    | L.Lapply (f,x) ->
+      let app =  Apply {f=pathlike [] f; x=pathlike [] x} in
+      match acc with
+        | [] -> app
+        | _ :: _ as proj -> Proj {me=app;proj}
+  in
+  pathlike [] x

lib/longident_converter.mli

@@ -1 +1,2 @@
 val from_lid: Longident.t -> Paths.Expr.t
+val me_from_lid: Longident.t -> M2l.module_expr

lib/m2l.ml

@@ -68,6 +68,10 @@ and module_expr =
       Note: This construction does not exist (yet?) in OCaml proper.
       It is used here to simplify the interaction between
       pattern open and first class module.*)
+  | Proj of {me:module_expr; proj:Paths.Simple.t}
+   (** [F(X).Y]: this construction only exists in [open F(X).Y] currently *)
+
+
 and module_type =
   | Alias of Paths.Simple.t (** [module m = A…]  *)
   | Ident of Paths.Expr.t
@@ -153,7 +157,8 @@ module Sch = struct
           "Extension_node", Mu.extension;
           "Abstract",Void;
           "Unpacked", Void;
-          "Open_me",[Array (reopen path_loc); Mu.module_expr]
+          "Open_me",[Array (reopen path_loc); Mu.module_expr];
+          "Proj", [Mu.module_expr;  reopen Paths.S.sch]
         ]
 
   let with_sch_rhs =
@@ -232,7 +237,8 @@ module Sch = struct
     | Extension_node x -> C(S(S(S(S(S(S(Z x)))))))
     | Abstract -> C(S(S(S(S(S(S(S E)))))))
     | Unpacked -> C(S(S(S(S(S(S(S(S E))))))))
-    | Open_me r -> C(S(S(S(S(S(S(S(S(S(Z [r.opens;r.expr]))))))))))
+    | Open_me r ->      C(S(S(S(S(S(S(S(S(S(Z [r.opens;r.expr]))))))))))
+    | Proj {me;proj} -> C(S(S(S(S(S(S(S(S(S(S(Z [me;proj])))))))))))
   and me_rev = let open Tuple in
     function
     | C Z x -> Ident x
@@ -246,6 +252,7 @@ module Sch = struct
     | C S S S S S S S S E -> Unpacked
     | C S S S S S S S S S Z [opens;expr] ->
       Open_me {opens;expr}
+    | C S S S S S S S S S S Z [me;proj] -> Proj {me;proj}
     | _ -> .
 
 
@@ -502,6 +509,7 @@ and pp_me ppf = function
   | Ident np -> Paths.Simple.pp ppf np
   | Str m2l -> Pp.fp ppf "@,struct@, %a end" pp m2l
   | Apply {f;x} -> Pp.fp ppf "%a(@,%a@,)" pp_me f pp_me x
+  | Proj {me;proj} -> Pp.fp ppf "%a.%a" pp_me me Paths.Simple.pp proj
   | Fun { arg; body } -> Pp.fp ppf "%a@,→%a" (Arg.pp pp_mt) arg pp_me body
   | Constraint (me,mt) -> Pp.fp ppf "%a: @,%a" pp_me me pp_mt mt
   | Val annot -> Pp.fp ppf "⟨val %a⟩" pp_annot annot
@@ -574,7 +582,7 @@ module Sig_only = struct
   and main l = map List.rev (rev false @@ List.rev l)
   and mex = function
     | ( Val _ | Abstract | Unpacked )  as a-> false, a
-    | (Ident _ | Apply _ | Extension_node _ ) as a -> true, a
+    | (Ident _ | Apply _ | Extension_node _ | Proj _) as a -> true, a
     | Fun {arg;body} ->
       let b, arg = sig_arg mty arg in
       let b', body = mex body in

lib/m2l.mli

@@ -92,11 +92,13 @@ and module_expr =
       In particular, it is useful for constraining first class module unpacking
       as [Constraint(Abstract, signature)]. *)
   | Unpacked (** [(module M)] *)
+
   | Open_me of { opens:Paths.Simple.t Loc.ext list; expr:module_expr}
   (** [M.(…N.( module_expr)…)]
       Note: This construction does not exist (yet?) in OCaml proper.
       It is used here to simplify the interaction between
       pattern open and first class module.*)
+  | Proj of {me:module_expr; proj:Paths.Simple.t }
 
 (** Module type level representation *)
 and module_type =

lib/zipper_def.ml

@@ -172,6 +172,7 @@ module type s = sig
     | Ident: path_in_context me
     | Apply_left: M2l.module_expr -> M2l.module_expr me
     | Apply_right: module_expr -> M2l.module_expr me
+    | Proj_left: Paths.Simple.t -> M2l.module_expr me
     | Fun_left: {name:Name.t option; diff:state_diff; body:M2l.module_expr} -> M2l.module_type me
     | Fun_right:
         (module_type Arg.t * state_diff ) option

lib/zipper_fold.ml

@@ -60,6 +60,7 @@ module Zip(F:Zdef.fold)(State:Sk.state) = struct
   let pack = user F.pack
   let expr_ext name = user_ml (F.expr_ext name)
   let me_ident = both Sk.ident F.me_ident
+  let me_proj _proj _me = assert false
   let apply param loc f =
     both2 (fun f x -> Sk.apply param loc ~f ~x) (F.apply loc) f
   let me_fun_none =  both (fun f -> Sk.fn ~f ~x:None) (F.me_fun None)
@@ -196,6 +197,9 @@ module Make(F:Zdef.fold)(Env:Stage.envt) = struct
       me (Me (Apply_left x)::path) ~param ~ctx ~state f >>= fun f ->
       me (Me (Apply_right f)::path) ~param ~ctx ~state x >>|
       D.apply param ctx.uloc f
+    | Proj {me=mep;proj} ->
+      me (Me (Proj_left proj)::path) ~param ~ctx ~state mep >>=
+      D.me_proj proj
     | Fun {arg = None; body } ->
       me (Me (Fun_right None) :: path) ~param ~ctx ~state body
       >>| D.me_fun_none
@@ -438,6 +442,8 @@ module Make(F:Zdef.fold)(Env:Stage.envt) = struct
     | Mt Of :: path -> restart_mt ~ctx ~state ~param path (D.mt_of x)
     | Me(Apply_right fn) :: path ->
       restart_me path ~ctx ~param ~state (D.apply param ctx.uloc fn x)
+    | Me (Proj_left proj) :: path ->
+      restart_me path ~ctx ~param ~state (D.me_proj proj x)
     | Me(Fun_right None) :: path ->
       restart_me path ~state ~ctx ~param (D.me_fun_none x)
     | Me(Fun_right Some (r,diff)) :: path ->

lib/zipper_pp.ml

@@ -96,6 +96,8 @@ module Make(Def:Zipper_def.s)(R:Result_printer with module T := Def.T) = struct
     | Me (Apply_left right) :: rest ->
       me rest (fun ppf -> Pp.fp ppf "%t(%a)" sub M2l.pp_me right)
     | Me Apply_right left :: rest -> me rest (fp2 "%t(%t)" (R.pp_me left.user) sub)
+    | Me (Proj_left right) :: rest ->
+      me rest (fun ppf -> Pp.fp ppf "%t.%a" sub Paths.Simple.pp right)
     | Me Fun_right left :: rest -> me rest (fp2 "functor (%t) ->%t" (r_arg left) sub)
     | Me Constraint_left mt :: rest ->
       me rest (fun ppf -> Pp.fp ppf "(%t:%a)" sub M2l.pp_mt mt)