diff --git a/src/document/generator.ml b/src/document/generator.ml index 039f55aa23..8659e086ce 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) -> ( @@ -1511,10 +1513,13 @@ 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; _ } -> + | Functor _ -> false + | TypeOf (ModPath m) | TypeOf (StructInclude m) -> 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)) @@ -1548,19 +1553,28 @@ 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 _ | 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 - | TypeOf { t_desc; _ } -> mty_typeof t_desc + 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 -> @@ -1600,6 +1614,7 @@ module Make (Syntax : SYNTAX) = struct | TypeOf { t_desc; _ } -> mty_typeof t_desc | Signature _ -> Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag + | Strengthen _ -> O.txt "unexpanded strengthening" and mty_in_decl : Paths.Identifier.Signature.t -> Odoc_model.Lang.ModuleType.expr -> text @@ -1634,6 +1649,9 @@ module Make (Syntax : SYNTAX) = struct ++ O.cut ++ mty arg.expr ++ O.txt ")" in O.sp ++ text_arg ++ mty_in_decl base expr + | 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 64d261d7ca..70c4ce7704 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 and module_ (t : Odoc_model.Lang.Module.t) = diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index ad36cf4f78..0c2e6fdf1a 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -548,19 +548,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 {t_desc = ModuleType.StructInclude (Env.Path.read_module env p); t_expansion=None }) + 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 962de3df42..c52e7a6c65 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -81,19 +81,15 @@ 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 + | Functor of FunctorParameter.t * expr | With of substitution list * expr - | TypeOf of typeof_t - - (* Nb. this may have an expansion! *) + | TypeOf of type_of_desc + | Project of Projection.t * expr + | Strengthen of Path.Module.t * expr end type path_t = { @@ -107,12 +103,24 @@ and ModuleType : sig w_expr : U.expr; } + type typeof_t = { + t_desc : type_of_desc; + 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 | Functor of FunctorParameter.t * expr | With of with_t | TypeOf of typeof_t + | Strengthen of strengthen_t type t = { id : Identifier.ModuleType.t; @@ -520,12 +528,13 @@ module rec SourceTree : sig end = SourceTree -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) - | With { w_substitutions; w_expr; _ } -> Some (With (w_substitutions, w_expr)) +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) + | 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/paths.ml b/src/model/paths.ml index 8569f3ebf4..9edbb79bbe 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -688,6 +688,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 92368846f9..e9561f5e31 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -366,6 +366,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 026605b6d8..ed644f7679 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -327,6 +327,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 56c96bc008..45d79ddbb4 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 @@ -152,7 +161,8 @@ 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) + | Strengthen x -> C ("Strengthen", x, moduletype_strengthen_t)) and moduletype_u_expr = let open Lang.ModuleType.U in @@ -160,12 +170,21 @@ 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", (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) + | Project (x1, x2) -> + 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/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml index 0719ca910a..fa55bdd5d2 100644 --- a/src/model_desc/paths_desc.ml +++ b/src/model_desc/paths_desc.ml @@ -392,6 +392,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 @@ -458,6 +466,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 6dca564e62..7842d964ab 100644 --- a/src/model_desc/paths_desc.mli +++ b/src/model_desc/paths_desc.mli @@ -10,6 +10,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 0a1d1530bc..3c4f7b9c7f 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 @@ -372,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; @@ -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 @@ -592,21 +592,29 @@ 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); _ } -> + | Functor _ -> None + | 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 + | Strengthen (_, e) -> find_parent e in match find_parent cexpr with | 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 @@ -635,13 +643,22 @@ 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 + | 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 | ModPath p -> ModPath (module_path env p) | StructInclude p -> StructInclude (module_path env p) in - TypeOf { t_desc; t_expansion } + TypeOf t + | Project (proj, expr) -> Project (proj, inner expr) + | Strengthen (path, expr) -> Strengthen (module_path env path, inner expr) in inner expr @@ -698,6 +715,11 @@ and module_type_expr : | StructInclude p -> StructInclude (module_path env p) in TypeOf { t_desc; t_expansion } + | 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 0cb73ac0f4..7d0eadb881 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -199,17 +199,15 @@ 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 + | Functor of FunctorParameter.t * expr + | TypeOf of type_of_desc + | Project of Cpath.projection * expr + | Strengthen of Cpath.module_ * expr end type path_t = { @@ -223,12 +221,24 @@ and ModuleType : sig w_expr : U.expr; } + type typeof_t = { + t_desc : type_of_desc; + 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 | With of with_t | Functor of FunctorParameter.t * expr | TypeOf of typeof_t + | Strengthen of strengthen_t type t = { locs : Odoc_model.Paths.Identifier.SourceLocation.t option; @@ -455,7 +465,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 +754,14 @@ 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 + | 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 + | 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 @@ -761,6 +778,9 @@ 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 + | 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 @@ -1085,6 +1105,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 @@ -1813,6 +1854,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 -> @@ -2124,6 +2173,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 @@ -2136,18 +2203,26 @@ 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 + | 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 | 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 + | 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 - let open Paths in match m with | Lang.ModuleType.Signature s -> let s = signature ident_map s in @@ -2174,23 +2249,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 @@ -2199,6 +2261,16 @@ module Of_Lang = struct in let t_expansion = option simple_expansion ident_map t_expansion in ModuleType.(TypeOf { t_desc; t_expansion }) + | 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 = @@ -2454,8 +2526,22 @@ let module_of_functor_argument (arg : FunctorParameter.parameter) = hidden = false; } +let rec umty_of_mty (e : ModuleType.expr) : 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 (p, e) -> Functor (p, umty_of_mty e) + | TypeOf { t_desc; _ } -> TypeOf t_desc + | 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) = 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 bc289ad73e..bb8103ebb6 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -182,17 +182,15 @@ 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 + | Functor of FunctorParameter.t * expr + | TypeOf of type_of_desc + | Project of Cpath.projection * expr + | Strengthen of Cpath.module_ * expr end type path_t = { @@ -206,12 +204,24 @@ and ModuleType : sig w_expr : U.expr; } + type typeof_t = { + t_desc : type_of_desc; + 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 | With of with_t | Functor of FunctorParameter.t * expr | TypeOf of typeof_t + | Strengthen of strengthen_t type t = { locs : Odoc_model.Paths.Identifier.SourceLocation.t option; @@ -426,7 +436,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 @@ -589,6 +599,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 : @@ -796,4 +811,8 @@ end val module_of_functor_argument : FunctorParameter.parameter -> Module.t +val umty_of_mty : 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/cpath.ml b/src/xref2/cpath.ml index fac68c865f..d1080c9a35 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/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..f41147c273 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 -> @@ -760,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) @@ -772,18 +794,16 @@ 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; - } + | 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) -> + 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 } -> @@ -805,20 +825,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 { @@ -831,6 +841,13 @@ and module_type_expr map identifier = function t_desc = StructInclude (Path.module_ map p); t_expansion = Opt.map (simple_expansion map identifier) t_expansion; } + | 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 1a229af651..8af5252ede 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -751,17 +751,24 @@ 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) - | 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 } + | 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) + | 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 = @@ -797,15 +804,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) @@ -826,6 +834,13 @@ and module_type_expr : t_desc = ModPath (module_path env p); t_expansion = do_expn t_expansion None; } + | 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 9b1652c634..c9a1d961fc 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.U.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_; } @@ -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.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_ = fun s p -> @@ -508,6 +522,32 @@ 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 + | 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 @@ -629,12 +669,16 @@ 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 -> + let e = U.Strengthen (p, e) in + raise (MTOInvalidated e) + | None -> StructInclude (module_path s p)) and module_type_type_of_desc_noexn s t = let open Component.ModuleType in @@ -642,31 +686,56 @@ 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 = +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' - | `Substituted p' | `Dot (p', _) -> mto_module_path_invalidated s p' - | `Module (`Module p', _) -> mto_resolved_module_path_invalidated s p' - | `Module (_, _) -> false + | `Substituted p' -> mto_module_path_invalidated s p' + | `Dot (p', id) -> + mto_module_path_invalidated s p' + |> Option.map (fun e -> apply_projection (`Dot (`Here, id)) e) + | `Module (`Module p', id) -> + mto_resolved_module_path_invalidated s p' + |> Option.map (fun e -> apply_projection (`Module (`Here, id)) e) + | `Module (_, _) -> None | `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 + (* 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 (substituted_module_type_expr mty)) + | `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 + | `Local id -> ( + match PathModuleMap.find id s.module_type_of_invalidating_modules with + | exception Not_found -> None + | 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 + type in the same way *) mto_resolved_module_path_invalidated s p1 - || mto_resolved_module_path_invalidated s p2 - | `Module (`Module p, _) | `Substituted p -> + |> Option.map (fun e -> apply_projection (`Apply (`Here, `Resolved p2)) e) + | `Module (`Module p, id) -> mto_resolved_module_path_invalidated s p - | `Module (_, _) -> false - | `Alias (p1, _p2, _) -> mto_resolved_module_path_invalidated s p1 + |> 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 + |> 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.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 @@ -682,33 +751,22 @@ 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 *) - assert false)) + | 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 (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 } - -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) + | 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 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) and module_type_expr s t = let open Component.ModuleType in @@ -736,11 +794,18 @@ 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 -> - module_type_expr s (module_type_of_simple_expansion e)) + with MTOInvalidated _ -> + 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 } + | 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 @@ -1091,6 +1156,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..5bc91e1fda 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 = @@ -415,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 @@ -1576,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 @@ -1611,24 +1626,49 @@ 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 = Some (Signature sg); _ } -> Ok sg - | TypeOf { t_desc; _ } -> Error (`UnexpandedTypeOf t_desc) + 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) -> + 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 -> + 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 = @@ -1665,7 +1705,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) @@ -1673,7 +1715,67 @@ 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 + | 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 -> + 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 -> @@ -1712,14 +1814,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 -> TypeOf t - | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr) - | Functor _ -> assert false - and fragmap : mark_substituted:bool -> Env.t -> @@ -1734,21 +1828,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 @@ -1757,7 +1843,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 = @@ -1799,14 +1885,25 @@ 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 (_, 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 (id, r, Component.Delayed.put (fun () -> x)) :: items, true, - id :: subbed_modules, + (id, old_ty) :: subbed_modules, removed ) | Right y -> Ok @@ -1967,11 +2064,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 = @@ -2298,6 +2396,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/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 diff --git a/src/xref2/type_of.ml b/src/xref2/type_of.ml deleted file mode 100644 index 844d6da385..0000000000 --- a/src/xref2/type_of.ml +++ /dev/null @@ -1,174 +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.t_desc 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 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 -> ( - 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) - -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/odoc_print/odoc_print.ml b/test/odoc_print/odoc_print.ml index 66c47eb1f1..a60dc538ed 100644 --- a/test/odoc_print/odoc_print.ml +++ b/test/odoc_print/odoc_print.ml @@ -36,6 +36,9 @@ and signature_of_module_type_expr = function | TypeOf _ -> None | With { w_expansion = Some e; _ } -> Some (signature_of_simple_expansion e) | With _ -> 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/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! 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 new file mode 100644 index 0000000000..978af365da --- /dev/null +++ b/test/xref2/transparent_ascription.t/run.t @@ -0,0 +1,213 @@ +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], + > concrete: (.[1].equation.manifest != "None") })' + [ + { + "Type": { + "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 + } + } + ] + +`Nested.P1.N1.M` should be a module whose type is the resolved module type path +`T`: + + $ odoc_print test.odoc -r Nested.P1.N1.M \ + > | jq '.type_.ModuleType.Path.p_path."`Resolved"."`Identifier"."`ModuleType"[1]' + "T" + +`Nested.P1.N2` should be like `Basic.P.N`: + + $ odoc_print test.odoc -r Nested.P1.N2 \ + > | jq '.type_.ModuleType.Signature.items + > | ((.[].Type | select(.)) |= { id: .[1].id."`Type"[1] })' + [ + { + "Type": { + "id": "t" + } + } + ] + +`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" + } + } + ] + +`Via_alias.P.N` should be like `Basic.P.N`: + + $ odoc_print test.odoc -r Via_alias.P.N \ + > | jq '.type_.ModuleType.Signature.items + > | ((.[].Type | select(.)) |= { id: .[1].id."`Type"[1] })' + [ + { + "Type": { + "id": "t" + } + } + ] + +`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" + } + } + ] + +`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] })))' + { + "t_desc": { + "ModPath": "...I" + }, + "t_expansion": [ + { + "Type": { + "id": "t" + } + } + ] + } + +`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" + } + } + ] + +Bug +=== + + $ ocamlc -c -bin-annot bug.mli + $ odoc compile bug.cmti + +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[].Include.expansion.content.items + > | ((.[].Value | select(.)) |= { id: .id."`Value"[1] })' + [ + { + "Value": { + "id": "print" + } + } + ] diff --git a/test/xref2/transparent_ascription.t/test.mli b/test/xref2/transparent_ascription.t/test.mli new file mode 100644 index 0000000000..60e4f0b329 --- /dev/null +++ b/test/xref2/transparent_ascription.t/test.mli @@ -0,0 +1,306 @@ +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 + + (* [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]. [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. *) + +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 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 + 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' + + 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 + of [M] *) + +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 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 + type t = T.t list + + val iter : t -> f:(T.t -> unit) -> unit +end + +module In_functor : sig + module type S = sig + module F : functor (T : T) -> T + + 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 F = List_of + + module Q : S with module F := List_of +end + +module Wrapped_list_of : sig + module F = List_of +end + +module In_nested_functor : sig + module type S = sig + module O : sig + module F (_ : T) : T + end + + 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 G : module type of O.F + + module N2 : module type of O.F (Int) + + 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.F (Int) + end + end + end + + module P1 : S with module O = Wrapped_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 + 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 + 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.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