From 9a4fd26716ead0b825013c2a5030eac9a7a50b24 Mon Sep 17 00:00:00 2001 From: octachron Date: Sat, 28 Sep 2024 10:10:14 +0200 Subject: [PATCH] WIP: add projections to module expr to handle open F(X).Y --- lib/ast_converter.mlp | 5 +++-- lib/longident_converter.ml | 14 ++++++++++++++ lib/longident_converter.mli | 1 + lib/m2l.ml | 14 +++++++++++--- lib/m2l.mli | 2 ++ lib/zipper_def.ml | 1 + lib/zipper_fold.ml | 6 ++++++ lib/zipper_pp.ml | 2 ++ 8 files changed, 40 insertions(+), 5 deletions(-) diff --git a/lib/ast_converter.mlp b/lib/ast_converter.mlp index 7981b95a..fc883acb 100644 --- a/lib/ast_converter.mlp +++ b/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 diff --git a/lib/longident_converter.ml b/lib/longident_converter.ml index 3519515a..1a727d13 100644 --- a/lib/longident_converter.ml +++ b/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 diff --git a/lib/longident_converter.mli b/lib/longident_converter.mli index c88148f7..f5becc5d 100644 --- a/lib/longident_converter.mli +++ b/lib/longident_converter.mli @@ -1 +1,2 @@ val from_lid: Longident.t -> Paths.Expr.t +val me_from_lid: Longident.t -> M2l.module_expr diff --git a/lib/m2l.ml b/lib/m2l.ml index 42402178..623228b2 100644 --- a/lib/m2l.ml +++ b/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 diff --git a/lib/m2l.mli b/lib/m2l.mli index 90d16b9f..a5f65f6e 100644 --- a/lib/m2l.mli +++ b/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 = diff --git a/lib/zipper_def.ml b/lib/zipper_def.ml index cf2f1df0..df2fb51f 100644 --- a/lib/zipper_def.ml +++ b/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 diff --git a/lib/zipper_fold.ml b/lib/zipper_fold.ml index e46b9084..d57fa9bb 100644 --- a/lib/zipper_fold.ml +++ b/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 -> diff --git a/lib/zipper_pp.ml b/lib/zipper_pp.ml index f273ac98..1db0f595 100644 --- a/lib/zipper_pp.ml +++ b/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)