diff --git a/src/document/comment.ml b/src/document/comment.ml index 1061250082..f84c572a88 100644 --- a/src/document/comment.ml +++ b/src/document/comment.ml @@ -29,7 +29,8 @@ module Reference = struct let open Reference.Resolved in match r with | `Identifier id -> Identifier.name id - | `SubstAlias (_, r) -> render_resolved (r :> t) + | `Alias (_, r) -> render_resolved (r :> t) + | `AliasModuleType (_, r) -> render_resolved (r :> t) | `Module (r, s) -> render_resolved (r :> t) ^ "." ^ ModuleName.to_string s | `Canonical (_, `Resolved r) -> render_resolved (r :> t) | `Canonical (p, _) -> render_resolved (p :> t) diff --git a/src/document/generator.ml b/src/document/generator.ml index ecd7b62dd4..662eb07068 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -163,7 +163,7 @@ module Make (Syntax : SYNTAX) = struct match fragment with | `Root _ -> assert false | `Subst (_, rr) -> render_resolved_fragment (rr :> t) - | `SubstAlias (_, rr) -> render_resolved_fragment (rr :> t) + | `Alias (_, rr) -> render_resolved_fragment (rr :> t) | `Module (`Root _, s) -> ModuleName.to_string s | `Module_type (`Root _, s) -> ModuleTypeName.to_string s | `Type (`Root _, s) -> TypeName.to_string s diff --git a/src/document/url.ml b/src/document/url.ml index 47cf426d80..e1da94d970 100644 --- a/src/document/url.ml +++ b/src/document/url.ml @@ -19,12 +19,15 @@ let render_path : Odoc_model.Paths.Path.t -> string = | `OpaqueModule p -> render_resolved (p :> t) | `OpaqueModuleType p -> render_resolved (p :> t) | `Subst (_, p) -> render_resolved (p :> t) - | `SubstAlias (_, p) -> render_resolved (p :> t) | `SubstT (_, p) -> render_resolved (p :> t) | `Alias (p1, p2) -> if Odoc_model.Paths.Path.is_hidden (`Resolved (p2 :> t)) then render_resolved (p1 :> t) else render_resolved (p2 :> t) + | `AliasModuleType (p1, p2) -> + if Odoc_model.Paths.Path.is_hidden (`Resolved (p2 :> t)) then + render_resolved (p1 :> t) + else render_resolved (p2 :> t) | `Hidden p -> render_resolved (p :> t) | `Module (p, s) -> render_resolved (p :> t) ^ "." ^ ModuleName.to_string s | `Canonical (_, `Resolved p) -> render_resolved (p :> t) diff --git a/src/model/paths.ml b/src/model/paths.ml index 572ce4f3ef..ae09e9c149 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -445,8 +445,6 @@ module Path = struct | `Hidden _ -> true | `Subst (p1, p2) -> inner (p1 : module_type :> any) || inner (p2 : module_ :> any) - | `SubstAlias (p1, p2) -> - inner (p1 : module_ :> any) || inner (p2 : module_ :> any) | `Module (p, _) -> inner (p : module_ :> any) | `Apply (p, _) -> inner (p : module_ :> any) | `ModuleType (_, m) when Names.ModuleTypeName.is_internal m -> true @@ -457,6 +455,8 @@ module Path = struct | `ClassType (p, _) -> inner (p : module_ :> any) | `Alias (p1, p2) -> inner (p1 : module_ :> any) && inner (p2 : module_ :> any) + | `AliasModuleType (p1, p2) -> + inner (p1 : module_type :> any) && inner (p2 : module_type :> any) | `SubstT (p1, p2) -> inner (p1 :> any) || inner (p2 :> any) | `CanonicalModuleType (_, `Resolved _) -> false | `CanonicalModuleType (x, _) -> inner (x : module_type :> any) @@ -492,13 +492,16 @@ module Path = struct | `CanonicalModuleType (_, `Resolved p) -> parent_module_type_identifier p | `CanonicalModuleType (p, _) -> parent_module_type_identifier p | `OpaqueModuleType mt -> parent_module_type_identifier mt + | `AliasModuleType (sub, orig) -> + if is_path_hidden (`Resolved (sub :> t)) then + parent_module_type_identifier orig + else parent_module_type_identifier sub and parent_module_identifier : Paths_types.Resolved_path.module_ -> Identifier.Signature.t = function | `Identifier id -> (id : Identifier.Path.Module.t :> Identifier.Signature.t) | `Subst (sub, _) -> parent_module_type_identifier sub - | `SubstAlias (sub, _) -> parent_module_identifier sub | `Hidden p -> parent_module_identifier p | `Module (m, n) -> `Module (parent_module_identifier m, n) | `Canonical (_, `Resolved p) -> parent_module_identifier p @@ -521,7 +524,6 @@ module Path = struct let rec identifier : t -> Identifier.Path.Module.t = function | `Identifier id -> id | `Subst (_, p) -> identifier p - | `SubstAlias (_, p) -> identifier p | `Hidden p -> identifier p | `Module (m, n) -> `Module (parent_module_identifier m, n) | `Canonical (_, `Resolved p) -> identifier p @@ -536,7 +538,6 @@ module Path = struct let rec canonical_ident : t -> Identifier.Path.Module.t option = function | `Identifier _id -> None | `Subst (_, _) -> None - | `SubstAlias (_, _) -> None | `Hidden p -> canonical_ident p | `Module (p, n) -> ( match canonical_ident p with @@ -564,6 +565,10 @@ module Path = struct | `CanonicalModuleType (_, `Resolved p) -> identifier p | `CanonicalModuleType (p, _) -> identifier p | `OpaqueModuleType mt -> identifier mt + | `AliasModuleType (sub, orig) -> + if is_path_hidden (`Resolved (sub :> Paths_types.Resolved_path.any)) + then identifier orig + else identifier sub let rec canonical_ident : t -> Identifier.ModuleType.t option = function | `Identifier _id -> None @@ -572,6 +577,7 @@ module Path = struct | Some x -> Some (`ModuleType ((x :> Identifier.Signature.t), n)) | None -> None) | `SubstT (_, _) -> None + | `AliasModuleType (_, _) -> None | `CanonicalModuleType (_, `Resolved p) -> Some (identifier p) | `CanonicalModuleType (_, _) -> None | `OpaqueModuleType m -> canonical_ident (m :> t) @@ -626,7 +632,6 @@ module Path = struct let rec identifier : t -> Identifier.t = function | `Identifier id -> id | `Subst (_, p) -> identifier (p :> t) - | `SubstAlias (_, p) -> identifier (p :> t) | `Hidden p -> identifier (p :> t) | `Module (m, n) -> `Module (parent_module_identifier m, n) | `Canonical (_, `Resolved p) -> identifier (p :> t) @@ -639,6 +644,9 @@ module Path = struct | `Alias (sub, orig) -> if is_path_hidden (`Resolved (sub :> t)) then identifier (orig :> t) else identifier (sub :> t) + | `AliasModuleType (sub, orig) -> + if is_path_hidden (`Resolved (sub :> t)) then identifier (orig :> t) + else identifier (sub :> t) | `SubstT (p, _) -> identifier (p :> t) | `CanonicalModuleType (_, `Resolved p) -> identifier (p :> t) | `CanonicalModuleType (p, _) -> identifier (p :> t) @@ -685,7 +693,7 @@ module Fragment = struct = function | `Root i -> Base i | `Subst (_, p) -> split_parent (sig_of_mod p) - | `SubstAlias (_, p) -> split_parent (sig_of_mod p) + | `Alias (_, p) -> split_parent (sig_of_mod p) | `OpaqueModule m -> split_parent (sig_of_mod m) | `Module (p, name) -> ( match split_parent p with @@ -698,7 +706,7 @@ module Fragment = struct let rec split : t -> string * t option = function | `Root _ -> ("", None) | `Subst (_, p) -> split (sig_of_mod p) - | `SubstAlias (_, p) -> split (sig_of_mod p) + | `Alias (_, p) -> split (sig_of_mod p) | `OpaqueModule m -> split (sig_of_mod m) | `Module (m, name) -> ( match split_parent m with @@ -713,7 +721,7 @@ module Fragment = struct (Path.Resolved.Module.identifier i :> Identifier.Signature.t) | `Subst (s, _) -> (Path.Resolved.ModuleType.identifier s :> Identifier.Signature.t) - | `SubstAlias (i, _) -> + | `Alias (i, _) -> (Path.Resolved.Module.identifier i :> Identifier.Signature.t) | `Module (m, n) -> `Module (identifier m, n) | `OpaqueModule m -> identifier (sig_of_mod m) @@ -724,7 +732,7 @@ module Fragment = struct let rec split : t -> string * t option = function | `Subst (_, p) -> split p - | `SubstAlias (_, p) -> split p + | `Alias (_, p) -> split p | `Module (m, name) -> ( match split_parent m with | Base _ -> (ModuleName.to_string name, None) @@ -771,8 +779,7 @@ module Fragment = struct | `Root (`ModuleType _r) -> assert false | `Root (`Module _r) -> assert false | `Subst (s, _) -> Path.Resolved.identifier (s :> Path.Resolved.t) - | `SubstAlias (p, _) -> - (Path.Resolved.Module.identifier p :> Identifier.t) + | `Alias (p, _) -> (Path.Resolved.Module.identifier p :> Identifier.t) | `Module (m, n) -> `Module (Signature.identifier m, n) | `Module_type (m, n) -> `ModuleType (Signature.identifier m, n) | `Type (m, n) -> `Type (Signature.identifier m, n) @@ -784,7 +791,7 @@ module Fragment = struct | `Root (`ModuleType r) -> Path.is_resolved_hidden (r :> Path.Resolved.t) | `Root (`Module r) -> Path.is_resolved_hidden (r :> Path.Resolved.t) | `Subst (s, _) -> Path.is_resolved_hidden (s :> Path.Resolved.t) - | `SubstAlias (s, _) -> Path.is_resolved_hidden (s :> Path.Resolved.t) + | `Alias (s, _) -> Path.is_resolved_hidden (s :> Path.Resolved.t) | `Module (m, _) | `Module_type (m, _) | `Type (m, _) @@ -886,10 +893,15 @@ module Reference = struct function | `Identifier id -> id | `Hidden s -> parent_signature_identifier (s :> signature) - | `SubstAlias (sub, orig) -> + | `Alias (sub, orig) -> if Path.Resolved.Module.is_hidden sub then parent_signature_identifier (orig :> signature) else (Path.Resolved.Module.identifier sub :> Identifier.Signature.t) + | `AliasModuleType (sub, orig) -> + if Path.Resolved.ModuleType.is_hidden sub then + parent_signature_identifier (orig :> signature) + else + (Path.Resolved.ModuleType.identifier sub :> Identifier.Signature.t) | `Module (m, n) -> `Module (parent_signature_identifier m, n) | `Canonical (_, `Resolved r) -> parent_signature_identifier (r : module_ :> signature) @@ -909,8 +921,8 @@ module Reference = struct and parent_identifier : parent -> Identifier.Parent.t = function | `Identifier id -> id - | (`Hidden _ | `SubstAlias _ | `Module _ | `Canonical _ | `ModuleType _) - as sg -> + | ( `Hidden _ | `Alias _ | `AliasModuleType _ | `Module _ | `Canonical _ + | `ModuleType _ ) as sg -> (parent_signature_identifier sg :> Identifier.Parent.t) | `Type _ as t -> (parent_type_identifier t :> Identifier.Parent.t) | (`Class _ | `ClassType _) as c -> @@ -919,14 +931,14 @@ module Reference = struct and label_parent_identifier : label_parent -> Identifier.LabelParent.t = function | `Identifier id -> id - | ( `Hidden _ | `SubstAlias _ | `Module _ | `Canonical _ | `ModuleType _ - | `Type _ | `Class _ | `ClassType _ ) as r -> + | ( `Hidden _ | `Alias _ | `AliasModuleType _ | `Module _ | `Canonical _ + | `ModuleType _ | `Type _ | `Class _ | `ClassType _ ) as r -> (parent_identifier r :> Identifier.LabelParent.t) and identifier : t -> Identifier.t = function | `Identifier id -> id - | ( `SubstAlias _ | `Module _ | `Canonical _ | `Hidden _ | `Type _ - | `Class _ | `ClassType _ | `ModuleType _ ) as r -> + | ( `Alias _ | `AliasModuleType _ | `Module _ | `Canonical _ | `Hidden _ + | `Type _ | `Class _ | `ClassType _ | `ModuleType _ ) as r -> (label_parent_identifier r :> Identifier.t) | `Field (p, n) -> `Field (parent_identifier p, n) | `Constructor (s, n) -> `Constructor (parent_type_identifier s, n) diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index 45d6f9b8ad..469193ea0d 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -201,7 +201,6 @@ and Resolved_path : sig type module_ = [ `Identifier of Identifier.path_module | `Subst of module_type * module_ - | `SubstAlias of module_ * module_ | `Hidden of module_ | `Module of module_ * ModuleName.t | `Canonical of module_ * Path.module_ @@ -214,6 +213,7 @@ and Resolved_path : sig [ `Identifier of Identifier.path_module_type | `SubstT of module_type * module_type | `CanonicalModuleType of module_type * Path.module_type + | `AliasModuleType of module_type * module_type | `ModuleType of module_ * ModuleTypeName.t | `OpaqueModuleType of module_type ] (** @canonical Odoc_model.Paths.Path.Resolved.ModuleType.t *) @@ -234,12 +234,12 @@ and Resolved_path : sig type any = [ `Identifier of Identifier.any | `Subst of module_type * module_ - | `SubstAlias of module_ * module_ | `Hidden of module_ | `Module of module_ * ModuleName.t | `Canonical of module_ * Path.module_ | `Apply of module_ * module_ | `Alias of module_ * module_ + | `AliasModuleType of module_type * module_type | `OpaqueModule of module_ | `ModuleType of module_ * ModuleTypeName.t | `CanonicalModuleType of module_type * Path.module_type @@ -293,14 +293,14 @@ and Resolved_fragment : sig type signature = [ `Root of root | `Subst of Resolved_path.module_type * module_ - | `SubstAlias of Resolved_path.module_ * module_ + | `Alias of Resolved_path.module_ * module_ | `Module of signature * ModuleName.t | `OpaqueModule of module_ ] (** @canonical Odoc_model.Paths.Fragment.Resolved.Signature.t *) and module_ = [ `Subst of Resolved_path.module_type * module_ - | `SubstAlias of Resolved_path.module_ * module_ + | `Alias of Resolved_path.module_ * module_ | `Module of signature * ModuleName.t | `OpaqueModule of module_ ] (** @canonical Odoc_model.Paths.Fragment.Resolved.Module.t *) @@ -321,7 +321,7 @@ and Resolved_fragment : sig type any = [ `Root of root | `Subst of Resolved_path.module_type * module_ - | `SubstAlias of Resolved_path.module_ * module_ + | `Alias of Resolved_path.module_ * module_ | `Module of signature * ModuleName.t | `Module_type of signature * ModuleTypeName.t | `Type of signature * TypeName.t @@ -589,7 +589,7 @@ and Resolved_reference : sig and module_ = [ `Identifier of Identifier.path_module | `Hidden of module_ - | `SubstAlias of Resolved_path.module_ * module_ + | `Alias of Resolved_path.module_ * module_ | `Module of signature * ModuleName.t | `Canonical of module_ * Reference.module_ ] (** @canonical Odoc_model.Paths.Reference.Resolved.Module.t *) @@ -598,10 +598,11 @@ and Resolved_reference : sig and signature = [ `Identifier of Identifier.signature | `Hidden of module_ - | `SubstAlias of Resolved_path.module_ * module_ + | `Alias of Resolved_path.module_ * module_ | `Module of signature * ModuleName.t | `Canonical of module_ * Reference.module_ - | `ModuleType of signature * ModuleTypeName.t ] + | `ModuleType of signature * ModuleTypeName.t + | `AliasModuleType of Resolved_path.module_type * module_type ] (** @canonical Odoc_model.Paths.Reference.Resolved.Signature.t *) and class_signature = @@ -613,7 +614,8 @@ and Resolved_reference : sig (* parent is [ signature | class_signature ] *) and parent = [ `Identifier of Identifier.parent - | `SubstAlias of Resolved_path.module_ * module_ + | `Alias of Resolved_path.module_ * module_ + | `AliasModuleType of Resolved_path.module_type * module_type | `Module of signature * ModuleName.t | `Hidden of module_ | `Canonical of module_ * Reference.module_ @@ -627,7 +629,8 @@ and Resolved_reference : sig is that the Identifier allows more types *) and label_parent = [ `Identifier of Identifier.label_parent - | `SubstAlias of Resolved_path.module_ * module_ + | `Alias of Resolved_path.module_ * module_ + | `AliasModuleType of Resolved_path.module_type * module_type | `Module of signature * ModuleName.t | `Hidden of module_ | `Canonical of module_ * Reference.module_ @@ -637,9 +640,10 @@ and Resolved_reference : sig | `Type of signature * TypeName.t ] (** @canonical Odoc_model.Paths.Reference.Resolved.LabelParent.t *) - type module_type = + and module_type = [ `Identifier of Identifier.reference_module_type - | `ModuleType of signature * ModuleTypeName.t ] + | `ModuleType of signature * ModuleTypeName.t + | `AliasModuleType of Resolved_path.module_type * module_type ] (** @canonical Odoc_model.Paths.Reference.Resolved.ModuleType.t *) type type_ = @@ -708,7 +712,8 @@ and Resolved_reference : sig type any = [ `Identifier of Identifier.any - | `SubstAlias of Resolved_path.module_ * module_ + | `Alias of Resolved_path.module_ * module_ + | `AliasModuleType of Resolved_path.module_type * module_type | `Module of signature * ModuleName.t | `Hidden of module_ | `Canonical of module_ * Reference.module_ diff --git a/src/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml index c22bbdda43..eca4c6ae37 100644 --- a/src/model_desc/paths_desc.ml +++ b/src/model_desc/paths_desc.ml @@ -192,11 +192,6 @@ module General_paths = struct ( "`Subst", ((x1 :> rp), (x2 :> rp)), Pair (resolved_path, resolved_path) ) - | `SubstAlias (x1, x2) -> - C - ( "`SubstAlias", - ((x1 :> rp), (x2 :> rp)), - Pair (resolved_path, resolved_path) ) | `Hidden x -> C ("`Hidden", (x :> rp), resolved_path) | `Module (x1, x2) -> C ("`Module", ((x1 :> rp), x2), Pair (resolved_path, Names.modulename)) @@ -212,6 +207,11 @@ module General_paths = struct ( "`Alias", ((x1 :> rp), (x2 :> rp)), Pair (resolved_path, resolved_path) ) + | `AliasModuleType (x1, x2) -> + C + ( "`AliasModuleType", + ((x1 :> rp), (x2 :> rp)), + Pair (resolved_path, resolved_path) ) | `OpaqueModule x -> C ("`OpaqueModule", (x :> rp), resolved_path) | `ModuleType (x1, x2) -> C @@ -360,9 +360,14 @@ module General_paths = struct ( "`ModuleType", ((x1 :> rr), x2), Pair (resolved_reference, Names.moduletypename) ) - | `SubstAlias (x1, x2) -> + | `Alias (x1, x2) -> C - ( "`SubstAlias", + ( "`Alias", + ((x1 :> rp), (x2 :> rr)), + Pair (resolved_path, resolved_reference) ) + | `AliasModuleType (x1, x2) -> + C + ( "`AliasModuleType", ((x1 :> rp), (x2 :> rr)), Pair (resolved_path, resolved_reference) ) | `Type (x1, x2) -> @@ -391,9 +396,9 @@ module General_paths = struct ( "`Subst", ((x1 :> rp), (x2 :> rf)), Pair (resolved_path, resolved_fragment) ) - | `SubstAlias (x1, x2) -> + | `Alias (x1, x2) -> C - ( "`SubstAlias", + ( "`Alias", ((x1 :> rp), (x2 :> rf)), Pair (resolved_path, resolved_fragment) ) | `Module (x1, x2) -> diff --git a/src/xref2/cfrag.ml b/src/xref2/cfrag.ml index eb8f6c2b20..4fefca48c7 100644 --- a/src/xref2/cfrag.ml +++ b/src/xref2/cfrag.ml @@ -8,13 +8,13 @@ type root = type resolved_signature = [ `Root of root | `Subst of Cpath.Resolved.module_type * resolved_module - | `SubstAlias of Cpath.Resolved.module_ * resolved_module + | `Alias of Cpath.Resolved.module_ * resolved_module | `Module of resolved_signature * ModuleName.t | `OpaqueModule of resolved_module ] and resolved_module = [ `Subst of Cpath.Resolved.module_type * resolved_module - | `SubstAlias of Cpath.Resolved.module_ * resolved_module + | `Alias of Cpath.Resolved.module_ * resolved_module | `Module of resolved_signature * ModuleName.t | `OpaqueModule of resolved_module ] @@ -48,8 +48,7 @@ let rec resolved_signature_split_parent : resolved_signature -> resolved_base_name = function | `Root i -> RBase i | `Subst (_, p) -> resolved_signature_split_parent (p :> resolved_signature) - | `SubstAlias (_, p) -> - resolved_signature_split_parent (p :> resolved_signature) + | `Alias (_, p) -> resolved_signature_split_parent (p :> resolved_signature) | `OpaqueModule m -> resolved_signature_split_parent (m :> resolved_signature) | `Module (p, name) -> ( match resolved_signature_split_parent p with @@ -71,7 +70,7 @@ let rec signature_split_parent : signature -> base_name = function let rec resolved_module_split : resolved_module -> string * resolved_module option = function | `Subst (_, p) -> resolved_module_split p - | `SubstAlias (_, p) -> resolved_module_split p + | `Alias (_, p) -> resolved_module_split p | `Module (m, name) -> ( match resolved_signature_split_parent m with | RBase _ -> (ModuleName.to_string name, None) @@ -136,7 +135,7 @@ let type_split : type_ -> string * type_ option = function | Branch (base, m) -> (ModuleName.to_string base, Some (`Dot (m, name)))) let rec unresolve_module : resolved_module -> module_ = function - | `OpaqueModule m | `Subst (_, m) | `SubstAlias (_, m) -> unresolve_module m + | `OpaqueModule m | `Subst (_, m) | `Alias (_, m) -> unresolve_module m | `Module (parent, m) -> `Dot (unresolve_signature parent, ModuleName.to_string m) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 2b1ce90f03..0580a0bb91 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -314,7 +314,7 @@ and module_type : Env.t -> ModuleType.t -> ModuleType.t = let expr = match m.expr with | None -> None - | Some e -> Some (module_type_expr env sg_id e) + | Some e -> Some (module_type_expr env sg_id ~expand_paths:false e) in { m with expr } @@ -611,8 +611,12 @@ and u_module_type_expr : inner expr and module_type_expr : - Env.t -> Id.Signature.t -> ModuleType.expr -> ModuleType.expr = - fun env id expr -> + Env.t -> + Id.Signature.t -> + ?expand_paths:bool -> + ModuleType.expr -> + ModuleType.expr = + fun env id ?(expand_paths = true) expr -> let get_expansion cur e = match cur with | Some e -> Some (simple_expansion env id e) @@ -629,7 +633,9 @@ and module_type_expr : match expr with | Signature s -> Signature (signature env id s) | Path { p_path; p_expansion } as e -> - let p_expansion = get_expansion p_expansion e in + let p_expansion = + if expand_paths then get_expansion p_expansion e else p_expansion + in Path { p_path = module_type_path env p_path; p_expansion } | With { w_substitutions; w_expansion; w_expr } as e -> ( let w_expansion = get_expansion w_expansion e in diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 81d5aa8abc..ce20be2cce 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -892,9 +892,6 @@ module Fmt = struct | `Subst (p1, p2) -> Format.fprintf ppf "subst(%a,%a)" resolved_module_type_path p1 resolved_module_path p2 - | `SubstAlias (p1, p2) -> - Format.fprintf ppf "substalias(%a,%a)" resolved_module_path p1 - resolved_module_path p2 | `Hidden p1 -> Format.fprintf ppf "hidden(%a)" resolved_module_path p1 | `Canonical (p1, p2) -> Format.fprintf ppf "canonical(%a,%a)" resolved_module_path p1 @@ -938,6 +935,9 @@ module Fmt = struct module_type_path m2 | `OpaqueModuleType m -> Format.fprintf ppf "opaquemoduletype(%a)" resolved_module_type_path m + | `AliasModuleType (mt1, mt2) -> + Format.fprintf ppf "aliasmoduletype(%a,%a)" resolved_module_type_path + mt1 resolved_module_type_path mt2 | `SubstT (mt1, mt2) -> Format.fprintf ppf "subst(%a,%a)" resolved_module_type_path mt1 resolved_module_type_path mt2 @@ -1084,6 +1084,11 @@ module Fmt = struct (path :> t) model_resolved_path (realpath :> t) + | `AliasModuleType (path, realpath) -> + Format.fprintf ppf "aliasmoduletype(%a,%a)" model_resolved_path + (path :> t) + model_resolved_path + (realpath :> t) | `Subst (modty, m) -> Format.fprintf ppf "subst(%a,%a)" model_resolved_path (modty :> t) @@ -1115,8 +1120,6 @@ module Fmt = struct model_path (p2 :> Odoc_model.Paths.Path.t) | `Hidden p -> Format.fprintf ppf "hidden(%a)" model_resolved_path (p :> t) - | `SubstAlias (_, _) -> - Format.fprintf ppf "UNIMPLEMENTED substalias in model_resolved_path" | `Class (parent, name) -> Format.fprintf ppf "%a.%s" model_resolved_path (parent :> t) @@ -1236,7 +1239,7 @@ module Fmt = struct (path :> Odoc_model.Paths.Path.Resolved.t) model_resolved_fragment (m :> t) - | `SubstAlias (_, _) -> Format.fprintf ppf "UNIMPLEMENTED subst alias!?" + | `Alias (_, _) -> Format.fprintf ppf "UNIMPLEMENTED subst alias!?" | `Class (sg, c) -> Format.fprintf ppf "%a.%s" model_resolved_fragment (sg :> t) @@ -1257,8 +1260,7 @@ module Fmt = struct and resolved_signature_fragment ppf (f : Cfrag.resolved_signature) = match f with | `Root r -> Format.fprintf ppf "%a" resolved_root_fragment r - | (`Subst _ | `SubstAlias _ | `Module _) as x -> - resolved_module_fragment ppf x + | (`Subst _ | `Alias _ | `Module _) as x -> resolved_module_fragment ppf x | `OpaqueModule m -> Format.fprintf ppf "opaquemodule(%a)" resolved_module_fragment m @@ -1267,7 +1269,7 @@ module Fmt = struct | `Subst (s, f) -> Format.fprintf ppf "subst(%a,%a)" resolved_module_type_path s resolved_module_fragment f - | `SubstAlias (m, f) -> + | `Alias (m, f) -> Format.fprintf ppf "substalias(%a,%a)" resolved_module_path m resolved_module_fragment f | `Module (p, n) -> @@ -1370,8 +1372,13 @@ module Fmt = struct Format.fprintf ppf "%a.%s" model_resolved_reference (parent :> t) (InstanceVariableName.to_string name) - | `SubstAlias (x, y) -> - Format.fprintf ppf "substalias(%a,%a)" model_resolved_path + | `Alias (x, y) -> + Format.fprintf ppf "alias(%a,%a)" model_resolved_path + (x :> Odoc_model.Paths.Path.Resolved.t) + model_resolved_reference + (y :> Odoc_model.Paths.Reference.Resolved.t) + | `AliasModuleType (x, y) -> + Format.fprintf ppf "aliasmoduletype(%a,%a)" model_resolved_path (x :> Odoc_model.Paths.Path.Resolved.t) model_resolved_reference (y :> Odoc_model.Paths.Reference.Resolved.t) @@ -1677,7 +1684,6 @@ module Of_Lang = struct | `Alias (p1, p2) -> `Alias (recurse p1, recurse p2) | `Subst (p1, p2) -> `Subst (resolved_module_type_path ident_map p1, recurse p2) - | `SubstAlias (p1, p2) -> `SubstAlias (recurse p1, recurse p2) | `Canonical (p1, p2) -> `Canonical (recurse p1, module_path ident_map p2) | `Hidden p1 -> `Hidden (recurse p1) | `OpaqueModule m -> `OpaqueModule (recurse m) @@ -1696,6 +1702,10 @@ module Of_Lang = struct (resolved_module_type_path ident_map p1, module_type_path ident_map p2) | `OpaqueModuleType m -> `OpaqueModuleType (resolved_module_type_path ident_map m) + | `AliasModuleType (m1, m2) -> + `AliasModuleType + ( resolved_module_type_path ident_map m1, + resolved_module_type_path ident_map m2 ) | `SubstT (p1, p2) -> `SubstT ( resolved_module_type_path ident_map p1, @@ -1785,7 +1795,7 @@ module Of_Lang = struct `Root (`ModuleType (resolved_module_type_path ident_map path)) | `Root (`Module path) -> `Root (`Module (resolved_module_path ident_map path)) - | (`SubstAlias _ | `Subst _ | `Module _ | `OpaqueModule _) as x -> + | (`Alias _ | `Subst _ | `Module _ | `OpaqueModule _) as x -> (resolved_module_fragment ident_map x :> Cfrag.resolved_signature) and resolved_module_fragment : @@ -1797,8 +1807,8 @@ module Of_Lang = struct `Subst ( resolved_module_type_path ident_map p, resolved_module_fragment ident_map m ) - | `SubstAlias (p, m) -> - `SubstAlias + | `Alias (p, m) -> + `Alias ( resolved_module_path ident_map p, resolved_module_fragment ident_map m ) | `Module (p, m) -> `Module (resolved_signature_fragment ident_map p, m) diff --git a/src/xref2/cpath.ml b/src/xref2/cpath.ml index 6449e6037a..9a8f6e5d69 100644 --- a/src/xref2/cpath.ml +++ b/src/xref2/cpath.ml @@ -10,7 +10,6 @@ module rec Resolved : sig | `Identifier of Identifier.Path.Module.t | `Substituted of module_ | `Subst of module_type * module_ - | `SubstAlias of module_ * module_ | `Hidden of module_ | `Module of parent * ModuleName.t | `Canonical of module_ * Cpath.module_ @@ -24,6 +23,7 @@ module rec Resolved : sig | `Identifier of Identifier.ModuleType.t | `ModuleType of parent * ModuleTypeName.t | `SubstT of module_type * module_type + | `AliasModuleType of module_type * module_type | `CanonicalModuleType of module_type * Cpath.module_type | `OpaqueModuleType of module_type ] @@ -103,9 +103,6 @@ let rec resolved_module_path_of_cpath : | `Subst (a, b) -> `Subst (resolved_module_type_path_of_cpath a, resolved_module_path_of_cpath b) - | `SubstAlias (a, b) -> - `SubstAlias - (resolved_module_path_of_cpath a, resolved_module_path_of_cpath b) | `Hidden x -> `Hidden (resolved_module_path_of_cpath x) | `Canonical (a, b) -> `Canonical (resolved_module_path_of_cpath a, module_path_of_cpath b) @@ -131,6 +128,10 @@ and resolved_module_type_path_of_cpath : `SubstT ( resolved_module_type_path_of_cpath p1, resolved_module_type_path_of_cpath p2 ) + | `AliasModuleType (m1, m2) -> + `AliasModuleType + ( resolved_module_type_path_of_cpath m1, + resolved_module_type_path_of_cpath m2 ) | `CanonicalModuleType (p1, p2) -> `CanonicalModuleType (resolved_module_type_path_of_cpath p1, module_type_path_of_cpath p2) @@ -201,11 +202,7 @@ let rec is_resolved_module_substituted : Resolved.module_ -> bool = function | `Substituted _ -> true | `Identifier _ -> false | `Subst (_a, _) -> false (* is_resolved_module_type_substituted a*) - | `SubstAlias (a, _) - | `Hidden a - | `Canonical (a, _) - | `Apply (a, _) - | `Alias (a, _) -> + | `Hidden a | `Canonical (a, _) | `Apply (a, _) | `Alias (a, _) -> is_resolved_module_substituted a | `Module (a, _) -> is_resolved_parent_substituted a | `OpaqueModule a -> is_resolved_module_substituted a @@ -222,6 +219,7 @@ and is_resolved_module_type_substituted : Resolved.module_type -> bool = | `Identifier _ -> false | `ModuleType (a, _) -> is_resolved_parent_substituted a | `SubstT _ -> false + | `AliasModuleType (m1, _) -> is_resolved_module_type_substituted m1 | `CanonicalModuleType (m, _) | `OpaqueModuleType m -> is_resolved_module_type_substituted m @@ -306,7 +304,7 @@ and is_resolved_module_hidden : | `Substituted p | `Apply (p, _) -> inner p | `Module (p, _) -> is_resolved_parent_hidden ~weak_canonical_test p | `Subst (p1, p2) -> is_resolved_module_type_hidden p1 || inner p2 - | `SubstAlias (p1, p2) | `Alias (p1, p2) -> inner p1 || inner p2 + | `Alias (p1, p2) -> inner p1 || inner p2 | `OpaqueModule m -> inner m in inner @@ -334,6 +332,8 @@ and is_resolved_module_type_hidden : Resolved.module_type -> bool = function | `ModuleType (p, _) -> is_resolved_parent_hidden ~weak_canonical_test:false p | `SubstT (p1, p2) -> is_resolved_module_type_hidden p1 || is_resolved_module_type_hidden p2 + | `AliasModuleType (p1, p2) -> + is_resolved_module_type_hidden p1 || is_resolved_module_type_hidden p2 | `CanonicalModuleType (_, `Resolved _) -> false | `CanonicalModuleType (p, _) -> is_resolved_module_type_hidden p | `OpaqueModuleType m -> is_resolved_module_type_substituted m @@ -388,7 +388,7 @@ let rec resolved_module_of_resolved_module_reference : `Module (`Module (resolved_module_of_resolved_signature_reference parent), name) | `Identifier i -> `Identifier i - | `SubstAlias (_m1, _m2) -> failwith "gah" + | `Alias (_m1, _m2) -> failwith "gah" | `Hidden s -> `Hidden (resolved_module_of_resolved_module_reference s) | `Canonical (m1, m2) -> `Canonical @@ -398,10 +398,11 @@ let rec resolved_module_of_resolved_module_reference : and resolved_module_of_resolved_signature_reference : Reference.Resolved.Signature.t -> Resolved.module_ = function | `Identifier (#Identifier.Module.t as i) -> `Identifier i - | (`SubstAlias _ | `Canonical _ | `Module _ | `Hidden _) as r' -> + | (`Alias _ | `Canonical _ | `Module _ | `Hidden _) as r' -> resolved_module_of_resolved_module_reference r' | `ModuleType (_, n) -> failwith ("Not a module reference: " ^ ModuleTypeName.to_string n) + | `AliasModuleType _ -> failwith "Not a module reference: aliasmoduletype" | `Identifier _ -> failwith "Not a module reference : identifier" and module_of_module_reference : Reference.Module.t -> module_ = function @@ -428,7 +429,6 @@ let rec unresolve_resolved_module_path : Resolved.module_ -> module_ = function | `Local x -> `Local (x, false) | `Substituted x -> unresolve_resolved_module_path x | `Subst (_, x) -> unresolve_resolved_module_path x - | `SubstAlias (_, x) -> unresolve_resolved_module_path x | `Hidden x -> unresolve_resolved_module_path x (* should assert false here *) | `Module (p, m) -> `Dot (unresolve_resolved_parent_path p, ModuleName.to_string m) @@ -445,6 +445,7 @@ and unresolve_resolved_module_type_path : Resolved.module_type -> module_type = | `ModuleType (p, n) -> `Dot (unresolve_resolved_parent_path p, ModuleTypeName.to_string n) | `SubstT (_, m) -> unresolve_resolved_module_type_path m + | `AliasModuleType (_, m2) -> unresolve_resolved_module_type_path m2 | `CanonicalModuleType (p, _) -> unresolve_resolved_module_type_path p | `OpaqueModuleType m -> unresolve_resolved_module_type_path m diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index db476e8c0a..b069ebb159 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -137,8 +137,6 @@ module Path = struct | `Identifier y -> `Identifier y | `Subst (mty, m) -> `Subst (resolved_module_type map mty, resolved_module map m) - | `SubstAlias (m1, m2) -> - `SubstAlias (resolved_module map m1, resolved_module map m2) | `Hidden h -> `Hidden (resolved_module map h) | `Module (p, n) -> `Module (resolved_parent map p, n) | `Canonical (r, m) -> `Canonical (resolved_module map r, module_ map m) @@ -169,6 +167,9 @@ module Path = struct | `Substituted s -> resolved_module_type map s | `SubstT (p1, p2) -> `SubstT (resolved_module_type map p1, resolved_module_type map p2) + | `AliasModuleType (p1, p2) -> + `AliasModuleType + (resolved_module_type map p1, resolved_module_type map p2) | `CanonicalModuleType (p1, p2) -> `CanonicalModuleType (resolved_module_type map p1, module_type map p2) | `OpaqueModuleType m -> `OpaqueModuleType (resolved_module_type map m) @@ -226,8 +227,8 @@ module Path = struct match f with | `Subst (p, f) -> `Subst (resolved_module_type map p, resolved_module_fragment map f) - | `SubstAlias (p, f) -> - `SubstAlias (resolved_module map p, resolved_module_fragment map f) + | `Alias (p, f) -> + `Alias (resolved_module map p, resolved_module_fragment map f) | `Module (p, n) -> `Module (resolved_signature_fragment map p, n) | `OpaqueModule m -> `OpaqueModule (resolved_module_fragment map m) @@ -239,7 +240,7 @@ module Path = struct match f with | `Root (`ModuleType p) -> `Root (`ModuleType (resolved_module_type map p)) | `Root (`Module p) -> `Root (`Module (resolved_module map p)) - | (`OpaqueModule _ | `Subst _ | `SubstAlias _ | `Module _) as x -> + | (`OpaqueModule _ | `Subst _ | `Alias _ | `Module _) as x -> (resolved_module_fragment map x :> Odoc_model.Paths.Fragment.Resolved.Signature.t) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 03246902e9..0b04a9b0a9 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -44,7 +44,6 @@ let rec should_reresolve : Paths.Path.Resolved.t -> bool = match p with | `Identifier _ -> false | `Subst (x, y) -> should_reresolve (x :> t) || should_reresolve (y :> t) - | `SubstAlias (x, y) -> should_reresolve (x :> t) || should_reresolve (y :> t) | `Hidden p -> should_reresolve (p :> t) | `Canonical (x, y) -> should_reresolve (x :> t) || should_resolve (y :> Paths.Path.t) @@ -56,6 +55,8 @@ let rec should_reresolve : Paths.Path.Resolved.t -> bool = should_reresolve (x :> t) || should_reresolve (y :> Paths.Path.Resolved.t) | `SubstT (x, y) -> should_reresolve (x :> t) || should_reresolve (y :> t) | `Alias (x, y) -> should_reresolve (x :> t) || should_reresolve (y :> t) + | `AliasModuleType (x, y) -> + should_reresolve (x :> t) || should_reresolve (y :> t) | `Type (p, _) | `Class (p, _) | `ClassType (p, _) @@ -619,17 +620,37 @@ and module_type_expr : Env.t -> Id.Signature.t -> ModuleType.expr -> ModuleType.expr = fun env id expr -> let open ModuleType in - let do_expn e = - Opt.map (simple_expansion env (id :> Paths.Identifier.Signature.t)) e + let do_expn cur (e : Paths.Path.ModuleType.t option) = + match (cur, e) with + | Some e, _ -> + Some (simple_expansion env (id :> Paths.Identifier.Signature.t) e) + | None, Some (`Resolved p_path) -> + let hidden_alias = + Paths.Path.is_hidden (`Resolved (p_path :> Paths.Path.Resolved.t)) + in + let self_canonical = + let i = Paths.Path.Resolved.ModuleType.identifier p_path in + (i :> Id.Signature.t) = id + in + let expansion_needed = self_canonical || hidden_alias in + if expansion_needed then + let cp = Component.Of_Lang.(resolved_module_type_path empty p_path) in + match + Expand_tools.expansion_of_module_type_expr env id + (Path { p_path = `Resolved cp; p_expansion = None }) + with + | Ok (_, _, e) -> + let le = Lang_of.(simple_expansion empty id e) in + Some (simple_expansion env id le) + | Error _ -> None + else None + | None, _ -> None in match expr with | Signature s -> Signature (signature env id s) | Path { p_path; p_expansion } -> - Path - { - p_path = module_type_path env p_path; - p_expansion = do_expn p_expansion; - } + let p_path = module_type_path env p_path in + Path { p_path; p_expansion = do_expn p_expansion (Some p_path) } | With { w_substitutions; w_expansion; w_expr } as unresolved -> ( let cexpr = Component.Of_Lang.(u_module_type_expr empty w_expr) in match @@ -639,7 +660,7 @@ and module_type_expr : With { w_substitutions = handle_fragments env id sg w_substitutions; - w_expansion = do_expn w_expansion; + w_expansion = do_expn w_expansion None; w_expr = u_module_type_expr env id w_expr; } | Error e -> @@ -654,13 +675,13 @@ and module_type_expr : TypeOf { t_desc = StructInclude (module_path env p); - t_expansion = do_expn t_expansion; + t_expansion = do_expn t_expansion None; } | TypeOf { t_desc = ModPath p; t_expansion } -> TypeOf { t_desc = ModPath (module_path env p); - t_expansion = do_expn t_expansion; + t_expansion = do_expn t_expansion None; } and type_decl_representation : diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index e64240a3ef..9c6f391d58 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -158,14 +158,10 @@ module M = struct let p, r = match Tools.get_module_path_modifiers env ~add_canonical:true m with | None -> (base_path, base_ref) - | Some (`SubstAliased cp) -> - let cp = Tools.reresolve_module env cp in - let p = Lang_of.(Path.resolved_module empty cp) in - (`SubstAlias (cp, base_path), `SubstAlias (p, base_ref)) | Some (`Aliased cp) -> let cp = Tools.reresolve_module env cp in let p = Lang_of.(Path.resolved_module empty cp) in - (`Alias (cp, base_path), `SubstAlias (p, base_ref)) + (`Alias (cp, base_path), `Alias (p, base_ref)) | Some (`SubstMT cp) -> let cp = Tools.reresolve_module_type env cp in (`Subst (cp, base_path), base_ref) @@ -203,7 +199,13 @@ module MT = struct type t = module_type_lookup_result - let of_component _env mt base_path base_ref : t = (base_ref, base_path, mt) + let of_component env mt base_path base_ref : t = + match Tools.get_module_type_path_modifiers env ~add_canonical:true mt with + | None -> (base_ref, base_path, mt) + | Some (`AliasModuleType cp) -> + let cp = Tools.reresolve_module_type env cp in + let p = Lang_of.(Path.resolved_module_type empty cp) in + (`AliasModuleType (p, base_ref), `AliasModuleType (cp, base_path), mt) let in_signature env ((parent', parent_cp, sg) : signature_lookup_result) name : t option = @@ -214,8 +216,8 @@ module MT = struct (`ModuleType (parent_cp, name)) (`ModuleType (parent', name))) - let of_element _env (`ModuleType (id, mt)) : t = - (`Identifier id, `Identifier id, mt) + let of_element env (`ModuleType (id, mt)) : t = + of_component env mt (`Identifier id) (`Identifier id) let in_env env name : t option = env_lookup_by_name Env.s_module_type name env >>= fun e -> diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 97e692d591..d854b81b95 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -215,8 +215,6 @@ let rec resolved_module_path : | Not_replaced p1 -> p1 in `Subst (p1, resolved_module_path s p2) - | `SubstAlias (p1, p2) -> - `SubstAlias (resolved_module_path s p1, resolved_module_path s p2) | `Hidden p1 -> `Hidden (resolved_module_path s p1) | `Canonical (p1, p2) -> `Canonical (resolved_module_path s p1, module_path s p2) @@ -295,6 +293,13 @@ and resolved_module_type_path : with | Not_replaced p1, Not_replaced p2 -> Not_replaced (`SubstT (p1, p2)) | Replaced mt, _ | _, Replaced mt -> Replaced mt) + | `AliasModuleType (p1, p2) -> ( + match + (resolved_module_type_path s p1, resolved_module_type_path s p2) + with + | Not_replaced p1, Not_replaced p2 -> + Not_replaced (`AliasModuleType (p1, p2)) + | Replaced mt, _ | _, Replaced mt -> Replaced mt) and module_type_path : t -> Cpath.module_type -> Cpath.module_type module_type_or_replaced = @@ -427,7 +432,7 @@ let rec resolved_signature_fragment : in `Root (`ModuleType p) | `Root (`Module p) -> `Root (`Module (resolved_module_path t p)) - | (`Subst _ | `SubstAlias _ | `OpaqueModule _ | `Module _) as x -> + | (`Subst _ | `Alias _ | `OpaqueModule _ | `Module _) as x -> (resolved_module_fragment t x :> Cfrag.resolved_signature) and resolved_module_fragment : @@ -444,8 +449,8 @@ and resolved_module_fragment : assert false in `Subst (p, resolved_module_fragment t f) - | `SubstAlias (m, f) -> - `SubstAlias (resolved_module_path t m, resolved_module_fragment t f) + | `Alias (m, f) -> + `Alias (resolved_module_path t m, resolved_module_fragment t f) | `Module (sg, n) -> `Module (resolved_signature_fragment t sg, n) | `OpaqueModule m -> `OpaqueModule (resolved_module_fragment t m) @@ -680,7 +685,6 @@ and mto_resolved_module_path_invalidated s p = | `Module (_, _) -> false | `Alias (p1, _p2) -> mto_resolved_module_path_invalidated s p1 | `Subst (_p1, p2) -> mto_resolved_module_path_invalidated s p2 - | `SubstAlias (p1, _p2) -> mto_resolved_module_path_invalidated s p1 | `Hidden p -> 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 diff --git a/src/xref2/test.md b/src/xref2/test.md index 5f16906013..6e58e7634e 100644 --- a/src/xref2/test.md +++ b/src/xref2/test.md @@ -120,7 +120,7 @@ and `Resolved_path.module_` is: type module_ = [ | `Identifier of Identifier.path_module | `Subst of module_type * module_ - | `SubstAlias of module_ * module_ + | `Alias of module_ * module_ | `Hidden of module_ | `Module of module_ * ModuleName.t | `Canonical of module_ * Path.module_ diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index ce82d44225..330e71bbaa 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -7,9 +7,9 @@ open ResultMonad type ('a, 'b) either = Left of 'a | Right of 'b type module_modifiers = - [ `Aliased of Cpath.Resolved.module_ - | `SubstAliased of Cpath.Resolved.module_ - | `SubstMT of Cpath.Resolved.module_type ] + [ `Aliased of Cpath.Resolved.module_ | `SubstMT of Cpath.Resolved.module_type ] + +type module_type_modifiers = [ `AliasModuleType of Cpath.Resolved.module_type ] let core_types = let open Odoc_model.Lang.TypeDecl in @@ -432,6 +432,29 @@ and get_substituted_module_type : else None | _ -> (* Format.fprintf Format.err_formatter "<< + add_canonical:bool -> + Component.ModuleType.t -> + module_type_modifiers option = + fun env ~add_canonical m -> + let alias_of expr = + match expr with + | Component.ModuleType.Path alias_path -> ( + match + resolve_module_type ~mark_substituted:true ~add_canonical env + alias_path.p_path + with + | Ok (resolved_alias_path, _) -> Some resolved_alias_path + | Error _ -> None) + (* | Functor (_arg, res) -> alias_of res *) + | _ -> None + in + match m.expr with + | Some e -> ( + match alias_of e with Some e -> Some (`AliasModuleType e) | None -> None) + | None -> None + and process_module_type env ~add_canonical m p' = let open Component.ModuleType in let open OptionMonad in @@ -441,9 +464,15 @@ and process_module_type env ~add_canonical m p' = m.expr >>= get_substituted_module_type env >>= fun p -> Some (`SubstT (p, p')) in + let p' = match substpath with Some p -> p | None -> p' in - let p'' = if add_canonical then add_canonical_path_mt m p' else p' in - p'' + let p'' = + match get_module_type_path_modifiers env ~add_canonical m with + | Some (`AliasModuleType e) -> `AliasModuleType (e, p') + | None -> p' + in + let p''' = if add_canonical then add_canonical_path_mt m p'' else p'' in + p''' and get_module_path_modifiers : Env.t -> add_canonical:bool -> Component.Module.t -> _ option = @@ -466,7 +495,6 @@ and process_module_path env ~add_canonical m p = let p' = match get_module_path_modifiers env ~add_canonical m with | None -> p - | Some (`SubstAliased p') -> `SubstAlias (p', p) | Some (`Aliased p') -> `Alias (p', p) | Some (`SubstMT p') -> `Subst (p', p) in @@ -487,9 +515,10 @@ and handle_module_lookup env ~add_canonical id parent sg sub = and handle_module_type_lookup env ~add_canonical id p sg sub = let open OptionMonad in Find.module_type_in_sig sg id >>= fun (`FModuleType (name, mt)) -> + let mt = Subst.module_type sub mt in let p' = simplify_module_type env (`ModuleType (p, name)) in let p'' = process_module_type env ~add_canonical mt p' in - Some (p'', Subst.module_type sub mt) + Some (p'', mt) and handle_type_lookup env id p sg = match Find.careful_type_in_sig sg id with @@ -542,7 +571,6 @@ and lookup_module : >>= fun (sg, sub) -> find_in_sg sg sub | `Alias (_, p) -> lookup_module ~mark_substituted env p | `Subst (_, p) -> lookup_module ~mark_substituted env p - | `SubstAlias (_, p) -> lookup_module ~mark_substituted env p | `Hidden p -> lookup_module ~mark_substituted env p | `Canonical (p, _) -> lookup_module ~mark_substituted env p | `OpaqueModule m -> lookup_module ~mark_substituted env m @@ -573,6 +601,7 @@ and lookup_module_type : lookup_parent ~mark_substituted:true env parent |> map_error (fun e -> (e :> simple_module_type_lookup_error)) >>= fun (sg, sub) -> find_in_sg sg sub + | `AliasModuleType (_, mt) -> lookup_module_type ~mark_substituted env mt | `OpaqueModuleType m -> lookup_module_type ~mark_substituted env m in lookup env @@ -966,8 +995,6 @@ and reresolve_module : Env.t -> Cpath.Resolved.module_ -> Cpath.Resolved.module_ | `Alias (p1, p2) -> `Alias (reresolve_module env p1, reresolve_module env p2) | `Subst (p1, p2) -> `Subst (reresolve_module_type env p1, reresolve_module env p2) - | `SubstAlias (p1, p2) -> - `SubstAlias (reresolve_module env p1, reresolve_module env p2) | `Hidden p -> let p' = reresolve_module env p in `Hidden p' @@ -1076,6 +1103,9 @@ and reresolve_module_type : (reresolve_module_type env p1, handle_canonical_module_type env p2) | `SubstT (p1, p2) -> `SubstT (reresolve_module_type env p1, reresolve_module_type env p2) + | `AliasModuleType (p1, p2) -> + `AliasModuleType + (reresolve_module_type env p1, reresolve_module_type env p2) | `OpaqueModuleType m -> `OpaqueModuleType (reresolve_module_type env m) and reresolve_type : Env.t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ = @@ -1552,12 +1582,6 @@ and find_external_module_path : | `Local x -> Some (`Local x) | `Substituted x -> find_external_module_path x >>= fun x -> Some (`Substituted x) - | `SubstAlias (x, y) -> ( - match (find_external_module_path x, find_external_module_path y) with - | Some x, Some y -> Some (`SubstAlias (x, y)) - | Some x, None -> Some x - | None, Some x -> Some x - | None, None -> None) | `Canonical (x, y) -> find_external_module_path x >>= fun x -> Some (`Canonical (x, y)) | `Hidden x -> find_external_module_path x >>= fun x -> Some (`Hidden x) @@ -1588,6 +1612,14 @@ and find_external_module_type_path : | `CanonicalModuleType (x, _) | `Substituted x -> find_external_module_type_path x >>= fun x -> Some (`Substituted x) | `Identifier _ -> Some p + | `AliasModuleType (x, y) -> ( + match + (find_external_module_type_path x, find_external_module_type_path y) + with + | Some x, Some y -> Some (`AliasModuleType (x, y)) + | Some x, None -> Some x + | None, Some x -> Some x + | None, None -> None) | `OpaqueModuleType m -> find_external_module_type_path m >>= fun x -> Some (`OpaqueModuleType x) @@ -1607,9 +1639,9 @@ and fixup_module_cfrag (f : Cfrag.resolved_module) : Cfrag.resolved_module = match find_external_module_type_path path with | Some p -> `Subst (p, frag) | None -> frag) - | `SubstAlias (path, frag) -> ( + | `Alias (path, frag) -> ( match find_external_module_path path with - | Some p -> `SubstAlias (p, frag) + | Some p -> `Alias (p, frag) | None -> frag) | `Module (parent, name) -> `Module (fixup_signature_cfrag parent, name) | `OpaqueModule m -> `OpaqueModule (fixup_module_cfrag m) @@ -1623,7 +1655,7 @@ and fixup_module_type_cfrag (f : Cfrag.resolved_module_type) : and fixup_signature_cfrag (f : Cfrag.resolved_signature) = match f with | `Root x -> `Root x - | (`OpaqueModule _ | `Subst _ | `SubstAlias _ | `Module _) as f -> + | (`OpaqueModule _ | `Subst _ | `Alias _ | `Module _) as f -> (fixup_module_cfrag f :> Cfrag.resolved_signature) and fixup_type_cfrag (f : Cfrag.resolved_type) : Cfrag.resolved_type = @@ -1686,12 +1718,9 @@ and resolve_signature_fragment : | None -> (* Format.fprintf Format.err_formatter "No modifier for frag %a\n%!" Component.Fmt.resolved_signature_fragment new_frag; *) (new_path, new_frag) - | Some (`SubstAliased p') -> - (* Format.fprintf Format.err_formatter "SubstAlias for frag %a\n%!" Component.Fmt.resolved_signature_fragment new_frag; *) - (`SubstAlias (p', new_path), `SubstAlias (p', new_frag)) | Some (`Aliased p') -> (* Format.fprintf Format.err_formatter "Alias for frag %a\n%!" Component.Fmt.resolved_signature_fragment new_frag; *) - (`Alias (p', new_path), `SubstAlias (p', new_frag)) + (`Alias (p', new_path), `Alias (p', new_frag)) | Some (`SubstMT p') -> (* Format.fprintf Format.err_formatter "SubstMT for frag %a\n%!" Component.Fmt.resolved_signature_fragment new_frag; *) (`Subst (p', new_path), `Subst (p', new_frag)) @@ -1721,8 +1750,7 @@ and resolve_module_fragment : let f' = match modifier with | None -> new_frag - | Some (`SubstAliased p') -> `SubstAlias (p', new_frag) - | Some (`Aliased p') -> `SubstAlias (p', new_frag) + | Some (`Aliased p') -> `Alias (p', new_frag) | Some (`SubstMT p') -> `Subst (p', new_frag) in let f'' = @@ -1782,7 +1810,7 @@ let rec reresolve_signature_fragment : match m with | `Root (`ModuleType p) -> `Root (`ModuleType (reresolve_module_type env p)) | `Root (`Module p) -> `Root (`Module (reresolve_module env p)) - | (`OpaqueModule _ | `Subst _ | `SubstAlias _ | `Module _) as x -> + | (`OpaqueModule _ | `Subst _ | `Alias _ | `Module _) as x -> (reresolve_module_fragment env x :> Cfrag.resolved_signature) and reresolve_module_fragment : @@ -1792,9 +1820,9 @@ and reresolve_module_fragment : | `Subst (p, f) -> let p' = reresolve_module_type env p in `Subst (p', reresolve_module_fragment env f) - | `SubstAlias (p, f) -> + | `Alias (p, f) -> let p' = reresolve_module env p in - `SubstAlias (p', reresolve_module_fragment env f) + `Alias (p', reresolve_module_fragment env f) | `OpaqueModule m -> `OpaqueModule (reresolve_module_fragment env m) | `Module (sg, m) -> `Module (reresolve_signature_fragment env sg, m) diff --git a/src/xref2/tools.mli b/src/xref2/tools.mli index ff5a130eb4..a9eae29475 100644 --- a/src/xref2/tools.mli +++ b/src/xref2/tools.mli @@ -182,13 +182,19 @@ val handle_module_type_lookup : (Cpath.Resolved.module_type * Component.ModuleType.t) option type module_modifiers = - [ `Aliased of Cpath.Resolved.module_ - | `SubstAliased of Cpath.Resolved.module_ - | `SubstMT of Cpath.Resolved.module_type ] + [ `Aliased of Cpath.Resolved.module_ | `SubstMT of Cpath.Resolved.module_type ] + +type module_type_modifiers = [ `AliasModuleType of Cpath.Resolved.module_type ] val get_module_path_modifiers : Env.t -> add_canonical:bool -> Component.Module.t -> module_modifiers option +val get_module_type_path_modifiers : + Env.t -> + add_canonical:bool -> + Component.ModuleType.t -> + module_type_modifiers option + val prefix_signature : Cpath.Resolved.parent * Component.Signature.t -> Component.Signature.t diff --git a/test/generators/cases/module_type_alias.mli b/test/generators/cases/module_type_alias.mli new file mode 100644 index 0000000000..be6fd4c16d --- /dev/null +++ b/test/generators/cases/module_type_alias.mli @@ -0,0 +1,20 @@ +(** Module Type Aliases *) + + +module type A = sig + type a +end + + +module type B = functor ( C : sig type c end ) -> sig + type b +end + +module type D = A + +module type E = functor ( F : sig type f end ) -> B + +module type G = functor ( H : sig type h end) -> D + +module type I = B + diff --git a/test/generators/html/Module-module-type-S2-M.html b/test/generators/html/Module-module-type-S2-M.html deleted file mode 100644 index 37e3c3a367..0000000000 --- a/test/generators/html/Module-module-type-S2-M.html +++ /dev/null @@ -1,18 +0,0 @@ - - - M (Module.S2.M) - - - - - - - -
-

Module S2.M

-
- - \ No newline at end of file diff --git a/test/generators/html/Module-module-type-S2.html b/test/generators/html/Module-module-type-S2.html deleted file mode 100644 index afd270f1c7..0000000000 --- a/test/generators/html/Module-module-type-S2.html +++ /dev/null @@ -1,57 +0,0 @@ - - - S2 (Module.S2) - - - - - - - -
-

Module type Module.S2

-
-
-
-
- - type t -
-
-
-
- - type u -
-
-
-
- - type 'a v - -
-
-
-
- - - type ('a, 'b) w - -
-
-
-
- - module - M - : sig ... - end - - -
-
-
- - \ No newline at end of file diff --git a/test/generators/html/Module.html b/test/generators/html/Module.html index 57cda91353..9712f85bdc 100644 --- a/test/generators/html/Module.html +++ b/test/generators/html/Module.html @@ -54,7 +54,7 @@

Module Module

Foo.

module type - S2 + S2 = S diff --git a/test/generators/html/Ocamlary-Dep6-X-module-type-R.html b/test/generators/html/Module_type_alias-module-type-A.html similarity index 52% rename from test/generators/html/Ocamlary-Dep6-X-module-type-R.html rename to test/generators/html/Module_type_alias-module-type-A.html index a9b764a2f0..9151e3535a 100644 --- a/test/generators/html/Ocamlary-Dep6-X-module-type-R.html +++ b/test/generators/html/Module_type_alias-module-type-A.html @@ -1,6 +1,6 @@ - R (Ocamlary.Dep6.X.R) + A (Module_type_alias.A) @@ -8,19 +8,17 @@ -