diff --git a/src/document/comment.ml b/src/document/comment.ml index 9522ec7f6f..70a06b4322 100644 --- a/src/document/comment.ml +++ b/src/document/comment.ml @@ -107,7 +107,7 @@ module Reference = struct let to_ir : ?text:Inline.t -> Reference.t -> Inline.t = fun ?text ref -> match ref with - | `Resolved r -> ( + | `Resolved r -> (* IDENTIFIER MUST BE RENAMED TO DEFINITION. *) let id = Reference.Resolved.identifier r in let rendered = render_resolved r in @@ -119,16 +119,10 @@ module Reference = struct (* Add a tooltip if the content is not the rendered reference. *) match text with None -> None | Some _ -> Some rendered in - match Url.from_identifier ~stop_before:false id with - | Ok url -> - let target = Target.Internal (Resolved url) in - let link = { Link.target; content; tooltip } in - [ inline @@ Inline.Link link ] - | Error (Not_linkable _) -> content - | Error exn -> - (* FIXME: better error message *) - Printf.eprintf "Id.href failed: %S\n%!" (Url.Error.to_string exn); - content) + let url = Url.from_identifier ~stop_before:false id in + let target = Target.Internal (Resolved url) in + let link = { Link.target; content; tooltip } in + [ inline @@ Inline.Link link ] | _ -> ( let s = render_unresolved ref in match text with diff --git a/src/document/generator.ml b/src/document/generator.ml index c8850dd266..b3beecb0ed 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -43,18 +43,15 @@ let unresolved content = O.elt [ inline @@ Link link ] let path_to_id path = - match Url.Anchor.from_identifier (path :> Paths.Identifier.t) with - | Error _ -> None - | Ok url -> Some url + let url = Url.Anchor.from_identifier (path :> Paths.Identifier.t) in + Some url let source_anchor source_loc = - (* Remove when dropping support for OCaml < 4.08 *) - let to_option = function Result.Ok x -> Some x | Result.Error _ -> None in match source_loc with | Some id -> - Url.Anchor.from_identifier - (id : Paths.Identifier.SourceLocation.t :> Paths.Identifier.t) - |> to_option + Some + (Url.Anchor.from_identifier + (id : Paths.Identifier.SourceLocation.t :> Paths.Identifier.t)) | _ -> None let attach_expansion ?(status = `Default) (eq, o, e) page text = @@ -141,14 +138,12 @@ module Make (Syntax : SYNTAX) = struct | `OpaqueModule _ | `OpaqueModuleType _ -> true | _ -> false in - let id = Paths.Path.Resolved.identifier rp in - let txt = Url.render_path path in - match Url.from_identifier ~stop_before id with - | Ok href -> resolved href [ inline @@ Text txt ] - | Error (Url.Error.Not_linkable _) -> O.txt txt - | Error exn -> - Printf.eprintf "Id.href failed: %S\n%!" (Url.Error.to_string exn); - O.txt txt) + let txt = [ inline @@ Text (Url.render_path path) ] in + match Paths.Path.Resolved.identifier rp with + | Some id -> + let href = Url.from_identifier ~stop_before id in + resolved href txt + | None -> O.elt txt) let dot prefix suffix = prefix ^ "." ^ suffix @@ -192,13 +187,8 @@ module Make (Syntax : SYNTAX) = struct let open Fragment in let id = Resolved.identifier (fragment :> Resolved.t) in let txt = render_resolved_fragment (fragment :> Resolved.t) in - match Url.from_identifier ~stop_before:false id with - | Ok href -> resolved href [ inline @@ Text txt ] - | Error (Not_linkable _) -> unresolved [ inline @@ Text txt ] - | Error exn -> - Printf.eprintf "[FRAG] Id.href failed: %S\n%!" - (Url.Error.to_string exn); - unresolved [ inline @@ Text txt ] + let href = Url.from_identifier ~stop_before:false id in + resolved href [ inline @@ Text txt ] let from_fragment : Fragment.leaf -> text = function | `Resolved r @@ -274,10 +264,8 @@ module Make (Syntax : SYNTAX) = struct in let implementation = match implementation with - | Some (Odoc_model.Lang.Source_info.Resolved id) -> ( - match Url.Anchor.from_identifier (id :> Paths.Identifier.t) with - | Ok url -> Some url - | Error _ -> None) + | Some (Odoc_model.Lang.Source_info.Resolved id) -> + Some (Url.Anchor.from_identifier (id :> Paths.Identifier.t)) | _ -> None in Some (Source_page.Link { implementation; documentation }) @@ -517,26 +505,22 @@ module Make (Syntax : SYNTAX) = struct end = struct let record fields = let field mutable_ id typ = - match Url.from_identifier ~stop_before:true id with - | Error e -> failwith (Url.Error.to_string e) - | Ok url -> - let name = Paths.Identifier.name id in - let attrs = - [ "def"; "record"; Url.Anchor.string_of_kind url.kind ] - in - let cell = - (* O.td ~a:[ O.a_class ["def"; kind ] ] - * [O.a ~a:[O.a_href ("#" ^ anchor); O.a_class ["anchor"]] [] - * ; *) - O.code - ((if mutable_ then O.keyword "mutable" ++ O.txt " " else O.noop) - ++ O.txt name - ++ O.txt Syntax.Type.annotation_separator - ++ type_expr typ - ++ O.txt Syntax.Type.Record.field_separator) - (* ] *) - in - (url, attrs, cell) + let url = Url.from_identifier ~stop_before:true id in + let name = Paths.Identifier.name id in + let attrs = [ "def"; "record"; Url.Anchor.string_of_kind url.kind ] in + let cell = + (* O.td ~a:[ O.a_class ["def"; kind ] ] + * [O.a ~a:[O.a_href ("#" ^ anchor); O.a_class ["anchor"]] [] + * ; *) + O.code + ((if mutable_ then O.keyword "mutable" ++ O.txt " " else O.noop) + ++ O.txt name + ++ O.txt Syntax.Type.annotation_separator + ++ type_expr typ + ++ O.txt Syntax.Type.Record.field_separator) + (* ] *) + in + (url, attrs, cell) in let rows = fields @@ -603,17 +587,13 @@ module Make (Syntax : SYNTAX) = struct let variant cstrs : DocumentedSrc.t = let constructor id args res = - match Url.from_identifier ~stop_before:true id with - | Error e -> failwith (Url.Error.to_string e) - | Ok url -> - let attrs = - [ "def"; "variant"; Url.Anchor.string_of_kind url.kind ] - in - let content = - let doc = constructor id args res in - O.documentedSrc (O.txt "| ") @ doc - in - (url, attrs, content) + let url = Url.from_identifier ~stop_before:true id in + let attrs = [ "def"; "variant"; Url.Anchor.string_of_kind url.kind ] in + let content = + let doc = constructor id args res in + O.documentedSrc (O.txt "| ") @ doc + in + (url, attrs, content) in match cstrs with | [] -> O.documentedSrc (O.txt "|") @@ -639,19 +619,13 @@ module Make (Syntax : SYNTAX) = struct let extension_constructor (t : Odoc_model.Lang.Extension.Constructor.t) = let id = (t.id :> Paths.Identifier.t) in - match Url.from_identifier ~stop_before:true id with - | Error e -> failwith (Url.Error.to_string e) - | Ok url -> - let anchor = Some url in - let attrs = - [ "def"; "variant"; Url.Anchor.string_of_kind url.kind ] - in - let code = - O.documentedSrc (O.txt "| ") @ constructor id t.args t.res - in - let doc = Comment.to_ir t.doc in - let markers = Syntax.Comment.markers in - DocumentedSrc.Nested { anchor; attrs; code; doc; markers } + let url = Url.from_identifier ~stop_before:true id in + let anchor = Some url in + let attrs = [ "def"; "variant"; Url.Anchor.string_of_kind url.kind ] in + let code = O.documentedSrc (O.txt "| ") @ constructor id t.args t.res in + let doc = Comment.to_ir t.doc in + let markers = Syntax.Comment.markers in + DocumentedSrc.Nested { anchor; attrs; code; doc; markers } let extension (t : Odoc_model.Lang.Extension.t) = let prefix = @@ -1384,8 +1358,8 @@ module Make (Syntax : SYNTAX) = struct let content = functor_parameter arg in let attr = [ "parameter" ] in let anchor = - Utils.option_of_result - @@ Url.Anchor.from_identifier (arg.id :> Paths.Identifier.t) + Some + (Url.Anchor.from_identifier (arg.id :> Paths.Identifier.t)) in let doc = [] in [ @@ -1612,11 +1586,10 @@ module Make (Syntax : SYNTAX) = struct let name = let open Odoc_model.Lang.FunctorParameter in let name = Paths.Identifier.name arg.id in - match + let href = Url.from_identifier ~stop_before (arg.id :> Paths.Identifier.t) - with - | Error _ -> O.txt name - | Ok href -> resolved href [ inline @@ Text name ] + in + resolved href [ inline @@ Text name ] in (if Syntax.Mod.functor_keyword then O.keyword "functor" else O.noop) ++ (O.box_hv @@ O.span @@ -1653,12 +1626,11 @@ module Make (Syntax : SYNTAX) = struct let name = let open Odoc_model.Lang.FunctorParameter in let name = Paths.Identifier.name arg.id in - match + let href = Url.from_identifier ~stop_before (arg.id :> Paths.Identifier.t) - with - | Error _ -> O.txt name - | Ok href -> resolved href [ inline @@ Text name ] + in + resolved href [ inline @@ Text name ] in O.box_hv @@ O.txt "(" ++ name @@ -1774,8 +1746,7 @@ module Make (Syntax : SYNTAX) = struct in let content = O.documentedSrc md_def in let anchor = - Utils.option_of_result - @@ Url.Anchor.from_identifier (id :> Paths.Identifier.t) + Some (Url.Anchor.from_identifier (id :> Paths.Identifier.t)) in let attr = [ "modules" ] in let doc = [] in diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index 3ce033d323..596cee6ab8 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -22,10 +22,7 @@ end = struct | None -> None | Some (index_id, title) -> let path = - match Url.from_identifier ~stop_before:false (index_id :> Id.t) with - | Ok r -> r - | Error _ -> assert false - (* This error case should never happen since [stop_before] is false, and even less since it's a page id *) + Url.from_identifier ~stop_before:false (index_id :> Id.t) in let content = Comment.link_content title in Some (path, sidebar_toc_entry path content) @@ -65,15 +62,12 @@ let of_lang (v : Odoc_index.sidebar) = let item id = let content = [ inline @@ Text (Odoc_model.Paths.Identifier.name id) ] in let path = Url.from_identifier ~stop_before:false (id :> Id.t) in - match path with - | Ok path -> Some (path, sidebar_toc_entry path content) - | Error _ -> None - (* This error case should never happen since [stop_before] is false *) + (path, sidebar_toc_entry path content) in let units = List.map (fun { Odoc_index.units; name } -> - let units = List.filter_map item units in + let units = List.map item units in { name; units }) v.libs in diff --git a/src/document/url.ml b/src/document/url.ml index 35a1950f78..57864ee175 100644 --- a/src/document/url.ml +++ b/src/document/url.ml @@ -7,6 +7,7 @@ let render_path : Path.t -> string = let open Path.Resolved in function | `Identifier id -> Identifier.name id + | `CoreType n -> TypeName.to_string n | `OpaqueModule p -> render_resolved (p :> t) | `OpaqueModuleType p -> render_resolved (p :> t) | `Subst (_, p) -> render_resolved (p :> t) @@ -65,21 +66,6 @@ let render_path : Path.t -> string = render_path -module Error = struct - type nonrec t = - | Not_linkable of string - | Uncaught_exn of string - (* These should basicaly never happen *) - | Unexpected_anchor of string - - let to_string = function - | Not_linkable s -> Printf.sprintf "Not_linkable %S" s - | Uncaught_exn s -> Printf.sprintf "Uncaught_exn %S" s - | Unexpected_anchor s -> Printf.sprintf "Unexpected_anchor %S" s -end - -open Odoc_utils.ResultMonad - module Path = struct type nonsrc_pv = [ Identifier.Page.t_pv @@ -265,16 +251,14 @@ module Anchor = struct let mk ~kind parent str_name = let page = Path.from_identifier parent in - Ok { page; anchor = str_name; kind } + { page; anchor = str_name; kind } (* This is needed to ensure that references to polymorphic constructors have links that use the right suffix: those resolved references are turned into _constructor_ identifiers. *) let suffix_for_constructor x = x - let rec from_identifier : Identifier.t -> (t, Error.t) result = - let open Error in - function + let rec from_identifier : Identifier.t -> t = function | { iv = `Module (parent, mod_name); _ } -> let parent = Path.from_identifier (parent :> Path.any) in let kind = `Module in @@ -282,128 +266,111 @@ module Anchor = struct Printf.sprintf "%s-%s" (Path.string_of_kind kind) (ModuleName.to_string mod_name) in - Ok { page = parent; anchor; kind } + { page = parent; anchor; kind } | { iv = `Root _; _ } as p -> let page = Path.from_identifier (p :> Path.any) in - Ok { page; kind = `Module; anchor = "" } + { page; kind = `Module; anchor = "" } | { iv = `Page _; _ } as p -> let page = Path.from_identifier (p :> Path.any) in - Ok { page; kind = `Page; anchor = "" } + { page; kind = `Page; anchor = "" } | { iv = `LeafPage _; _ } as p -> let page = Path.from_identifier (p :> Path.any) in - Ok { page; kind = `LeafPage; anchor = "" } + { page; kind = `LeafPage; anchor = "" } (* For all these identifiers, page names and anchors are the same *) | { iv = `Parameter _ | `Result _ | `ModuleType _ | `Class _ | `ClassType _; _; } as p -> - Ok (anchorify_path @@ Path.from_identifier p) + anchorify_path @@ Path.from_identifier p | { iv = `Type (parent, type_name); _ } -> let page = Path.from_identifier (parent :> Path.any) in let kind = `Type in - Ok - { - page; - anchor = - Format.asprintf "%a-%s" pp_kind kind - (TypeName.to_string type_name); - kind; - } - | { iv = `CoreType ty_name; _ } -> - Error (Not_linkable ("core_type:" ^ TypeName.to_string ty_name)) + { + page; + anchor = + Format.asprintf "%a-%s" pp_kind kind (TypeName.to_string type_name); + kind; + } | { iv = `Extension (parent, name); _ } -> let page = Path.from_identifier (parent :> Path.any) in let kind = `Extension in - Ok - { - page; - anchor = - Format.asprintf "%a-%s" pp_kind kind - (ExtensionName.to_string name); - kind; - } + { + page; + anchor = + Format.asprintf "%a-%s" pp_kind kind (ExtensionName.to_string name); + kind; + } | { iv = `ExtensionDecl (parent, name, _); _ } -> let page = Path.from_identifier (parent :> Path.any) in let kind = `ExtensionDecl in - Ok - { - page; - anchor = - Format.asprintf "%a-%s" pp_kind kind - (ExtensionName.to_string name); - kind; - } + { + page; + anchor = + Format.asprintf "%a-%s" pp_kind kind (ExtensionName.to_string name); + kind; + } | { iv = `Exception (parent, name); _ } -> let page = Path.from_identifier (parent :> Path.any) in let kind = `Exception in - Ok - { - page; - anchor = - Format.asprintf "%a-%s" pp_kind kind - (ExceptionName.to_string name); - kind; - } - | { iv = `CoreException name; _ } -> - Error (Not_linkable ("core_exception:" ^ ExceptionName.to_string name)) + { + page; + anchor = + Format.asprintf "%a-%s" pp_kind kind (ExceptionName.to_string name); + kind; + } | { iv = `Value (parent, name); _ } -> let page = Path.from_identifier (parent :> Path.any) in let kind = `Val in - Ok - { - page; - anchor = - Format.asprintf "%a-%s" pp_kind kind (ValueName.to_string name); - kind; - } + { + page; + anchor = + Format.asprintf "%a-%s" pp_kind kind (ValueName.to_string name); + kind; + } | { iv = `Method (parent, name); _ } -> let str_name = MethodName.to_string name in let page = Path.from_identifier (parent :> Path.any) in let kind = `Method in - Ok - { page; anchor = Format.asprintf "%a-%s" pp_kind kind str_name; kind } + { page; anchor = Format.asprintf "%a-%s" pp_kind kind str_name; kind } | { iv = `InstanceVariable (parent, name); _ } -> let str_name = InstanceVariableName.to_string name in let page = Path.from_identifier (parent :> Path.any) in let kind = `Val in - Ok - { page; anchor = Format.asprintf "%a-%s" pp_kind kind str_name; kind } + { page; anchor = Format.asprintf "%a-%s" pp_kind kind str_name; kind } | { iv = `Constructor (parent, name); _ } -> - from_identifier (parent :> Identifier.t) >>= fun page -> + let page = from_identifier (parent :> Identifier.t) in let kind = `Constructor in let suffix = suffix_for_constructor (ConstructorName.to_string name) in - Ok (add_suffix ~kind page suffix) + add_suffix ~kind page suffix | { iv = `Field (parent, name); _ } -> - from_identifier (parent :> Identifier.t) >>= fun page -> + let page = from_identifier (parent :> Identifier.t) in let kind = `Field in let suffix = FieldName.to_string name in - Ok (add_suffix ~kind page suffix) + add_suffix ~kind page suffix | { iv = `Label (parent, anchor); _ } -> ( let str_name = LabelName.to_string anchor in (* [Identifier.LabelParent.t] contains datatypes. [`CoreType] can't happen, [`Type] may not happen either but just in case, use the grand-parent. *) match parent with - | { iv = `CoreType _; _ } -> - Error (Unexpected_anchor "core_type label parent") | { iv = `Type (gp, _); _ } -> mk ~kind:`Section gp str_name | { iv = #Path.nonsrc_pv; _ } as p -> mk ~kind:`Section (p :> Path.any) str_name) | { iv = `SourceLocation (parent, loc); _ } -> let page = Path.from_identifier (parent :> Path.any) in - Ok { page; kind = `SourceAnchor; anchor = DefName.to_string loc } + { page; kind = `SourceAnchor; anchor = DefName.to_string loc } | { iv = `SourceLocationInternal (parent, loc); _ } -> let page = Path.from_identifier (parent :> Path.any) in - Ok { page; kind = `SourceAnchor; anchor = LocalName.to_string loc } + { page; kind = `SourceAnchor; anchor = LocalName.to_string loc } | { iv = `SourceLocationMod parent; _ } -> let page = Path.from_identifier (parent :> Path.any) in - Ok { page; kind = `SourceAnchor; anchor = "" } + { page; kind = `SourceAnchor; anchor = "" } | { iv = `SourcePage _; _ } as p -> let page = Path.from_identifier (p :> Path.any) in - Ok { page; kind = `Page; anchor = "" } + { page; kind = `Page; anchor = "" } | { iv = `AssetFile _; _ } as p -> let page = Path.from_identifier p in - Ok { page; kind = `File; anchor = "" } + { page; kind = `File; anchor = "" } let polymorphic_variant ~type_ident elt = let name_of_type_constr te = @@ -414,18 +381,16 @@ module Anchor = struct invalid_arg "DocOckHtml.Url.Polymorphic_variant_decl.name_of_type_constr" in - match from_identifier type_ident with - | Error e -> failwith (Error.to_string e) - | Ok url -> ( - match elt with - | Odoc_model.Lang.TypeExpr.Polymorphic_variant.Type te -> - let kind = `Type in - let suffix = name_of_type_constr te in - add_suffix ~kind url suffix - | Constructor { name; _ } -> - let kind = `Constructor in - let suffix = suffix_for_constructor name in - add_suffix ~kind url suffix) + let url = from_identifier type_ident in + match elt with + | Odoc_model.Lang.TypeExpr.Polymorphic_variant.Type te -> + let kind = `Type in + let suffix = name_of_type_constr te in + add_suffix ~kind url suffix + | Constructor { name; _ } -> + let kind = `Constructor in + let suffix = suffix_for_constructor name in + add_suffix ~kind url suffix (** The anchor looks like [extension-decl-"Path.target_type"-FirstConstructor]. *) @@ -449,12 +414,11 @@ let from_path page = let from_identifier ~stop_before x = match x with | { Identifier.iv = #Path.any_pv; _ } as p when not stop_before -> - Ok (from_path @@ Path.from_identifier p) + from_path @@ Path.from_identifier p | p -> Anchor.from_identifier p let from_asset_identifier p = from_path @@ Path.from_identifier p let kind id = - match Anchor.from_identifier id with - | Error e -> failwith (Error.to_string e) - | Ok { kind; _ } -> kind + let { Anchor.kind; _ } = Anchor.from_identifier id in + kind diff --git a/src/document/url.mli b/src/document/url.mli index f69c1c57c9..b7361e9cc4 100644 --- a/src/document/url.mli +++ b/src/document/url.mli @@ -1,16 +1,5 @@ -open Result open Odoc_model.Paths -module Error : sig - type nonrec t = - | Not_linkable of string - | Uncaught_exn of string - (* These should basicaly never happen *) - | Unexpected_anchor of string - - val to_string : t -> string -end - module Path : sig type kind = [ `Module @@ -90,7 +79,7 @@ module Anchor : sig e.g. "module", "module-type", "exception", ... *) } - val from_identifier : Identifier.t -> (t, Error.t) result + val from_identifier : Identifier.t -> t val polymorphic_variant : type_ident:Identifier.t -> @@ -110,7 +99,7 @@ type t = Anchor.t val from_path : Path.t -> t -val from_identifier : stop_before:bool -> Identifier.t -> (t, Error.t) result +val from_identifier : stop_before:bool -> Identifier.t -> t (** [from_identifier] turns an identifier to an url. Some identifiers can be accessed in different ways. For instance, @@ -120,14 +109,11 @@ val from_identifier : stop_before:bool -> Identifier.t -> (t, Error.t) result The [stop_before] boolean controls that: with [~stop_before:true], the url will point to the parent page when applicable. - There are several wrong ways to use [from_identifier]: - - Using [~stop_before:false] with a module that does not contain an - expansion, such as a module alias. This will return [Ok url] but [url] - leads to a 404. - - Calling it with an unlinkable id, such as a core type. This will return - an [Error _] value. + There is a pitfall with [from_identifier]: Using [~stop_before:false] with + a module that does not contain an expansion, such as a module alias. This + will return a [url] leading to a 404 page. - Please, reader, go and fix this API. Thanks. *) + It would be nice to enforce no 404 by the type system. *) val from_asset_identifier : Identifier.AssetFile.t -> t diff --git a/src/index/entry.ml b/src/index/entry.ml index 86dea01015..5f597e9cab 100644 --- a/src/index/entry.ml +++ b/src/index/entry.ml @@ -172,7 +172,10 @@ let entries_of_item (x : Fold.item) = | Exception exc -> let res = match exc.res with - | None -> TypeExpr.Constr (Odoc_model.Predefined.exn_path, []) + | None -> + TypeExpr.Constr + ( `Resolved (`CoreType (Odoc_model.Names.TypeName.make_std "exn")), + [] ) | Some x -> x in let kind = Exception { args = exc.args; res } in diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index f043a72cbc..bd4ccfc6f9 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -1052,11 +1052,7 @@ and read_signature_noenv env parent (items : Odoc_model.Compat.signature) = if Env.is_shadowed env id then let identifier = Env.find_type_identifier env id in - let name = - match identifier.iv with - | `CoreType n - | `Type (_, n) -> n - in + let `Type (_, name) = identifier.iv in { shadowed with s_types = (Ident.name id, name) :: shadowed.s_types } else shadowed in diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index e0b87df5b8..389dab488b 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -20,8 +20,6 @@ open Names module Id = Paths.Identifier module P = Paths.Path -type type_ident = Paths.Identifier.Path.Type.t - module LocHashtbl = Hashtbl.Make(struct type t = Location.t let equal l1 l2 = l1 = l2 @@ -644,16 +642,15 @@ let find_extension_identifier env id = let find_value_identifier env id = Ident.find_same id env.values -(** Lookup a type in the environment. If it isn't found, it's assumed to be a - core type. *) +(** Lookup a type in the environment. If it isn't found, it means it's a core + type. *) let find_type env id = - try (Ident.find_same id env.types :> Id.Path.Type.t) + try Some (Ident.find_same id env.types :> Id.Path.Type.t) with Not_found -> ( - try (Ident.find_same id env.classes :> Id.Path.Type.t) + try Some (Ident.find_same id env.classes :> Id.Path.Type.t) with Not_found -> ( - try (Ident.find_same id env.class_types :> Id.Path.Type.t) - with Not_found -> - (Paths.Identifier.Mk.core_type (Ident.name id) :> type_ident))) + try Some (Ident.find_same id env.class_types :> Id.Path.Type.t) + with Not_found -> None)) let find_class_type env id = try @@ -684,7 +681,9 @@ module Path = struct with Not_found -> assert false let read_type_ident env id = - `Identifier (find_type env id, false) + match find_type env id with + | Some id -> `Identifier (id , false) + | None -> `Resolved (`CoreType (TypeName.of_ident id)) let read_value_ident env id : Paths.Path.Value.t = `Identifier (find_value_identifier env id, false) diff --git a/src/loader/ident_env.cppo.mli b/src/loader/ident_env.cppo.mli index b487ca2f81..337f9ffafe 100644 --- a/src/loader/ident_env.cppo.mli +++ b/src/loader/ident_env.cppo.mli @@ -55,7 +55,7 @@ val find_module_type : t -> Ident.t -> Paths.Identifier.ModuleType.t val find_value_identifier : t -> Ident.t -> Paths.Identifier.Value.t -val find_type : t -> Ident.t -> Paths.Identifier.Path.Type.t +val find_type : t -> Ident.t -> Paths.Identifier.Path.Type.t option val find_constructor_identifier : t -> Ident.t -> Paths.Identifier.Constructor.t diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 580888bf08..73b4bb73bf 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -223,7 +223,6 @@ let anchor_of_identifier id = continue anchor parent | `Page _ -> assert false | `LeafPage _ -> assert false - | `CoreType _ -> assert false | `SourceLocation _ -> assert false | `ClassType (parent, name) -> let anchor = anchor `ClassType (TypeName.to_string name) in @@ -232,7 +231,6 @@ let anchor_of_identifier id = | `Value (parent, name) -> let anchor = anchor `Val (ValueName.to_string name) in continue anchor parent - | `CoreException _ -> assert false | `Constructor (parent, name) -> let anchor = anchor `Constructor (ConstructorName.to_string name) in continue anchor parent diff --git a/src/model/odoc_model.ml b/src/model/odoc_model.ml index 0bf1becc3a..98e45dd101 100644 --- a/src/model/odoc_model.ml +++ b/src/model/odoc_model.ml @@ -2,7 +2,6 @@ module Lang = Lang module Comment = Comment module Paths = Paths module Names = Names -module Predefined = Predefined module Root = Root module Error = Error module Location_ = Location_ diff --git a/src/model/paths.ml b/src/model/paths.ml index be120e4484..bb1bdf213d 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -39,13 +39,11 @@ module Identifier = struct | `Result x -> name_aux (x :> t) | `ModuleType (_, name) -> ModuleTypeName.to_string name | `Type (_, name) -> TypeName.to_string name - | `CoreType name -> TypeName.to_string name | `Constructor (_, name) -> ConstructorName.to_string name | `Field (_, name) -> FieldName.to_string name | `Extension (_, name) -> ExtensionName.to_string name | `ExtensionDecl (_, _, name) -> ExtensionName.to_string name | `Exception (_, name) -> ExceptionName.to_string name - | `CoreException name -> ExceptionName.to_string name | `Value (_, name) -> ValueName.to_string name | `Class (_, name) -> TypeName.to_string name | `ClassType (_, name) -> TypeName.to_string name @@ -71,13 +69,11 @@ module Identifier = struct | `Result x -> is_hidden (x :> t) | `ModuleType (_, name) -> ModuleTypeName.is_hidden name | `Type (_, name) -> TypeName.is_hidden name - | `CoreType name -> TypeName.is_hidden name | `Constructor (parent, _) -> is_hidden (parent :> t) | `Field (parent, _) -> is_hidden (parent :> t) | `Extension (parent, _) -> is_hidden (parent :> t) | `ExtensionDecl (parent, _, _) -> is_hidden (parent :> t) | `Exception (parent, _) -> is_hidden (parent :> t) - | `CoreException _ -> false | `Value (_, name) -> ValueName.is_hidden name | `Class (_, name) -> TypeName.is_hidden name | `ClassType (_, name) -> TypeName.is_hidden name @@ -109,7 +105,6 @@ module Identifier = struct ModuleTypeName.to_string name :: full_name_aux (parent :> t) | `Type (parent, name) -> TypeName.to_string name :: full_name_aux (parent :> t) - | `CoreType name -> [ TypeName.to_string name ] | `Constructor (parent, name) -> ConstructorName.to_string name :: full_name_aux (parent :> t) | `Field (parent, name) -> @@ -120,7 +115,6 @@ module Identifier = struct ExtensionName.to_string name :: full_name_aux (parent :> t) | `Exception (parent, name) -> ExceptionName.to_string name :: full_name_aux (parent :> t) - | `CoreException name -> [ ExceptionName.to_string name ] | `Value (parent, name) -> ValueName.to_string name :: full_name_aux (parent :> t) | `Class (parent, name) -> @@ -152,7 +146,6 @@ module Identifier = struct fun (n : non_src) -> match n with | { iv = `Result i; _ } -> label_parent_aux (i :> non_src) - | { iv = `CoreType _; _ } | { iv = `CoreException _; _ } -> assert false | { iv = `Root _; _ } as p -> (p :> label_parent) | { iv = `Page _; _ } as p -> (p :> label_parent) | { iv = `LeafPage _; _ } as p -> (p :> label_parent) @@ -586,12 +579,6 @@ module Identifier = struct [> `Exception of Signature.t * ExceptionName.t ] id = mk_parent ExceptionName.to_string "exn" (fun (p, n) -> `Exception (p, n)) - let core_exception = - mk_fresh - (fun s -> s) - "coreexn" - (fun s -> `CoreException (ExceptionName.make_std s)) - let value : Signature.t * ValueName.t -> [> `Value of Signature.t * ValueName.t ] id = @@ -669,6 +656,7 @@ module Path = struct | `ModuleType (_, m) when Names.ModuleTypeName.is_hidden m -> true | `ModuleType (p, _) -> inner (p : module_ :> any) | `Type (_, t) when Names.TypeName.is_hidden t -> true + | `CoreType t -> Names.TypeName.is_hidden t | `Type (p, _) -> inner (p : module_ :> any) | `Value (_, t) when Names.ValueName.is_hidden t -> true | `Value (p, _) -> inner (p : module_ :> any) @@ -722,10 +710,9 @@ module Path = struct type t = Paths_types.Resolved_path.any let rec parent_module_type_identifier : - Paths_types.Resolved_path.module_type -> Identifier.Signature.t = + Paths_types.Resolved_path.module_type -> Identifier.ModuleType.t = function - | `Identifier id -> - (id : Identifier.ModuleType.t :> Identifier.Signature.t) + | `Identifier id -> (id : Identifier.ModuleType.t) | `ModuleType (m, n) -> Identifier.Mk.module_type (parent_module_identifier m, n) | `SubstT (m, _n) -> parent_module_type_identifier m @@ -742,7 +729,8 @@ module Path = struct 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 + | `Subst (sub, _) -> + (parent_module_type_identifier sub :> Identifier.Signature.t) | `Hidden p -> parent_module_identifier p | `Module (m, n) -> Identifier.Mk.module_ (parent_module_identifier m, n) | `Canonical (_, `Resolved p) -> parent_module_identifier p @@ -765,6 +753,9 @@ module Path = struct module ModuleType = struct type t = Paths_types.Resolved_path.module_type + + let identifier : t -> Identifier.ModuleType.t = + parent_module_type_identifier end module Type = struct @@ -779,21 +770,26 @@ module Path = struct type t = Paths_types.Resolved_path.class_type end - let rec identifier : t -> Identifier.t = function - | `Identifier id -> id + let rec identifier : t -> Identifier.t option = function + | `Identifier id -> Some id + | `CoreType _ -> None | `Subst (sub, _) -> identifier (sub :> t) | `Hidden p -> identifier (p :> t) - | `Module (m, n) -> Identifier.Mk.module_ (parent_module_identifier m, n) + | `Module (m, n) -> + Some (Identifier.Mk.module_ (parent_module_identifier m, n)) | `Canonical (_, `Resolved p) -> identifier (p :> t) | `Canonical (p, _) -> identifier (p :> t) | `Apply (m, _) -> identifier (m :> t) - | `Type (m, n) -> Identifier.Mk.type_ (parent_module_identifier m, n) - | `Value (m, n) -> Identifier.Mk.value (parent_module_identifier m, n) + | `Type (m, n) -> + Some (Identifier.Mk.type_ (parent_module_identifier m, n)) + | `Value (m, n) -> + Some (Identifier.Mk.value (parent_module_identifier m, n)) | `ModuleType (m, n) -> - Identifier.Mk.module_type (parent_module_identifier m, n) - | `Class (m, n) -> Identifier.Mk.class_ (parent_module_identifier m, n) + Some (Identifier.Mk.module_type (parent_module_identifier m, n)) + | `Class (m, n) -> + Some (Identifier.Mk.class_ (parent_module_identifier m, n)) | `ClassType (m, n) -> - Identifier.Mk.class_type (parent_module_identifier m, n) + Some (Identifier.Mk.class_type (parent_module_identifier m, n)) | `Alias (dest, `Resolved src) -> if is_resolved_hidden ~weak_canonical_test:false (dest :> t) then identifier (src :> t) @@ -851,9 +847,13 @@ module Fragment = struct type t = Paths_types.Resolved_fragment.signature let rec sgidentifier : t -> Identifier.Signature.t = function - | `Root (`ModuleType i) -> Path.Resolved.parent_module_type_identifier i + | `Root (`ModuleType i) -> + (Path.Resolved.parent_module_type_identifier i + :> Identifier.Signature.t) | `Root (`Module i) -> Path.Resolved.parent_module_identifier i - | `Subst (s, _) -> Path.Resolved.parent_module_type_identifier s + | `Subst (s, _) -> + (Path.Resolved.parent_module_type_identifier s + :> Identifier.Signature.t) | `Alias (i, _) -> Path.Resolved.parent_module_identifier i | `Module (m, n) -> Identifier.Mk.module_ (sgidentifier m, n) | `OpaqueModule m -> sgidentifier (m :> t) @@ -876,7 +876,7 @@ module Fragment = struct let rec identifier : t -> Identifier.t = function | `Root (`ModuleType _r) -> assert false | `Root (`Module _r) -> assert false - | `Subst (s, _) -> Path.Resolved.identifier (s :> Path.Resolved.t) + | `Subst (s, _) -> (Path.Resolved.ModuleType.identifier s :> Identifier.t) | `Alias (p, _) -> (Path.Resolved.parent_module_identifier p :> Identifier.t) | `Module (m, n) -> Identifier.Mk.module_ (Signature.sgidentifier m, n) diff --git a/src/model/paths.mli b/src/model/paths.mli index f1abf58777..e19dcae21f 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -316,8 +316,6 @@ module Identifier : sig Signature.t * ExceptionName.t -> [> `Exception of Signature.t * ExceptionName.t ] id - val core_exception : string -> [> `CoreException of ExceptionName.t ] id - val value : Signature.t * ValueName.t -> [> `Value of Signature.t * ValueName.t ] id @@ -391,7 +389,8 @@ module rec Path : sig type t = Paths_types.Resolved_path.any - val identifier : t -> Identifier.t + val identifier : t -> Identifier.t option + (** If the path points to a core type, no identifier can be generated *) val is_hidden : t -> bool end diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index 0da86d1554..ac0d0cfc18 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -77,8 +77,7 @@ module Identifier = struct and class_signature = class_signature_pv id (** @canonical Odoc_model.Paths.Identifier.ClassSignature.t *) - type datatype_pv = - [ `Type of signature * TypeName.t | `CoreType of TypeName.t ] + type datatype_pv = [ `Type of signature * TypeName.t ] (** @canonical Odoc_model.Paths.Identifier.DataType.t_pv *) and datatype = datatype_pv id @@ -132,7 +131,7 @@ module Identifier = struct and module_type = module_type_pv id (** @canonical Odoc_model.Paths.Identifier.ModuleType.t *) - type type_pv = [ `Type of signature * TypeName.t | `CoreType of TypeName.t ] + type type_pv = [ `Type of signature * TypeName.t ] (** @canonical Odoc_model.Paths.Identifier.Type.t_pv *) and type_ = type_pv id @@ -163,9 +162,7 @@ module Identifier = struct and extension_decl = extension_decl_pv id (** @canonical Odoc_model.Paths.Identifier.ExtensionDecl.t *) - type exception_pv = - [ `Exception of signature * ExceptionName.t - | `CoreException of ExceptionName.t ] + type exception_pv = [ `Exception of signature * ExceptionName.t ] (** @canonical Odoc_model.Paths.Identifier.Exception.t_pv *) and exception_ = exception_pv id @@ -407,7 +404,8 @@ and Resolved_path : sig | `CanonicalType of type_ * Path.type_ | `Type of module_ * TypeName.t | `Class of module_ * TypeName.t - | `ClassType of module_ * TypeName.t ] + | `ClassType of module_ * TypeName.t + | `CoreType of TypeName.t ] (** @canonical Odoc_model.Paths.Path.Resolved.Type.t *) type any = @@ -434,7 +432,8 @@ and Resolved_path : sig | `ClassType of module_ * TypeName.t | `Class of module_ * TypeName.t | `Value of module_ * ValueName.t - | `ClassType of module_ * TypeName.t ] + | `ClassType of module_ * TypeName.t + | `CoreType of TypeName.t ] (** @canonical Odoc_model.Paths.Path.Resolved.t *) end = Resolved_path diff --git a/src/model/predefined.ml b/src/model/predefined.ml deleted file mode 100644 index 03594099e5..0000000000 --- a/src/model/predefined.ml +++ /dev/null @@ -1,148 +0,0 @@ -(* - * Copyright (c) 2014 Leo White - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Lang -open Names - -let predefined_location = - let point = { Location_.line = 1; column = 0 } in - { Location_.file = "predefined"; start = point; end_ = point } - -let empty_doc = [] - -let mk_equation params = - let open TypeDecl.Equation in - { params; private_ = false; manifest = None; constraints = [] } - -let nullary_equation = mk_equation [] -let covariant_equation = - mk_equation [ { desc = Var "'a"; variance = Some Pos; injectivity = true } ] -let invariant_equation = - mk_equation [ { desc = Var "'a"; variance = None; injectivity = true } ] - -let source_loc = None - -let mk_type ?(doc = empty_doc) ?(eq = nullary_equation) ?repr id = - let canonical = None in - { - TypeDecl.id; - source_loc; - doc; - canonical; - equation = eq; - representation = repr; - } - -let mk_constr ?(args = TypeDecl.Constructor.Tuple []) id = - { TypeDecl.Constructor.id; doc = empty_doc; args; res = None } - -module Mk = Paths.Identifier.Mk - -let bool_identifier = Mk.core_type "bool" -let unit_identifier = Mk.core_type "unit" -let exn_identifier = Mk.core_type "exn" -let list_identifier = Mk.core_type "list" -let option_identifier = Mk.core_type "option" - -let false_identifier = - Mk.constructor (bool_identifier, ConstructorName.make_std "false") - -let true_identifier = - Mk.constructor (bool_identifier, ConstructorName.make_std "true") - -let void_identifier = - Mk.constructor (unit_identifier, ConstructorName.make_std "()") - -let nil_identifier = - Mk.constructor (list_identifier, ConstructorName.make_std "([])") - -let cons_identifier = - Mk.constructor (list_identifier, ConstructorName.make_std "(::)") - -let none_identifier = - Mk.constructor (option_identifier, ConstructorName.make_std "None") - -let some_identifier = - Mk.constructor (option_identifier, ConstructorName.make_std "Some") - -let exn_path = `Resolved (`Identifier exn_identifier) -let list_path = `Resolved (`Identifier list_identifier) - -let false_decl = mk_constr ~args:(Tuple []) false_identifier -let true_decl = mk_constr ~args:(Tuple []) true_identifier -let void_decl = mk_constr ~args:(Tuple []) void_identifier -let nil_decl = mk_constr ~args:(Tuple []) nil_identifier - -let cons_decl = - let head = TypeExpr.Var "'a" in - let tail = TypeExpr.(Constr (list_path, [ head ])) in - mk_constr ~args:(Tuple [ head; tail ]) cons_identifier - -let none_decl = mk_constr ~args:(Tuple []) none_identifier -let some_decl = mk_constr ~args:(Tuple [ TypeExpr.Var "'a" ]) some_identifier - -(** The type representation for known core types. *) -let type_repr_of_core_type = - let open TypeDecl.Representation in - function - | "bool" -> Some (Variant [ false_decl; true_decl ]) - | "unit" -> Some (Variant [ void_decl ]) - | "exn" -> Some Extensible - | "option" -> Some (Variant [ none_decl; some_decl ]) - | "list" -> Some (Variant [ nil_decl; cons_decl ]) - | _ -> None - -let type_eq_of_core_type = function - | "lazy_t" | "extension_constructor" -> Some covariant_equation - | "array" -> Some invariant_equation - | _ -> None - -let doc_of_core_type = - let elt x = Location_.at predefined_location x in - let words ss = - ss - |> List.rev_map (fun s -> [ elt `Space; elt (`Word s) ]) - |> List.flatten |> List.tl |> List.rev - in - let paragraph x = elt (`Paragraph x) in - function - | "floatarray" -> - Some - [ - paragraph - (words [ "This"; "type"; "is"; "used"; "to"; "implement"; "the" ] - @ [ - elt `Space; - elt - (`Reference - ( `Module - ( `Root ("Array", `TModule), - ModuleName.make_std "Floatarray" ), - [] )); - elt `Space; - ] - @ words - [ "module."; "It"; "should"; "not"; "be"; "used"; "directly." ] - ); - ] - | _ -> None - -let type_of_core_type name = - let identifier = Mk.core_type name - and repr = type_repr_of_core_type name - and eq = type_eq_of_core_type name - and doc = doc_of_core_type name in - mk_type ?doc ?repr ?eq identifier diff --git a/src/model/predefined.mli b/src/model/predefined.mli deleted file mode 100644 index 98c125b17e..0000000000 --- a/src/model/predefined.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* - * Copyright (c) 2014 Leo White - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Paths - -val exn_path : Path.Type.t - -val type_of_core_type : string -> Lang.TypeDecl.t -(** The type declaration of a core type given its name. *) diff --git a/src/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml index 2efe8c6e7c..c3c4792a6d 100644 --- a/src/model_desc/paths_desc.ml +++ b/src/model_desc/paths_desc.ml @@ -119,7 +119,6 @@ module General_paths = struct ( "`Type", ((parent :> id_t), name), Pair (identifier, Names.typename) ) - | `CoreType name -> C ("`CoreType", name, Names.typename) | `Constructor (parent, name) -> C ( "`Constructor", @@ -145,7 +144,6 @@ module General_paths = struct ( "`Exception", ((parent :> id_t), name), Pair (identifier, Names.exceptionname) ) - | `CoreException name -> C ("`CoreException", name, Names.exceptionname) | `Value (parent, name) -> C ( "`Value", @@ -234,6 +232,7 @@ module General_paths = struct Variant (function | `Identifier x -> C ("`Identifier", x, identifier) + | `CoreType n -> C ("`CoreType", n, Names.typename) | `Subst (x1, x2) -> C ( "`Subst", diff --git a/src/occurrences/odoc_occurrences.ml b/src/occurrences/odoc_occurrences.ml index 1bf5b40f1b..31bc9da042 100644 --- a/src/occurrences/odoc_occurrences.ml +++ b/src/occurrences/odoc_occurrences.ml @@ -5,7 +5,9 @@ let of_impl ~include_hidden unit htbl = let open Odoc_model.Paths.Path.Resolved in let p = (p :> t) in let id = identifier p in - if (not (is_hidden p)) || include_hidden then Table.add tbl id + match id with + | Some id when (not (is_hidden p)) || include_hidden -> Table.add tbl id + | _ -> () in let open Odoc_model.Lang in List.iter diff --git a/src/occurrences/table.ml b/src/occurrences/table.ml index b6f233c3e7..465c02570e 100644 --- a/src/occurrences/table.ml +++ b/src/occurrences/table.ml @@ -40,7 +40,6 @@ let add ?(quantity = 1) tbl id = | `Field (parent, _) -> do_ parent | `Extension (parent, _) -> do_ parent | `Type (parent, _) -> do_ parent - | `CoreType _ -> incr tbl id | `Constructor (parent, _) -> do_ parent | `Exception (parent, _) -> do_ parent | `ExtensionDecl (parent, _, _) -> do_ parent @@ -48,9 +47,9 @@ let add ?(quantity = 1) tbl id = | `Value (parent, _) -> do_ parent | `ClassType (parent, _) -> do_ parent | `Root _ -> incr tbl id - | `SourcePage _ | `Page _ | `LeafPage _ | `SourceLocation _ - | `CoreException _ | `Label _ | `SourceLocationMod _ | `Result _ - | `AssetFile _ | `SourceLocationInternal _ -> + | `SourcePage _ | `Page _ | `LeafPage _ | `SourceLocation _ | `Label _ + | `SourceLocationMod _ | `Result _ | `AssetFile _ + | `SourceLocationInternal _ -> assert false in let _htbl = add ~kind:`Direct id in @@ -78,9 +77,9 @@ let rec get t id = | `Value (parent, _) -> do_ parent | `ClassType (parent, _) -> do_ parent | `Root _ -> ( try Some (H.find t id) with Not_found -> None) - | `SourcePage _ | `Page _ | `LeafPage _ | `CoreType _ | `SourceLocation _ - | `CoreException _ | `Label _ | `SourceLocationMod _ | `Result _ - | `AssetFile _ | `SourceLocationInternal _ -> + | `SourcePage _ | `Page _ | `LeafPage _ | `SourceLocation _ | `Label _ + | `SourceLocationMod _ | `Result _ | `AssetFile _ | `SourceLocationInternal _ + -> None let get t id = diff --git a/src/odoc/url.ml b/src/odoc/url.ml index 95c6e09e77..6b60874e94 100644 --- a/src/odoc/url.ml +++ b/src/odoc/url.ml @@ -26,19 +26,16 @@ let resolve url_to_string directories reference = Odoc_xref2.Errors.Tools_error.pp_reference_lookup_error e in Error (`Msg error) - | Ok (resolved_reference, _) -> ( + | Ok (resolved_reference, _) -> let identifier = Odoc_model.Paths.Reference.Resolved.identifier resolved_reference in let url = Odoc_document.Url.from_identifier ~stop_before:false identifier in - match url with - | Error e -> Error (`Msg (Odoc_document.Url.Error.to_string e)) - | Ok url -> - let href = url_to_string url in - print_endline href; - Ok ())) + let href = url_to_string url in + print_endline href; + Ok ()) let reference_to_url_html { Html_page.html_config = config; _ } root_url = let url_to_string url = diff --git a/src/search/html.ml b/src/search/html.ml index 9e47a02b9e..da016bd55d 100644 --- a/src/search/html.ml +++ b/src/search/html.ml @@ -19,16 +19,12 @@ let url { Entry.id; kind; doc = _ } = shorten the match. *) match kind with Doc _ -> false | _ -> true in - match Odoc_document.Url.from_identifier ~stop_before id with - | Ok url -> - let config = - Odoc_html.Config.v ~search_result:true ~semantic_uris:false - ~indent:false ~flat:false ~open_details:false ~as_json:false ~remap:[] - () - in - let url = Odoc_html.Link.href ~config ~resolve:(Base "") url in - Result.Ok url - | Error _ as e -> e + let url = Odoc_document.Url.from_identifier ~stop_before id in + let config = + Odoc_html.Config.v ~search_result:true ~semantic_uris:false ~indent:false + ~flat:false ~open_details:false ~as_json:false ~remap:[] () + in + Odoc_html.Link.href ~config ~resolve:(Base "") url let map_option f = function Some x -> Some (f x) | None -> None diff --git a/src/search/html.mli b/src/search/html.mli index 2134584808..32862220b6 100644 --- a/src/search/html.mli +++ b/src/search/html.mli @@ -5,7 +5,7 @@ type html = Html_types.div_content Tyxml.Html.elt val of_entry : Entry.t -> html list -val url : Entry.t -> (string, Odoc_document.Url.Error.t) Result.result +val url : Entry.t -> string (** The below is intended for search engine that do not use the Json output but Odoc as a library. Most search engine will use their own representation diff --git a/src/search/json_index/json_display.ml b/src/search/json_index/json_display.ml index e269291cab..d2171ee43b 100644 --- a/src/search/json_index/json_display.ml +++ b/src/search/json_index/json_display.ml @@ -1,13 +1,10 @@ open Odoc_search let of_entry entry h = - match Html.url entry with - | Result.Ok url -> - let html = - h - |> List.map (fun html -> - Format.asprintf "%a" (Tyxml.Html.pp_elt ()) html) - |> String.concat "" - in - Result.Ok (`Object [ ("url", `String url); ("html", `String html) ]) - | Error _ as e -> e + let url = Html.url entry in + let html = + h + |> List.map (fun html -> Format.asprintf "%a" (Tyxml.Html.pp_elt ()) html) + |> String.concat "" + in + `Object [ ("url", `String url); ("html", `String html) ] diff --git a/src/search/json_index/json_display.mli b/src/search/json_index/json_display.mli index df72e9d198..18e4cfbe6b 100644 --- a/src/search/json_index/json_display.mli +++ b/src/search/json_index/json_display.mli @@ -1,6 +1,3 @@ open Odoc_search -val of_entry : - Odoc_index.Entry.t -> - Html.html list -> - (Odoc_html.Json.json, Odoc_document.Url.Error.t) Result.result +val of_entry : Odoc_index.Entry.t -> Html.html list -> Odoc_html.Json.json diff --git a/src/search/json_index/json_search.ml b/src/search/json_index/json_search.ml index 386a5d5739..102bbbd144 100644 --- a/src/search/json_index/json_search.ml +++ b/src/search/json_index/json_search.ml @@ -51,7 +51,6 @@ let rec of_id x = ret "ModuleType" (ModuleTypeName.to_string name) :: of_id (parent :> t) | `Type (parent, name) -> ret "Type" (TypeName.to_string name) :: of_id (parent :> t) - | `CoreType name -> [ ret "CoreType" (TypeName.to_string name) ] | `Constructor (parent, name) -> ret "Constructor" (ConstructorName.to_string name) :: of_id (parent :> t) | `Field (parent, name) -> @@ -62,8 +61,6 @@ let rec of_id x = ret "ExtensionDecl" (ExtensionName.to_string name) :: of_id (parent :> t) | `Exception (parent, name) -> ret "Exception" (ExceptionName.to_string name) :: of_id (parent :> t) - | `CoreException name -> - [ ret "CoreException" (ExceptionName.to_string name) ] | `Value (parent, name) -> ret "Value" (ValueName.to_string name) :: of_id (parent :> t) | `Class (parent, name) -> @@ -182,13 +179,10 @@ let of_entry ({ Entry.id; doc; kind } as entry) html occurrences = ] | None -> [] in - match Json_display.of_entry entry html with - | Result.Ok display -> - Result.Ok - (`Object - ([ ("id", j_id); ("doc", doc); ("kind", kind); ("display", display) ] - @ occurrences)) - | Error _ as e -> e + let display = Json_display.of_entry entry html in + `Object + ([ ("id", j_id); ("doc", doc); ("kind", kind); ("display", display) ] + @ occurrences) let output_json ppf first entries = let output_json json = @@ -199,13 +193,8 @@ let output_json ppf first entries = (fun first (entry, html, occurrences) -> let json = of_entry entry html occurrences in if not first then Format.fprintf ppf ","; - match json with - | Ok json -> - output_json json; - false - | Error e -> - Printf.eprintf "%S" (Odoc_document.Url.Error.to_string e); - true) + output_json json; + false) first entries let unit ?occurrences ppf u = diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index ce8339e519..140ba42188 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -740,9 +740,7 @@ and type_decl : Env.t -> TypeDecl.t -> TypeDecl.t = fun env t -> let open TypeDecl in let container = - match t.id.iv with - | `Type (parent, _) -> (parent :> Id.LabelParent.t) - | `CoreType _ -> assert false + match t.id.iv with `Type (parent, _) -> (parent :> Id.LabelParent.t) in let equation = type_decl_equation env container t.equation in let representation = @@ -869,13 +867,15 @@ and type_expression : Env.t -> Id.LabelParent.t -> _ -> _ = let cp = Component.Of_Lang.(type_path (empty ()) path) in let ts = List.map (type_expression env parent) ts' in match Tools.resolve_type env cp with - | Ok (cp, (`FType _ | `FClass _ | `FClassType _)) -> + | Ok (cp, (`FType _ | `FClass _ | `FClassType _ | `CoreType _)) -> let p = Lang_of.(Path.resolved_type (empty ()) cp) in Constr (`Resolved p, ts) | Ok (_cp, `FType_removed (_, x, _eq)) -> (* Substitute type variables ? *) Lang_of.(type_expr (empty ()) parent x) - | Error _e -> Constr (Lang_of.(Path.type_ (empty ()) cp), ts)) + | Error _e -> + Constr ((Lang_of.(Path.type_ (empty ()) cp) :> Paths.Path.Type.t), ts) + ) | Polymorphic_variant v -> Polymorphic_variant (type_expression_polyvar env parent v) | Object o -> Object (type_expression_object env parent o) diff --git a/src/xref2/component.ml b/src/xref2/component.ml index d3eb1e2bca..9f08ccbd16 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -665,7 +665,6 @@ module Fmt = struct | `Result parent -> if c.short_paths then model_identifier c ppf (parent :> id) else Format.fprintf ppf "%a.result" (model_identifier c) (parent :> id) - | `CoreType name -> Format.fprintf ppf "%s" (TypeName.to_string name) | `Constructor (ty, x) -> Format.fprintf ppf "%a.%s" (model_identifier c) (ty :> id) @@ -674,8 +673,6 @@ module Fmt = struct Format.fprintf ppf "%a.%s" (model_identifier c) (parent :> id) (ValueName.to_string name) - | `CoreException name -> - Format.fprintf ppf "%s" (ExceptionName.to_string name) | `Class (sg, name) -> Format.fprintf ppf "%a.%s" (model_identifier c) (sg :> id) @@ -1220,6 +1217,7 @@ module Fmt = struct config -> Format.formatter -> Cpath.Resolved.type_ -> unit = fun c ppf p -> match p with + | `CoreType n -> Format.fprintf ppf "%s" (TypeName.to_string n) | `Local id -> ident_fmt c ppf id | `Gpath p -> model_resolved_path c ppf (p :> rpath) | `Substituted x -> wrap c "substituted" resolved_type_path ppf x @@ -1353,6 +1351,7 @@ module Fmt = struct and model_resolved_path (c : config) ppf (p : rpath) = let open Odoc_model.Paths.Path.Resolved in match p with + | `CoreType x -> Format.fprintf ppf "%s" (TypeName.to_string x) | `Identifier id -> Format.fprintf ppf "%a" (model_identifier c) (id :> id) | `Module (parent, name) -> Format.fprintf ppf "%a.%s" (model_resolved_path c) @@ -1953,6 +1952,7 @@ module Of_Lang = struct _ -> Odoc_model.Paths.Path.Resolved.Type.t -> Cpath.Resolved.type_ = fun ident_map p -> match p with + | `CoreType _ as c -> c | `Identifier i -> ( match identifier Maps.Path.Type.find ident_map.path_types i with | `Local l -> `Local l diff --git a/src/xref2/cpath.ml b/src/xref2/cpath.ml index 7e34e056a8..8eb67bf16d 100644 --- a/src/xref2/cpath.ml +++ b/src/xref2/cpath.ml @@ -32,6 +32,7 @@ module rec Resolved : sig | `Gpath of Path.Resolved.Type.t | `Substituted of type_ | `CanonicalType of type_ * Path.Type.t + | `CoreType of TypeName.t | `Type of parent * TypeName.t | `Class of parent * TypeName.t | `ClassType of parent * TypeName.t ] @@ -125,6 +126,7 @@ and is_resolved_module_type_substituted : Resolved.module_type -> bool = and is_resolved_type_substituted : Resolved.type_ -> bool = function | `Local _ -> false + | `CoreType _ -> false | `Substituted _ -> true | `Gpath _ -> false | `CanonicalType (t, _) -> is_resolved_type_substituted t @@ -244,14 +246,14 @@ and is_type_hidden : type_ -> bool = function | `Identifier ({ iv = `Type (_, t); _ }, b) -> b || TypeName.is_hidden t | `Identifier ({ iv = `ClassType (_, t); _ }, b) -> b || TypeName.is_hidden t | `Identifier ({ iv = `Class (_, t); _ }, b) -> b || TypeName.is_hidden t - | `Identifier ({ iv = `CoreType _; _ }, b) -> b | `Local (_, b) -> b - | `Substituted p -> is_type_hidden p + | `Substituted p -> is_type_hidden (p :> type_) | `DotT (p, _) -> is_module_hidden p | `Type (p, _) | `Class (p, _) | `ClassType (p, _) -> is_resolved_parent_hidden ~weak_canonical_test:false p and is_resolved_type_hidden : Resolved.type_ -> bool = function + | `CoreType n -> TypeName.is_hidden n | `Local _ -> false | `Gpath p -> Odoc_model.Paths.Path.Resolved.(is_hidden (p :> t)) | `Substituted p -> is_resolved_type_hidden p @@ -362,7 +364,7 @@ and unresolve_resolved_parent_path : Resolved.parent -> module_ = function | `FragmentRoot | `ModuleType _ -> assert false and unresolve_resolved_type_path : Resolved.type_ -> type_ = function - | (`Gpath _ | `Local _) as p -> `Resolved p + | (`Gpath _ | `Local _ | `CoreType _) as p -> `Resolved p | `Substituted x -> unresolve_resolved_type_path x | `CanonicalType (t1, _) -> unresolve_resolved_type_path t1 | `Type (p, n) -> `DotT (unresolve_resolved_parent_path p, n) @@ -381,7 +383,7 @@ and unresolve_module_type_path : module_type -> module_type = function | y -> y and unresolve_type_path : type_ -> type_ = function - | `Resolved m -> unresolve_resolved_type_path m + | `Resolved m -> (unresolve_resolved_type_path m :> type_) | y -> y and unresolve_class_type_path : class_type -> class_type = function diff --git a/src/xref2/find.ml b/src/xref2/find.ml index fad642d0a1..7aabd3e1a1 100644 --- a/src/xref2/find.ml +++ b/src/xref2/find.ml @@ -7,6 +7,8 @@ type module_type = [ `FModuleType of ModuleTypeName.t * ModuleType.t ] type datatype = [ `FType of TypeName.t * TypeDecl.t ] +type core_type = [ `CoreType of TypeName.t ] + type class_ = [ `FClass of TypeName.t * Class.t | `FClassType of TypeName.t * ClassType.t ] @@ -127,7 +129,7 @@ type careful_module = [ module_ | `FModule_removed of Cpath.module_ ] type careful_module_type = [ module_type | `FModuleType_removed of ModuleType.expr ] -type careful_type = [ type_ | removed_type ] +type careful_type = [ type_ | removed_type | core_type ] type careful_class = [ class_ | removed_type ] diff --git a/src/xref2/find.mli b/src/xref2/find.mli index 33045ef4e9..4016e24478 100644 --- a/src/xref2/find.mli +++ b/src/xref2/find.mli @@ -113,7 +113,9 @@ type careful_module = [ module_ | `FModule_removed of Cpath.module_ ] type careful_module_type = [ module_type | `FModuleType_removed of ModuleType.expr ] -type careful_type = [ type_ | removed_type ] +type core_type = [ `CoreType of TypeName.t ] + +type careful_type = [ type_ | removed_type | core_type ] type careful_class = [ class_ | removed_type ] diff --git a/src/xref2/ident.ml b/src/xref2/ident.ml index ced7940cb2..f9a2e6af4b 100644 --- a/src/xref2/ident.ml +++ b/src/xref2/ident.ml @@ -68,9 +68,7 @@ module Of_Identifier = struct let type_ : Type.t -> type_ = fun t -> let i = fresh_int () in - match t.iv with - | `Type (_, n) -> `LType (n, i) - | `CoreType _n -> failwith "Bad" + match t.iv with `Type (_, n) -> `LType (n, i) let module_ : Module.t -> module_ = function | { iv = `Module (_, n) | `Root (_, n); _ } -> @@ -92,10 +90,7 @@ module Of_Identifier = struct fun e -> match e.iv with `Extension (_, n) -> `LExtension (n, fresh_int ()) let exception_ : Exception.t -> exception_ = - fun e -> - match e.iv with - | `Exception (_, n) -> `LException (n, fresh_int ()) - | `CoreException _ -> failwith "Bad" + fun e -> match e.iv with `Exception (_, n) -> `LException (n, fresh_int ()) let value : Value.t -> value = fun v -> match v.iv with `Value (_, n) -> `LValue (n, fresh_int ()) diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 5b35fec06f..db8e0f304a 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -178,6 +178,7 @@ module Path = struct and resolved_type map (p : Cpath.Resolved.type_) : Odoc_model.Paths.Path.Resolved.Type.t = match p with + | `CoreType _ as c -> c | `Gpath y -> y | `Local id -> `Identifier (Component.TypeMap.find id map.path_type) | `CanonicalType (t1, t2) -> `CanonicalType (resolved_type map t1, t2) @@ -695,7 +696,7 @@ and typ_ext map parent t = let open Component.Extension in { parent; - type_path = Path.type_ map t.type_path; + type_path = (Path.type_ map t.type_path :> Paths.Path.Type.t); doc = docs (parent :> Identifier.LabelParent.t) t.doc; type_params = t.type_params; private_ = t.private_; @@ -991,7 +992,9 @@ and type_expr map (parent : Identifier.LabelParent.t) (t : Component.TypeExpr.t) Arrow (lbl, type_expr map parent t1, type_expr map parent t2) | Tuple ts -> Tuple (List.map (type_expr map parent) ts) | Constr (path, ts) -> - Constr (Path.type_ map path, List.map (type_expr map parent) ts) + Constr + ( (Path.type_ map path :> Paths.Path.Type.t), + List.map (type_expr map parent) ts ) | Polymorphic_variant v -> Polymorphic_variant (type_expr_polyvar map parent v) | Object o -> Object (type_expr_object map parent o) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index e61f4958ba..6684315665 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -74,8 +74,9 @@ let expansion_needed self target = let hidden_alias = Paths.Path.Resolved.is_hidden self and self_canonical = let i = Paths.Path.Resolved.identifier self in - i = (target :> Paths.Identifier.t) + i = Some (target :> Paths.Identifier.t) in + self_canonical || hidden_alias exception Loop @@ -93,6 +94,7 @@ let rec should_reresolve : Paths.Path.Resolved.t -> bool = fun p -> let open Paths.Path.Resolved in match p with + | `CoreType _ -> false | `Identifier _ -> false | `Subst (x, y) -> should_reresolve (x :> t) || should_reresolve (y :> t) | `Hidden p -> should_reresolve (p :> t) @@ -922,7 +924,7 @@ and type_decl : Env.t -> Id.Signature.t -> TypeDecl.t -> TypeDecl.t = | Some (Constr (`Resolved path, params)) when Paths.Path.Resolved.(is_hidden (path :> t)) || Paths.Path.Resolved.(identifier (path :> t)) - = (t.id :> Paths.Identifier.t) -> + = Some (t.id :> Paths.Identifier.t) -> Some (path, params) | _ -> None in @@ -950,7 +952,9 @@ and type_decl : Env.t -> Id.Signature.t -> TypeDecl.t -> TypeDecl.t = with _ -> default.equation in { default with equation = type_decl_equation env parent equation } - | Ok (`FClass _ | `FClassType _ | `FType_removed _) | Error _ -> default) + | Ok (`FClass _ | `FClassType _ | `FType_removed _ | `CoreType _) + | Error _ -> + default) | None -> default and type_decl_equation env parent t = @@ -1084,7 +1088,7 @@ and type_expression : Env.t -> Id.Signature.t -> _ -> _ = Constr (`Resolved p, ts)) | _ -> Constr (`Resolved p, ts) else Constr (`Resolved p, ts) - | Ok (cp', (`FClass _ | `FClassType _)) -> + | Ok (cp', (`FClass _ | `FClassType _ | `CoreType _)) -> let p = Lang_of.(Path.resolved_type (empty ()) cp') in Constr (`Resolved p, ts) | Ok (_cp, `FType_removed (_, x, _eq)) -> diff --git a/src/xref2/shape_tools.cppo.ml b/src/xref2/shape_tools.cppo.ml index 9dc63087d8..c01ed5390b 100644 --- a/src/xref2/shape_tools.cppo.ml +++ b/src/xref2/shape_tools.cppo.ml @@ -48,7 +48,7 @@ let rec shape_of_id env : | `Class (parent, name) -> proj parent Kind.Class (TypeName.to_string_unsafe name) | `ClassType (parent, name) -> proj parent Kind.Class_type (TypeName.to_string_unsafe name) - | `Page _ | `LeafPage _ | `Label _ | `CoreType _ | `CoreException _ + | `Page _ | `LeafPage _ | `Label _ | `Constructor _ | `Field _ | `Method _ | `InstanceVariable _ | `Parameter _ -> (* Not represented in shapes. *) diff --git a/src/xref2/subst.ml b/src/xref2/subst.ml index 1fb51573b8..2e149045e9 100644 --- a/src/xref2/subst.ml +++ b/src/xref2/subst.ml @@ -314,6 +314,7 @@ and resolved_type_path : (Cpath.Resolved.type_, TypeExpr.t * TypeDecl.Equation.t) or_replaced = fun s p -> match p with + | `CoreType _ as c -> Not_replaced c | `Local id -> ( if TypeMap.mem id s.type_replacement then Replaced (TypeMap.find id s.type_replacement) diff --git a/src/xref2/test.md b/src/xref2/test.md index 33f4110050..d48abbd261 100644 --- a/src/xref2/test.md +++ b/src/xref2/test.md @@ -3260,13 +3260,7 @@ let sg = Common.signature_of_mli_string test_data;; ihash = 1011043008; ikey = "v_{x}6/shadowed/(XXXX).m_Foo3.r_Root.p_None"}; source_loc = None; value = Odoc_model.Lang.Value.Abstract; doc = []; - type_ = - Odoc_model.Lang.TypeExpr.Constr - (`Identifier - ({Odoc_model__Paths_types.iv = `CoreType int; ihash = 432452609; - ikey = "coret_int"}, - false), - [])}; + type_ = Odoc_model.Lang.TypeExpr.Constr (`Resolved (`CoreType int), [])}; Odoc_model.Lang.Signature.Value {Odoc_model.Lang.Value.id = {Odoc_model__Paths_types.iv = diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index 9fa365a8fa..77f842d66c 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -531,6 +531,7 @@ and handle_module_type_lookup env id p sg sub = and handle_type_lookup env id p sg = match Find.careful_type_in_sig sg id with | Some (`FClass (name, _) as t) -> Ok (`Class (p, name), t) + | Some (`CoreType _ as c) -> Ok (c, c) | Some (`FClassType (name, _) as t) -> Ok (`ClassType (p, name), t) | Some (`FType (name, _) as t) -> Ok (simplify_type env (`Type (p, name)), t) | Some (`FType_removed (name, _, _) as t) -> Ok (`Type (p, name), t) @@ -740,24 +741,16 @@ and lookup_type_gpath : | Some (`FType (name, t)) -> Ok (`FType (name, Subst.type_ sub t)) | Some (`FType_removed (name, texpr, eq)) -> Ok (`FType_removed (name, Subst.type_expr sub texpr, eq)) + | Some (`CoreType _ as c) -> Ok c | None -> Error `Find_failure in let res = match p with - | `Identifier { iv = `CoreType name; _ } -> - (* CoreTypes aren't put into the environment, so they can't be handled - by the next clause. They are already resolved. *) - Ok - (`FType - ( name, - Component.Of_Lang.( - type_decl (empty ()) - (Odoc_model.Predefined.type_of_core_type - (TypeName.to_string name))) )) + | `CoreType _ as c -> Ok c | `Identifier ({ iv = `Type _; _ } as i) -> of_option ~error:(`Lookup_failureT i) (Env.(lookup_by_id s_datatype) i env) - >>= fun (`Type ({ iv = `CoreType name | `Type (_, name); _ }, t)) -> + >>= fun (`Type ({ iv = `Type (_, name); _ }, t)) -> Ok (`FType (name, t)) | `Identifier ({ iv = `Class _; _ } as i) -> of_option ~error:(`Lookup_failureT i) (Env.(lookup_by_id s_class) i env) @@ -846,6 +839,7 @@ and lookup_type : handle_type_lookup env name p sg >>= fun (_, t') -> let t = match t' with + | `CoreType _ as c -> c | `FClass (name, c) -> `FClass (name, Subst.class_ sub c) | `FClassType (name, ct) -> `FClassType (name, Subst.class_type sub ct) | `FType (name, t) -> `FType (name, Subst.type_ sub t) @@ -856,6 +850,7 @@ and lookup_type : in let res = match p with + | `CoreType _ as c -> Ok c | `Local id -> Error (`LocalType (env, id)) | `Gpath p -> lookup_type_gpath env p | `CanonicalType (t1, _) -> lookup_type env t1 @@ -1019,6 +1014,7 @@ and resolve_type : Env.t -> Cpath.type_ -> resolve_type_result = handle_type_lookup env id parent parent_sig >>= fun (p', t') -> let t = match t' with + | `CoreType _ as c -> c | `FClass (name, c) -> `FClass (name, Subst.class_ sub c) | `FClassType (name, ct) -> `FClassType (name, Subst.class_type sub ct) | `FType (name, t) -> `FType (name, Subst.type_ sub t) @@ -1056,6 +1052,7 @@ and resolve_type : Env.t -> Cpath.type_ -> resolve_type_result = handle_type_lookup env id parent parent_sg >>= fun (p', t') -> let t = match t' with + | `CoreType _ as c -> c | `FClass (name, c) -> `FClass (name, Subst.class_ sub c) | `FClassType (name, ct) -> `FClassType (name, Subst.class_type sub ct) | `FType (name, t) -> `FType (name, Subst.type_ sub t) @@ -1486,7 +1483,7 @@ and reresolve_type : Env.t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ = fun env path -> let result = match path with - | `Gpath _ | `Local _ -> path + | `Gpath _ | `Local _ | `CoreType _ -> path | `Substituted s -> `Substituted (reresolve_type env s) | `CanonicalType (p1, p2) -> `CanonicalType (reresolve_type env p1, handle_canonical_type env p2) diff --git a/test/xref2/classes.t/run.t b/test/xref2/classes.t/run.t index 13023883e2..f83eb9bec8 100644 --- a/test/xref2/classes.t/run.t +++ b/test/xref2/classes.t/run.t @@ -137,9 +137,7 @@ resolve correctly. All of the 'Class' json objects should contain "Constr": [ { "`Resolved": { - "`Identifier": { - "`CoreType": "unit" - } + "`CoreType": "unit" } }, [] diff --git a/test/xref2/deep_substitution.t/run.t b/test/xref2/deep_substitution.t/run.t index ec42338988..3431498bac 100644 --- a/test/xref2/deep_substitution.t/run.t +++ b/test/xref2/deep_substitution.t/run.t @@ -47,9 +47,7 @@ its RHS correctly replaced with an `int` "Constr": [ { "`Resolved": { - "`Identifier": { - "`CoreType": "int" - } + "`CoreType": "int" } }, [] diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index a427375894..3a7822761d 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -582,6 +582,7 @@ module LangUtils = struct | `Hidden _ | `SubstitutedT _ | `SubstitutedMT _ + | `CoreType _ | `Substituted _ | `SubstitutedCT _ | `Canonical _ -> Format.fprintf ppf "unimplemented resolved_path" @@ -598,7 +599,7 @@ module LangUtils = struct | `DotT (parent,s) -> Format.fprintf ppf "%a.%a" path (parent :> Odoc_model.Paths.Path.t) TypeName.fmt s | `DotV (parent,s) -> Format.fprintf ppf "%a.%a" path (parent :> Odoc_model.Paths.Path.t) ValueName.fmt s | `Apply (func,arg) -> Format.fprintf ppf "%a(%a)" path (func :> Odoc_model.Paths.Path.t) path (arg :> Odoc_model.Paths.Path.t) - | `SubstitutedT _|`SubstitutedMT _|`Substituted _|`SubstitutedCT _ -> Format.fprintf ppf "Unimplemented path" + | `SubstitutedT _|`SubstitutedMT _|`Substituted _|`SubstitutedCT _ -> Format.fprintf ppf "Unimplemented path" and model_fragment ppf (f : Odoc_model.Paths.Fragment.t) = match f with diff --git a/test/xref2/subst/test.md b/test/xref2/subst/test.md index 005d06f4af..1d6f9599fa 100644 --- a/test/xref2/subst/test.md +++ b/test/xref2/subst/test.md @@ -145,7 +145,7 @@ module ComplexTypeExpr/19 : (sig : val map/29 : (([resolved(int) * a] resolved(t/28) * [a * resolved(int)] resolved(t/28))) -> ((a) -> b) -> ([resolved(int) * b] resolved(t/28) * [b * resolved(int)] resolved(t/28)) val join/30 : (([resolved(int) * ([resolved(int) * a] resolved(t/28) * [a * resolved(int)] resolved(t/28))] resolved(t/28) * [([resolved(int) * a] resolved(t/28) * [a * resolved(int)] resolved(t/28)) * resolved(int)] resolved(t/28))) -> ([resolved(int) * a] resolved(t/28) * [a * resolved(int)] resolved(t/28)) - (removed=type (a) t = (([identifier(int,false) * a] local(t/28,false) * [a * identifier(int,false)] local(t/28,false)))) + (removed=type (a) t = (([resolved(int) * a] local(t/28,false) * [a * resolved(int)] local(t/28,false)))) end) end (canonical=None) module Erase/18 :