From 956f2caba9fd03781ccadf48bd691ccff77dd8f3 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 21 Apr 2023 13:25:54 +0100 Subject: [PATCH 01/18] Remove expansion from "unexpanded" `module type of` We've been keeping each `module type of` expression's expansion around, even in the nominally unexpanded version of the type. This was needed in case the expression was invalidated so that we had the expansion on hand as a fallback. However, it led to exponential blowup in the case of deeply nested `module type of`s. Happily, we can do without the expansion if we do a little more work when substituting: We already track in the `subst` which module paths have been invalidated. When we need to invalidate a module path, we can stash the expression for the module's type in that `subst`. This is effectively the same data that we were keeping in the "unexpanded" expansion. And then when we need to expand an invalidated `module type of`, we can use the stashed expression. --- src/document/generator.ml | 5 +- src/loader/cmt.ml | 2 +- src/model/lang.ml | 16 +- src/model_desc/lang_desc.ml | 2 +- src/xref2/compile.ml | 11 +- src/xref2/component.ml | 25 +- src/xref2/component.mli | 14 +- src/xref2/expand_tools.ml | 4 +- src/xref2/lang_of.ml | 14 +- src/xref2/link.ml | 6 +- src/xref2/subst.ml | 94 +- src/xref2/subst.mli | 6 +- src/xref2/tools.ml | 43 +- src/xref2/type_of.ml | 16 +- test/xref2/transparent_ascription.t/run.t | 1113 ++++++++++++++++++ test/xref2/transparent_ascription.t/test.mli | 101 ++ 16 files changed, 1341 insertions(+), 131 deletions(-) create mode 100644 test/xref2/transparent_ascription.t/run.t create mode 100644 test/xref2/transparent_ascription.t/test.mli diff --git a/src/document/generator.ml b/src/document/generator.ml index 21a29a964d..5e1b6ad54c 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -1510,8 +1510,7 @@ module Make (Syntax : SYNTAX) = struct and umty_hidden : Odoc_model.Lang.ModuleType.U.expr -> bool = function | Path p -> Paths.Path.(is_hidden (p :> t)) | With (_, expr) -> umty_hidden expr - | TypeOf { t_desc = ModPath m; _ } - | TypeOf { t_desc = StructInclude m; _ } -> + | TypeOf (ModPath m) | TypeOf (StructInclude m) -> Paths.Path.(is_hidden (m :> t)) | Signature _ -> false @@ -1559,7 +1558,7 @@ module Make (Syntax : SYNTAX) = struct | With (_, expr) when is_elidable_with_u expr -> Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag | With (subs, expr) -> mty_with subs expr - | TypeOf { t_desc; _ } -> mty_typeof t_desc + | TypeOf t -> mty_typeof t and mty : Odoc_model.Lang.ModuleType.expr -> text = fun m -> diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 31a8786e7b..6876d3de19 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -544,7 +544,7 @@ and read_include env parent incl = let decl_modty = match unwrap_module_expr_desc incl.incl_mod.mod_desc with | Tmod_ident(p, _) -> - Some (ModuleType.U.TypeOf {t_desc = ModuleType.StructInclude (Env.Path.read_module env p); t_expansion=None }) + Some (ModuleType.U.TypeOf (ModuleType.StructInclude (Env.Path.read_module env p))) | _ -> let mty = read_module_expr env parent container incl.incl_mod in umty_of_mty mty diff --git a/src/model/lang.ml b/src/model/lang.ml index 2544f0fdc8..4d18551505 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -92,19 +92,12 @@ and ModuleType : sig | Signature of Signature.t | Functor of FunctorParameter.t * simple_expansion - type typeof_t = { - t_desc : type_of_desc; - t_expansion : simple_expansion option; - } - module U : sig type expr = | Path of Path.ModuleType.t | Signature of Signature.t | With of substitution list * expr - | TypeOf of typeof_t - - (* Nb. this may have an expansion! *) + | TypeOf of type_of_desc end type path_t = { @@ -118,6 +111,11 @@ and ModuleType : sig w_expr : U.expr; } + type typeof_t = { + t_desc : type_of_desc; + t_expansion : simple_expansion option; + } + type expr = | Path of path_t | Signature of Signature.t @@ -534,7 +532,7 @@ let umty_of_mty : ModuleType.expr -> ModuleType.U.expr option = function | Signature sg -> Some (Signature sg) | Path { p_path; _ } -> Some (Path p_path) | Functor _ -> None - | TypeOf t -> Some (TypeOf t) + | TypeOf t -> Some (TypeOf t.t_desc) | With { w_substitutions; w_expr; _ } -> Some (With (w_substitutions, w_expr)) (** Query the top-comment of a signature. This is [s.doc] most of the time with diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index 8f9ea51506..012687907d 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -173,7 +173,7 @@ and moduletype_u_expr = ( "With", (t, e), Pair (List moduletype_substitution, moduletype_u_expr) ) - | TypeOf x -> C ("TypeOf", x, moduletype_typeof_t)) + | TypeOf x -> C ("TypeOf", x, moduletype_type_of_desc)) and moduletype_t = let open Lang.ModuleType in diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 0a1d1530bc..ca2c2d1239 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -592,8 +592,7 @@ and module_type_map_subs env id cexpr subs = | Path (`Resolved p) -> Some (`ModuleType p) | Path _ -> None | With (_, e) -> find_parent e - | TypeOf { t_desc = ModPath (`Resolved p); _ } - | TypeOf { t_desc = StructInclude (`Resolved p); _ } -> + | TypeOf (ModPath (`Resolved p)) | TypeOf (StructInclude (`Resolved p)) -> Some (`Module p) | TypeOf _ -> None in @@ -635,13 +634,13 @@ and u_module_type_expr : in let result : ModuleType.U.expr = With (subs', expr') in result - | TypeOf { t_desc; t_expansion } -> - let t_desc = - match t_desc with + | TypeOf t -> + let t = + match t with | ModPath p -> ModPath (module_path env p) | StructInclude p -> StructInclude (module_path env p) in - TypeOf { t_desc; t_expansion } + TypeOf t in inner expr diff --git a/src/xref2/component.ml b/src/xref2/component.ml index bca7b69a26..4f94f0b2ab 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -199,17 +199,12 @@ and ModuleType : sig | Signature of Signature.t | Functor of FunctorParameter.t * simple_expansion - type typeof_t = { - t_desc : type_of_desc; - t_expansion : simple_expansion option; - } - module U : sig type expr = | Path of Cpath.module_type | Signature of Signature.t | With of substitution list * expr - | TypeOf of typeof_t + | TypeOf of type_of_desc end type path_t = { @@ -223,6 +218,11 @@ and ModuleType : sig w_expr : U.expr; } + type typeof_t = { + t_desc : type_of_desc; + t_expansion : simple_expansion option; + } + type expr = | Path of path_t | Signature of Signature.t @@ -455,7 +455,7 @@ and Substitution : sig type_replacement : (TypeExpr.t * TypeDecl.Equation.t) PathTypeMap.t; module_type_replacement : ModuleType.expr ModuleTypeMap.t; path_invalidating_modules : Ident.path_module list; - module_type_of_invalidating_modules : Ident.path_module list; + module_type_of_invalidating_modules : ModuleType.expr PathModuleMap.t; unresolve_opaque_paths : bool; } end = @@ -744,7 +744,7 @@ module Fmt = struct | With (subs, e) -> Format.fprintf ppf "%a with [%a]" u_module_type_expr e substitution_list subs - | TypeOf { t_desc; _ } -> module_type_type_of_desc ppf t_desc + | TypeOf t -> module_type_type_of_desc ppf t and module_type_expr ppf mt = let open ModuleType in @@ -2121,14 +2121,13 @@ module Of_Lang = struct | With (w, e) -> let w' = List.map (with_module_type_substitution ident_map) w in With (w', u_module_type_expr ident_map e) - | TypeOf { t_desc; t_expansion } -> - let t_desc = - match t_desc with + | TypeOf t -> + let t = + match t with | ModPath p -> ModuleType.ModPath (module_path ident_map p) | StructInclude p -> StructInclude (module_path ident_map p) in - let t_expansion = Opt.map (simple_expansion ident_map) t_expansion in - TypeOf { t_desc; t_expansion } + TypeOf t and module_type_expr ident_map m = let open Odoc_model in diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 483cb0c676..d7adfdab79 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -182,17 +182,12 @@ and ModuleType : sig | Signature of Signature.t | Functor of FunctorParameter.t * simple_expansion - type typeof_t = { - t_desc : type_of_desc; - t_expansion : simple_expansion option; - } - module U : sig type expr = | Path of Cpath.module_type | Signature of Signature.t | With of substitution list * expr - | TypeOf of typeof_t + | TypeOf of type_of_desc end type path_t = { @@ -206,6 +201,11 @@ and ModuleType : sig w_expr : U.expr; } + type typeof_t = { + t_desc : type_of_desc; + t_expansion : simple_expansion option; + } + type expr = | Path of path_t | Signature of Signature.t @@ -426,7 +426,7 @@ and Substitution : sig type_replacement : (TypeExpr.t * TypeDecl.Equation.t) PathTypeMap.t; module_type_replacement : ModuleType.expr ModuleTypeMap.t; path_invalidating_modules : Ident.path_module list; - module_type_of_invalidating_modules : Ident.path_module list; + module_type_of_invalidating_modules : ModuleType.expr PathModuleMap.t; unresolve_opaque_paths : bool; } end diff --git a/src/xref2/expand_tools.ml b/src/xref2/expand_tools.ml index 5056796004..443190e6cd 100644 --- a/src/xref2/expand_tools.ml +++ b/src/xref2/expand_tools.ml @@ -25,7 +25,9 @@ let handle_expansion env id expansion = Subst.add_module (arg.id :> Ident.path_module) p rp Subst.identity in let subst = - Subst.mto_invalidate_module (arg.id :> Ident.path_module) subst + Subst.mto_invalidate_module + (arg.id :> Ident.path_module) + arg.expr subst in (env', Subst.module_type_expr subst expr) in diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 4d838d4404..7ef65ac10f 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -772,18 +772,8 @@ and u_module_type_expr map identifier = function With ( List.map (mty_substitution map identifier) subs, u_module_type_expr map identifier expr ) - | TypeOf { t_desc = ModPath p; t_expansion } -> - TypeOf - { - t_desc = ModPath (Path.module_ map p); - t_expansion = Opt.map (simple_expansion map identifier) t_expansion; - } - | TypeOf { t_desc = StructInclude p; t_expansion } -> - TypeOf - { - t_desc = StructInclude (Path.module_ map p); - t_expansion = Opt.map (simple_expansion map identifier) t_expansion; - } + | TypeOf (ModPath p) -> TypeOf (ModPath (Path.module_ map p)) + | TypeOf (StructInclude p) -> TypeOf (StructInclude (Path.module_ map p)) and module_type_expr map identifier = function | Component.ModuleType.Path { p_path; p_expansion } -> diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 5f896fc17a..67ffc59fe0 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -748,10 +748,8 @@ and u_module_type_expr : | Error e -> Errors.report ~what:(`Module_type_U cexpr) ~tools_error:e `Resolve; unresolved) - | TypeOf { t_desc = StructInclude p; t_expansion } -> - TypeOf { t_desc = StructInclude (module_path env p); t_expansion } - | TypeOf { t_desc = ModPath p; t_expansion } -> - TypeOf { t_desc = ModPath (module_path env p); t_expansion } + | TypeOf (StructInclude p) -> TypeOf (StructInclude (module_path env p)) + | TypeOf (ModPath p) -> TypeOf (ModPath (module_path env p)) and module_type_expr : Env.t -> Id.Signature.t -> ModuleType.expr -> ModuleType.expr = diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 9b1652c634..ffc233bbea 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -2,7 +2,7 @@ open Component exception Invalidated -exception MTOInvalidated +exception MTOInvalidated of Component.ModuleType.expr type ('a, 'b) or_replaced = Not_replaced of 'a | Replaced of 'b @@ -28,7 +28,7 @@ let identity = class_type = PathClassTypeMap.empty; type_replacement = PathTypeMap.empty; path_invalidating_modules = []; - module_type_of_invalidating_modules = []; + module_type_of_invalidating_modules = PathModuleMap.empty; unresolve_opaque_paths = false; } @@ -37,11 +37,11 @@ let unresolve_opaque_paths s = { s with unresolve_opaque_paths = true } let path_invalidate_module id t = { t with path_invalidating_modules = id :: t.path_invalidating_modules } -let mto_invalidate_module id t = +let mto_invalidate_module id e t = { t with module_type_of_invalidating_modules = - id :: t.module_type_of_invalidating_modules; + PathModuleMap.add id e t.module_type_of_invalidating_modules; } let add_module id p rp t = @@ -108,12 +108,12 @@ let add_module_type_replacement path mty t = ModuleTypeMap.add path mty t.module_type_replacement; } -let add_module_substitution : Ident.path_module -> t -> t = - fun id t -> +let add_module_substitution : Ident.path_module -> ModuleType.expr -> t -> t = + fun id e t -> { t with module_type_of_invalidating_modules = - id :: t.module_type_of_invalidating_modules; + PathModuleMap.add id e t.module_type_of_invalidating_modules; path_invalidating_modules = id :: t.path_invalidating_modules; module_ = PathModuleMap.add id `Substituted t.module_; } @@ -142,6 +142,15 @@ let rename_class_type : Ident.path_class_type -> Ident.path_class_type -> t -> t t.type_; } +let u_module_type_expr_of_module_type_expr (e : Component.ModuleType.expr) : + Component.ModuleType.U.expr = + match e with + | Path { p_path; _ } -> Path p_path + | Signature s -> Signature s + | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) + | Functor (_, _) -> assert false + | TypeOf { t_desc; _ } -> TypeOf t_desc + let rec substitute_vars vars t = let open TypeExpr in match t with @@ -629,12 +638,14 @@ and functor_parameter s t = and module_type_type_of_desc s t = let open Component.ModuleType in match t with - | ModPath p -> - if mto_module_path_invalidated s p then raise MTOInvalidated - else ModPath (module_path s p) - | StructInclude p -> - if mto_module_path_invalidated s p then raise MTOInvalidated - else StructInclude (module_path s p) + | ModPath p -> ( + match mto_module_path_invalidated s p with + | Some e -> raise (MTOInvalidated e) + | None -> ModPath (module_path s p)) + | StructInclude p -> ( + match mto_module_path_invalidated s p with + | Some e -> raise (MTOInvalidated e) + | None -> StructInclude (module_path s p)) and module_type_type_of_desc_noexn s t = let open Component.ModuleType in @@ -642,30 +653,37 @@ and module_type_type_of_desc_noexn s t = | ModPath p -> ModPath (module_path s p) | StructInclude p -> StructInclude (module_path s p) -and mto_module_path_invalidated : t -> Cpath.module_ -> bool = +(* CR lmaurer: This seems wrong! If a subpath of the path is invalidated, that's + not the same as the whole path being invalidated. But I can't seem to get this + to break. *) +and mto_module_path_invalidated : t -> Cpath.module_ -> ModuleType.expr option = fun s p -> match p with | `Resolved p' -> mto_resolved_module_path_invalidated s p' | `Substituted p' | `Dot (p', _) -> mto_module_path_invalidated s p' | `Module (`Module p', _) -> mto_resolved_module_path_invalidated s p' - | `Module (_, _) -> false - | `Apply (p1, p2) -> - mto_module_path_invalidated s p1 || mto_module_path_invalidated s p2 - | `Local (id, _) -> List.mem id s.module_type_of_invalidating_modules - | `Identifier _ -> false - | `Forward _ -> false - | `Root _ -> false + | `Module (_, _) -> None + | `Apply (p1, p2) -> ( + match mto_module_path_invalidated s p1 with + | Some _ as ans -> ans + | None -> mto_module_path_invalidated s p2) + | `Local (id, _) -> + PathModuleMap.find_opt id s.module_type_of_invalidating_modules + | `Identifier _ -> None + | `Forward _ -> None + | `Root _ -> None and mto_resolved_module_path_invalidated s p = match p with - | `Local id -> List.mem id s.module_type_of_invalidating_modules - | `Gpath _ -> false - | `Apply (p1, p2) -> - mto_resolved_module_path_invalidated s p1 - || mto_resolved_module_path_invalidated s p2 + | `Local id -> PathModuleMap.find_opt id s.module_type_of_invalidating_modules + | `Gpath _ -> None + | `Apply (p1, p2) -> ( + match mto_resolved_module_path_invalidated s p1 with + | Some _ as ans -> ans + | None -> mto_resolved_module_path_invalidated s p2) | `Module (`Module p, _) | `Substituted p -> mto_resolved_module_path_invalidated s p - | `Module (_, _) -> false + | `Module (_, _) -> None | `Alias (p1, _p2, _) -> mto_resolved_module_path_invalidated s p1 | `Subst (_p1, p2) -> mto_resolved_module_path_invalidated s p2 | `Hidden p -> mto_resolved_module_path_invalidated s p @@ -682,7 +700,7 @@ and u_module_type_expr s t = match eqn with | Path p -> Path p.p_path | Signature s -> Signature s - | TypeOf t -> TypeOf t + | TypeOf { t_desc; _ } -> TypeOf t_desc | With w -> With (w.w_substitutions, w.w_expr) | Functor _ -> (* non functor cannot be substituted away to a functor *) @@ -691,18 +709,10 @@ and u_module_type_expr s t = | With (subs, e) -> With (List.map (with_module_type_substitution s) subs, u_module_type_expr s e) - | TypeOf { t_desc; t_expansion = Some (Signature e) } -> ( - try - TypeOf - { - t_desc = module_type_type_of_desc s t_desc; - t_expansion = Some (Signature (apply_sig_map_sg s e)); - } - with MTOInvalidated -> u_module_type_expr s (Signature e)) - | TypeOf { t_expansion = Some (Functor _); _ } -> assert false - | TypeOf { t_desc; t_expansion = None } -> - TypeOf - { t_desc = module_type_type_of_desc_noexn s t_desc; t_expansion = None } + | TypeOf t -> ( + try TypeOf (module_type_type_of_desc s t) + with MTOInvalidated e -> + u_module_type_expr s (e |> u_module_type_expr_of_module_type_expr)) and module_type_of_simple_expansion : Component.ModuleType.simple_expansion -> Component.ModuleType.expr = @@ -736,7 +746,7 @@ and module_type_expr s t = t_desc = module_type_type_of_desc s t_desc; t_expansion = Some (simple_expansion s e); } - with MTOInvalidated -> + with MTOInvalidated _ -> module_type_expr s (module_type_of_simple_expansion e)) | TypeOf { t_desc; t_expansion = None } -> TypeOf @@ -1091,6 +1101,6 @@ and apply_sig_map s items removed = in let dont_recompile = List.length s.path_invalidating_modules = 0 - && List.length s.module_type_of_invalidating_modules = 0 + && PathModuleMap.cardinal s.module_type_of_invalidating_modules = 0 in (inner items [], removed_items s removed, dont_recompile) diff --git a/src/xref2/subst.mli b/src/xref2/subst.mli index 1afb221526..238081ce9e 100644 --- a/src/xref2/subst.mli +++ b/src/xref2/subst.mli @@ -9,7 +9,8 @@ val unresolve_opaque_paths : t -> t val path_invalidate_module : Ident.path_module -> t -> t -val mto_invalidate_module : Ident.path_module -> t -> t +val mto_invalidate_module : + Ident.path_module -> Component.ModuleType.expr -> t -> t val add_module : Ident.path_module -> Cpath.module_ -> Cpath.Resolved.module_ -> t -> t @@ -30,7 +31,8 @@ val add_type_replacement : val add_module_type_replacement : Ident.module_type -> ModuleType.expr -> t -> t -val add_module_substitution : Ident.path_module -> t -> t +val add_module_substitution : + Ident.path_module -> Component.ModuleType.expr -> t -> t val type_ : t -> Component.TypeDecl.t -> Component.TypeDecl.t diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index e9c0ae6af6..6f15d5723d 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -1627,8 +1627,17 @@ and signature_of_u_module_type_expr : signature_of_u_module_type_expr ~mark_substituted env s >>= fun sg -> let subs = unresolve_subs subs in handle_signature_with_subs ~mark_substituted env sg subs - | TypeOf { t_expansion = Some (Signature sg); _ } -> Ok sg - | TypeOf { t_desc; _ } -> Error (`UnexpandedTypeOf t_desc) + | TypeOf t -> + expansion_of_module_type_type_of_desc env t >>= assert_not_functor + +and expansion_of_module_type_type_of_desc : + Env.t -> + Component.ModuleType.type_of_desc -> + (expansion, expansion_of_module_error) Result.result = + fun env desc -> + match desc with + | ModPath p -> expansion_of_module_path env p ~strengthen:false + | StructInclude p -> expansion_of_module_path env p ~strengthen:true (* and expansion_of_simple_expansion : Component.ModuleType.simple_expansion -> expansion = @@ -1716,7 +1725,7 @@ and umty_of_mty : Component.ModuleType.expr -> Component.ModuleType.U.expr = function | Signature sg -> Signature sg | Path { p_path; _ } -> Path p_path - | TypeOf t -> TypeOf t + | TypeOf { t_desc; _ } -> TypeOf t_desc | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) | Functor _ -> assert false @@ -1734,21 +1743,13 @@ and fragmap : let open Component.Module in match decl with | Alias (path, _) -> - expansion_of_module_path env ~strengthen:true path - >>= assert_not_functor - >>= fun sg -> Ok (ModuleType (With { w_substitutions = [ subst ]; w_expansion = None; - w_expr = - TypeOf - { - t_desc = StructInclude path; - t_expansion = Some (Signature sg); - }; + w_expr = TypeOf (StructInclude path); })) | ModuleType mty' -> Ok @@ -1799,14 +1800,21 @@ and fragmap : Component.Signature.RType (id, texpr, eq) :: removed )) | Component.Signature.Module (id, r, m), { module_ = Some (id', fn); _ } when Ident.Name.module_ id = id' -> ( - fn (Component.Delayed.get m) >>= function + let m = Component.Delayed.get m in + fn m >>= function | Left x -> + let old_ty = + match m.type_ with + | ModuleType e -> e + | Alias (m, exp) -> + TypeOf { t_desc = StructInclude m; t_expansion = exp } + in Ok ( Component.Signature.Module (id, r, Component.Delayed.put (fun () -> x)) :: items, true, - id :: subbed_modules, + (id, old_ty) :: subbed_modules, removed ) | Right y -> Ok @@ -1967,11 +1975,12 @@ and fragmap : let map_items items = (* Invalidate resolved paths containing substituted idents - See the `With11` test for an example of why this is necessary *) - let sub_of_substituted x sub = + let sub_of_substituted (x, exp) sub = let x = (x :> Ident.path_module) in - (if mark_substituted then Subst.add_module_substitution x sub else sub) + (if mark_substituted then Subst.add_module_substitution x exp sub + else sub) |> Subst.path_invalidate_module x - |> Subst.mto_invalidate_module x + |> Subst.mto_invalidate_module x exp in let substituted_sub = diff --git a/src/xref2/type_of.ml b/src/xref2/type_of.ml index 844d6da385..b16d124f38 100644 --- a/src/xref2/type_of.ml +++ b/src/xref2/type_of.ml @@ -89,7 +89,7 @@ and module_type env m = and module_type_expr_typeof env (id : Id.Signature.t) t = let open Odoc_model.Lang.ModuleType in let p, strengthen = - match t.t_desc with ModPath p -> (p, false) | StructInclude p -> (p, true) + match t with ModPath p -> (p, false) | StructInclude p -> (p, true) in let cp = Component.Of_Lang.(module_path (empty ()) p) in let open Expand_tools in @@ -107,7 +107,7 @@ and module_type_expr env (id : Id.Signature.t) expr = | Signature sg -> Signature (signature env sg) | With w -> With { w with w_expr = u_module_type_expr env id w.w_expr } | TypeOf t -> ( - match module_type_expr_typeof env id t with + match module_type_expr_typeof env id t.t_desc with | Ok e -> let se = Lang_of.(simple_expansion (empty ()) id e) in TypeOf { t with t_expansion = Some (simple_expansion env se) } @@ -123,17 +123,7 @@ and u_module_type_expr env id expr = | Path _ -> expr | Signature sg -> Signature (signature env sg) | With (subs, w) -> With (subs, u_module_type_expr env id w) - | TypeOf t -> ( - match module_type_expr_typeof env id t with - | Ok e -> - let se = Lang_of.(simple_expansion (empty ()) id e) in - TypeOf { t with t_expansion = Some (simple_expansion env se) } - | Error e - when Errors.is_unexpanded_module_type_of (e :> Errors.Tools_error.any) - -> - again := true; - expr - | Error _e -> expr) + | TypeOf t -> TypeOf t and functor_parameter env p = { p with expr = module_type_expr env (p.id :> Id.Signature.t) p.expr } diff --git a/test/xref2/transparent_ascription.t/run.t b/test/xref2/transparent_ascription.t/run.t new file mode 100644 index 0000000000..8d4ce9fc63 --- /dev/null +++ b/test/xref2/transparent_ascription.t/run.t @@ -0,0 +1,1113 @@ +Transparent ascription +====================== + + $ ocamlc -c -bin-annot test.mli + $ odoc compile test.cmti + $ odoc_print test.odoc -r Basic.P.N + { + "id": { + "`Module": [ + { + "`Module": [ + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Basic" ] }, "P" + ] + }, + "N" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "Signature": { + "items": [ + { + "Type": [ + "Ordinary", + { + "id": { + "`Type": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, "Basic" + ] + }, + "P" + ] + }, + "N" + ] + }, + "t" + ] + }, + "locs": "None", + "doc": [], + "equation": { + "params": [], + "private_": "false", + "manifest": "None", + "constraints": [] + }, + "representation": "None" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + }, + "canonical": "None", + "hidden": "false" + } + $ odoc_print test.odoc -r Nested.P1.N1 + { + "id": { + "`Module": [ + { + "`Module": [ + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, "P1" + ] + }, + "N1" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "Signature": { + "items": [ + { + "Module": [ + "Ordinary", + { + "id": { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, "Nested" + ] + }, + "P1" + ] + }, + "N1" + ] + }, + "M" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "Path": { + "p_expansion": { + "Some": { + "Signature": { + "items": [ + { + "Type": [ + "Ordinary", + { + "id": { + "`Type": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Root": [ + "None", "Test" + ] + }, + "Nested" + ] + }, + "P1" + ] + }, + "N1" + ] + }, + "M" + ] + }, + "t" + ] + }, + "locs": "None", + "doc": [], + "equation": { + "params": [], + "private_": "false", + "manifest": "None", + "constraints": [] + }, + "representation": "None" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + }, + "p_path": { + "`Resolved": { + "`Identifier": { + "`ModuleType": [ + { "`Root": [ "None", "Test" ] }, "T" + ] + } + } + } + } + } + }, + "canonical": "None", + "hidden": "false" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + }, + "canonical": "None", + "hidden": "false" + } + $ odoc_print test.odoc -r Nested.P1.N2 + { + "id": { + "`Module": [ + { + "`Module": [ + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, "P1" + ] + }, + "N2" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "Signature": { + "items": [ + { + "Type": [ + "Ordinary", + { + "id": { + "`Type": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, "Nested" + ] + }, + "P1" + ] + }, + "N2" + ] + }, + "t" + ] + }, + "locs": "None", + "doc": [], + "equation": { + "params": [], + "private_": "false", + "manifest": "None", + "constraints": [] + }, + "representation": "None" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + }, + "canonical": "None", + "hidden": "false" + } + $ odoc_print test.odoc -r Nested.P2.N1 + { + "id": { + "`Module": [ + { + "`Module": [ + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, "P2" + ] + }, + "N1" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "Signature": { + "items": [ + { + "Module": [ + "Ordinary", + { + "id": { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, "Nested" + ] + }, + "P2" + ] + }, + "N1" + ] + }, + "M" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "Path": { + "p_expansion": { + "Some": { + "Signature": { + "items": [ + { + "Type": [ + "Ordinary", + { + "id": { + "`Type": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Root": [ + "None", "Test" + ] + }, + "Nested" + ] + }, + "P2" + ] + }, + "N1" + ] + }, + "M" + ] + }, + "t" + ] + }, + "locs": "None", + "doc": [], + "equation": { + "params": [], + "private_": "false", + "manifest": "None", + "constraints": [] + }, + "representation": "None" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + }, + "p_path": { + "`Resolved": { + "`Identifier": { + "`ModuleType": [ + { "`Root": [ "None", "Test" ] }, "T" + ] + } + } + } + } + } + }, + "canonical": "None", + "hidden": "false" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + }, + "canonical": "None", + "hidden": "false" + } + $ odoc_print test.odoc -r Nested.P2.N2 + { + "id": { + "`Module": [ + { + "`Module": [ + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, "P2" + ] + }, + "N2" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "Signature": { + "items": [ + { + "Type": [ + "Ordinary", + { + "id": { + "`Type": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, "Nested" + ] + }, + "P2" + ] + }, + "N2" + ] + }, + "t" + ] + }, + "locs": "None", + "doc": [], + "equation": { + "params": [], + "private_": "false", + "manifest": "None", + "constraints": [] + }, + "representation": "None" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + }, + "canonical": "None", + "hidden": "false" + } + $ odoc_print test.odoc -r Via_alias.P.N + { + "id": { + "`Module": [ + { + "`Module": [ + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Via_alias" ] }, + "P" + ] + }, + "N" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "Signature": { + "items": [ + { + "Type": [ + "Ordinary", + { + "id": { + "`Type": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, "Via_alias" + ] + }, + "P" + ] + }, + "N" + ] + }, + "t" + ] + }, + "locs": "None", + "doc": [], + "equation": { + "params": [], + "private_": "false", + "manifest": { + "Some": { + "Constr": [ + { + "`Resolved": { + "`Type": [ + { + "`Alias": [ + { + "`Identifier": { + "`Module": [ + { "`Root": [ "None", "Test" ] }, + "Int" + ] + } + }, + { + "`Identifier": { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Root": [ "None", "Test" ] + }, + "Via_alias" + ] + }, + "P" + ] + }, + "M" + ] + } + } + ] + }, + "t" + ] + } + }, + [] + ] + } + }, + "constraints": [] + }, + "representation": "None" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + }, + "canonical": "None", + "hidden": "false" + } + $ odoc_print test.odoc -r Cascade.P.N1 + { + "id": { + "`Module": [ + { + "`Module": [ + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Cascade" ] }, "P" + ] + }, + "N1" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "TypeOf": { + "t_desc": { + "ModPath": { + "`Resolved": { + "`Identifier": { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, "Cascade" + ] + }, + "P" + ] + }, + "O" + ] + } + } + } + }, + "t_expansion": { + "Some": { + "Signature": { + "items": [ + { + "Module": [ + "Ordinary", + { + "id": { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, + "Cascade" + ] + }, + "P" + ] + }, + "N1" + ] + }, + "I" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "Signature": { + "items": [ + { + "Type": [ + "Ordinary", + { + "id": { + "`Type": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Root": [ + "None", "Test" + ] + }, + "Cascade" + ] + }, + "P" + ] + }, + "N1" + ] + }, + "I" + ] + }, + "t" + ] + }, + "locs": "None", + "doc": [], + "equation": { + "params": [], + "private_": "false", + "manifest": "None", + "constraints": [] + }, + "representation": "None" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + }, + "canonical": "None", + "hidden": "false" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + } + } + } + }, + "canonical": "None", + "hidden": "false" + } + $ odoc_print test.odoc -r Cascade.P.N2 + { + "id": { + "`Module": [ + { + "`Module": [ + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Cascade" ] }, "P" + ] + }, + "N2" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "TypeOf": { + "t_desc": { + "ModPath": { + "`Resolved": { + "`Module": [ + { + "`Identifier": { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, "Cascade" + ] + }, + "P" + ] + }, + "O" + ] + } + }, + "I" + ] + } + } + }, + "t_expansion": { + "Some": { + "Signature": { + "items": [ + { + "Type": [ + "Ordinary", + { + "id": { + "`Type": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, + "Cascade" + ] + }, + "P" + ] + }, + "N2" + ] + }, + "t" + ] + }, + "locs": "None", + "doc": [], + "equation": { + "params": [], + "private_": "false", + "manifest": "None", + "constraints": [] + }, + "representation": "None" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + } + } + } + }, + "canonical": "None", + "hidden": "false" + } + $ odoc_print test.odoc -r In_functor_parameter.P.G + { + "id": { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, "In_functor_parameter" + ] + }, + "P" + ] + }, + "G" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "ModuleType": { + "Functor": [ + { + "Named": { + "id": { + "`Parameter": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, + "In_functor_parameter" + ] + }, + "P" + ] + }, + "G" + ] + }, + "X" + ] + }, + "expr": { + "Signature": { + "items": [ + { + "Type": [ + "Ordinary", + { + "id": { + "`Type": [ + { + "`Parameter": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, + "In_functor_parameter" + ] + }, + "P" + ] + }, + "G" + ] + }, + "X" + ] + }, + "t" + ] + }, + "locs": "None", + "doc": [], + "equation": { + "params": [], + "private_": "false", + "manifest": "None", + "constraints": [] + }, + "representation": "None" + } + ] + }, + { + "Value": { + "id": { + "`Value": [ + { + "`Parameter": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, + "In_functor_parameter" + ] + }, + "P" + ] + }, + "G" + ] + }, + "X" + ] + }, + "plus" + ] + }, + "locs": "None", + "doc": [], + "type_": { + "Arrow": [ + "None", + { + "Constr": [ + { + "`Resolved": { + "`Identifier": { + "`Type": [ + { + "`Parameter": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Root": [ + "None", "Test" + ] + }, + "In_functor_parameter" + ] + }, + "P" + ] + }, + "G" + ] + }, + "X" + ] + }, + "t" + ] + } + } + }, + [] + ] + }, + { + "Arrow": [ + "None", + { + "Constr": [ + { + "`Resolved": { + "`Identifier": { + "`Type": [ + { + "`Parameter": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Root": [ + "None", "Test" + ] + }, + "In_functor_parameter" + ] + }, + "P" + ] + }, + "G" + ] + }, + "X" + ] + }, + "t" + ] + } + } + }, + [] + ] + }, + { + "Constr": [ + { + "`Resolved": { + "`Identifier": { + "`Type": [ + { + "`Parameter": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Root": [ + "None", "Test" + ] + }, + "In_functor_parameter" + ] + }, + "P" + ] + }, + "G" + ] + }, + "X" + ] + }, + "t" + ] + } + } + }, + [] + ] + } + ] + } + ] + }, + "value": "Abstract" + } + } + ], + "compiled": "true", + "doc": [] + } + } + } + }, + { + "Signature": { + "items": [ + { + "Type": [ + "Ordinary", + { + "id": { + "`Type": [ + { + "`Result": { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { "`Root": [ "None", "Test" ] }, + "In_functor_parameter" + ] + }, + "P" + ] + }, + "G" + ] + } + }, + "t" + ] + }, + "locs": "None", + "doc": [], + "equation": { + "params": [], + "private_": "false", + "manifest": "None", + "constraints": [] + }, + "representation": "None" + } + ] + } + ], + "compiled": "true", + "doc": [] + } + } + ] + } + }, + "canonical": "None", + "hidden": "false" + } + $ odoc link test.odoc + $ odoc html-generate test.odocl -o html + $ odoc support-files -o html + $ cp -a html /tmp/test-html diff --git a/test/xref2/transparent_ascription.t/test.mli b/test/xref2/transparent_ascription.t/test.mli new file mode 100644 index 0000000000..3fe379b7a9 --- /dev/null +++ b/test/xref2/transparent_ascription.t/test.mli @@ -0,0 +1,101 @@ +module type T = sig + type t +end + +module Int : sig + type t = int + + val plus : t -> t -> t +end + +(* Since [module type of] is interpreted "eagerly," subsequent substitutions + should not change them, even when odoc preserves the [module type of] + expression. Thus even though substitution can add information, we need to + remove that information from any [module type of] for the substituted + module. *) + +module Basic : sig + module type S = sig + module M : T + + module N : module type of M + end + + (* [P.N] should just have type [T] because [module type of M] has already + evaluated to [T] *) + module P : S with module M = Int +end + +(* This should apply even when the module type that changes is nested. *) + +module Wrapped_int : sig + module M = Int +end + +module Nested : sig + module type S = sig + module O : sig + module M : T + end + + module N1 : module type of O + + module N2 : module type of O.M + end + + module P1 : S with module O = Wrapped_int + + module P2 : S with module O.M = Int +end + +(* Same when the [module type of] goes through an alias, though oddly [P.t] ends + up strengthened to [type t = M.t] since that's the module type of [M']. *) + +module Via_alias : sig + module type S = sig + module M : T + + module M' = M + + module N : module type of M' + end + + module P : S with module M = Int +end + +module Cascade : sig + module type S = sig + module M : T + + module O : sig + module I : module type of M + end + + module N1 : module type of O + + module N2 : module type of O.I + end + + module P : S with module M = Int +end + +(* The same logic should apply to functor parameters, but _in reverse_ since + functor types are contravariant in their parameters. In other words, a + substitution can _remove_ information from a parameter type and we need + to _put that information back_ into the [module type of] result. *) + +module Identity (T : T) : T + +module In_functor_parameter : sig + module type S = sig + module F (X : sig + type t + + val plus : t -> t -> t + end) : T + + module G : module type of F + end + + module P : S with module F = Identity +end From 6d5864cdd9ed4885b5e0627d6a6ee57f4b4f246b Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 21 Apr 2023 16:14:48 +0100 Subject: [PATCH 02/18] Avoid `Map.S.find_opt` for compatibility --- src/xref2/subst.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index ffc233bbea..4fc7886ca7 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -667,15 +667,20 @@ and mto_module_path_invalidated : t -> Cpath.module_ -> ModuleType.expr option = match mto_module_path_invalidated s p1 with | Some _ as ans -> ans | None -> mto_module_path_invalidated s p2) - | `Local (id, _) -> - PathModuleMap.find_opt id s.module_type_of_invalidating_modules + | `Local (id, _) -> ( + match PathModuleMap.find id s.module_type_of_invalidating_modules with + | exception Not_found -> None + | mty -> Some mty) | `Identifier _ -> None | `Forward _ -> None | `Root _ -> None and mto_resolved_module_path_invalidated s p = match p with - | `Local id -> PathModuleMap.find_opt id s.module_type_of_invalidating_modules + | `Local id -> ( + match PathModuleMap.find id s.module_type_of_invalidating_modules with + | exception Not_found -> None + | mty -> Some mty) | `Gpath _ -> None | `Apply (p1, p2) -> ( match mto_resolved_module_path_invalidated s p1 with From 900a1c54abb54a12bbfdf49eb588eb1925a2fd64 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 21 Apr 2023 16:22:50 +0100 Subject: [PATCH 03/18] Fix formatting in cram test --- test/xref2/transparent_ascription.t/run.t | 95 ++++++++++++++--------- 1 file changed, 59 insertions(+), 36 deletions(-) diff --git a/test/xref2/transparent_ascription.t/run.t b/test/xref2/transparent_ascription.t/run.t index 8d4ce9fc63..a6fa39485a 100644 --- a/test/xref2/transparent_ascription.t/run.t +++ b/test/xref2/transparent_ascription.t/run.t @@ -9,7 +9,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Basic" ] }, "P" + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Basic" ] }, + "P" ] }, "N" @@ -33,7 +34,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Root": [ "None", "Test" ] }, "Basic" + { "`Root": [ "None", "Test" ] }, + "Basic" ] }, "P" @@ -72,7 +74,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, "P1" + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, + "P1" ] }, "N1" @@ -96,7 +99,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Root": [ "None", "Test" ] }, "Nested" + { "`Root": [ "None", "Test" ] }, + "Nested" ] }, "P1" @@ -173,7 +177,8 @@ Transparent ascription "`Resolved": { "`Identifier": { "`ModuleType": [ - { "`Root": [ "None", "Test" ] }, "T" + { "`Root": [ "None", "Test" ] }, + "T" ] } } @@ -201,7 +206,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, "P1" + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, + "P1" ] }, "N2" @@ -225,7 +231,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Root": [ "None", "Test" ] }, "Nested" + { "`Root": [ "None", "Test" ] }, + "Nested" ] }, "P1" @@ -264,7 +271,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, "P2" + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, + "P2" ] }, "N1" @@ -288,7 +296,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Root": [ "None", "Test" ] }, "Nested" + { "`Root": [ "None", "Test" ] }, + "Nested" ] }, "P2" @@ -365,7 +374,8 @@ Transparent ascription "`Resolved": { "`Identifier": { "`ModuleType": [ - { "`Root": [ "None", "Test" ] }, "T" + { "`Root": [ "None", "Test" ] }, + "T" ] } } @@ -393,7 +403,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, "P2" + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, + "P2" ] }, "N2" @@ -417,7 +428,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Root": [ "None", "Test" ] }, "Nested" + { "`Root": [ "None", "Test" ] }, + "Nested" ] }, "P2" @@ -481,7 +493,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Root": [ "None", "Test" ] }, "Via_alias" + { "`Root": [ "None", "Test" ] }, + "Via_alias" ] }, "P" @@ -515,24 +528,29 @@ Transparent ascription } }, { - "`Identifier": { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Root": [ "None", "Test" ] - }, - "Via_alias" - ] - }, - "P" - ] - }, - "M" - ] - } + "`Identifier": [ + { + "`Module": [ + { + "`Module": [ + { + "`Module": [ + { + "`Root": [ + "None", "Test" + ] + }, + "Via_alias" + ] + }, + "P" + ] + }, + "M" + ] + }, + "false" + ] } ] }, @@ -565,7 +583,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Cascade" ] }, "P" + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Cascade" ] }, + "P" ] }, "N1" @@ -585,7 +604,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Root": [ "None", "Test" ] }, "Cascade" + { "`Root": [ "None", "Test" ] }, + "Cascade" ] }, "P" @@ -707,7 +727,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Cascade" ] }, "P" + { "`Module": [ { "`Root": [ "None", "Test" ] }, "Cascade" ] }, + "P" ] }, "N2" @@ -729,7 +750,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Root": [ "None", "Test" ] }, "Cascade" + { "`Root": [ "None", "Test" ] }, + "Cascade" ] }, "P" @@ -805,7 +827,8 @@ Transparent ascription "`Module": [ { "`Module": [ - { "`Root": [ "None", "Test" ] }, "In_functor_parameter" + { "`Root": [ "None", "Test" ] }, + "In_functor_parameter" ] }, "P" From 970e758b8b130cdfe425709f39a3e2e92d678618 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 27 Apr 2023 17:01:56 +0200 Subject: [PATCH 04/18] Get rid of Type_of The resolution of `module type of` no longer need to be done incrementally and can be done while resolving module types in general. The `Type_of` module has no other purposes since the change in `U.TypeOf` and can be removed. Co-authored-by: Jon Ludlam --- src/xref2/compile.ml | 3 +- src/xref2/tools.ml | 7 +- src/xref2/type_of.ml | 164 ------------------- src/xref2/type_of.mli | 9 - test/xref2/multi_file_module_type_of.t/run.t | 2 +- 5 files changed, 8 insertions(+), 177 deletions(-) delete mode 100644 src/xref2/type_of.ml delete mode 100644 src/xref2/type_of.mli diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index ca2c2d1239..f0516a51aa 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -60,8 +60,7 @@ let rec unit env t = and content env id = let open Compilation_unit in function - | Module m -> - let sg = Type_of.signature env m in + | Module sg -> let sg = signature env (id :> Id.Signature.t) sg in Module sg | Pack p -> Pack p diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index 6f15d5723d..5e1a33e7f1 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -1682,7 +1682,12 @@ and expansion_of_module_type_expr : | Component.ModuleType.TypeOf { t_expansion = Some (Signature sg); _ } -> Ok (Signature sg) | Component.ModuleType.TypeOf { t_desc; _ } -> - Error (`UnexpandedTypeOf t_desc) + let cp, strengthen = + match t_desc with + | ModPath p -> (p, false) + | StructInclude p -> (p, true) + in + expansion_of_module_path env ~strengthen cp and expansion_of_module_type : Env.t -> diff --git a/src/xref2/type_of.ml b/src/xref2/type_of.ml deleted file mode 100644 index b16d124f38..0000000000 --- a/src/xref2/type_of.ml +++ /dev/null @@ -1,164 +0,0 @@ -(* Type_of.ml *) - -(* Deals with expanding `module type of` expressions *) - -open Odoc_model -open Lang -module Id = Odoc_model.Paths.Identifier - -let again = ref false - -let rec signature : Env.t -> Signature.t -> Signature.t = - fun env sg -> - let items, _ = signature_items env sg.items in - { sg with items } - -and signature_items : Env.t -> Signature.item list -> _ = - fun initial_env s -> - let open Signature in - let rec loop items env xs = - match xs with - | [] -> (List.rev items, env) - | item :: rest -> ( - match item with - | Module (Nonrec, _) -> assert false - | Module (r, m) -> - let add_to_env env m = - let ty = - Component.Delayed.( - put (fun () -> Component.Of_Lang.(module_ (empty ()) m))) - in - Env.add_module (m.id :> Paths.Identifier.Path.Module.t) ty [] env - in - let env = - match r with - | Nonrec -> assert false - | Ordinary | And -> env - | Rec -> - let rec find modules rest = - match rest with - | Module (And, m') :: sgs -> find (m' :: modules) sgs - | Module (_, _) :: _ -> List.rev modules - | _ :: sgs -> find modules sgs - | [] -> List.rev modules - in - let modules = find [ m ] rest in - List.fold_left add_to_env env modules - in - let m' = module_ env m in - let env'' = - match r with - | Nonrec -> assert false - | And | Rec -> env - | Ordinary -> add_to_env env m' - in - loop (Module (r, m') :: items) env'' rest - | ModuleSubstitution m -> - let env' = Env.open_module_substitution m env in - loop (item :: items) env' rest - | ModuleType mt -> - let m' = module_type env mt in - let ty = Component.Of_Lang.(module_type (empty ()) m') in - let env' = Env.add_module_type mt.id ty env in - loop (ModuleType (module_type env mt) :: items) env' rest - | Include i -> - let i', env' = include_ env i in - loop (Include i' :: items) env' rest - | item -> loop (item :: items) env rest) - in - loop [] initial_env s - -and module_ env m = - match m.type_ with - | Alias _ -> m - | ModuleType expr -> - { - m with - type_ = ModuleType (module_type_expr env (m.id :> Id.Signature.t) expr); - } - -and module_type env m = - match m.expr with - | None -> m - | Some expr -> - { - m with - expr = Some (module_type_expr env (m.id :> Id.Signature.t) expr); - } - -and module_type_expr_typeof env (id : Id.Signature.t) t = - let open Odoc_model.Lang.ModuleType in - let p, strengthen = - match t with ModPath p -> (p, false) | StructInclude p -> (p, true) - in - let cp = Component.Of_Lang.(module_path (empty ()) p) in - let open Expand_tools in - let open Utils.ResultMonad in - Tools.expansion_of_module_path env ~strengthen cp >>= fun exp -> - handle_expansion env id exp >>= fun (_env, e) -> Ok e - -and module_type_expr env (id : Id.Signature.t) expr = - match expr with - | Path _ -> expr - | Functor (Unit, expr) -> Functor (Unit, module_type_expr env id expr) - | Functor (Named p, expr) -> - let env = Env.add_functor_parameter (Named p) env in - Functor (Named (functor_parameter env p), module_type_expr env id expr) - | Signature sg -> Signature (signature env sg) - | With w -> With { w with w_expr = u_module_type_expr env id w.w_expr } - | TypeOf t -> ( - match module_type_expr_typeof env id t.t_desc with - | Ok e -> - let se = Lang_of.(simple_expansion (empty ()) id e) in - TypeOf { t with t_expansion = Some (simple_expansion env se) } - | Error e - when Errors.is_unexpanded_module_type_of (e :> Errors.Tools_error.any) - -> - again := true; - expr - | Error _e -> expr) - -and u_module_type_expr env id expr = - match expr with - | Path _ -> expr - | Signature sg -> Signature (signature env sg) - | With (subs, w) -> With (subs, u_module_type_expr env id w) - | TypeOf t -> TypeOf t - -and functor_parameter env p = - { p with expr = module_type_expr env (p.id :> Id.Signature.t) p.expr } - -and simple_expansion : - Env.t -> ModuleType.simple_expansion -> ModuleType.simple_expansion = - fun env -> function - | Signature sg -> Signature (signature env sg) - | Functor (Named n, sg) -> - Functor (Named (functor_parameter env n), simple_expansion env sg) - | Functor (Unit, sg) -> Functor (Unit, simple_expansion env sg) - -and include_ env i = - let decl = - match i.decl with - | Alias _ -> i.decl - | ModuleType t -> ModuleType (u_module_type_expr env i.parent t) - in - let items, env' = - let { Include.content; _ } = i.expansion in - signature_items env content.items - in - ( { - i with - expansion = - { i.expansion with content = { i.expansion.content with items } }; - decl; - }, - env' ) - -let signature env = - let rec loop sg = - again := false; - let sg' = signature env sg in - Tools.reset_caches (); - if !again then if sg' = sg then sg else loop sg' else sg' - in - loop diff --git a/src/xref2/type_of.mli b/src/xref2/type_of.mli deleted file mode 100644 index e77f374438..0000000000 --- a/src/xref2/type_of.mli +++ /dev/null @@ -1,9 +0,0 @@ -open Odoc_model.Lang -(** The purpose of this module is to expand module type - expressions of the form [module type of]. This is necessary - so odoc can keep track of these expressions but mainting the - semantics of the underlying OCaml. *) - -val signature : Env.t -> Signature.t -> Signature.t -(** Expand all of the [module type of] expressions within the - given signature *) diff --git a/test/xref2/multi_file_module_type_of.t/run.t b/test/xref2/multi_file_module_type_of.t/run.t index c6b5a70d07..f0d3d2947b 100644 --- a/test/xref2/multi_file_module_type_of.t/run.t +++ b/test/xref2/multi_file_module_type_of.t/run.t @@ -37,7 +37,7 @@ another warning when we run `odoc compile` on test2.cmti: $ odoc compile --package foo test2.cmti -I . --enable-missing-root-warning File "test2.cmti": Warning: Couldn't find the following modules: - Test1 + Test0 Crucially though, we do expect this command to have terminated! From 7c1360b88b31356f7c85e56eee5d5913b289bc35 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 27 Apr 2023 18:15:15 +0200 Subject: [PATCH 05/18] Reduce noise in transparent ascription test --- test/xref2/transparent_ascription.t/run.t | 1176 ++------------------- 1 file changed, 95 insertions(+), 1081 deletions(-) diff --git a/test/xref2/transparent_ascription.t/run.t b/test/xref2/transparent_ascription.t/run.t index a6fa39485a..1d0ed5808f 100644 --- a/test/xref2/transparent_ascription.t/run.t +++ b/test/xref2/transparent_ascription.t/run.t @@ -3,1133 +3,147 @@ Transparent ascription $ ocamlc -c -bin-annot test.mli $ odoc compile test.cmti - $ odoc_print test.odoc -r Basic.P.N + +The following modules should be expanded (and be a `"Signature": {}`): + + $ odoc_print test.odoc -r Basic.P.N | jq ".type_ | (.ModuleType.Signature|={})" { - "id": { - "`Module": [ - { - "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Basic" ] }, - "P" - ] - }, - "N" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "Signature": { - "items": [ - { - "Type": [ - "Ordinary", - { - "id": { - "`Type": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "Basic" - ] - }, - "P" - ] - }, - "N" - ] - }, - "t" - ] - }, - "locs": "None", - "doc": [], - "equation": { - "params": [], - "private_": "false", - "manifest": "None", - "constraints": [] - }, - "representation": "None" - } - ] - } - ], - "compiled": "true", - "doc": [] - } - } - }, - "canonical": "None", - "hidden": "false" + "ModuleType": { + "Signature": {} + } } - $ odoc_print test.odoc -r Nested.P1.N1 + + $ odoc_print test.odoc -r Nested.P1.N1 | jq ".type_ | (.ModuleType.Signature|={})" { - "id": { - "`Module": [ - { - "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, - "P1" - ] - }, - "N1" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "Signature": { - "items": [ - { - "Module": [ - "Ordinary", - { - "id": { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "Nested" - ] - }, - "P1" - ] - }, - "N1" - ] - }, - "M" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "Path": { - "p_expansion": { - "Some": { - "Signature": { - "items": [ - { - "Type": [ - "Ordinary", - { - "id": { - "`Type": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Root": [ - "None", "Test" - ] - }, - "Nested" - ] - }, - "P1" - ] - }, - "N1" - ] - }, - "M" - ] - }, - "t" - ] - }, - "locs": "None", - "doc": [], - "equation": { - "params": [], - "private_": "false", - "manifest": "None", - "constraints": [] - }, - "representation": "None" - } - ] - } - ], - "compiled": "true", - "doc": [] - } - } - }, - "p_path": { - "`Resolved": { - "`Identifier": { - "`ModuleType": [ - { "`Root": [ "None", "Test" ] }, - "T" - ] - } - } - } - } - } - }, - "canonical": "None", - "hidden": "false" - } - ] - } - ], - "compiled": "true", - "doc": [] - } - } - }, - "canonical": "None", - "hidden": "false" + "ModuleType": { + "Signature": {} + } } - $ odoc_print test.odoc -r Nested.P1.N2 + + $ odoc_print test.odoc -r Nested.P1.N2 | jq ".type_ | (.ModuleType.Signature|={})" { - "id": { - "`Module": [ - { - "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, - "P1" - ] - }, - "N2" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "Signature": { - "items": [ - { - "Type": [ - "Ordinary", - { - "id": { - "`Type": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "Nested" - ] - }, - "P1" - ] - }, - "N2" - ] - }, - "t" - ] - }, - "locs": "None", - "doc": [], - "equation": { - "params": [], - "private_": "false", - "manifest": "None", - "constraints": [] - }, - "representation": "None" - } - ] - } - ], - "compiled": "true", - "doc": [] - } - } - }, - "canonical": "None", - "hidden": "false" + "ModuleType": { + "Signature": {} + } } - $ odoc_print test.odoc -r Nested.P2.N1 + + $ odoc_print test.odoc -r Nested.P2.N1 | jq ".type_ | (.ModuleType.Signature|={})" { - "id": { - "`Module": [ - { - "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, - "P2" - ] - }, - "N1" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "Signature": { - "items": [ - { - "Module": [ - "Ordinary", - { - "id": { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "Nested" - ] - }, - "P2" - ] - }, - "N1" - ] - }, - "M" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "Path": { - "p_expansion": { - "Some": { - "Signature": { - "items": [ - { - "Type": [ - "Ordinary", - { - "id": { - "`Type": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Root": [ - "None", "Test" - ] - }, - "Nested" - ] - }, - "P2" - ] - }, - "N1" - ] - }, - "M" - ] - }, - "t" - ] - }, - "locs": "None", - "doc": [], - "equation": { - "params": [], - "private_": "false", - "manifest": "None", - "constraints": [] - }, - "representation": "None" - } - ] - } - ], - "compiled": "true", - "doc": [] - } - } - }, - "p_path": { - "`Resolved": { - "`Identifier": { - "`ModuleType": [ - { "`Root": [ "None", "Test" ] }, - "T" - ] - } - } - } - } - } - }, - "canonical": "None", - "hidden": "false" - } - ] - } - ], - "compiled": "true", - "doc": [] - } - } - }, - "canonical": "None", - "hidden": "false" + "ModuleType": { + "Signature": {} + } } - $ odoc_print test.odoc -r Nested.P2.N2 + + $ odoc_print test.odoc -r Nested.P2.N2 | jq ".type_ | (.ModuleType.Signature|={})" { - "id": { - "`Module": [ - { - "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Nested" ] }, - "P2" - ] - }, - "N2" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "Signature": { - "items": [ - { - "Type": [ - "Ordinary", - { - "id": { - "`Type": [ + "ModuleType": { + "Signature": {} + } + } + + $ odoc_print test.odoc -r Via_alias.P.N | jq ".type_ | (.ModuleType.Signature|={})" + { + "ModuleType": { + "Signature": {} + } + } + +The following modules expressions should remain as they are typed: +(the `t_expansion` should be `Some {}`) + + $ odoc_print test.odoc -r Cascade.P.N1 | jq ".type_ | (.ModuleType.TypeOf.t_expansion.Some|={})" + { + "ModuleType": { + "TypeOf": { + "t_desc": { + "ModPath": { + "`Resolved": { + "`Identifier": { + "`Module": [ + { + "`Module": [ { "`Module": [ { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "Nested" - ] - }, - "P2" + "`Root": [ + "None", + "Test" ] }, - "N2" + "Cascade" ] }, - "t" + "P" ] }, - "locs": "None", - "doc": [], - "equation": { - "params": [], - "private_": "false", - "manifest": "None", - "constraints": [] - }, - "representation": "None" - } - ] + "O" + ] + } } - ], - "compiled": "true", - "doc": [] + } + }, + "t_expansion": { + "Some": {} } } - }, - "canonical": "None", - "hidden": "false" + } } - $ odoc_print test.odoc -r Via_alias.P.N + + $ odoc_print test.odoc -r Cascade.P.N2 | jq ".type_ | (.ModuleType.TypeOf.t_expansion.Some|={})" { - "id": { - "`Module": [ - { - "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Via_alias" ] }, - "P" - ] - }, - "N" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "Signature": { - "items": [ - { - "Type": [ - "Ordinary", + "ModuleType": { + "TypeOf": { + "t_desc": { + "ModPath": { + "`Resolved": { + "`Module": [ { - "id": { - "`Type": [ + "`Identifier": { + "`Module": [ { "`Module": [ { "`Module": [ { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "Via_alias" + "`Root": [ + "None", + "Test" ] }, - "P" + "Cascade" ] }, - "N" + "P" ] }, - "t" - ] - }, - "locs": "None", - "doc": [], - "equation": { - "params": [], - "private_": "false", - "manifest": { - "Some": { - "Constr": [ - { - "`Resolved": { - "`Type": [ - { - "`Alias": [ - { - "`Identifier": { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "Int" - ] - } - }, - { - "`Identifier": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Root": [ - "None", "Test" - ] - }, - "Via_alias" - ] - }, - "P" - ] - }, - "M" - ] - }, - "false" - ] - } - ] - }, - "t" - ] - } - }, - [] - ] - } - }, - "constraints": [] - }, - "representation": "None" - } - ] - } - ], - "compiled": "true", - "doc": [] - } - } - }, - "canonical": "None", - "hidden": "false" - } - $ odoc_print test.odoc -r Cascade.P.N1 - { - "id": { - "`Module": [ - { - "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Cascade" ] }, - "P" - ] - }, - "N1" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "TypeOf": { - "t_desc": { - "ModPath": { - "`Resolved": { - "`Identifier": { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "Cascade" - ] - }, - "P" - ] - }, - "O" - ] - } - } - } - }, - "t_expansion": { - "Some": { - "Signature": { - "items": [ - { - "Module": [ - "Ordinary", - { - "id": { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "Cascade" - ] - }, - "P" - ] - }, - "N1" - ] - }, - "I" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "Signature": { - "items": [ - { - "Type": [ - "Ordinary", - { - "id": { - "`Type": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Root": [ - "None", "Test" - ] - }, - "Cascade" - ] - }, - "P" - ] - }, - "N1" - ] - }, - "I" - ] - }, - "t" - ] - }, - "locs": "None", - "doc": [], - "equation": { - "params": [], - "private_": "false", - "manifest": "None", - "constraints": [] - }, - "representation": "None" - } - ] - } - ], - "compiled": "true", - "doc": [] - } - } - }, - "canonical": "None", - "hidden": "false" - } + "O" ] } - ], - "compiled": "true", - "doc": [] - } + }, + "I" + ] } } - } - } - }, - "canonical": "None", - "hidden": "false" - } - $ odoc_print test.odoc -r Cascade.P.N2 - { - "id": { - "`Module": [ - { - "`Module": [ - { "`Module": [ { "`Root": [ "None", "Test" ] }, "Cascade" ] }, - "P" - ] }, - "N2" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "TypeOf": { - "t_desc": { - "ModPath": { - "`Resolved": { - "`Module": [ - { - "`Identifier": { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "Cascade" - ] - }, - "P" - ] - }, - "O" - ] - } - }, - "I" - ] - } - } - }, - "t_expansion": { - "Some": { - "Signature": { - "items": [ - { - "Type": [ - "Ordinary", - { - "id": { - "`Type": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "Cascade" - ] - }, - "P" - ] - }, - "N2" - ] - }, - "t" - ] - }, - "locs": "None", - "doc": [], - "equation": { - "params": [], - "private_": "false", - "manifest": "None", - "constraints": [] - }, - "representation": "None" - } - ] - } - ], - "compiled": "true", - "doc": [] - } - } - } + "t_expansion": { + "Some": {} } } - }, - "canonical": "None", - "hidden": "false" + } } - $ odoc_print test.odoc -r In_functor_parameter.P.G + + $ odoc_print test.odoc -r In_functor_parameter.P.G | jq ".type_ | (.ModuleType.Functor|=[]) | (.ModuleType.TypeOf.t_expansion.Some|={})" { - "id": { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "In_functor_parameter" - ] - }, - "P" - ] - }, - "G" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "ModuleType": { - "Functor": [ - { - "Named": { - "id": { - "`Parameter": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "In_functor_parameter" - ] - }, - "P" - ] - }, - "G" - ] - }, - "X" - ] - }, - "expr": { - "Signature": { - "items": [ - { - "Type": [ - "Ordinary", - { - "id": { - "`Type": [ - { - "`Parameter": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "In_functor_parameter" - ] - }, - "P" - ] - }, - "G" - ] - }, - "X" - ] - }, - "t" - ] - }, - "locs": "None", - "doc": [], - "equation": { - "params": [], - "private_": "false", - "manifest": "None", - "constraints": [] - }, - "representation": "None" - } - ] - }, - { - "Value": { - "id": { - "`Value": [ - { - "`Parameter": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "In_functor_parameter" - ] - }, - "P" - ] - }, - "G" - ] - }, - "X" - ] - }, - "plus" - ] - }, - "locs": "None", - "doc": [], - "type_": { - "Arrow": [ - "None", - { - "Constr": [ - { - "`Resolved": { - "`Identifier": { - "`Type": [ - { - "`Parameter": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Root": [ - "None", "Test" - ] - }, - "In_functor_parameter" - ] - }, - "P" - ] - }, - "G" - ] - }, - "X" - ] - }, - "t" - ] - } - } - }, - [] - ] - }, - { - "Arrow": [ - "None", - { - "Constr": [ - { - "`Resolved": { - "`Identifier": { - "`Type": [ - { - "`Parameter": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Root": [ - "None", "Test" - ] - }, - "In_functor_parameter" - ] - }, - "P" - ] - }, - "G" - ] - }, - "X" - ] - }, - "t" - ] - } - } - }, - [] - ] - }, - { - "Constr": [ - { - "`Resolved": { - "`Identifier": { - "`Type": [ - { - "`Parameter": [ - { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Root": [ - "None", "Test" - ] - }, - "In_functor_parameter" - ] - }, - "P" - ] - }, - "G" - ] - }, - "X" - ] - }, - "t" - ] - } - } - }, - [] - ] - } - ] - } - ] - }, - "value": "Abstract" - } - } - ], - "compiled": "true", - "doc": [] - } - } - } - }, - { - "Signature": { - "items": [ - { - "Type": [ - "Ordinary", - { - "id": { - "`Type": [ - { - "`Result": { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { "`Root": [ "None", "Test" ] }, - "In_functor_parameter" - ] - }, - "P" - ] - }, - "G" - ] - } - }, - "t" - ] - }, - "locs": "None", - "doc": [], - "equation": { - "params": [], - "private_": "false", - "manifest": "None", - "constraints": [] - }, - "representation": "None" - } - ] - } - ], - "compiled": "true", - "doc": [] - } - } - ] + "ModuleType": { + "Functor": [], + "TypeOf": { + "t_expansion": { + "Some": {} + } } - }, - "canonical": "None", - "hidden": "false" + } } + $ odoc link test.odoc $ odoc html-generate test.odocl -o html $ odoc support-files -o html From a058ec359ba2fb91e0fce9dbd75d153eb5c2ffd9 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 12 May 2023 15:50:27 +0100 Subject: [PATCH 06/18] Tweak jq queries to make sure the tests are sensitive enough In particular, in most cases it's crucial that the signature _not_ include the value `plus`, so we need to output the items in some form. --- test/xref2/transparent_ascription.t/run.t | 219 ++++++++----------- test/xref2/transparent_ascription.t/test.mli | 9 +- 2 files changed, 105 insertions(+), 123 deletions(-) diff --git a/test/xref2/transparent_ascription.t/run.t b/test/xref2/transparent_ascription.t/run.t index 1d0ed5808f..5b0974d72b 100644 --- a/test/xref2/transparent_ascription.t/run.t +++ b/test/xref2/transparent_ascription.t/run.t @@ -4,147 +4,122 @@ Transparent ascription $ ocamlc -c -bin-annot test.mli $ odoc compile test.cmti -The following modules should be expanded (and be a `"Signature": {}`): +`Basic.P.N` should be a signature with just one type called `t`: - $ odoc_print test.odoc -r Basic.P.N | jq ".type_ | (.ModuleType.Signature|={})" - { - "ModuleType": { - "Signature": {} + $ odoc_print test.odoc -r Basic.P.N \ + > | jq '.type_.ModuleType.Signature.items + > | ((.[].Type | select(.)) |= { id: .[1].id."`Type"[1] })' + [ + { + "Type": { + "id": "t" + } } - } + ] - $ odoc_print test.odoc -r Nested.P1.N1 | jq ".type_ | (.ModuleType.Signature|={})" - { - "ModuleType": { - "Signature": {} - } - } +`Nested.P1.N1.M` should be a module whose type is the resolved module type path +`T`: - $ odoc_print test.odoc -r Nested.P1.N2 | jq ".type_ | (.ModuleType.Signature|={})" - { - "ModuleType": { - "Signature": {} - } - } + $ odoc_print test.odoc -r Nested.P1.N1.M \ + > | jq '.type_.ModuleType.Path.p_path."`Resolved"."`Identifier"."`ModuleType"[1]' + "T" - $ odoc_print test.odoc -r Nested.P2.N1 | jq ".type_ | (.ModuleType.Signature|={})" - { - "ModuleType": { - "Signature": {} - } - } +`Nested.P1.N2` should be like `Basic.P.N`: - $ odoc_print test.odoc -r Nested.P2.N2 | jq ".type_ | (.ModuleType.Signature|={})" - { - "ModuleType": { - "Signature": {} + $ odoc_print test.odoc -r Nested.P1.N2 \ + > | jq '.type_.ModuleType.Signature.items + > | ((.[].Type | select(.)) |= { id: .[1].id."`Type"[1] })' + [ + { + "Type": { + "id": "t" + } } - } + ] - $ odoc_print test.odoc -r Via_alias.P.N | jq ".type_ | (.ModuleType.Signature|={})" - { - "ModuleType": { - "Signature": {} +`Nested.P2.N1.M` should be like `Nested.P1.N1.M`: + + $ odoc_print test.odoc -r Nested.P2.N1.M \ + > | jq '.type_.ModuleType.Path.p_path."`Resolved"."`Identifier"."`ModuleType"[1]' + "T" + +`Nested.P2.N2` should be like `Basic.P.N`: + + $ odoc_print test.odoc -r Nested.P2.N2 \ + > | jq '.type_.ModuleType.Signature.items + > | ((.[].Type | select(.)) |= { id: .[1].id."`Type"[1] })' + [ + { + "Type": { + "id": "t" + } } - } + ] -The following modules expressions should remain as they are typed: -(the `t_expansion` should be `Some {}`) +`Via_alias.P.N` should be like `Basic.P.N`: - $ odoc_print test.odoc -r Cascade.P.N1 | jq ".type_ | (.ModuleType.TypeOf.t_expansion.Some|={})" - { - "ModuleType": { - "TypeOf": { - "t_desc": { - "ModPath": { - "`Resolved": { - "`Identifier": { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Root": [ - "None", - "Test" - ] - }, - "Cascade" - ] - }, - "P" - ] - }, - "O" - ] - } - } - } - }, - "t_expansion": { - "Some": {} - } + $ odoc_print test.odoc -r Via_alias.P.N \ + > | jq '.type_.ModuleType.Signature.items + > | ((.[].Type | select(.)) |= { id: .[1].id."`Type"[1] })' + [ + { + "Type": { + "id": "t" } } - } + ] - $ odoc_print test.odoc -r Cascade.P.N2 | jq ".type_ | (.ModuleType.TypeOf.t_expansion.Some|={})" - { - "ModuleType": { - "TypeOf": { - "t_desc": { - "ModPath": { - "`Resolved": { - "`Module": [ - { - "`Identifier": { - "`Module": [ - { - "`Module": [ - { - "`Module": [ - { - "`Root": [ - "None", - "Test" - ] - }, - "Cascade" - ] - }, - "P" - ] - }, - "O" - ] - } - }, - "I" - ] - } - } - }, - "t_expansion": { - "Some": {} - } +`Cascade.P.N1.I` should be like `Basic.P.N`: + + $ odoc_print test.odoc -r Cascade.P.N1.I \ + > | jq '.type_.ModuleType.Signature.items + > | ((.[].Type | select(.)) |= { id: .[1].id."`Type"[1] })' + [ + { + "Type": { + "id": "t" } } - } + ] - $ odoc_print test.odoc -r In_functor_parameter.P.G | jq ".type_ | (.ModuleType.Functor|=[]) | (.ModuleType.TypeOf.t_expansion.Some|={})" +`Cascade.P.N2` should actually keep the module type `module type of +Cascade.P.O.I`, but with an expansion like `Basic.P.N`: + + $ odoc_print test.odoc -r Cascade.P.N2 \ + > | jq '.type_.ModuleType.TypeOf + > | (.t_desc.ModPath |= "..." + ."`Resolved"."`Module"[1]) + > | (.t_expansion |= + > (.Some.Signature.items + > | ((.[].Type | select(.)) |= { id: .[1].id."`Type"[1] })))' { - "ModuleType": { - "Functor": [], - "TypeOf": { - "t_expansion": { - "Some": {} + "t_desc": { + "ModPath": "...I" + }, + "t_expansion": [ + { + "Type": { + "id": "t" } } - } + ] } - $ odoc link test.odoc - $ odoc html-generate test.odocl -o html - $ odoc support-files -o html - $ cp -a html /tmp/test-html +`In_functor_parameter.P.G` should be a functor type whose argument type has both +a type `t` *and* a value `plus`: + + $ odoc_print test.odoc -r In_functor_parameter.P.G \ + > | jq '.type_.ModuleType.Functor[0].Named.expr.Signature.items + > | ((.[].Type | select(.)) |= { id: .[1].id."`Type"[1] }) + > | ((.[].Value | select(.)) |= { id: .id."`Value"[1] })' + [ + { + "Type": { + "id": "t" + } + }, + { + "Value": { + "id": "plus" + } + } + ] diff --git a/test/xref2/transparent_ascription.t/test.mli b/test/xref2/transparent_ascription.t/test.mli index 3fe379b7a9..1bb257faf8 100644 --- a/test/xref2/transparent_ascription.t/test.mli +++ b/test/xref2/transparent_ascription.t/test.mli @@ -21,7 +21,7 @@ module Basic : sig module N : module type of M end - (* [P.N] should just have type [T] because [module type of M] has already + (* [P.N] should just have type [t] because [module type of M] has already evaluated to [T] *) module P : S with module M = Int end @@ -63,6 +63,9 @@ module Via_alias : sig module P : S with module M = Int end +(* Now we take the module type of something that _itself_ took the module type + of [M] *) + module Cascade : sig module type S = sig module M : T @@ -73,6 +76,8 @@ module Cascade : sig module N1 : module type of O + (* Interestingly, this [module type of] expression is never invalidated + and retains the link to [O.I]. *) module N2 : module type of O.I end @@ -97,5 +102,7 @@ module In_functor_parameter : sig module G : module type of F end + (* [P.G]'s argument type should have _both_ [plus] and [t] even though + [Identity]'s argument type does not *) module P : S with module F = Identity end From 53c94306fb11b7e2c69bcb7c5606df63aba82e53 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 12 May 2023 21:25:00 +0100 Subject: [PATCH 07/18] Add test demonstrating bug --- test/xref2/transparent_ascription.t/bug.mli | 21 +++++++++++++++++++++ test/xref2/transparent_ascription.t/run.t | 16 ++++++++++++++++ 2 files changed, 37 insertions(+) create mode 100644 test/xref2/transparent_ascription.t/bug.mli diff --git a/test/xref2/transparent_ascription.t/bug.mli b/test/xref2/transparent_ascription.t/bug.mli new file mode 100644 index 0000000000..42915329ad --- /dev/null +++ b/test/xref2/transparent_ascription.t/bug.mli @@ -0,0 +1,21 @@ +module type Value = sig + val print : unit +end + +module type Set = sig + type t + + val empty : unit + + module Element : Value +end + +module type Function = sig + module Domain : Set + + module Point : sig + include module type of Domain.Element + end +end + +module Inverse (F : Function with type Domain.t = unit) : sig end diff --git a/test/xref2/transparent_ascription.t/run.t b/test/xref2/transparent_ascription.t/run.t index 5b0974d72b..01e11253fa 100644 --- a/test/xref2/transparent_ascription.t/run.t +++ b/test/xref2/transparent_ascription.t/run.t @@ -123,3 +123,19 @@ a type `t` *and* a value `plus`: } } ] + +Bug +=== + + $ ocamlc -c -bin-annot bug.mli + $ odoc compile bug.cmti + +This should print the items in `Value` (i.e., just the value `print`) but +instead it prints the items in `Set` + + $ odoc_print bug.odoc -r Inverse \ + > | jq '.type_.ModuleType.Functor[0].Named.expr.With.w_expansion.Some + > .Signature.items[] + > | select(.Module[1].id."`Module"[1] == "Point") + > | .Module[1].type_.ModuleType.Signature.items[]' + * output is currently incorrect * From 250a38e8c5ce93af78ccc7f97daf23d8a125d6a0 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 19 May 2023 10:42:45 +0100 Subject: [PATCH 08/18] Code review --- src/xref2/component.ml | 8 ++++++++ src/xref2/component.mli | 2 ++ src/xref2/subst.ml | 15 ++++----------- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 4f94f0b2ab..43fc2ae116 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -2438,6 +2438,14 @@ let module_of_functor_argument (arg : FunctorParameter.parameter) = hidden = false; } +let umty_of_mty (e : ModuleType.expr) : ModuleType.U.expr option = + match e with + | Path { p_path; _ } -> Some (Path p_path) + | Signature s -> Some (Signature s) + | With { w_substitutions; w_expr; _ } -> Some (With (w_substitutions, w_expr)) + | Functor (_, _) -> None + | TypeOf { t_desc; _ } -> Some (TypeOf t_desc) + (** This is equivalent to {!Lang.extract_signature_doc}. *) let extract_signature_doc (s : Signature.t) = match (s.doc, s.items) with diff --git a/src/xref2/component.mli b/src/xref2/component.mli index d7adfdab79..25c59c37ea 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -796,4 +796,6 @@ end val module_of_functor_argument : FunctorParameter.parameter -> Module.t +val umty_of_mty : ModuleType.expr -> ModuleType.U.expr option + val extract_signature_doc : Signature.t -> CComment.docs diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 4fc7886ca7..f1159fdf8f 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -142,15 +142,6 @@ let rename_class_type : Ident.path_class_type -> Ident.path_class_type -> t -> t t.type_; } -let u_module_type_expr_of_module_type_expr (e : Component.ModuleType.expr) : - Component.ModuleType.U.expr = - match e with - | Path { p_path; _ } -> Path p_path - | Signature s -> Signature s - | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) - | Functor (_, _) -> assert false - | TypeOf { t_desc; _ } -> TypeOf t_desc - let rec substitute_vars vars t = let open TypeExpr in match t with @@ -716,8 +707,10 @@ and u_module_type_expr s t = (List.map (with_module_type_substitution s) subs, u_module_type_expr s e) | TypeOf t -> ( try TypeOf (module_type_type_of_desc s t) - with MTOInvalidated e -> - u_module_type_expr s (e |> u_module_type_expr_of_module_type_expr)) + with MTOInvalidated e -> ( + match Component.umty_of_mty e with + | Some e -> u_module_type_expr s e + | None -> assert false)) and module_type_of_simple_expansion : Component.ModuleType.simple_expansion -> Component.ModuleType.expr = From 06c0c0d5c1189107d18f10795320e1df0a3d7a69 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 19 May 2023 14:52:34 +0100 Subject: [PATCH 09/18] Add correct output for bug test --- test/xref2/transparent_ascription.t/run.t | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/test/xref2/transparent_ascription.t/run.t b/test/xref2/transparent_ascription.t/run.t index 01e11253fa..00de3aa901 100644 --- a/test/xref2/transparent_ascription.t/run.t +++ b/test/xref2/transparent_ascription.t/run.t @@ -130,12 +130,19 @@ Bug $ ocamlc -c -bin-annot bug.mli $ odoc compile bug.cmti -This should print the items in `Value` (i.e., just the value `print`) but -instead it prints the items in `Set` +This should print the items in `Value` (i.e., just the value `print`). If the +bug from PR #958 is present, it will instead print the items in `Set`. $ odoc_print bug.odoc -r Inverse \ > | jq '.type_.ModuleType.Functor[0].Named.expr.With.w_expansion.Some > .Signature.items[] > | select(.Module[1].id."`Module"[1] == "Point") - > | .Module[1].type_.ModuleType.Signature.items[]' - * output is currently incorrect * + > | .Module[1].type_.ModuleType.Signature.items[].Include.expansion.content.items + > | ((.[].Value | select(.)) |= { id: .id."`Value"[1] })' + [ + { + "Value": { + "id": "print" + } + } + ] From c1c66557ccaec41d7999ac753117e08e169f6745 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 19 May 2023 15:54:22 +0100 Subject: [PATCH 10/18] Avoid gratuitous `include` expressions in output --- src/xref2/component.ml | 5 +++++ src/xref2/component.mli | 2 ++ src/xref2/subst.ml | 8 +------- src/xref2/tools.ml | 8 ++++++-- 4 files changed, 14 insertions(+), 9 deletions(-) diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 43fc2ae116..0da38ff4c1 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -2451,3 +2451,8 @@ let extract_signature_doc (s : Signature.t) = match (s.doc, s.items) with | [], Include { expansion_; status = `Inline; _ } :: _ -> expansion_.doc | doc, _ -> doc + +let rec mty_of_simple_expansion : ModuleType.simple_expansion -> ModuleType.expr + = function + | Signature sg -> Signature sg + | Functor (arg, e) -> Functor (arg, mty_of_simple_expansion e) diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 25c59c37ea..d6355190d2 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -799,3 +799,5 @@ val module_of_functor_argument : FunctorParameter.parameter -> Module.t val umty_of_mty : ModuleType.expr -> ModuleType.U.expr option val extract_signature_doc : Signature.t -> CComment.docs + +val mty_of_simple_expansion : ModuleType.simple_expansion -> ModuleType.expr diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index f1159fdf8f..3cdddc42ec 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -712,12 +712,6 @@ and u_module_type_expr s t = | Some e -> u_module_type_expr s e | None -> assert false)) -and module_type_of_simple_expansion : - Component.ModuleType.simple_expansion -> Component.ModuleType.expr = - function - | Signature sg -> Signature sg - | Functor (arg, e) -> Functor (arg, module_type_of_simple_expansion e) - and module_type_expr s t = let open Component.ModuleType in match t with @@ -745,7 +739,7 @@ and module_type_expr s t = t_expansion = Some (simple_expansion s e); } with MTOInvalidated _ -> - module_type_expr s (module_type_of_simple_expansion e)) + module_type_expr s (Component.mty_of_simple_expansion e)) | TypeOf { t_desc; t_expansion = None } -> TypeOf { t_desc = module_type_type_of_desc_noexn s t_desc; t_expansion = None } diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index 5e1a33e7f1..1c53f4f594 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -1811,8 +1811,12 @@ and fragmap : let old_ty = match m.type_ with | ModuleType e -> e - | Alias (m, exp) -> - TypeOf { t_desc = StructInclude m; t_expansion = exp } + | Alias (_, Some exp) -> + (* Avoid creating [module type of] expressions when + possible since they will wind up in the html *) + Component.mty_of_simple_expansion exp + | Alias (m, None) -> + TypeOf { t_desc = StructInclude m; t_expansion = None } in Ok ( Component.Signature.Module From f0de582b4fb17f27e3f9392df3d3fa6c1fd32c8f Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Sat, 3 Jun 2023 11:18:39 +0100 Subject: [PATCH 11/18] Attempt to deal with the `(module type of A.B) with module A = M` problem --- src/xref2/component.ml | 3 +++ src/xref2/component.mli | 2 ++ src/xref2/subst.ml | 50 +++++++++++++++++++++++++++++++++-------- 3 files changed, 46 insertions(+), 9 deletions(-) diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 0da38ff4c1..fe29155a02 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -2446,6 +2446,9 @@ let umty_of_mty (e : ModuleType.expr) : ModuleType.U.expr option = | Functor (_, _) -> None | TypeOf { t_desc; _ } -> Some (TypeOf t_desc) +let umty_of_mty_exn e = + match umty_of_mty e with None -> assert false | Some e -> e + (** This is equivalent to {!Lang.extract_signature_doc}. *) let extract_signature_doc (s : Signature.t) = match (s.doc, s.items) with diff --git a/src/xref2/component.mli b/src/xref2/component.mli index d6355190d2..e8f8ec1977 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -798,6 +798,8 @@ val module_of_functor_argument : FunctorParameter.parameter -> Module.t val umty_of_mty : ModuleType.expr -> ModuleType.U.expr option +val umty_of_mty_exn : ModuleType.expr -> ModuleType.U.expr + val extract_signature_doc : Signature.t -> CComment.docs val mty_of_simple_expansion : ModuleType.simple_expansion -> ModuleType.expr diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 3cdddc42ec..3cfe8b6742 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -644,19 +644,24 @@ and module_type_type_of_desc_noexn s t = | ModPath p -> ModPath (module_path s p) | StructInclude p -> StructInclude (module_path s p) -(* CR lmaurer: This seems wrong! If a subpath of the path is invalidated, that's - not the same as the whole path being invalidated. But I can't seem to get this - to break. *) and mto_module_path_invalidated : t -> Cpath.module_ -> ModuleType.expr option = fun s p -> match p with | `Resolved p' -> mto_resolved_module_path_invalidated s p' - | `Substituted p' | `Dot (p', _) -> mto_module_path_invalidated s p' - | `Module (`Module p', _) -> mto_resolved_module_path_invalidated s p' + | `Substituted p' -> mto_module_path_invalidated s p' + | `Dot (p', id) -> + mto_module_path_invalidated s p' + |> Option.map (member_of_module_type_expr s id) + | `Module (`Module p', id) -> + let id = Odoc_model.Names.ModuleName.to_string id in + mto_resolved_module_path_invalidated s p' + |> Option.map (member_of_module_type_expr s id) | `Module (_, _) -> None | `Apply (p1, p2) -> ( match mto_module_path_invalidated s p1 with - | Some _ as ans -> ans + | Some _ as ans -> + Format.eprintf "WOW WE DID IT@.%!"; + ans | None -> mto_module_path_invalidated s p2) | `Local (id, _) -> ( match PathModuleMap.find id s.module_type_of_invalidating_modules with @@ -674,11 +679,16 @@ and mto_resolved_module_path_invalidated s p = | mty -> Some mty) | `Gpath _ -> None | `Apply (p1, p2) -> ( + Format.eprintf "WOW WE DID IT HERE@.%a@.%!" + Component.Fmt.resolved_module_path p; match mto_resolved_module_path_invalidated s p1 with | Some _ as ans -> ans | None -> mto_resolved_module_path_invalidated s p2) - | `Module (`Module p, _) | `Substituted p -> + | `Module (`Module p, id) -> + let id = Odoc_model.Names.ModuleName.to_string id in mto_resolved_module_path_invalidated s p + |> Option.map (member_of_module_type_expr s id) + | `Substituted p -> mto_resolved_module_path_invalidated s p | `Module (_, _) -> None | `Alias (p1, _p2, _) -> mto_resolved_module_path_invalidated s p1 | `Subst (_p1, p2) -> mto_resolved_module_path_invalidated s p2 @@ -686,7 +696,25 @@ and mto_resolved_module_path_invalidated s p = | `Canonical (p1, _p2) -> mto_resolved_module_path_invalidated s p1 | `OpaqueModule p -> mto_resolved_module_path_invalidated s p -and u_module_type_expr s t = +and member_of_module_type_expr s id (t : ModuleType.expr) = + match t with + | Signature sg -> member_of_sig s sg id + | Path { p_path = _; p_expansion = Some (Signature sg) } -> + member_of_sig s sg id + | Path _ -> assert false + | With _ -> assert false + | Functor _ -> assert false + | TypeOf _ -> assert false + +and member_of_sig _s sg id = + match Find.module_in_sig sg id with + | None -> assert false + | Some (`FModule (_, m)) -> ( + match m.type_ with + | Alias (p, exp) -> TypeOf { t_desc = StructInclude p; t_expansion = exp } + | ModuleType e -> e) + +and u_module_type_expr s (t as t0) = let open Component.ModuleType.U in match t with | Path p -> ( @@ -710,7 +738,11 @@ and u_module_type_expr s t = with MTOInvalidated e -> ( match Component.umty_of_mty e with | Some e -> u_module_type_expr s e - | None -> assert false)) + | None -> + Format.eprintf "WELP, LET'S TRY THIS@.%a@.%a@.%!" + Component.Fmt.u_module_type_expr t0 Component.Fmt.module_type_expr + e; + TypeOf (module_type_type_of_desc_noexn s t))) and module_type_expr s t = let open Component.ModuleType in From 9134eb7cd86bb522ae53a66506ad8f387e737ab6 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 16 Jun 2023 17:38:48 +0100 Subject: [PATCH 12/18] Add lazy projections as module type expressions Given ``` module type S = sig module A : module B : module type of A end module type S' = S with module A := M ``` we now have a nice story for invalidating `A` in the type of `B` and moving `A`'s type over, evaluating `S'` to ``` sig module B : end ``` There is, however, a problem if `B`'s type is something more complicated: ``` module type S = sig module A : module B : module type of A.F end module type S' = S with module A := M ``` What can we evaluate `S'` to? We don't have a way to say ``` sig module B : .F end ``` Note that `A` is gone - there is no name for it or its type anymore, so there's no path `P` on which we can build `P.F`. If the type of `A` is something nice like a signature, we can project `F` out, but it might not be that simple. And we can't count on having an expansion for `A` or `B` on hand (anymore), so if `` is just a path, we're sunk: there's no syntax to project a field out of a path to a module _type_. Even worse, `B`'s type could be `module type of A(X)`, which we do _not_ want to sort out in the middle of `subst.ml`. The solution is simply to allow `.F` and `(X)` as module type expressions after all. Specifically, both `ModuleType.expr` and `ModuleType.U.expr` now have a `Project` constructor that takes a _projection_, essentially a path suffix including submodule names and arguments to pass, and a general module type expression. These projections are easy to evaluate given the expansion of the expression, and thus they're easy to compile away when computing expansions. The only problem at the moment is that `ModuleType.U.expr` doesn't have a `Functor` constructor, which means this patch can't handle ``` module type S = sig module A : functor (X : T) -> U module B : sig include module type of struct include A(M) end end end module type S' = S with module A := F ``` because `module type of struct include A(M)` will be a `ModuleType.U.expr` and substitution needs to produce `((functor (X : T) -> U)(M))` which is not a `ModuleType.U.expr` because `(functor (X : T) -> U)` isn't a functor literal. My current plan is simply to add `Functor` as a constructor to `ModuleType.U.expr`, which (IMO) has the added benefit of removing the awkward asymmetry between `ModuleType.expr` and `ModuleType.U.expr`. --- src/document/generator.ml | 8 +++ src/document/targets.ml | 3 + src/model/lang.ml | 6 +- src/model/paths.ml | 4 ++ src/model/paths.mli | 5 ++ src/model/paths_types.ml | 4 ++ src/model_desc/lang_desc.ml | 8 ++- src/model_desc/paths_desc.ml | 10 +++ src/model_desc/paths_desc.mli | 2 + src/xref2/compile.ml | 8 +++ src/xref2/component.ml | 45 +++++++++++- src/xref2/component.mli | 7 ++ src/xref2/cpath.ml | 6 ++ src/xref2/lang_of.ml | 15 ++++ src/xref2/link.ml | 2 + src/xref2/subst.ml | 65 ++++++----------- src/xref2/tools.ml | 73 ++++++++++++++++++++ test/odoc_print/odoc_print.ml | 4 ++ test/xref2/transparent_ascription.t/test.mli | 68 ++++++++++++++++++ 19 files changed, 295 insertions(+), 48 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 5e1b6ad54c..ada047f0f8 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -1381,6 +1381,7 @@ module Make (Syntax : SYNTAX) = struct match simple_expansion_of e with | Some e -> Some (Functor (f_parameter, e)) | None -> None) + | Project _ -> failwith "Thought we were done with this" in match simple_expansion_of t with | None -> None @@ -1513,6 +1514,7 @@ module Make (Syntax : SYNTAX) = struct | TypeOf (ModPath m) | TypeOf (StructInclude m) -> Paths.Path.(is_hidden (m :> t)) | Signature _ -> false + | Project (_, expr) -> umty_hidden expr and mty_hidden : Odoc_model.Lang.ModuleType.expr -> bool = function | Path { p_path = mty_path; _ } -> Paths.Path.(is_hidden (mty_path :> t)) @@ -1548,6 +1550,7 @@ module Make (Syntax : SYNTAX) = struct | Signature _ -> true | With (_, expr) -> is_elidable_with_u expr | TypeOf _ -> false + | Project (_, expr) -> is_elidable_with_u expr (* TODO: Correct? *) and umty : Odoc_model.Lang.ModuleType.U.expr -> text = fun m -> @@ -1559,6 +1562,7 @@ module Make (Syntax : SYNTAX) = struct Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag | With (subs, expr) -> mty_with subs expr | TypeOf t -> mty_typeof t + | Project _ -> (* TODO *) O.txt "" and mty : Odoc_model.Lang.ModuleType.expr -> text = fun m -> @@ -1598,6 +1602,7 @@ module Make (Syntax : SYNTAX) = struct | TypeOf { t_desc; _ } -> mty_typeof t_desc | Signature _ -> Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag + | Project _ -> O.txt "unexpanded projection" and mty_in_decl : Paths.Identifier.Signature.t -> Odoc_model.Lang.ModuleType.expr -> text @@ -1632,6 +1637,9 @@ module Make (Syntax : SYNTAX) = struct ++ O.cut ++ mty arg.expr ++ O.txt ")" in O.sp ++ text_arg ++ mty_in_decl base expr + | Project _ -> + (* TODO *) + unresolved [ inline (Text "") ] (* TODO : Centralize the list juggling for type parameters *) and type_expr_in_subst td typath = diff --git a/src/document/targets.ml b/src/document/targets.ml index 64d261d7ca..399ea8e1b7 100644 --- a/src/document/targets.ml +++ b/src/document/targets.ml @@ -51,6 +51,9 @@ and module_type_expr (t : Odoc_model.Lang.ModuleType.expr) = | With { w_expansion = e_opt; _ } | TypeOf { t_expansion = e_opt; _ } -> opt_expansion e_opt + | Project _ -> + (* TODO *) + [] and module_ (t : Odoc_model.Lang.Module.t) = let url = Url.Path.from_identifier t.id in diff --git a/src/model/lang.ml b/src/model/lang.ml index 4d18551505..8f2c9242e2 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -98,6 +98,7 @@ and ModuleType : sig | Signature of Signature.t | With of substitution list * expr | TypeOf of type_of_desc + | Project of Projection.t * expr end type path_t = { @@ -122,6 +123,7 @@ and ModuleType : sig | Functor of FunctorParameter.t * expr | With of with_t | TypeOf of typeof_t + | Project of Projection.t * expr type t = { id : Identifier.ModuleType.t; @@ -528,12 +530,14 @@ module rec SourceTree : sig end = SourceTree -let umty_of_mty : ModuleType.expr -> ModuleType.U.expr option = function +let rec umty_of_mty : ModuleType.expr -> ModuleType.U.expr option = function | Signature sg -> Some (Signature sg) | Path { p_path; _ } -> Some (Path p_path) | Functor _ -> None | TypeOf t -> Some (TypeOf t.t_desc) | With { w_substitutions; w_expr; _ } -> Some (With (w_substitutions, w_expr)) + | Project (proj, e) -> + umty_of_mty e |> Option.map (fun e -> ModuleType.U.Project (proj, e)) (** Query the top-comment of a signature. This is [s.doc] most of the time with an exception for signature starting with an inline includes. *) diff --git a/src/model/paths.ml b/src/model/paths.ml index c688e17a8b..eead10e5b5 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -893,6 +893,10 @@ module Path = struct let is_hidden = is_path_hidden end +module Projection = struct + type t = Paths_types.Path.projection +end + module Fragment = struct module Resolved = struct type t = Paths_types.Resolved_fragment.any diff --git a/src/model/paths.mli b/src/model/paths.mli index d9947933a1..34f8a1749c 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -584,6 +584,11 @@ module rec Path : sig val is_hidden : t -> bool end +(** Suffixes of module paths *) +module Projection : sig + type t = Paths_types.Path.projection +end + (** OCaml path fragments for specifying module substitutions *) module Fragment : sig module Resolved : sig diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index 0a018de3e0..ebb4757595 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -299,6 +299,10 @@ module rec Path : sig | `Dot of module_ * string | `Apply of module_ * module_ ] (** @canonical Odoc_model.Paths.Path.t *) + + type projection = + [ `Here | `Dot of projection * string | `Apply of projection * module_ ] + (** @canonical Odoc_model.Paths.Projection.t *) end = Path diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index 012687907d..52d904cbea 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -160,7 +160,9 @@ and moduletype_expr = | Functor (x1, x2) -> C ("Functor", (x1, x2), Pair (functorparameter_t, moduletype_expr)) | With t -> C ("With", t, moduletype_with_t) - | TypeOf x -> C ("TypeOf", x, moduletype_typeof_t)) + | TypeOf x -> C ("TypeOf", x, moduletype_typeof_t) + | Project (x1, x2) -> + C ("Project", (x1, x2), Pair (projection, moduletype_expr))) and moduletype_u_expr = let open Lang.ModuleType.U in @@ -173,7 +175,9 @@ and moduletype_u_expr = ( "With", (t, e), Pair (List moduletype_substitution, moduletype_u_expr) ) - | TypeOf x -> C ("TypeOf", x, moduletype_type_of_desc)) + | TypeOf x -> C ("TypeOf", x, moduletype_type_of_desc) + | Project (x1, x2) -> + C ("Project", (x1, x2), Pair (projection, moduletype_u_expr))) and moduletype_t = let open Lang.ModuleType in diff --git a/src/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml index 8b23f6d163..438d63f906 100644 --- a/src/model_desc/paths_desc.ml +++ b/src/model_desc/paths_desc.ml @@ -374,6 +374,14 @@ module General_paths = struct ((x1 :> rr), x2), Pair (resolved_reference, Names.valuename) )) + let rec projection : Paths.Projection.t t = + Variant + (function + | `Here -> C0 "`Here" + | `Dot (proj, s) -> C ("`Dot", (proj, s), Pair (projection, string)) + | `Apply (proj, m) -> + C ("`Apply", (proj, (m :> p)), Pair (projection, path))) + let resolved_fragment_root : Paths.Fragment.Resolved.root t = Variant (function @@ -459,6 +467,8 @@ let resolved_path : [< Paths.Path.Resolved.t ] Type_desc.t = let path : [< Paths.Path.t ] Type_desc.t = Indirect ((fun n -> (n :> General_paths.p)), General_paths.path) +let projection = General_paths.projection + let resolved_fragment = Indirect ((fun n -> (n :> General_paths.rf)), General_paths.resolved_fragment) diff --git a/src/model_desc/paths_desc.mli b/src/model_desc/paths_desc.mli index 8bdb184cf6..defccc941f 100644 --- a/src/model_desc/paths_desc.mli +++ b/src/model_desc/paths_desc.mli @@ -12,6 +12,8 @@ val resolved_path : [< Path.Resolved.t ] Type_desc.t val path : [< Path.t ] Type_desc.t +val projection : Projection.t Type_desc.t + val resolved_fragment : [< Fragment.Resolved.t ] Type_desc.t val fragment : [< Fragment.t ] Type_desc.t diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index f0516a51aa..b7a15e2437 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -594,6 +594,10 @@ and module_type_map_subs env id cexpr subs = | TypeOf (ModPath (`Resolved p)) | TypeOf (StructInclude (`Resolved p)) -> Some (`Module p) | TypeOf _ -> None + | Project _ -> + (* Preserving the behavior from when this type would have been replaced + by its expansion *) + None in match find_parent cexpr with | None -> None @@ -640,6 +644,7 @@ and u_module_type_expr : | StructInclude p -> StructInclude (module_path env p) in TypeOf t + | Project (proj, expr) -> Project (proj, inner expr) in inner expr @@ -696,6 +701,9 @@ and module_type_expr : | StructInclude p -> StructInclude (module_path env p) in TypeOf { t_desc; t_expansion } + | Project (proj, expr) -> + (* CR lmaurer: Does [id] need to change here? *) + Project (proj, module_type_expr env id expr) and type_decl : Env.t -> TypeDecl.t -> TypeDecl.t = fun env t -> diff --git a/src/xref2/component.ml b/src/xref2/component.ml index fe29155a02..875621b7b1 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -205,6 +205,7 @@ and ModuleType : sig | Signature of Signature.t | With of substitution list * expr | TypeOf of type_of_desc + | Project of Cpath.projection * expr end type path_t = { @@ -229,6 +230,7 @@ and ModuleType : sig | With of with_t | Functor of FunctorParameter.t * expr | TypeOf of typeof_t + | Project of Cpath.projection * expr type t = { locs : Odoc_model.Lang.Locations.t option; @@ -745,6 +747,8 @@ module Fmt = struct Format.fprintf ppf "%a with [%a]" u_module_type_expr e substitution_list subs | TypeOf t -> module_type_type_of_desc ppf t + | Project (proj, e) -> + Format.fprintf ppf "(%a)%a" u_module_type_expr e projection proj and module_type_expr ppf mt = let open ModuleType in @@ -761,6 +765,8 @@ module Fmt = struct Format.fprintf ppf "module type of %a" module_path p | TypeOf { t_desc = StructInclude p; _ } -> Format.fprintf ppf "module type of struct include %a end" module_path p + | Project (proj, e) -> + Format.fprintf ppf "(%a)%a" module_type_expr e projection proj and functor_parameter ppf x = let open FunctorParameter in @@ -1085,6 +1091,27 @@ module Fmt = struct Format.fprintf ppf "%a.%s" resolved_parent_path p (Odoc_model.Names.ClassTypeName.to_string t) + and model_projection : + Format.formatter -> Odoc_model.Paths.Projection.t -> unit = + fun ppf proj -> + match proj with + | `Here -> () + | `Dot (proj, id) -> Format.fprintf ppf "%a.%s" model_projection proj id + | `Apply (proj, p) -> + Format.fprintf ppf "%a(%a)" model_projection proj model_path + (p :> Odoc_model.Paths.Path.t) + + and projection : Format.formatter -> Cpath.projection -> unit = + fun ppf proj -> + match proj with + | `Here -> () + | `Dot (proj, id) -> Format.fprintf ppf "%a.%s" projection proj id + | `Module (proj, id) -> + Format.fprintf ppf "%a.%a" projection proj + Odoc_model.Names.ModuleName.fmt id + | `Apply (proj, p) -> + Format.fprintf ppf "%a(%a)" projection proj module_path p + and model_path : Format.formatter -> Odoc_model.Paths.Path.t -> unit = fun ppf (p : Odoc_model.Paths.Path.t) -> match p with @@ -1798,6 +1825,14 @@ module Of_Lang = struct | `Local i -> `Local (i, b)) | `Dot (path', x) -> `Dot (module_path ident_map path', x) + let rec projection : _ -> Odoc_model.Paths.Projection.t -> Cpath.projection = + fun ident_map proj -> + match proj with + | `Here -> `Here + | `Dot (proj, s) -> `Dot (projection ident_map proj, s) + | `Apply (proj, p) -> + `Apply (projection ident_map proj, module_path ident_map p) + let rec resolved_signature_fragment : map -> Odoc_model.Paths.Fragment.Resolved.Signature.t -> @@ -2128,6 +2163,9 @@ module Of_Lang = struct | StructInclude p -> StructInclude (module_path ident_map p) in TypeOf t + | Project (proj, e) -> + let proj' = projection ident_map proj in + Project (proj', u_module_type_expr ident_map e) and module_type_expr ident_map m = let open Odoc_model in @@ -2183,6 +2221,9 @@ module Of_Lang = struct in let t_expansion = option simple_expansion ident_map t_expansion in ModuleType.(TypeOf { t_desc; t_expansion }) + | Lang.ModuleType.Project (proj, expr) -> + ModuleType.Project + (projection ident_map proj, module_type_expr ident_map expr) and module_type ident_map m = let expr = @@ -2438,13 +2479,15 @@ let module_of_functor_argument (arg : FunctorParameter.parameter) = hidden = false; } -let umty_of_mty (e : ModuleType.expr) : ModuleType.U.expr option = +let rec umty_of_mty (e : ModuleType.expr) : ModuleType.U.expr option = match e with | Path { p_path; _ } -> Some (Path p_path) | Signature s -> Some (Signature s) | With { w_substitutions; w_expr; _ } -> Some (With (w_substitutions, w_expr)) | Functor (_, _) -> None | TypeOf { t_desc; _ } -> Some (TypeOf t_desc) + | Project (proj, e) -> + umty_of_mty e |> Option.map (fun e -> ModuleType.U.Project (proj, e)) let umty_of_mty_exn e = match umty_of_mty e with None -> assert false | Some e -> e diff --git a/src/xref2/component.mli b/src/xref2/component.mli index e8f8ec1977..4886037321 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -188,6 +188,7 @@ and ModuleType : sig | Signature of Signature.t | With of substitution list * expr | TypeOf of type_of_desc + | Project of Cpath.projection * expr end type path_t = { @@ -212,6 +213,7 @@ and ModuleType : sig | With of with_t | Functor of FunctorParameter.t * expr | TypeOf of typeof_t + | Project of Cpath.projection * expr type t = { locs : Odoc_model.Lang.Locations.t option; @@ -589,6 +591,11 @@ module Fmt : sig val class_type_path : Format.formatter -> Cpath.class_type -> unit + val model_projection : + Format.formatter -> Odoc_model.Paths.Projection.t -> unit + + val projection : Format.formatter -> Cpath.projection -> unit + val model_path : Format.formatter -> Odoc_model.Paths.Path.t -> unit val model_resolved_path : diff --git a/src/xref2/cpath.ml b/src/xref2/cpath.ml index ec2949917e..0123f3fa52 100644 --- a/src/xref2/cpath.ml +++ b/src/xref2/cpath.ml @@ -83,6 +83,12 @@ and Cpath : sig | `Dot of module_ * string | `Class of Resolved.parent * ClassName.t | `ClassType of Resolved.parent * ClassTypeName.t ] + + type projection = + [ `Here + | `Dot of projection * string + | `Module of projection * ModuleName.t + | `Apply of projection * module_ ] end = Cpath diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 7ef65ac10f..1905be192d 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -208,6 +208,15 @@ module Path = struct | `ClassType (p, name) -> `ClassType (resolved_parent map p, name) | `Substituted s -> resolved_class_type map s + let rec projection map (proj : Cpath.projection) : + Odoc_model.Paths.Projection.t = + match proj with + | `Here -> `Here + | `Dot (proj, s) -> `Dot (projection map proj, s) + | `Module (proj, name) -> + `Dot (projection map proj, Names.ModuleName.to_string name) + | `Apply (proj, p) -> `Apply (projection map proj, module_ map p) + let rec module_fragment : maps -> Cfrag.module_ -> Odoc_model.Paths.Fragment.Module.t = fun map f -> @@ -774,6 +783,8 @@ and u_module_type_expr map identifier = function u_module_type_expr map identifier expr ) | TypeOf (ModPath p) -> TypeOf (ModPath (Path.module_ map p)) | TypeOf (StructInclude p) -> TypeOf (StructInclude (Path.module_ map p)) + | Project (proj, expr) -> + Project (Path.projection map proj, u_module_type_expr map identifier expr) and module_type_expr map identifier = function | Component.ModuleType.Path { p_path; p_expansion } -> @@ -821,6 +832,10 @@ and module_type_expr map identifier = function t_desc = StructInclude (Path.module_ map p); t_expansion = Opt.map (simple_expansion map identifier) t_expansion; } + | Project (proj, expr) -> + (* CR lmaurer: [identifier] seems a bit wrong here but it's not always + precise elsewhere, I think? *) + Project (Path.projection map proj, module_type_expr map identifier expr) and module_type : maps -> diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 67ffc59fe0..1dc5509525 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -750,6 +750,7 @@ and u_module_type_expr : unresolved) | TypeOf (StructInclude p) -> TypeOf (StructInclude (module_path env p)) | TypeOf (ModPath p) -> TypeOf (ModPath (module_path env p)) + | Project (proj, expr) -> Project (proj, u_module_type_expr env id expr) and module_type_expr : Env.t -> Id.Signature.t -> ModuleType.expr -> ModuleType.expr = @@ -814,6 +815,7 @@ and module_type_expr : t_desc = ModPath (module_path env p); t_expansion = do_expn t_expansion None; } + | Project (proj, expr) -> Project (proj, module_type_expr env id expr) and type_decl_representation : Env.t -> diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 3cfe8b6742..f04993d86a 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -2,7 +2,7 @@ open Component exception Invalidated -exception MTOInvalidated of Component.ModuleType.expr +exception MTOInvalidated of Cpath.projection * Component.ModuleType.expr type ('a, 'b) or_replaced = Not_replaced of 'a | Replaced of 'b @@ -631,11 +631,11 @@ and module_type_type_of_desc s t = match t with | ModPath p -> ( match mto_module_path_invalidated s p with - | Some e -> raise (MTOInvalidated e) + | Some (proj, e) -> raise (MTOInvalidated (proj, e)) | None -> ModPath (module_path s p)) | StructInclude p -> ( match mto_module_path_invalidated s p with - | Some e -> raise (MTOInvalidated e) + | Some (proj, e) -> raise (MTOInvalidated (proj, e)) | None -> StructInclude (module_path s p)) and module_type_type_of_desc_noexn s t = @@ -644,18 +644,18 @@ and module_type_type_of_desc_noexn s t = | ModPath p -> ModPath (module_path s p) | StructInclude p -> StructInclude (module_path s p) -and mto_module_path_invalidated : t -> Cpath.module_ -> ModuleType.expr option = +and mto_module_path_invalidated : + t -> Cpath.module_ -> (Cpath.projection * ModuleType.expr) option = fun s p -> match p with | `Resolved p' -> mto_resolved_module_path_invalidated s p' | `Substituted p' -> mto_module_path_invalidated s p' | `Dot (p', id) -> mto_module_path_invalidated s p' - |> Option.map (member_of_module_type_expr s id) + |> Option.map (fun (proj, e) -> (`Dot (proj, id), e)) | `Module (`Module p', id) -> - let id = Odoc_model.Names.ModuleName.to_string id in mto_resolved_module_path_invalidated s p' - |> Option.map (member_of_module_type_expr s id) + |> Option.map (fun (proj, e) -> (`Module (proj, id), e)) | `Module (_, _) -> None | `Apply (p1, p2) -> ( match mto_module_path_invalidated s p1 with @@ -666,7 +666,7 @@ and mto_module_path_invalidated : t -> Cpath.module_ -> ModuleType.expr option = | `Local (id, _) -> ( match PathModuleMap.find id s.module_type_of_invalidating_modules with | exception Not_found -> None - | mty -> Some mty) + | mty -> Some (`Here, mty)) | `Identifier _ -> None | `Forward _ -> None | `Root _ -> None @@ -676,18 +676,15 @@ and mto_resolved_module_path_invalidated s p = | `Local id -> ( match PathModuleMap.find id s.module_type_of_invalidating_modules with | exception Not_found -> None - | mty -> Some mty) + | mty -> Some (`Here, mty)) | `Gpath _ -> None - | `Apply (p1, p2) -> ( - Format.eprintf "WOW WE DID IT HERE@.%a@.%!" - Component.Fmt.resolved_module_path p; - match mto_resolved_module_path_invalidated s p1 with - | Some _ as ans -> ans - | None -> mto_resolved_module_path_invalidated s p2) + | `Apply (p1, p2) -> + (* Only consider invalid if [p1] is invalidated - [p2] can't mess up the type in the same way *) + mto_resolved_module_path_invalidated s p1 + |> Option.map (fun (proj, e) -> (`Apply (proj, `Resolved p2), e)) | `Module (`Module p, id) -> - let id = Odoc_model.Names.ModuleName.to_string id in mto_resolved_module_path_invalidated s p - |> Option.map (member_of_module_type_expr s id) + |> Option.map (fun (proj, e) -> (`Module (proj, id), e)) | `Substituted p -> mto_resolved_module_path_invalidated s p | `Module (_, _) -> None | `Alias (p1, _p2, _) -> mto_resolved_module_path_invalidated s p1 @@ -696,25 +693,7 @@ and mto_resolved_module_path_invalidated s p = | `Canonical (p1, _p2) -> mto_resolved_module_path_invalidated s p1 | `OpaqueModule p -> mto_resolved_module_path_invalidated s p -and member_of_module_type_expr s id (t : ModuleType.expr) = - match t with - | Signature sg -> member_of_sig s sg id - | Path { p_path = _; p_expansion = Some (Signature sg) } -> - member_of_sig s sg id - | Path _ -> assert false - | With _ -> assert false - | Functor _ -> assert false - | TypeOf _ -> assert false - -and member_of_sig _s sg id = - match Find.module_in_sig sg id with - | None -> assert false - | Some (`FModule (_, m)) -> ( - match m.type_ with - | Alias (p, exp) -> TypeOf { t_desc = StructInclude p; t_expansion = exp } - | ModuleType e -> e) - -and u_module_type_expr s (t as t0) = +and u_module_type_expr s t = let open Component.ModuleType.U in match t with | Path p -> ( @@ -726,6 +705,7 @@ and u_module_type_expr s (t as t0) = | Signature s -> Signature s | TypeOf { t_desc; _ } -> TypeOf t_desc | With w -> With (w.w_substitutions, w.w_expr) + | Project (proj, e) -> Project (proj, Component.umty_of_mty_exn e) | Functor _ -> (* non functor cannot be substituted away to a functor *) assert false)) @@ -735,14 +715,10 @@ and u_module_type_expr s (t as t0) = (List.map (with_module_type_substitution s) subs, u_module_type_expr s e) | TypeOf t -> ( try TypeOf (module_type_type_of_desc s t) - with MTOInvalidated e -> ( - match Component.umty_of_mty e with - | Some e -> u_module_type_expr s e - | None -> - Format.eprintf "WELP, LET'S TRY THIS@.%a@.%a@.%!" - Component.Fmt.u_module_type_expr t0 Component.Fmt.module_type_expr - e; - TypeOf (module_type_type_of_desc_noexn s t))) + with MTOInvalidated (proj, e) -> ( + let e = u_module_type_expr s (Component.umty_of_mty_exn e) in + match proj with `Here -> e | _ -> Project (proj, e))) + | Project (proj, e) -> Project (proj, u_module_type_expr s e) and module_type_expr s t = let open Component.ModuleType in @@ -775,6 +751,7 @@ and module_type_expr s t = | TypeOf { t_desc; t_expansion = None } -> TypeOf { t_desc = module_type_type_of_desc_noexn s t_desc; t_expansion = None } + | Project (proj, e) -> Project (proj, module_type_expr s e) and with_module_type_substitution s sub = let open Component.ModuleType in diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index 1c53f4f594..443bcd4792 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -21,6 +21,8 @@ type module_modifiers = type module_type_modifiers = [ `AliasModuleType of Cpath.Resolved.module_type ] +let resolve_module_path_fwd = ref (fun _ _ -> assert false) + (* These three functions take a fully-qualified canonical path and return a list of shorter possibilities to test *) let c_mod_poss env p = @@ -1629,6 +1631,9 @@ and signature_of_u_module_type_expr : handle_signature_with_subs ~mark_substituted env sg subs | TypeOf t -> expansion_of_module_type_type_of_desc env t >>= assert_not_functor + | Project (proj, expr) -> + signature_of_u_module_type_expr ~mark_substituted env expr >>= fun sg -> + project_from_signature ~mark_substituted env proj sg and expansion_of_module_type_type_of_desc : Env.t -> @@ -1688,6 +1693,71 @@ and expansion_of_module_type_expr : | StructInclude p -> (p, true) in expansion_of_module_path env ~strengthen cp + | Component.ModuleType.Project (proj, expr) -> + expansion_of_module_type_expr ~mark_substituted env expr >>= fun exp -> + project_from_expansion ~mark_substituted env proj exp + +and project_from_signature : + mark_substituted:bool -> + Env.t -> + Cpath.projection -> + Component.Signature.t -> + (Component.Signature.t, expansion_of_module_error) Result.result = + fun ~mark_substituted env proj sg -> + project_from_expansion ~mark_substituted env proj (Signature sg) + >>= assert_not_functor + +and project_from_expansion : + mark_substituted:bool -> + Env.t -> + Cpath.projection -> + expansion -> + (expansion, expansion_of_module_error) Result.result = + fun ~mark_substituted env proj exp -> + match proj with + | `Here -> Ok exp + | `Dot (proj, id) -> + project_from_expansion ~mark_substituted env proj exp >>= fun exp -> + find_in_expansion env exp id + | `Module (proj, id) -> + project_from_expansion ~mark_substituted env proj exp >>= fun exp -> + let id = Odoc_model.Names.ModuleName.to_string id in + find_in_expansion env exp id + | `Apply (proj, arg_path) -> ( + project_from_expansion ~mark_substituted env proj exp >>= fun exp -> + match exp with + | Signature _ | Functor (Unit, _) -> assert false + | Functor (Named arg, expr) -> ( + (* CR lmaurer: Get rid of forward declaration *) + match !resolve_module_path_fwd env arg_path with + | Error err -> Error (`UnresolvedPath (`Module (arg_path, err))) + | Ok arg_path -> + (* CR lmaurer: Too much C&P from [handle_apply] *) + let substitution = + if mark_substituted then `Substituted arg_path else arg_path + in + + let subst = + Subst.add_module + (arg.id :> Ident.path_module) + (`Resolved substitution) substitution Subst.identity + in + let subst = Subst.unresolve_opaque_paths subst in + let expr = Subst.module_type_expr subst expr in + expansion_of_module_type_expr ~mark_substituted env expr)) + +and find_in_expansion : + Env.t -> + expansion -> + string -> + (expansion, expansion_of_module_error) Result.result = + fun env exp id -> + match exp with + | Functor _ -> assert false (* CR lmaurer: Better error? *) + | Signature sg -> ( + match Find.module_in_sig sg id with + | None -> assert false (* CR lmaurer: Better error? *) + | Some (`FModule (_, m)) -> expansion_of_module env m) and expansion_of_module_type : Env.t -> @@ -1732,6 +1802,7 @@ and umty_of_mty : Component.ModuleType.expr -> Component.ModuleType.U.expr = | Path { p_path; _ } -> Path p_path | TypeOf { t_desc; _ } -> TypeOf t_desc | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) + | Project (proj, mty) -> Project (proj, umty_of_mty mty) | Functor _ -> assert false and fragmap : @@ -2316,6 +2387,8 @@ let resolve_module_path env p = | Error (`UnresolvedForwardPath | `UnresolvedPath _) -> Ok p | Error (`UnexpandedTypeOf _) -> Ok p) +let () = resolve_module_path_fwd := resolve_module_path + let resolve_module_type_path env p = resolve_module_type ~mark_substituted:true ~add_canonical:true env p >>= fun (p, mt) -> diff --git a/test/odoc_print/odoc_print.ml b/test/odoc_print/odoc_print.ml index 66c47eb1f1..17923dce76 100644 --- a/test/odoc_print/odoc_print.ml +++ b/test/odoc_print/odoc_print.ml @@ -36,6 +36,10 @@ and signature_of_module_type_expr = function | TypeOf _ -> None | With { w_expansion = Some e; _ } -> Some (signature_of_simple_expansion e) | With _ -> None + | Project (`Here, expr) -> signature_of_module_type_expr expr + | Project _ -> + (* TODO could handle simple cases here *) + None and signature_of_module : Odoc_model.Lang.Module.t -> Odoc_model.Lang.Signature.t option = diff --git a/test/xref2/transparent_ascription.t/test.mli b/test/xref2/transparent_ascription.t/test.mli index 1bb257faf8..d7d18f587d 100644 --- a/test/xref2/transparent_ascription.t/test.mli +++ b/test/xref2/transparent_ascription.t/test.mli @@ -84,6 +84,69 @@ module Cascade : sig module P : S with module M = Int end +module List_of (T : T) : sig + type t = T.t list + + val iter : t -> f:(T.t -> unit) -> unit +end + +module In_functor : sig + module type S = sig + module M : functor (T : T) -> T + + module N1 : module type of M + module N2 : module type of M (Int) + module N2' : sig + include module type of M (Int) + end + end + + (* [P.N] should just have type [t] because [module type of M] has already + evaluated to [T] *) + module P : S with module M = List_of +end + +module Wrapped_list_of : sig + module M = List_of +end + +module In_nested_functor : sig + module type S = sig + module O : sig + module M (_ : T) : T + end + + (* {v + module N1 : module type of O + + module N1' : module type of struct + include O + end + + module N1'' : sig + include module type of O + end + + module N2 : module type of O.M + + module N3 : module type of O.M (Int) + + module N3' : module type of struct + include O.M (Int) + end + v} *) + module N3'' : sig + include module type of struct + include O.M (Int) + end + end + end + + module P1 : S with module O = Wrapped_list_of + + module P2 : S with module O.M = List_of +end + (* The same logic should apply to functor parameters, but _in reverse_ since functor types are contravariant in their parameters. In other words, a substitution can _remove_ information from a parameter type and we need @@ -100,6 +163,11 @@ module In_functor_parameter : sig end) : T module G : module type of F + module H : sig + include module type of struct + include F (Int) + end + end end (* [P.G]'s argument type should have _both_ [plus] and [t] even though From eef35433fa2d63979e76996428dbfeacb6143fe4 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 23 Jun 2023 11:45:52 +0100 Subject: [PATCH 13/18] Add missing clause to `mty_hidden` --- src/document/generator.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/document/generator.ml b/src/document/generator.ml index ada047f0f8..af3fcfc8ef 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -1522,6 +1522,7 @@ module Make (Syntax : SYNTAX) = struct | TypeOf { t_desc = ModPath m; _ } | TypeOf { t_desc = StructInclude m; _ } -> Paths.Path.(is_hidden (m :> t)) + | Project (_, expr) -> mty_hidden expr | _ -> false and mty_with subs expr = From 65d06cf55e88179e259ce80fd951b4fbd9c18828 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 23 Jun 2023 14:28:17 +0100 Subject: [PATCH 14/18] Add `Functor` constructor to `ModuleType.U.expr` Required so that `Project(`Apply(`Here, path), expr` can be a `ModuleType.U.expr`. --- src/document/generator.ml | 3 ++ src/loader/cmt.ml | 10 ++---- src/loader/cmti.ml | 15 +++------ src/model/lang.ml | 16 +++++----- src/model_desc/lang_desc.ml | 2 ++ src/xref2/compile.ml | 18 +++++++++-- src/xref2/component.ml | 63 ++++++++++++++++++++----------------- src/xref2/component.mli | 5 ++- src/xref2/lang_of.ml | 33 +++++++++++-------- src/xref2/link.ml | 15 ++++++--- src/xref2/subst.ml | 10 +++--- src/xref2/tools.ml | 44 +++++++++++++------------- src/xref2/tools.mli | 4 +-- 13 files changed, 133 insertions(+), 105 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index af3fcfc8ef..fda965e523 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -1511,6 +1511,7 @@ module Make (Syntax : SYNTAX) = struct and umty_hidden : Odoc_model.Lang.ModuleType.U.expr -> bool = function | Path p -> Paths.Path.(is_hidden (p :> t)) | With (_, expr) -> umty_hidden expr + | Functor _ -> false | TypeOf (ModPath m) | TypeOf (StructInclude m) -> Paths.Path.(is_hidden (m :> t)) | Signature _ -> false @@ -1549,6 +1550,7 @@ module Make (Syntax : SYNTAX) = struct function | Path _ -> false | Signature _ -> true + | Functor (_, expr) -> is_elidable_with_u expr | With (_, expr) -> is_elidable_with_u expr | TypeOf _ -> false | Project (_, expr) -> is_elidable_with_u expr (* TODO: Correct? *) @@ -1562,6 +1564,7 @@ module Make (Syntax : SYNTAX) = struct | With (_, expr) when is_elidable_with_u expr -> Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag | With (subs, expr) -> mty_with subs expr + | Functor _ -> (* TODO *) O.txt "" | TypeOf t -> mty_typeof t | Project _ -> (* TODO *) O.txt "" diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 6876d3de19..56b28a98d3 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -544,19 +544,15 @@ and read_include env parent incl = let decl_modty = match unwrap_module_expr_desc incl.incl_mod.mod_desc with | Tmod_ident(p, _) -> - Some (ModuleType.U.TypeOf (ModuleType.StructInclude (Env.Path.read_module env p))) + ModuleType.U.TypeOf (ModuleType.StructInclude (Env.Path.read_module env p)) | _ -> let mty = read_module_expr env parent container incl.incl_mod in umty_of_mty mty in let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in let expansion = { content; shadowed; } in - match decl_modty with - | Some m -> - let decl = ModuleType m in - [Include {parent; doc; decl; expansion; status; strengthened=None; loc }] - | _ -> - content.items + let decl = ModuleType decl_modty in + [Include {parent; doc; decl; expansion; status; strengthened=None; loc }] and read_open env parent o = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 4a6391197f..293ec98afa 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -553,11 +553,8 @@ and read_module_type env parent label_parent mty = | Tmty_with(body, subs) -> ( let body = read_module_type env parent label_parent body in let subs = List.map (read_with_constraint env parent label_parent) subs in - match Odoc_model.Lang.umty_of_mty body with - | Some w_expr -> - With {w_substitutions=subs; w_expansion=None; w_expr } - | None -> - failwith "error") + let w_expr = Odoc_model.Lang.umty_of_mty body in + With {w_substitutions=subs; w_expansion=None; w_expr }) | Tmty_typeof mexpr -> let decl = match mexpr.mod_desc with @@ -757,12 +754,8 @@ and read_include env parent incl = let expr = read_module_type env parent container incl.incl_mod in let umty = Odoc_model.Lang.umty_of_mty expr in let expansion = { content; shadowed; } in - match umty with - | Some uexpr -> - let decl = Include.ModuleType uexpr in - [Include {parent; doc; decl; expansion; status; strengthened=None; loc }] - | _ -> - content.items + let decl = Include.ModuleType umty in + [Include {parent; doc; decl; expansion; status; strengthened=None; loc }] and read_open env parent o = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in diff --git a/src/model/lang.ml b/src/model/lang.ml index 8f2c9242e2..92f620037f 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -96,6 +96,7 @@ and ModuleType : sig type expr = | Path of Path.ModuleType.t | Signature of Signature.t + | Functor of FunctorParameter.t * expr | With of substitution list * expr | TypeOf of type_of_desc | Project of Projection.t * expr @@ -530,14 +531,13 @@ module rec SourceTree : sig end = SourceTree -let rec umty_of_mty : ModuleType.expr -> ModuleType.U.expr option = function - | Signature sg -> Some (Signature sg) - | Path { p_path; _ } -> Some (Path p_path) - | Functor _ -> None - | TypeOf t -> Some (TypeOf t.t_desc) - | With { w_substitutions; w_expr; _ } -> Some (With (w_substitutions, w_expr)) - | Project (proj, e) -> - umty_of_mty e |> Option.map (fun e -> ModuleType.U.Project (proj, e)) +let rec umty_of_mty : ModuleType.expr -> ModuleType.U.expr = function + | Signature sg -> Signature sg + | Path { p_path; _ } -> Path p_path + | Functor (p, e) -> Functor (p, umty_of_mty e) + | TypeOf t -> TypeOf t.t_desc + | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) + | Project (proj, e) -> Project (proj, umty_of_mty e) (** Query the top-comment of a signature. This is [s.doc] most of the time with an exception for signature starting with an inline includes. *) diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index 52d904cbea..fbd15207ea 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -170,6 +170,8 @@ and moduletype_u_expr = (function | Path x -> C ("Path", (x :> Paths.Path.t), path) | Signature x -> C ("Signature", x, signature_t) + | Functor (x1, x2) -> + C ("Functor", (x1, x2), Pair (functorparameter_t, moduletype_u_expr)) | With (t, e) -> C ( "With", diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index b7a15e2437..61e06b809d 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -371,7 +371,8 @@ and include_ : Env.t -> Include.t -> Include.t * Env.t = Tools.expansion_of_module_path env ~strengthen:true p >>= fun exp -> Tools.assert_not_functor exp | ModuleType mty -> - Tools.signature_of_u_module_type_expr ~mark_substituted:false env mty + Tools.expansion_of_u_module_type_expr ~mark_substituted:false env mty + >>= fun exp -> Tools.assert_not_functor exp with | Error e -> Errors.report ~what:(`Include decl) ~tools_error:e `Expand; @@ -591,6 +592,7 @@ and module_type_map_subs env id cexpr subs = | Path (`Resolved p) -> Some (`ModuleType p) | Path _ -> None | With (_, e) -> find_parent e + | Functor _ -> None | TypeOf (ModPath (`Resolved p)) | TypeOf (StructInclude (`Resolved p)) -> Some (`Module p) | TypeOf _ -> None @@ -603,12 +605,15 @@ and module_type_map_subs env id cexpr subs = | None -> None | Some parent -> ( match - Tools.signature_of_u_module_type_expr ~mark_substituted:true env cexpr + Tools.expansion_of_u_module_type_expr ~mark_substituted:true env cexpr with | Error e -> Errors.report ~what:(`Module_type id) ~tools_error:e `Lookup; None - | Ok sg -> + | Ok (Functor _) -> + (* [cexpr] was in a [with] and thus should not have been a functor *) + assert false + | Ok (Signature sg) -> let fragment_root = match parent with (`ModuleType _ | `Module _) as x -> x in @@ -637,6 +642,13 @@ and u_module_type_expr : in let result : ModuleType.U.expr = With (subs', expr') in result + | Functor (param, res) -> + let param' = functor_parameter env param in + let env' = Env.add_functor_parameter param env in + let res' = + u_module_type_expr env' (Paths.Identifier.Mk.result id) res + in + Functor (param', res') | TypeOf t -> let t = match t with diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 875621b7b1..bda65c0a21 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -204,6 +204,7 @@ and ModuleType : sig | Path of Cpath.module_type | Signature of Signature.t | With of substitution list * expr + | Functor of FunctorParameter.t * expr | TypeOf of type_of_desc | Project of Cpath.projection * expr end @@ -746,6 +747,9 @@ module Fmt = struct | With (subs, e) -> Format.fprintf ppf "%a with [%a]" u_module_type_expr e substitution_list subs + | Functor (arg, res) -> + Format.fprintf ppf "(%a) -> %a" functor_parameter arg u_module_type_expr + res | TypeOf t -> module_type_type_of_desc ppf t | Project (proj, e) -> Format.fprintf ppf "(%a)%a" u_module_type_expr e projection proj @@ -2144,6 +2148,24 @@ module Of_Lang = struct let res = Opt.map (type_expression ident_map) e.res in { Exception.locs = e.locs; doc = docs ident_map e.doc; args; res } + and bind_functor_parameter ident_map param = + let open Odoc_model in + match param with + | Lang.FunctorParameter.Named arg -> + let identifier = arg.Lang.FunctorParameter.id in + let id = Ident.Of_Identifier.functor_parameter identifier in + let ident_map' = + { + ident_map with + functor_parameters = + Paths.Identifier.Maps.FunctorParameter.add identifier id + ident_map.functor_parameters; + } + in + let arg' = functor_parameter ident_map' id arg in + (ident_map', FunctorParameter.Named arg') + | Unit -> (ident_map, FunctorParameter.Unit) + and u_module_type_expr ident_map m = let open Odoc_model in match m with @@ -2156,6 +2178,9 @@ module Of_Lang = struct | With (w, e) -> let w' = List.map (with_module_type_substitution ident_map) w in With (w', u_module_type_expr ident_map e) + | Functor (arg, expr) -> + let ident_map', arg' = bind_functor_parameter ident_map arg in + Functor (arg', u_module_type_expr ident_map' expr) | TypeOf t -> let t = match t with @@ -2169,7 +2194,6 @@ module Of_Lang = struct and module_type_expr ident_map m = let open Odoc_model in - let open Paths in match m with | Lang.ModuleType.Signature s -> let s = signature ident_map s in @@ -2196,23 +2220,10 @@ module Of_Lang = struct } in ModuleType.With w' - | Lang.ModuleType.Functor (Named arg, expr) -> - let identifier = arg.Lang.FunctorParameter.id in - let id = Ident.Of_Identifier.functor_parameter identifier in - let ident_map' = - { - ident_map with - functor_parameters = - Identifier.Maps.FunctorParameter.add identifier id - ident_map.functor_parameters; - } - in - let arg' = functor_parameter ident_map' id arg in + | Lang.ModuleType.Functor (arg, expr) -> + let ident_map', arg' = bind_functor_parameter ident_map arg in let expr' = module_type_expr ident_map' expr in - ModuleType.Functor (Named arg', expr') - | Lang.ModuleType.Functor (Unit, expr) -> - let expr' = module_type_expr ident_map expr in - ModuleType.Functor (Unit, expr') + ModuleType.Functor (arg', expr') | Lang.ModuleType.TypeOf { t_desc; t_expansion } -> let t_desc = match t_desc with @@ -2479,18 +2490,14 @@ let module_of_functor_argument (arg : FunctorParameter.parameter) = hidden = false; } -let rec umty_of_mty (e : ModuleType.expr) : ModuleType.U.expr option = +let rec umty_of_mty (e : ModuleType.expr) : ModuleType.U.expr = match e with - | Path { p_path; _ } -> Some (Path p_path) - | Signature s -> Some (Signature s) - | With { w_substitutions; w_expr; _ } -> Some (With (w_substitutions, w_expr)) - | Functor (_, _) -> None - | TypeOf { t_desc; _ } -> Some (TypeOf t_desc) - | Project (proj, e) -> - umty_of_mty e |> Option.map (fun e -> ModuleType.U.Project (proj, e)) - -let umty_of_mty_exn e = - match umty_of_mty e with None -> assert false | Some e -> e + | Path { p_path; _ } -> Path p_path + | Signature s -> Signature s + | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) + | Functor (p, e) -> Functor (p, umty_of_mty e) + | TypeOf { t_desc; _ } -> TypeOf t_desc + | Project (proj, e) -> Project (proj, umty_of_mty e) (** This is equivalent to {!Lang.extract_signature_doc}. *) let extract_signature_doc (s : Signature.t) = diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 4886037321..c7d617d40d 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -187,6 +187,7 @@ and ModuleType : sig | Path of Cpath.module_type | Signature of Signature.t | With of substitution list * expr + | Functor of FunctorParameter.t * expr | TypeOf of type_of_desc | Project of Cpath.projection * expr end @@ -803,9 +804,7 @@ end val module_of_functor_argument : FunctorParameter.parameter -> Module.t -val umty_of_mty : ModuleType.expr -> ModuleType.U.expr option - -val umty_of_mty_exn : ModuleType.expr -> ModuleType.U.expr +val umty_of_mty : ModuleType.expr -> ModuleType.U.expr val extract_signature_doc : Signature.t -> CComment.docs diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 1905be192d..8492c49b74 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -769,6 +769,19 @@ and mty_substitution map identifier = function ModuleTypeSubst (Path.module_type_fragment map frag, module_type_expr map identifier eqn) +and bind_functor_parameter map functor_id = function + | Component.FunctorParameter.Named arg -> + let name = Ident.Name.typed_functor_parameter arg.id in + let identifier' = Identifier.Mk.parameter (functor_id, name) in + let map = + { + map with + functor_parameter = (arg.id, identifier') :: map.functor_parameter; + } + in + (map, Odoc_model.Lang.FunctorParameter.Named (functor_parameter map arg)) + | Unit -> (map, Unit) + and u_module_type_expr map identifier = function | Component.ModuleType.U.Path p_path -> Odoc_model.Lang.ModuleType.U.Path (Path.module_type map p_path) @@ -781,6 +794,10 @@ and u_module_type_expr map identifier = function With ( List.map (mty_substitution map identifier) subs, u_module_type_expr map identifier expr ) + | Functor (param, expr) -> + let map, param = bind_functor_parameter map identifier param in + Functor + (param, u_module_type_expr map (Identifier.Mk.result identifier) expr) | TypeOf (ModPath p) -> TypeOf (ModPath (Path.module_ map p)) | TypeOf (StructInclude p) -> TypeOf (StructInclude (Path.module_ map p)) | Project (proj, expr) -> @@ -806,20 +823,10 @@ and module_type_expr map identifier = function w_expansion = Opt.map (simple_expansion map identifier) w_expansion; w_expr = u_module_type_expr map identifier w_expr; } - | Functor (Named arg, expr) -> - let name = Ident.Name.typed_functor_parameter arg.id in - let identifier' = Identifier.Mk.parameter (identifier, name) in - let map = - { - map with - functor_parameter = (arg.id, identifier') :: map.functor_parameter; - } - in + | Functor (param, expr) -> + let map, param = bind_functor_parameter map identifier param in Functor - ( Named (functor_parameter map arg), - module_type_expr map (Identifier.Mk.result identifier) expr ) - | Functor (Unit, expr) -> - Functor (Unit, module_type_expr map (Identifier.Mk.result identifier) expr) + (param, module_type_expr map (Identifier.Mk.result identifier) expr) | TypeOf { t_desc = ModPath p; t_expansion } -> TypeOf { diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 1dc5509525..1fd1f05734 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -741,13 +741,19 @@ and u_module_type_expr : | With (subs, expr) as unresolved -> ( let cexpr = Component.Of_Lang.(u_module_type_expr (empty ()) expr) in match - Tools.signature_of_u_module_type_expr ~mark_substituted:true env cexpr + Tools.expansion_of_u_module_type_expr ~mark_substituted:true env cexpr with - | Ok sg -> + | Ok (Signature sg) -> With (handle_fragments env id sg subs, u_module_type_expr env id expr) + | Ok (Functor _) -> assert false | Error e -> Errors.report ~what:(`Module_type_U cexpr) ~tools_error:e `Resolve; unresolved) + | Functor (arg, res) -> + let arg' = functor_argument env arg in + let env = Env.add_functor_parameter arg' env in + let res' = u_module_type_expr env (Paths.Identifier.Mk.result id) res in + Functor (arg', res') | TypeOf (StructInclude p) -> TypeOf (StructInclude (module_path env p)) | TypeOf (ModPath p) -> TypeOf (ModPath (module_path env p)) | Project (proj, expr) -> Project (proj, u_module_type_expr env id expr) @@ -786,15 +792,16 @@ and module_type_expr : | With { w_substitutions; w_expansion; w_expr } as unresolved -> ( let cexpr = Component.Of_Lang.(u_module_type_expr (empty ()) w_expr) in match - Tools.signature_of_u_module_type_expr ~mark_substituted:true env cexpr + Tools.expansion_of_u_module_type_expr ~mark_substituted:true env cexpr with - | Ok sg -> + | Ok (Signature sg) -> With { w_substitutions = handle_fragments env id sg w_substitutions; w_expansion = do_expn w_expansion None; w_expr = u_module_type_expr env id w_expr; } + | Ok (Functor _) -> assert false | Error e -> Errors.report ~what:(`Module_type_U cexpr) ~tools_error:e `Expand; unresolved) diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index f04993d86a..39bf91111b 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -705,18 +705,18 @@ and u_module_type_expr s t = | Signature s -> Signature s | TypeOf { t_desc; _ } -> TypeOf t_desc | With w -> With (w.w_substitutions, w.w_expr) - | Project (proj, e) -> Project (proj, Component.umty_of_mty_exn e) - | Functor _ -> - (* non functor cannot be substituted away to a functor *) - assert false)) + | Project (proj, e) -> Project (proj, Component.umty_of_mty e) + | Functor (param, e) -> Functor (param, Component.umty_of_mty e))) | Signature sg -> Signature (signature s sg) | With (subs, e) -> With (List.map (with_module_type_substitution s) subs, u_module_type_expr s e) + | Functor (arg, expr) -> + Functor (functor_parameter s arg, u_module_type_expr s expr) | TypeOf t -> ( try TypeOf (module_type_type_of_desc s t) with MTOInvalidated (proj, e) -> ( - let e = u_module_type_expr s (Component.umty_of_mty_exn e) in + let e = u_module_type_expr s (Component.umty_of_mty e) in match proj with `Here -> e | _ -> Project (proj, e))) | Project (proj, e) -> Project (proj, u_module_type_expr s e) diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index 443bcd4792..a6418f7f8c 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -1613,27 +1613,37 @@ and unresolve_subs subs = | x -> x) subs -and signature_of_u_module_type_expr : +and expansion_of_u_module_type_expr : mark_substituted:bool -> Env.t -> Component.ModuleType.U.expr -> - (Component.Signature.t, expansion_of_module_error) Result.result = + (expansion, expansion_of_module_error) Result.result = fun ~mark_substituted env m -> match m with | Component.ModuleType.U.Path p -> ( match resolve_module_type ~mark_substituted ~add_canonical:true env p with - | Ok (_, mt) -> expansion_of_module_type env mt >>= assert_not_functor + | Ok (_, mt) -> expansion_of_module_type env mt | Error e -> Error (`UnresolvedPath (`ModuleType (p, e)))) - | Signature s -> Ok s + | Signature s -> Ok (Signature s) | With (subs, s) -> - signature_of_u_module_type_expr ~mark_substituted env s >>= fun sg -> + expansion_of_u_module_type_expr ~mark_substituted env s + >>= assert_not_functor + >>= fun sg -> let subs = unresolve_subs subs in - handle_signature_with_subs ~mark_substituted env sg subs - | TypeOf t -> - expansion_of_module_type_type_of_desc env t >>= assert_not_functor + handle_signature_with_subs ~mark_substituted env sg subs >>= fun sg -> + Ok (Signature sg) + | Functor (arg, expr) -> + expansion_of_u_module_type_expr ~mark_substituted env expr >>= fun exp -> + let expr : Component.ModuleType.expr = + match exp with + | Signature sg -> Signature sg + | Functor (arg2, expr) -> Functor (arg2, expr) + in + Ok (Functor (arg, expr)) + | TypeOf t -> expansion_of_module_type_type_of_desc env t | Project (proj, expr) -> - signature_of_u_module_type_expr ~mark_substituted env expr >>= fun sg -> - project_from_signature ~mark_substituted env proj sg + expansion_of_u_module_type_expr ~mark_substituted env expr >>= fun exp -> + project_from_expansion ~mark_substituted env proj exp and expansion_of_module_type_type_of_desc : Env.t -> @@ -1679,7 +1689,9 @@ and expansion_of_module_type_expr : items have been removed *) | Component.ModuleType.With { w_substitutions; w_expr; _ } -> - signature_of_u_module_type_expr ~mark_substituted env w_expr >>= fun sg -> + expansion_of_u_module_type_expr ~mark_substituted env w_expr + >>= assert_not_functor + >>= fun sg -> let subs = unresolve_subs w_substitutions in handle_signature_with_subs ~mark_substituted env sg subs >>= fun sg -> Ok (Signature sg) @@ -1697,16 +1709,6 @@ and expansion_of_module_type_expr : expansion_of_module_type_expr ~mark_substituted env expr >>= fun exp -> project_from_expansion ~mark_substituted env proj exp -and project_from_signature : - mark_substituted:bool -> - Env.t -> - Cpath.projection -> - Component.Signature.t -> - (Component.Signature.t, expansion_of_module_error) Result.result = - fun ~mark_substituted env proj sg -> - project_from_expansion ~mark_substituted env proj (Signature sg) - >>= assert_not_functor - and project_from_expansion : mark_substituted:bool -> Env.t -> diff --git a/src/xref2/tools.mli b/src/xref2/tools.mli index ebd03e8648..d7583c6078 100644 --- a/src/xref2/tools.mli +++ b/src/xref2/tools.mli @@ -246,11 +246,11 @@ val expansion_of_module_type_expr : be called during compile or link, whereas the reresolve functions should only be called during the link phase. *) -val signature_of_u_module_type_expr : +val expansion_of_u_module_type_expr : mark_substituted:bool -> Env.t -> Component.ModuleType.U.expr -> - (Component.Signature.t, expansion_of_module_error) Result.result + (expansion, expansion_of_module_error) Result.result (** The following functions are use for the resolution of {{!type:Odoc_model.Paths.Fragment.t}Fragments} Whilst resolving fragments it is necessary to process them in order, applying the 'with' expression of module or type equality or substitution, before resolving From 25edc41eb2418810bd68139c5b605adc58c37d51 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 30 Jun 2023 12:15:34 +0100 Subject: [PATCH 15/18] Remove debug output --- src/xref2/subst.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 39bf91111b..9ba668a122 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -659,9 +659,7 @@ and mto_module_path_invalidated : | `Module (_, _) -> None | `Apply (p1, p2) -> ( match mto_module_path_invalidated s p1 with - | Some _ as ans -> - Format.eprintf "WOW WE DID IT@.%!"; - ans + | Some _ as ans -> ans | None -> mto_module_path_invalidated s p2) | `Local (id, _) -> ( match PathModuleMap.find id s.module_type_of_invalidating_modules with From 858a05e3c78edf87e1860f0d4b0d72b127bc5d3f Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 4 Aug 2023 13:38:05 +0100 Subject: [PATCH 16/18] Add `Strengthen` operator for making ascription actually transparent Given ``` module type S = sig module A : T module type M : sig include module type of struct include A end end end module type P = S with module A = Int ``` we need to give `P.M` a strange type: `T` strengthened at `Int`. The substitution operation has no way of computing this module type, so as with `Project`, we need a new operator in the module-type language. --- src/document/generator.ml | 39 ++-- src/document/targets.ml | 3 +- src/model/lang.ml | 9 + src/model_desc/lang_desc.ml | 19 +- src/xref2/compile.ml | 9 +- src/xref2/component.ml | 28 +++ src/xref2/component.mli | 8 + src/xref2/lang_of.ml | 9 + src/xref2/link.ml | 9 + src/xref2/strengthen.ml | 50 ++++- src/xref2/subst.ml | 81 +++++--- src/xref2/tools.ml | 32 ++-- test/odoc_print/odoc_print.ml | 3 + test/xref2/transparent_ascription.t/test.mli | 184 ++++++++++++++++--- 14 files changed, 398 insertions(+), 85 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index acf7a8c5dc..82cb3c5390 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -1371,11 +1371,13 @@ module Make (Syntax : SYNTAX) = struct match t with | Path { p_expansion = None; _ } | TypeOf { t_expansion = None; _ } - | With { w_expansion = None; _ } -> + | With { w_expansion = None; _ } + | Strengthen { s_expansion = None; _ } -> None | Path { p_expansion = Some e; _ } | TypeOf { t_expansion = Some e; _ } - | With { w_expansion = Some e; _ } -> + | With { w_expansion = Some e; _ } + | Strengthen { s_expansion = Some e; _ } -> Some e | Signature sg -> Some (Signature sg) | Functor (f_parameter, e) -> ( @@ -1517,6 +1519,8 @@ module Make (Syntax : SYNTAX) = struct Paths.Path.(is_hidden (m :> t)) | Signature _ -> false | Project (_, expr) -> umty_hidden expr + | Strengthen (p, expr) -> + umty_hidden expr || Paths.Path.(is_hidden (p :> t)) and mty_hidden : Odoc_model.Lang.ModuleType.expr -> bool = function | Path { p_path = mty_path; _ } -> Paths.Path.(is_hidden (mty_path :> t)) @@ -1554,20 +1558,25 @@ module Make (Syntax : SYNTAX) = struct | Functor (_, expr) -> is_elidable_with_u expr | With (_, expr) -> is_elidable_with_u expr | TypeOf _ -> false - | Project (_, expr) -> is_elidable_with_u expr (* TODO: Correct? *) + | Project _ | Strengthen _ -> + (* Currently these are only produced in cases where the module type would + previously have been replaced by its expansion, which would have been + a signature *) + true and umty : Odoc_model.Lang.ModuleType.U.expr -> text = fun m -> - match m with - | Path p -> Link.from_path (p :> Paths.Path.t) - | Signature _ -> - Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag - | With (_, expr) when is_elidable_with_u expr -> - Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag - | With (subs, expr) -> mty_with subs expr - | Functor _ -> (* TODO *) O.txt "" - | TypeOf t -> mty_typeof t - | Project _ -> (* TODO *) O.txt "" + if is_elidable_with_u m then + Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag + else + match m with + | Path p -> Link.from_path (p :> Paths.Path.t) + | Signature _ | Project _ | Strengthen _ -> + (* impossible since [is_elidable_with_u m] was false *) + assert false + | With (subs, expr) -> mty_with subs expr + | Functor _ -> (* shouldn't happen *) O.txt "" + | TypeOf t -> mty_typeof t and mty : Odoc_model.Lang.ModuleType.expr -> text = fun m -> @@ -1608,6 +1617,7 @@ module Make (Syntax : SYNTAX) = struct | Signature _ -> Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag | Project _ -> O.txt "unexpanded projection" + | Strengthen _ -> O.txt "unexpanded strengthening" and mty_in_decl : Paths.Identifier.Signature.t -> Odoc_model.Lang.ModuleType.expr -> text @@ -1645,6 +1655,9 @@ module Make (Syntax : SYNTAX) = struct | Project _ -> (* TODO *) unresolved [ inline (Text "") ] + | Strengthen _ -> + (* TODO *) + unresolved [ inline (Text "") ] (* TODO : Centralize the list juggling for type parameters *) and type_expr_in_subst td typath = diff --git a/src/document/targets.ml b/src/document/targets.ml index 399ea8e1b7..2c4eb56017 100644 --- a/src/document/targets.ml +++ b/src/document/targets.ml @@ -49,7 +49,8 @@ and module_type_expr (t : Odoc_model.Lang.ModuleType.expr) = sub @ module_type_expr e | Path { p_expansion = e_opt; _ } | With { w_expansion = e_opt; _ } - | TypeOf { t_expansion = e_opt; _ } -> + | TypeOf { t_expansion = e_opt; _ } + | Strengthen { s_expansion = e_opt; _ } -> opt_expansion e_opt | Project _ -> (* TODO *) diff --git a/src/model/lang.ml b/src/model/lang.ml index 8f8d4988c6..00880f4e19 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -89,6 +89,7 @@ and ModuleType : sig | With of substitution list * expr | TypeOf of type_of_desc | Project of Projection.t * expr + | Strengthen of Path.Module.t * expr end type path_t = { @@ -107,6 +108,12 @@ and ModuleType : sig t_expansion : simple_expansion option; } + type strengthen_t = { + s_path : Path.Module.t; + s_expansion : simple_expansion option; + s_expr : U.expr; + } + type expr = | Path of path_t | Signature of Signature.t @@ -114,6 +121,7 @@ and ModuleType : sig | With of with_t | TypeOf of typeof_t | Project of Projection.t * expr + | Strengthen of strengthen_t type t = { id : Identifier.ModuleType.t; @@ -527,6 +535,7 @@ let rec umty_of_mty : ModuleType.expr -> ModuleType.U.expr = function | TypeOf t -> TypeOf t.t_desc | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) | Project (proj, e) -> Project (proj, umty_of_mty e) + | Strengthen { s_path; s_expr; _ } -> Strengthen (s_path, s_expr) (** Query the top-comment of a signature. This is [s.doc] most of the time with an exception for signature starting with an inline includes. *) diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index 96f0d8b64a..1f61070af0 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -143,6 +143,15 @@ and moduletype_typeof_t = F ("t_expansion", (fun t -> t.t_expansion), Option simple_expansion); ] +and moduletype_strengthen_t = + let open Lang.ModuleType in + Record + [ + F ("s_path", (fun t -> (t.s_path :> Paths.Path.t)), path); + F ("s_expr", (fun t -> t.s_expr), moduletype_u_expr); + F ("s_expansion", (fun t -> t.s_expansion), Option simple_expansion); + ] + and moduletype_expr = let open Lang.ModuleType in Variant @@ -154,7 +163,8 @@ and moduletype_expr = | With t -> C ("With", t, moduletype_with_t) | TypeOf x -> C ("TypeOf", x, moduletype_typeof_t) | Project (x1, x2) -> - C ("Project", (x1, x2), Pair (projection, moduletype_expr))) + C ("Project", (x1, x2), Pair (projection, moduletype_expr)) + | Strengthen x -> C ("Strengthen", x, moduletype_strengthen_t)) and moduletype_u_expr = let open Lang.ModuleType.U in @@ -171,7 +181,12 @@ and moduletype_u_expr = Pair (List moduletype_substitution, moduletype_u_expr) ) | TypeOf x -> C ("TypeOf", x, moduletype_type_of_desc) | Project (x1, x2) -> - C ("Project", (x1, x2), Pair (projection, moduletype_u_expr))) + C ("Project", (x1, x2), Pair (projection, moduletype_u_expr)) + | Strengthen (x1, x2) -> + C + ( "Strengthen", + ((x1 :> Paths.Path.t), x2), + Pair (path, moduletype_u_expr) )) and moduletype_t = let open Lang.ModuleType in diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 61e06b809d..fcc07ce1d6 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -383,7 +383,7 @@ and include_ : Env.t -> Include.t -> Include.t * Env.t = match i.strengthened with | Some p -> let cp = Component.Of_Lang.(module_path (empty ()) p) in - Strengthen.signature cp sg + Strengthen.signature cp sg ~deep:false | None -> sg in let e = Lang_of.(simple_expansion map i.parent (Signature sg')) in @@ -600,6 +600,7 @@ and module_type_map_subs env id cexpr subs = (* Preserving the behavior from when this type would have been replaced by its expansion *) None + | Strengthen (_, e) -> find_parent e in match find_parent cexpr with | None -> None @@ -657,6 +658,7 @@ and u_module_type_expr : in TypeOf t | Project (proj, expr) -> Project (proj, inner expr) + | Strengthen (path, expr) -> Strengthen (module_path env path, inner expr) in inner expr @@ -716,6 +718,11 @@ and module_type_expr : | Project (proj, expr) -> (* CR lmaurer: Does [id] need to change here? *) Project (proj, module_type_expr env id expr) + | Strengthen { s_path; s_expr; s_expansion } as e -> + let s_path = module_path env s_path in + let s_expr = u_module_type_expr env id s_expr in + let s_expansion = get_expansion s_expansion e in + Strengthen { s_path; s_expr; s_expansion } and type_decl : Env.t -> TypeDecl.t -> TypeDecl.t = fun env t -> diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 41490a9cab..29fe7e13f4 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -207,6 +207,7 @@ and ModuleType : sig | Functor of FunctorParameter.t * expr | TypeOf of type_of_desc | Project of Cpath.projection * expr + | Strengthen of Cpath.module_ * expr end type path_t = { @@ -225,6 +226,12 @@ and ModuleType : sig t_expansion : simple_expansion option; } + type strengthen_t = { + s_path : Cpath.module_; + s_expansion : simple_expansion option; + s_expr : U.expr; + } + type expr = | Path of path_t | Signature of Signature.t @@ -232,6 +239,7 @@ and ModuleType : sig | Functor of FunctorParameter.t * expr | TypeOf of typeof_t | Project of Cpath.projection * expr + | Strengthen of strengthen_t type t = { locs : Odoc_model.Paths.Identifier.SourceLocation.t option; @@ -753,6 +761,8 @@ module Fmt = struct | TypeOf t -> module_type_type_of_desc ppf t | Project (proj, e) -> Format.fprintf ppf "(%a)%a" u_module_type_expr e projection proj + | Strengthen (p, e) -> + Format.fprintf ppf "%a with %a" u_module_type_expr e module_path p and module_type_expr ppf mt = let open ModuleType in @@ -771,6 +781,9 @@ module Fmt = struct Format.fprintf ppf "module type of struct include %a end" module_path p | Project (proj, e) -> Format.fprintf ppf "(%a)%a" module_type_expr e projection proj + | Strengthen { s_expr; s_path; _ } -> + Format.fprintf ppf "%a with %a" u_module_type_expr s_expr module_path + s_path and functor_parameter ppf x = let open FunctorParameter in @@ -2202,6 +2215,10 @@ module Of_Lang = struct | Project (proj, e) -> let proj' = projection ident_map proj in Project (proj', u_module_type_expr ident_map e) + | Strengthen (p, e) -> + let p = module_path ident_map p in + let e = u_module_type_expr ident_map e in + Strengthen (p, e) and module_type_expr ident_map m = let open Odoc_model in @@ -2246,6 +2263,16 @@ module Of_Lang = struct | Lang.ModuleType.Project (proj, expr) -> ModuleType.Project (projection ident_map proj, module_type_expr ident_map expr) + | Lang.ModuleType.Strengthen s -> + let s' = + ModuleType. + { + s_path = module_path ident_map s.s_path; + s_expr = u_module_type_expr ident_map s.s_expr; + s_expansion = option simple_expansion ident_map s.s_expansion; + } + in + ModuleType.Strengthen s' and module_type ident_map m = let expr = @@ -2509,6 +2536,7 @@ let rec umty_of_mty (e : ModuleType.expr) : ModuleType.U.expr = | Functor (p, e) -> Functor (p, umty_of_mty e) | TypeOf { t_desc; _ } -> TypeOf t_desc | Project (proj, e) -> Project (proj, umty_of_mty e) + | Strengthen { s_path; s_expr; _ } -> Strengthen (s_path, s_expr) (** This is equivalent to {!Lang.extract_signature_doc}. *) let extract_signature_doc (s : Signature.t) = diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 7376bc1136..7ab2d40f1d 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -190,6 +190,7 @@ and ModuleType : sig | Functor of FunctorParameter.t * expr | TypeOf of type_of_desc | Project of Cpath.projection * expr + | Strengthen of Cpath.module_ * expr end type path_t = { @@ -208,6 +209,12 @@ and ModuleType : sig t_expansion : simple_expansion option; } + type strengthen_t = { + s_path : Cpath.module_; + s_expansion : simple_expansion option; + s_expr : U.expr; + } + type expr = | Path of path_t | Signature of Signature.t @@ -215,6 +222,7 @@ and ModuleType : sig | Functor of FunctorParameter.t * expr | TypeOf of typeof_t | Project of Cpath.projection * expr + | Strengthen of strengthen_t type t = { locs : Odoc_model.Paths.Identifier.SourceLocation.t option; diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 8492c49b74..2ac099852e 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -802,6 +802,8 @@ and u_module_type_expr map identifier = function | TypeOf (StructInclude p) -> TypeOf (StructInclude (Path.module_ map p)) | Project (proj, expr) -> Project (Path.projection map proj, u_module_type_expr map identifier expr) + | Strengthen (path, expr) -> + Strengthen (Path.module_ map path, u_module_type_expr map identifier expr) and module_type_expr map identifier = function | Component.ModuleType.Path { p_path; p_expansion } -> @@ -843,6 +845,13 @@ and module_type_expr map identifier = function (* CR lmaurer: [identifier] seems a bit wrong here but it's not always precise elsewhere, I think? *) Project (Path.projection map proj, module_type_expr map identifier expr) + | Strengthen { s_path; s_expr; s_expansion } -> + Strengthen + { + s_path = Path.module_ map s_path; + s_expr = u_module_type_expr map identifier s_expr; + s_expansion = Opt.map (simple_expansion map identifier) s_expansion; + } and module_type : maps -> diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 74f08ebeb1..9f743a059c 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -767,6 +767,8 @@ and u_module_type_expr : | TypeOf (StructInclude p) -> TypeOf (StructInclude (module_path env p)) | TypeOf (ModPath p) -> TypeOf (ModPath (module_path env p)) | Project (proj, expr) -> Project (proj, u_module_type_expr env id expr) + | Strengthen (path, expr) -> + Strengthen (module_path env path, u_module_type_expr env id expr) and module_type_expr : Env.t -> Id.Signature.t -> ModuleType.expr -> ModuleType.expr = @@ -833,6 +835,13 @@ and module_type_expr : t_expansion = do_expn t_expansion None; } | Project (proj, expr) -> Project (proj, module_type_expr env id expr) + | Strengthen { s_path; s_expr; s_expansion } -> + Strengthen + { + s_path = module_path env s_path; + s_expr = u_module_type_expr env id s_expr; + s_expansion = do_expn s_expansion None; + } and type_decl_representation : Env.t -> diff --git a/src/xref2/strengthen.ml b/src/xref2/strengthen.ml index 85a66dfebe..9d54707a2f 100644 --- a/src/xref2/strengthen.ml +++ b/src/xref2/strengthen.ml @@ -19,10 +19,11 @@ open Delayed let rec signature : Cpath.module_ -> ?canonical:Odoc_model.Paths.Path.Module.t -> + deep:bool -> Signature.t -> Signature.t = - fun prefix ?canonical sg -> - let sg', strengthened_modules = sig_items prefix ?canonical sg in + fun prefix ?canonical ~deep sg -> + let sg', strengthened_modules = sig_items prefix ?canonical ~deep sg in let substs = List.fold_left (fun s mid -> Subst.path_invalidate_module (mid :> Ident.path_module) s) @@ -30,7 +31,7 @@ let rec signature : in Subst.signature substs sg' -and sig_items prefix ?canonical sg = +and sig_items prefix ?canonical ~deep sg = let open Signature in let items, ids = List.fold_left @@ -43,7 +44,9 @@ and sig_items prefix ?canonical sg = | Some p -> Some (`Dot (p, name)) | None -> None in - let m' () = module_ ?canonical (`Dot (prefix, name)) (get m) in + let m' () = + module_ ?canonical ~deep (`Dot (prefix, name)) (get m) + in (Module (id, r, put m') :: items, id :: s) | ModuleType (id, mt) -> ( ModuleType @@ -63,7 +66,7 @@ and sig_items prefix ?canonical sg = :: items, s ) | Include i -> - let i', strengthened = include_ prefix i in + let i', strengthened = include_ ~deep prefix i in (Include i' :: items, strengthened @ s) | Exception _ | TypExt _ | Value _ | Class _ | ClassType _ | ModuleSubstitution _ | TypeSubstitution _ | ModuleTypeSubstitution _ @@ -75,10 +78,27 @@ and sig_items prefix ?canonical sg = and module_ : ?canonical:Odoc_model.Paths.Path.Module.t -> + deep:bool -> Cpath.module_ -> Component.Module.t -> Component.Module.t = - fun ?canonical prefix m -> { m with canonical; type_ = Alias (prefix, None) } + fun ?canonical ~deep prefix m -> + if deep then { m with canonical; type_ = module_decl prefix m.type_ } + else { m with canonical; type_ = Alias (prefix, None) } + +and module_decl : + Cpath.module_ -> Component.Module.decl -> Component.Module.decl = + fun prefix decl -> + match decl with + | Alias _ -> Alias (prefix, None) + | ModuleType mty -> + ModuleType + (Strengthen + { + s_expr = Component.umty_of_mty mty; + s_path = prefix; + s_expansion = None; + }) (* nuke the expansion as this could otherwise lead to inconsistencies - e.g. 'AlreadyASig' *) and module_type : @@ -114,7 +134,19 @@ and type_decl : Cpath.type_ -> TypeDecl.t -> TypeDecl.t = in { t with equation } -and include_ : Cpath.module_ -> Include.t -> Include.t * Ident.module_ list = - fun path i -> - let expansion_, strengthened = sig_items path i.expansion_ in +and include_ : + deep:bool -> Cpath.module_ -> Include.t -> Include.t * Ident.module_ list = + fun ~deep path i -> + let expansion_, strengthened = sig_items ~deep path i.expansion_ in ({ i with expansion_; strengthened = Some path }, strengthened) + +and simple_expansion : + Cpath.module_ -> + ?canonical:Odoc_model.Paths.Path.Module.t -> + deep:bool -> + ModuleType.simple_expansion -> + ModuleType.simple_expansion = + fun path ?canonical ~deep e -> + match e with + | Signature sg -> Signature (signature path ?canonical ~deep sg) + | Functor (arg, e) -> Functor (arg, simple_expansion path ?canonical ~deep e) diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 9ba668a122..89c4fb9a4c 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -2,7 +2,7 @@ open Component exception Invalidated -exception MTOInvalidated of Cpath.projection * Component.ModuleType.expr +exception MTOInvalidated of Component.ModuleType.expr type ('a, 'b) or_replaced = Not_replaced of 'a | Replaced of 'b @@ -184,6 +184,20 @@ and substitute_vars_poly_variant vars v = in { v with elements = List.map subst_element v.elements } +let rec compose_projections ~first ~second = + let next proj = compose_projections ~first ~second:proj in + match second with + | `Module (proj, f) -> `Module (next proj, f) + | `Dot (proj, s) -> `Dot (next proj, s) + | `Apply (proj, a) -> `Apply (next proj, a) + | `Here -> first + +let apply_projection proj e = + match e with + | ModuleType.Project (first, e) -> + ModuleType.Project (compose_projections ~first ~second:proj, e) + | _ -> ModuleType.Project (proj, e) + let rec resolved_module_path : t -> Cpath.Resolved.module_ -> Cpath.Resolved.module_ = fun s p -> @@ -631,11 +645,16 @@ and module_type_type_of_desc s t = match t with | ModPath p -> ( match mto_module_path_invalidated s p with - | Some (proj, e) -> raise (MTOInvalidated (proj, e)) + | Some e -> raise (MTOInvalidated e) | None -> ModPath (module_path s p)) | StructInclude p -> ( match mto_module_path_invalidated s p with - | Some (proj, e) -> raise (MTOInvalidated (proj, e)) + | Some e -> + let e = + Strengthen + { s_expr = umty_of_mty e; s_path = p; s_expansion = None } + in + raise (MTOInvalidated e) | None -> StructInclude (module_path s p)) and module_type_type_of_desc_noexn s t = @@ -644,27 +663,27 @@ and module_type_type_of_desc_noexn s t = | ModPath p -> ModPath (module_path s p) | StructInclude p -> StructInclude (module_path s p) -and mto_module_path_invalidated : - t -> Cpath.module_ -> (Cpath.projection * ModuleType.expr) option = +and mto_module_path_invalidated : t -> Cpath.module_ -> ModuleType.expr option = fun s p -> match p with | `Resolved p' -> mto_resolved_module_path_invalidated s p' | `Substituted p' -> mto_module_path_invalidated s p' | `Dot (p', id) -> mto_module_path_invalidated s p' - |> Option.map (fun (proj, e) -> (`Dot (proj, id), e)) + |> Option.map (fun e -> apply_projection (`Dot (`Here, id)) e) | `Module (`Module p', id) -> mto_resolved_module_path_invalidated s p' - |> Option.map (fun (proj, e) -> (`Module (proj, id), e)) + |> Option.map (fun e -> apply_projection (`Module (`Here, id)) e) | `Module (_, _) -> None - | `Apply (p1, p2) -> ( - match mto_module_path_invalidated s p1 with - | Some _ as ans -> ans - | None -> mto_module_path_invalidated s p2) + | `Apply (p1, p2) -> + (* Only consider invalid if [p1] is invalidated - [p2] can't mess up the + type in the same way *) + mto_module_path_invalidated s p1 + |> Option.map (fun e -> apply_projection (`Apply (`Here, p2)) e) | `Local (id, _) -> ( match PathModuleMap.find id s.module_type_of_invalidating_modules with | exception Not_found -> None - | mty -> Some (`Here, mty)) + | mty -> Some mty) | `Identifier _ -> None | `Forward _ -> None | `Root _ -> None @@ -674,18 +693,30 @@ and mto_resolved_module_path_invalidated s p = | `Local id -> ( match PathModuleMap.find id s.module_type_of_invalidating_modules with | exception Not_found -> None - | mty -> Some (`Here, mty)) + | mty -> Some mty) | `Gpath _ -> None | `Apply (p1, p2) -> - (* Only consider invalid if [p1] is invalidated - [p2] can't mess up the type in the same way *) + (* Only consider invalid if [p1] is invalidated - [p2] can't mess up the + type in the same way *) mto_resolved_module_path_invalidated s p1 - |> Option.map (fun (proj, e) -> (`Apply (proj, `Resolved p2), e)) + |> Option.map (fun e -> apply_projection (`Apply (`Here, `Resolved p2)) e) | `Module (`Module p, id) -> mto_resolved_module_path_invalidated s p - |> Option.map (fun (proj, e) -> (`Module (proj, id), e)) + |> Option.map (fun e -> apply_projection (`Module (`Here, id)) e) | `Substituted p -> mto_resolved_module_path_invalidated s p | `Module (_, _) -> None - | `Alias (p1, _p2, _) -> mto_resolved_module_path_invalidated s p1 + | `Alias (p1, _p2, _) -> + mto_resolved_module_path_invalidated s p1 + |> Option.map (fun e -> + (* The fact that an alias was used forces a strengthening operation + (since the [module type of] resolves to an otherwise-unwritable + alias type). *) + ModuleType.Strengthen + { + s_expr = Component.umty_of_mty e; + s_path = `Resolved p1; + s_expansion = None; + }) | `Subst (_p1, p2) -> mto_resolved_module_path_invalidated s p2 | `Hidden p -> mto_resolved_module_path_invalidated s p | `Canonical (p1, _p2) -> mto_resolved_module_path_invalidated s p1 @@ -704,7 +735,8 @@ and u_module_type_expr s t = | TypeOf { t_desc; _ } -> TypeOf t_desc | With w -> With (w.w_substitutions, w.w_expr) | Project (proj, e) -> Project (proj, Component.umty_of_mty e) - | Functor (param, e) -> Functor (param, Component.umty_of_mty e))) + | Functor (param, e) -> Functor (param, Component.umty_of_mty e) + | Strengthen s -> Strengthen (s.s_path, s.s_expr))) | Signature sg -> Signature (signature s sg) | With (subs, e) -> With @@ -713,10 +745,10 @@ and u_module_type_expr s t = Functor (functor_parameter s arg, u_module_type_expr s expr) | TypeOf t -> ( try TypeOf (module_type_type_of_desc s t) - with MTOInvalidated (proj, e) -> ( - let e = u_module_type_expr s (Component.umty_of_mty e) in - match proj with `Here -> e | _ -> Project (proj, e))) + with MTOInvalidated e -> u_module_type_expr s (Component.umty_of_mty e)) | Project (proj, e) -> Project (proj, u_module_type_expr s e) + | Strengthen (path, expr) -> + Strengthen (module_path s path, u_module_type_expr s expr) and module_type_expr s t = let open Component.ModuleType in @@ -750,6 +782,13 @@ and module_type_expr s t = TypeOf { t_desc = module_type_type_of_desc_noexn s t_desc; t_expansion = None } | Project (proj, e) -> Project (proj, module_type_expr s e) + | Strengthen { s_expr; s_path; s_expansion } -> + Strengthen + { + s_expr = u_module_type_expr s s_expr; + s_path = module_path s s_path; + s_expansion = option_ simple_expansion s s_expansion; + } and with_module_type_substitution s sub = let open Component.ModuleType in diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index a6418f7f8c..67b520e191 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -417,6 +417,19 @@ let simplify_type : Env.t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ = | None -> m) | _ -> m +let strengthen_expansion prefix exp ~deep = + match exp with + | Signature sg -> Signature (Strengthen.signature prefix sg ~deep) + | Functor (param, exp) -> + Functor + ( param, + Strengthen + { + s_expr = Component.umty_of_mty exp; + s_path = prefix; + s_expansion = None; + } ) + let rec handle_apply ~mark_substituted env func_path arg_path m = let rec find_functor mty = match mty with @@ -1578,7 +1591,7 @@ and expansion_of_module_path : | docs -> { sg with items = Comment (`Docs docs) :: sg.items } in if strengthen then - Ok (Signature (Strengthen.signature (`Resolved p') sg')) + Ok (Signature (Strengthen.signature (`Resolved p') sg' ~deep:false)) else Ok (Signature sg') | Functor _ as f -> Ok f) | Error _ when Cpath.is_module_forward path -> Error `UnresolvedForwardPath @@ -1644,6 +1657,9 @@ and expansion_of_u_module_type_expr : | Project (proj, expr) -> expansion_of_u_module_type_expr ~mark_substituted env expr >>= fun exp -> project_from_expansion ~mark_substituted env proj exp + | Strengthen (path, expr) -> + expansion_of_u_module_type_expr ~mark_substituted env expr >>= fun exp -> + Ok (strengthen_expansion path exp ~deep:false) and expansion_of_module_type_type_of_desc : Env.t -> @@ -1708,6 +1724,9 @@ and expansion_of_module_type_expr : | Component.ModuleType.Project (proj, expr) -> expansion_of_module_type_expr ~mark_substituted env expr >>= fun exp -> project_from_expansion ~mark_substituted env proj exp + | Component.ModuleType.Strengthen { s_expr; s_path; _ } -> + expansion_of_u_module_type_expr ~mark_substituted env s_expr + >>= fun exp -> Ok (strengthen_expansion s_path exp ~deep:false) and project_from_expansion : mark_substituted:bool -> @@ -1798,15 +1817,6 @@ and expansion_of_module_cached : let run env _id = expansion_of_module env m in ExpansionOfModuleMemo.memoize run env' id -and umty_of_mty : Component.ModuleType.expr -> Component.ModuleType.U.expr = - function - | Signature sg -> Signature sg - | Path { p_path; _ } -> Path p_path - | TypeOf { t_desc; _ } -> TypeOf t_desc - | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) - | Project (proj, mty) -> Project (proj, umty_of_mty mty) - | Functor _ -> assert false - and fragmap : mark_substituted:bool -> Env.t -> @@ -1836,7 +1846,7 @@ and fragmap : { w_substitutions = [ subst ]; w_expansion = None; - w_expr = umty_of_mty mty'; + w_expr = Component.umty_of_mty mty'; })) in let map_include_decl decl subst = diff --git a/test/odoc_print/odoc_print.ml b/test/odoc_print/odoc_print.ml index 17923dce76..965af8a377 100644 --- a/test/odoc_print/odoc_print.ml +++ b/test/odoc_print/odoc_print.ml @@ -40,6 +40,9 @@ and signature_of_module_type_expr = function | Project _ -> (* TODO could handle simple cases here *) None + | Strengthen { s_expansion = Some e; _ } -> + Some (signature_of_simple_expansion e) + | Strengthen _ -> None and signature_of_module : Odoc_model.Lang.Module.t -> Odoc_model.Lang.Signature.t option = diff --git a/test/xref2/transparent_ascription.t/test.mli b/test/xref2/transparent_ascription.t/test.mli index d7d18f587d..60e4f0b329 100644 --- a/test/xref2/transparent_ascription.t/test.mli +++ b/test/xref2/transparent_ascription.t/test.mli @@ -19,11 +19,31 @@ module Basic : sig module M : T module N : module type of M + + (* [N] but strong *) + module NS : module type of struct + include M + end + + (* [N] but included *) + module NI : sig + include module type of M + end + + (* [N] but strongly included *) + module NSI : sig + include module type of struct + include M + end + end end (* [P.N] should just have type [t] because [module type of M] has already - evaluated to [T] *) + evaluated to [T]. [P.NI] is similar. [P.NS] and [P.NSI] should have just + [t] but it should be equal to [Int.t]. *) module P : S with module M = Int + + module Q : S with module M := Int end (* This should apply even when the module type that changes is nested. *) @@ -40,12 +60,44 @@ module Nested : sig module N1 : module type of O + module N1S : module type of struct + include O + end + + module N1I : sig + include module type of O + end + + module N1SI : sig + include module type of struct + include O + end + end + module N2 : module type of O.M + + module N2S : module type of struct + include O.M + end + + module N2I : sig + include module type of O.M + end + + module N2SI : sig + include module type of struct + include O.M + end + end end module P1 : S with module O = Wrapped_int module P2 : S with module O.M = Int + + module Q1 : S with module O := Wrapped_int + + module Q2 : S with module O.M := Int end (* Same when the [module type of] goes through an alias, though oddly [P.t] ends @@ -58,9 +110,25 @@ module Via_alias : sig module M' = M module N : module type of M' + + module NS : module type of struct + include M' + end + + module NI : sig + include module type of M' + end + + module NSI : sig + include module type of struct + include M' + end + end end module P : S with module M = Int + + module Q : S with module M := Int end (* Now we take the module type of something that _itself_ took the module type @@ -76,12 +144,42 @@ module Cascade : sig module N1 : module type of O + module N1S : module type of struct + include O + end + + module N1I : sig + include module type of O + end + + module N1SI : sig + include module type of struct + include O + end + end + (* Interestingly, this [module type of] expression is never invalidated and retains the link to [O.I]. *) module N2 : module type of O.I + + module N2S : module type of struct + include O.I + end + + module N2I : sig + include module type of O.I + end + + module N2SI : sig + include module type of struct + include O.I + end + end end module P : S with module M = Int + + module Q : S with module M := Int end module List_of (T : T) : sig @@ -92,59 +190,82 @@ end module In_functor : sig module type S = sig - module M : functor (T : T) -> T + module F : functor (T : T) -> T - module N1 : module type of M - module N2 : module type of M (Int) - module N2' : sig - include module type of M (Int) + module G : module type of F + module N : module type of F (Int) + module NS : module type of struct + include F (Int) + end + module NI : sig + include module type of F (Int) + end + module NSI : sig + include module type of struct + include F (Int) + end end end (* [P.N] should just have type [t] because [module type of M] has already evaluated to [T] *) - module P : S with module M = List_of + module P : S with module F = List_of + + module Q : S with module F := List_of end module Wrapped_list_of : sig - module M = List_of + module F = List_of end module In_nested_functor : sig module type S = sig module O : sig - module M (_ : T) : T + module F (_ : T) : T end - (* {v - module N1 : module type of O + module N1 : module type of O + + module N1S : module type of struct + include O + end - module N1' : module type of struct - include O - end + module N1I : sig + include module type of O + end - module N1'' : sig - include module type of O - end + module N1SI : sig + include module type of struct + include O + end + end - module N2 : module type of O.M + module G : module type of O.F - module N3 : module type of O.M (Int) + module N2 : module type of O.F (Int) - module N3' : module type of struct - include O.M (Int) - end - v} *) - module N3'' : sig + module N2S : module type of struct + include O.F (Int) + end + + module N2I : sig + include module type of O.F (Int) + end + + module N2SI : sig include module type of struct - include O.M (Int) + include O.F (Int) end end end module P1 : S with module O = Wrapped_list_of - module P2 : S with module O.M = List_of + module P2 : S with module O.F = List_of + + module Q1 : S with module O := Wrapped_list_of + + module Q2 : S with module O.F := List_of end (* The same logic should apply to functor parameters, but _in reverse_ since @@ -163,7 +284,14 @@ module In_functor_parameter : sig end) : T module G : module type of F - module H : sig + module N : module type of F (Int) + module NS : module type of struct + include F (Int) + end + module NI : sig + include module type of F (Int) + end + module NSI : sig include module type of struct include F (Int) end @@ -173,4 +301,6 @@ module In_functor_parameter : sig (* [P.G]'s argument type should have _both_ [plus] and [t] even though [Identity]'s argument type does not *) module P : S with module F = Identity + + module Q : S with module F := Identity end From fceca49725925cfa0b57518848c494556c8cd9ba Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Fri, 4 Aug 2023 19:01:54 +0100 Subject: [PATCH 17/18] Replace a substituted module with its expansion where possible The original mechanism for dealing with substitution into unexpanded `module type of` expressions was to have them secretly be expanded after all and swap in the expansion when necessary. This necessarily meant that such a substitution always produced an expanded type - that is, either a signature or a functor whose body is a signature. This branch avoids this mechanism and can therefore produce a more informative type. It's not clear that this is an improvement, however, since it means the HTML can say something like `include T` when the user wrote no such thing. The old behaviour always produced `include sig ... end` instead (which _unambiguously_ wasn't something in the source). It's easy to go back to the old behaviour, however, simply by using the expansion when it's available. There are still cases where there's no expansion immediately available but we'd still rather say `sig ... end`: namely, if `Subst` has added a projection or strengthening operation, it will erase the expansion, so this mechanism won't kick in. However, these cases are currently always rendered as `include sig ... end` anyway. A more robust mechanism might be to simply add (yet) another constructor to the `ModuleType.expr` and `ModuleType.U.expr` grammars to explicitly mark that a sigature's inline form should always be rendered as `include sig ... end` (that is, that `is_elidable_with_u` in `generator.ml` should return `true`). --- src/xref2/subst.ml | 30 +++++++++- test/xref2/transparent_ascription.t/run.t | 69 ++++++++++++++++++++++- 2 files changed, 96 insertions(+), 3 deletions(-) diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 89c4fb9a4c..1a9b4f8d38 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -522,6 +522,33 @@ let rec type_fragment : t -> Cfrag.type_ -> Cfrag.type_ = type_fragment t frag') | `Dot (sg, n) -> `Dot (signature_fragment t sg, n) +let umty_of_simple_expansion exp = + Component.umty_of_mty (Component.mty_of_simple_expansion exp) + +(* Given the type of a module that is being substituted away as it appeared + where the module was declared, convert to the form to put in place of an + occurrence of the module in an unexpanded `module type of`. Attempt to + preserve older behaviour where substitution effectively expanded the module + type in place. See [Basic.P.NI] in the transparent ascription tests for an + example. *) +let rec substituted_module_type_expr : + Component.ModuleType.expr -> Component.ModuleType.U.expr = + fun e -> + match e with + | Signature sg -> Signature sg + | Functor (p, e) -> Functor (p, substituted_module_type_expr e) + | Path { p_expansion = Some exp; _ } + | With { w_expansion = Some exp; _ } + | TypeOf { t_expansion = Some exp; _ } + | Strengthen { s_expansion = Some exp; _ } -> + umty_of_simple_expansion exp + | Project (proj, e) -> Project (proj, substituted_module_type_expr e) + | Path { p_expansion = None; _ } + | With { w_expansion = None; _ } + | TypeOf { t_expansion = None; _ } + | Strengthen { s_expansion = None; _ } -> + Component.umty_of_mty e + let option_ conv s x = match x with Some x -> Some (conv s x) | None -> None let list conv s xs = List.map (conv s) xs @@ -745,7 +772,8 @@ and u_module_type_expr s t = Functor (functor_parameter s arg, u_module_type_expr s expr) | TypeOf t -> ( try TypeOf (module_type_type_of_desc s t) - with MTOInvalidated e -> u_module_type_expr s (Component.umty_of_mty e)) + with MTOInvalidated e -> + u_module_type_expr s (substituted_module_type_expr e)) | Project (proj, e) -> Project (proj, u_module_type_expr s e) | Strengthen (path, expr) -> Strengthen (module_path s path, u_module_type_expr s expr) diff --git a/test/xref2/transparent_ascription.t/run.t b/test/xref2/transparent_ascription.t/run.t index 00de3aa901..978af365da 100644 --- a/test/xref2/transparent_ascription.t/run.t +++ b/test/xref2/transparent_ascription.t/run.t @@ -4,15 +4,80 @@ Transparent ascription $ ocamlc -c -bin-annot test.mli $ odoc compile test.cmti + + `Basic.P.N` should be a signature with just one type called `t`: $ odoc_print test.odoc -r Basic.P.N \ > | jq '.type_.ModuleType.Signature.items - > | ((.[].Type | select(.)) |= { id: .[1].id."`Type"[1] })' + > | ((.[].Type | select(.)) + > |= { id: .[1].id."`Type"[1], + > concrete: (.[1].equation.manifest != "None") })' [ { "Type": { - "id": "t" + "id": "t", + "concrete": false + } + } + ] + +`Basic.P.NS` should be similar but strengthened to `M.t`: + + $ odoc_print test.odoc -r Basic.P.NS \ + > | jq '.type_.ModuleType.Signature.items + > | ((.[].Type | select(.)) + > |= { id: .[1].id."`Type"[1], + > concrete: (.[1].equation.manifest != "None") })' + [ + { + "Type": { + "id": "t", + "concrete": true + } + } + ] + +`Basic.P.NI` should be like `Basic.P.N`, only it's a signature that includes such +a signature. Crucially, to match old behaviour (and for arguably less confusing +output), the `include` statement should render as `include sig ... end` rather +than `include T` (which looks like something that would appear in the source but +does not). + + $ odoc_print test.odoc -r Basic.P.NI \ + > | jq '.type_.ModuleType.Signature.items[0].Include + > .decl.ModuleType.Signature.items + > | ((.[].Type | select(.)) + > |= { id: .[1].id."`Type"[1], + > concrete: (.[1].equation.manifest != "None") })' + [ + { + "Type": { + "id": "t", + "concrete": false + } + } + ] + +`Basic.P.NSI` should be like `Basic.P.NI`, only strengthened. In this case, +substitution complicates the `decl` in the term that's returned, but the +expansion is the most important thing anyway, so we check `expansion` instead of +`decl`: + + $ odoc_print test.odoc -r Basic.P.NSI \ + > | jq '.type_.ModuleType.Signature.items[0].Include + > .expansion.content.items + > | ((.[].Type | select(.)) + > |= { id: .[1].id."`Type"[1], + > concrete: (.[1].equation.manifest != "None") })' + [ + { + "Type": { + "id": "t", + "concrete": true } } ] From 3d8a0d4bbff5c7114b2a352a30332806e0a9dc20 Mon Sep 17 00:00:00 2001 From: Luke Maurer Date: Mon, 7 Aug 2023 11:54:04 +0100 Subject: [PATCH 18/18] Remove `Project` from expanded form of `ModuleType.expr` These are only generated when substituting into unexpanded module types, so the constructor for the expanded form was never actually used. The same can be said for `Strengthen`, but that's much more likely to see use in the future. --- src/document/generator.ml | 6 ------ src/document/targets.ml | 3 --- src/model/lang.ml | 2 -- src/model_desc/lang_desc.ml | 2 -- src/xref2/compile.ml | 3 --- src/xref2/component.ml | 7 ------- src/xref2/component.mli | 1 - src/xref2/lang_of.ml | 4 ---- src/xref2/link.ml | 1 - src/xref2/subst.ml | 33 +++++++++++---------------------- src/xref2/tools.ml | 3 --- test/odoc_print/odoc_print.ml | 4 ---- 12 files changed, 11 insertions(+), 58 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 82cb3c5390..8659e086ce 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -1384,7 +1384,6 @@ module Make (Syntax : SYNTAX) = struct match simple_expansion_of e with | Some e -> Some (Functor (f_parameter, e)) | None -> None) - | Project _ -> failwith "Thought we were done with this" in match simple_expansion_of t with | None -> None @@ -1528,7 +1527,6 @@ module Make (Syntax : SYNTAX) = struct | TypeOf { t_desc = ModPath m; _ } | TypeOf { t_desc = StructInclude m; _ } -> Paths.Path.(is_hidden (m :> t)) - | Project (_, expr) -> mty_hidden expr | _ -> false and mty_with subs expr = @@ -1616,7 +1614,6 @@ module Make (Syntax : SYNTAX) = struct | TypeOf { t_desc; _ } -> mty_typeof t_desc | Signature _ -> Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag - | Project _ -> O.txt "unexpanded projection" | Strengthen _ -> O.txt "unexpanded strengthening" and mty_in_decl : @@ -1652,9 +1649,6 @@ module Make (Syntax : SYNTAX) = struct ++ O.cut ++ mty arg.expr ++ O.txt ")" in O.sp ++ text_arg ++ mty_in_decl base expr - | Project _ -> - (* TODO *) - unresolved [ inline (Text "") ] | Strengthen _ -> (* TODO *) unresolved [ inline (Text "") ] diff --git a/src/document/targets.ml b/src/document/targets.ml index 2c4eb56017..70c4ce7704 100644 --- a/src/document/targets.ml +++ b/src/document/targets.ml @@ -52,9 +52,6 @@ and module_type_expr (t : Odoc_model.Lang.ModuleType.expr) = | TypeOf { t_expansion = e_opt; _ } | Strengthen { s_expansion = e_opt; _ } -> opt_expansion e_opt - | Project _ -> - (* TODO *) - [] and module_ (t : Odoc_model.Lang.Module.t) = let url = Url.Path.from_identifier t.id in diff --git a/src/model/lang.ml b/src/model/lang.ml index 3ef519e017..c52e7a6c65 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -120,7 +120,6 @@ and ModuleType : sig | Functor of FunctorParameter.t * expr | With of with_t | TypeOf of typeof_t - | Project of Projection.t * expr | Strengthen of strengthen_t type t = { @@ -535,7 +534,6 @@ let rec umty_of_mty : ModuleType.expr -> ModuleType.U.expr = function | Functor (p, e) -> Functor (p, umty_of_mty e) | TypeOf t -> TypeOf t.t_desc | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) - | Project (proj, e) -> Project (proj, umty_of_mty e) | Strengthen { s_path; s_expr; _ } -> Strengthen (s_path, s_expr) (** Query the top-comment of a signature. This is [s.doc] most of the time with diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index 1f61070af0..45d79ddbb4 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -162,8 +162,6 @@ and moduletype_expr = C ("Functor", (x1, x2), Pair (functorparameter_t, moduletype_expr)) | With t -> C ("With", t, moduletype_with_t) | TypeOf x -> C ("TypeOf", x, moduletype_typeof_t) - | Project (x1, x2) -> - C ("Project", (x1, x2), Pair (projection, moduletype_expr)) | Strengthen x -> C ("Strengthen", x, moduletype_strengthen_t)) and moduletype_u_expr = diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index fcc07ce1d6..3c4f7b9c7f 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -715,9 +715,6 @@ and module_type_expr : | StructInclude p -> StructInclude (module_path env p) in TypeOf { t_desc; t_expansion } - | Project (proj, expr) -> - (* CR lmaurer: Does [id] need to change here? *) - Project (proj, module_type_expr env id expr) | Strengthen { s_path; s_expr; s_expansion } as e -> let s_path = module_path env s_path in let s_expr = u_module_type_expr env id s_expr in diff --git a/src/xref2/component.ml b/src/xref2/component.ml index ba67b400b3..7d0eadb881 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -238,7 +238,6 @@ and ModuleType : sig | With of with_t | Functor of FunctorParameter.t * expr | TypeOf of typeof_t - | Project of Cpath.projection * expr | Strengthen of strengthen_t type t = { @@ -779,8 +778,6 @@ module Fmt = struct Format.fprintf ppf "module type of %a" module_path p | TypeOf { t_desc = StructInclude p; _ } -> Format.fprintf ppf "module type of struct include %a end" module_path p - | Project (proj, e) -> - Format.fprintf ppf "(%a)%a" module_type_expr e projection proj | Strengthen { s_expr; s_path; _ } -> Format.fprintf ppf "%a with %a" u_module_type_expr s_expr module_path s_path @@ -2264,9 +2261,6 @@ module Of_Lang = struct in let t_expansion = option simple_expansion ident_map t_expansion in ModuleType.(TypeOf { t_desc; t_expansion }) - | Lang.ModuleType.Project (proj, expr) -> - ModuleType.Project - (projection ident_map proj, module_type_expr ident_map expr) | Lang.ModuleType.Strengthen s -> let s' = ModuleType. @@ -2539,7 +2533,6 @@ let rec umty_of_mty (e : ModuleType.expr) : ModuleType.U.expr = | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) | Functor (p, e) -> Functor (p, umty_of_mty e) | TypeOf { t_desc; _ } -> TypeOf t_desc - | Project (proj, e) -> Project (proj, umty_of_mty e) | Strengthen { s_path; s_expr; _ } -> Strengthen (s_path, s_expr) (** This is equivalent to {!Lang.extract_signature_doc}. *) diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 7ab2d40f1d..bb8103ebb6 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -221,7 +221,6 @@ and ModuleType : sig | With of with_t | Functor of FunctorParameter.t * expr | TypeOf of typeof_t - | Project of Cpath.projection * expr | Strengthen of strengthen_t type t = { diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 2ac099852e..f41147c273 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -841,10 +841,6 @@ and module_type_expr map identifier = function t_desc = StructInclude (Path.module_ map p); t_expansion = Opt.map (simple_expansion map identifier) t_expansion; } - | Project (proj, expr) -> - (* CR lmaurer: [identifier] seems a bit wrong here but it's not always - precise elsewhere, I think? *) - Project (Path.projection map proj, module_type_expr map identifier expr) | Strengthen { s_path; s_expr; s_expansion } -> Strengthen { diff --git a/src/xref2/link.ml b/src/xref2/link.ml index d1d9096be2..8af5252ede 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -834,7 +834,6 @@ and module_type_expr : t_desc = ModPath (module_path env p); t_expansion = do_expn t_expansion None; } - | Project (proj, expr) -> Project (proj, module_type_expr env id expr) | Strengthen { s_path; s_expr; s_expansion } -> Strengthen { diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 1a9b4f8d38..c9a1d961fc 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -2,7 +2,7 @@ open Component exception Invalidated -exception MTOInvalidated of Component.ModuleType.expr +exception MTOInvalidated of Component.ModuleType.U.expr type ('a, 'b) or_replaced = Not_replaced of 'a | Replaced of 'b @@ -194,9 +194,9 @@ let rec compose_projections ~first ~second = let apply_projection proj e = match e with - | ModuleType.Project (first, e) -> - ModuleType.Project (compose_projections ~first ~second:proj, e) - | _ -> ModuleType.Project (proj, e) + | ModuleType.U.Project (first, e) -> + ModuleType.U.Project (compose_projections ~first ~second:proj, e) + | _ -> ModuleType.U.Project (proj, e) let rec resolved_module_path : t -> Cpath.Resolved.module_ -> Cpath.Resolved.module_ = @@ -542,7 +542,6 @@ let rec substituted_module_type_expr : | TypeOf { t_expansion = Some exp; _ } | Strengthen { s_expansion = Some exp; _ } -> umty_of_simple_expansion exp - | Project (proj, e) -> Project (proj, substituted_module_type_expr e) | Path { p_expansion = None; _ } | With { w_expansion = None; _ } | TypeOf { t_expansion = None; _ } @@ -677,10 +676,7 @@ and module_type_type_of_desc s t = | StructInclude p -> ( match mto_module_path_invalidated s p with | Some e -> - let e = - Strengthen - { s_expr = umty_of_mty e; s_path = p; s_expansion = None } - in + let e = U.Strengthen (p, e) in raise (MTOInvalidated e) | None -> StructInclude (module_path s p)) @@ -690,7 +686,8 @@ and module_type_type_of_desc_noexn s t = | ModPath p -> ModPath (module_path s p) | StructInclude p -> StructInclude (module_path s p) -and mto_module_path_invalidated : t -> Cpath.module_ -> ModuleType.expr option = +and mto_module_path_invalidated : t -> Cpath.module_ -> ModuleType.U.expr option + = fun s p -> match p with | `Resolved p' -> mto_resolved_module_path_invalidated s p' @@ -710,7 +707,7 @@ and mto_module_path_invalidated : t -> Cpath.module_ -> ModuleType.expr option = | `Local (id, _) -> ( match PathModuleMap.find id s.module_type_of_invalidating_modules with | exception Not_found -> None - | mty -> Some mty) + | mty -> Some (substituted_module_type_expr mty)) | `Identifier _ -> None | `Forward _ -> None | `Root _ -> None @@ -720,7 +717,7 @@ and mto_resolved_module_path_invalidated s p = | `Local id -> ( match PathModuleMap.find id s.module_type_of_invalidating_modules with | exception Not_found -> None - | mty -> Some mty) + | mty -> Some (substituted_module_type_expr mty)) | `Gpath _ -> None | `Apply (p1, p2) -> (* Only consider invalid if [p1] is invalidated - [p2] can't mess up the @@ -738,12 +735,7 @@ and mto_resolved_module_path_invalidated s p = (* The fact that an alias was used forces a strengthening operation (since the [module type of] resolves to an otherwise-unwritable alias type). *) - ModuleType.Strengthen - { - s_expr = Component.umty_of_mty e; - s_path = `Resolved p1; - s_expansion = None; - }) + ModuleType.U.Strengthen (`Resolved p1, e)) | `Subst (_p1, p2) -> mto_resolved_module_path_invalidated s p2 | `Hidden p -> mto_resolved_module_path_invalidated s p | `Canonical (p1, _p2) -> mto_resolved_module_path_invalidated s p1 @@ -761,7 +753,6 @@ and u_module_type_expr s t = | Signature s -> Signature s | TypeOf { t_desc; _ } -> TypeOf t_desc | With w -> With (w.w_substitutions, w.w_expr) - | Project (proj, e) -> Project (proj, Component.umty_of_mty e) | Functor (param, e) -> Functor (param, Component.umty_of_mty e) | Strengthen s -> Strengthen (s.s_path, s.s_expr))) | Signature sg -> Signature (signature s sg) @@ -772,8 +763,7 @@ and u_module_type_expr s t = Functor (functor_parameter s arg, u_module_type_expr s expr) | TypeOf t -> ( try TypeOf (module_type_type_of_desc s t) - with MTOInvalidated e -> - u_module_type_expr s (substituted_module_type_expr e)) + with MTOInvalidated e -> u_module_type_expr s e) | Project (proj, e) -> Project (proj, u_module_type_expr s e) | Strengthen (path, expr) -> Strengthen (module_path s path, u_module_type_expr s expr) @@ -809,7 +799,6 @@ and module_type_expr s t = | TypeOf { t_desc; t_expansion = None } -> TypeOf { t_desc = module_type_type_of_desc_noexn s t_desc; t_expansion = None } - | Project (proj, e) -> Project (proj, module_type_expr s e) | Strengthen { s_expr; s_path; s_expansion } -> Strengthen { diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index 67b520e191..5bc91e1fda 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -1721,9 +1721,6 @@ and expansion_of_module_type_expr : | StructInclude p -> (p, true) in expansion_of_module_path env ~strengthen cp - | Component.ModuleType.Project (proj, expr) -> - expansion_of_module_type_expr ~mark_substituted env expr >>= fun exp -> - project_from_expansion ~mark_substituted env proj exp | Component.ModuleType.Strengthen { s_expr; s_path; _ } -> expansion_of_u_module_type_expr ~mark_substituted env s_expr >>= fun exp -> Ok (strengthen_expansion s_path exp ~deep:false) diff --git a/test/odoc_print/odoc_print.ml b/test/odoc_print/odoc_print.ml index 965af8a377..a60dc538ed 100644 --- a/test/odoc_print/odoc_print.ml +++ b/test/odoc_print/odoc_print.ml @@ -36,10 +36,6 @@ and signature_of_module_type_expr = function | TypeOf _ -> None | With { w_expansion = Some e; _ } -> Some (signature_of_simple_expansion e) | With _ -> None - | Project (`Here, expr) -> signature_of_module_type_expr expr - | Project _ -> - (* TODO could handle simple cases here *) - None | Strengthen { s_expansion = Some e; _ } -> Some (signature_of_simple_expansion e) | Strengthen _ -> None