From d0b3dd326ba3b6a565fee09cc2ab9fbb5228eb09 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Mon, 5 Jun 2023 22:07:02 +0100 Subject: [PATCH] Source locations are now identifiers --- src/document/generator.ml | 29 +++++++++------------ src/document/url.ml | 44 ++++++++++++++++---------------- src/document/url.mli | 15 +++-------- src/loader/lookup_def.ml | 12 +++++---- src/loader/lookup_def.mli | 4 +-- src/model/lang.ml | 31 ++++++++--------------- src/model/names.ml | 1 + src/model/names.mli | 2 ++ src/model/paths.ml | 47 ++++++++++++++++++++++++----------- src/model/paths.mli | 33 ++++++++++++++++-------- src/model/paths_types.ml | 25 ++++++++++++++++--- src/model_desc/lang_desc.ml | 31 ++++++++--------------- src/model_desc/paths_desc.ml | 37 +++++++++++++-------------- src/model_desc/paths_desc.mli | 2 -- src/odoc/compile.ml | 4 ++- src/odoc/html_page.ml | 2 +- src/xref2/component.ml | 27 ++++++++++++++------ src/xref2/component.mli | 16 ++++++------ src/xref2/env.ml | 6 ++--- src/xref2/env.mli | 5 ++-- src/xref2/link.ml | 5 ++-- 21 files changed, 202 insertions(+), 176 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 6729943b32..959546736d 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -49,11 +49,10 @@ let path_to_id path = let source_anchor locs = match locs with - | Some { Odoc_model.Lang.Locations.anchor = Some anchor; source_parent } -> - Some (Url.Anchor.source_file_from_identifier source_parent ~anchor) - | Some { Odoc_model.Lang.Locations.anchor = None; source_parent } -> - let path = Url.Path.source_file_from_identifier source_parent in - Some (Url.from_path path) + | Some id -> + Url.Anchor.from_identifier + (id : Paths.Identifier.SourceLocation.t :> Paths.Identifier.t) + |> Result.to_option | _ -> None let attach_expansion ?(status = `Default) (eq, o, e) page text = @@ -242,7 +241,7 @@ module Make (Syntax : SYNTAX) = struct string -> Source_page.t end = struct - let path id = Url.Path.source_file_from_identifier id + let path id = Url.Path.from_identifier id let url id = Url.from_path (path id) let info_of_info url = function @@ -1792,7 +1791,7 @@ module Make (Syntax : SYNTAX) = struct | `SourceDir (parent, _) -> let mmap = add parent (add_dir dir) mmap in dir_ancestors_add parent mmap - | `SourceRoot _ -> mmap + | `Page _ -> mmap in let file_ancestors_add ({ iv = `SourcePage (parent, _); _ } as file) mmap = @@ -1804,11 +1803,11 @@ module Make (Syntax : SYNTAX) = struct M.empty dir_pages in let page_of_dir (dir : SourceDir.t) (dir_children, file_children) = - let url = Url.Path.source_dir_from_identifier dir in + let url = Url.Path.from_identifier dir in let block ?(attr = []) desc = Block.{ attr; desc } in let inline ?(attr = []) desc = Inline.[ { attr; desc } ] in let header = - let title = inline (Text (SourceDir.name dir)) in + let title = inline (Text (name dir)) in Item.Heading Heading.{ label = None; level = 0; title; source_anchor = None } in @@ -1822,18 +1821,14 @@ module Make (Syntax : SYNTAX) = struct in let li_of_child child = match child with - | { iv = `SourceRoot _; _ } -> - assert false (* No [`SourceRoot] is child of a [`SourceDir] *) + | { iv = `Page _; _ } -> + assert false (* No [`Page] is child of a [`SourceDir] *) | { iv = `SourceDir (_, name); _ } -> - let url = - child |> Url.Path.source_dir_from_identifier |> Url.from_path - in + let url = child |> Url.Path.from_identifier |> Url.from_path in (name, url) in let li_of_file_child ({ iv = `SourcePage (_, name); _ } as child) = - let url = - child |> Url.Path.source_file_from_identifier |> Url.from_path - in + let url = child |> Url.Path.from_identifier |> Url.from_path in (name, url) in let items = diff --git a/src/document/url.ml b/src/document/url.ml index 38db5a8714..3be65243d3 100644 --- a/src/document/url.ml +++ b/src/document/url.ml @@ -82,11 +82,14 @@ end let ( >>= ) x f = match x with Ok x -> f x | Error _ as e -> e module Path = struct - type source_pv = + type nonsrc_pv = [ Identifier.Page.t_pv | Identifier.Signature.t_pv | Identifier.ClassSignature.t_pv ] + type source_pv = + [ nonsrc_pv | Identifier.SourcePage.t_pv | Identifier.SourceDir.t_pv ] + and source = source_pv Odoc_model.Paths.Identifier.id type kind = @@ -174,25 +177,16 @@ module Path = struct let name = ClassTypeName.to_string name in mk ~parent kind name | { iv = `Result p; _ } -> from_identifier (p :> source) + | { iv = `SourceDir (parent, name); _ } + | { iv = `SourcePage (parent, name); _ } -> + let parent = from_identifier (parent :> source) in + let kind = `Page in + mk ~parent kind name let from_identifier p = from_identifier (p : [< source_pv ] Odoc_model.Paths.Identifier.id :> source) - let rec source_dir_from_identifier id = - match id.Odoc_model.Paths.Identifier.iv with - | `SourceRoot container -> from_identifier (container :> source) - | `SourceDir (parent, name) -> - let parent = source_dir_from_identifier parent in - let kind = `Page in - mk ~parent kind name - - let source_file_from_identifier id = - let (`SourcePage (parent, name)) = id.Odoc_model.Paths.Identifier.iv in - let parent = source_dir_from_identifier parent in - let kind = `SourcePage in - mk ~parent kind name - let to_list url = let rec loop acc { parent; name; kind } = match parent with @@ -369,16 +363,20 @@ module Anchor = struct happen, [`Type] may not happen either but just in case, use the grand-parent. *) match parent with - | { iv = #Path.source_pv; _ } as parent -> - mk ~kind:`Section parent str_name | { iv = `CoreType _; _ } -> Error (Unexpected_anchor "core_type label parent") - | { iv = `Type (gp, _); _ } -> mk ~kind:`Section gp str_name) - - let source_file_from_identifier id ~anchor = - let kind = `SourceAnchor in - let page = Path.source_file_from_identifier id in - { page; anchor; kind } + | { iv = `Type (gp, _); _ } -> mk ~kind:`Section gp str_name + | { iv = #Path.nonsrc_pv; _ } as p -> + mk ~kind:`Section (p :> Path.source) str_name) + | { iv = `SourceLocation (parent, loc); _ } -> + let page = Path.from_identifier (parent :> Path.source) in + Ok { page; kind = `SourceAnchor; anchor = DefName.to_string loc } + | { iv = `SourceLocationMod parent; _ } -> + let page = Path.from_identifier (parent :> Path.source) in + Ok { page; kind = `SourceAnchor; anchor = "" } + | { iv = `SourcePage (p, _name); _ } | { iv = `SourceDir (p, _name); _ } -> + let page = Path.from_identifier (p :> Path.source) in + Ok { page; kind = `Page; anchor = "" } let polymorphic_variant ~type_ident elt = let name_of_type_constr te = diff --git a/src/document/url.mli b/src/document/url.mli index 66a658e082..10bc88fa32 100644 --- a/src/document/url.mli +++ b/src/document/url.mli @@ -29,22 +29,18 @@ module Path : sig type t = { kind : kind; parent : t option; name : string } - type source_pv = + type nonsrc_pv = [ Identifier.Page.t_pv | Identifier.Signature.t_pv | Identifier.ClassSignature.t_pv ] + type source_pv = + [ nonsrc_pv | Identifier.SourcePage.t_pv | Identifier.SourceDir.t_pv ] + and source = source_pv Odoc_model.Paths.Identifier.id val from_identifier : [< source_pv ] Odoc_model.Paths.Identifier.id -> t - val source_dir_from_identifier : Odoc_model.Paths.Identifier.SourceDir.t -> t - (** A path to a source dir. *) - - val source_file_from_identifier : - Odoc_model.Paths.Identifier.SourcePage.t -> t - (** A path to a source file. *) - val to_list : t -> (kind * string) list val of_list : (kind * string) list -> t option @@ -93,9 +89,6 @@ module Anchor : sig val from_identifier : Identifier.t -> (t, Error.t) result - val source_file_from_identifier : - Odoc_model.Paths.Identifier.SourcePage.t -> anchor:string -> t - val polymorphic_variant : type_ident:Identifier.t -> Odoc_model.Lang.TypeExpr.Polymorphic_variant.element -> diff --git a/src/loader/lookup_def.ml b/src/loader/lookup_def.ml index da679e7a52..48c35a839a 100644 --- a/src/loader/lookup_def.ml +++ b/src/loader/lookup_def.ml @@ -11,10 +11,10 @@ type t = Shape.t (** Project an identifier into a shape. *) let rec shape_of_id lookup_shape : - [< Identifier.t_pv ] Identifier.id -> Shape.t option = + [< Identifier.NonSrc.t_pv ] Identifier.id -> Shape.t option = let proj parent kind name = let item = Shape.Item.make name kind in - match shape_of_id lookup_shape (parent :> Identifier.t) with + match shape_of_id lookup_shape (parent :> Identifier.NonSrc.t) with | Some shape -> Some (Shape.proj shape item) | None -> None in @@ -29,7 +29,7 @@ let rec shape_of_id lookup_shape : (* Apply the functor to an empty signature. This doesn't seem to cause any problem, as the shape would stop resolve on an item inside the result of the function, which is what we want. *) - shape_of_id lookup_shape (parent :> Identifier.t) >>= fun parent -> + shape_of_id lookup_shape (parent :> Identifier.NonSrc.t) >>= fun parent -> Some (Shape.app parent ~arg:(Shape.str Shape.Item.Map.empty)) | `ModuleType (parent, name) -> proj parent Kind.Module_type (ModuleTypeName.to_string name) @@ -69,8 +69,10 @@ let lookup_def lookup_unit id = Uid.unpack_uid (Uid.of_shape_uid uid) >>= fun (unit_name, id) -> lookup_unit unit_name >>= fun (unit, _) -> unit.Lang.Compilation_unit.source_info >>= fun sources -> - let anchor = id >>= fun id -> Some (Uid.anchor_of_id id) in - Some { Lang.Locations.source_parent = sources.id; anchor } + let anchor_opt = id >>= fun id -> Some (Uid.anchor_of_id id) in + match anchor_opt with + | Some anchor -> Some (Paths.Identifier.Mk.source_location (sources.id,Odoc_model.Names.DefName.make_std anchor)) + | None -> Some (Paths.Identifier.Mk.source_location_mod sources.id) let of_cmt (cmt : Cmt_format.cmt_infos) = cmt.cmt_impl_shape diff --git a/src/loader/lookup_def.mli b/src/loader/lookup_def.mli index 9148ef2d5e..06fe258cab 100644 --- a/src/loader/lookup_def.mli +++ b/src/loader/lookup_def.mli @@ -4,8 +4,8 @@ type t val lookup_def : (string -> (Lang.Compilation_unit.t * t) option) -> - Identifier.t -> - Lang.Locations.t option + Identifier.NonSrc.t -> + Identifier.SourceLocation.t option (** Returns the root module containing the definition of the given identifier and the corresponding anchor. *) diff --git a/src/model/lang.ml b/src/model/lang.ml index 2544f0fdc8..7b6b1e1345 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -16,16 +16,7 @@ open Paths -module Locations = struct - type t = { - source_parent : Identifier.SourcePage.t; - (** Correspond to where the source code is stored. Might be different - from the root component of the identifier inside expansions. *) - anchor : string option; - (** Location of the definition in the implementation file. *) - } -end - +(** {3 Modules} *) module Source_info = struct type anchor = { anchor : string } @@ -40,8 +31,6 @@ module Source_info = struct type t = { id : Identifier.SourcePage.t; infos : infos } end -(** {3 Modules} *) - module rec Module : sig type decl = | Alias of (Path.Module.t * ModuleType.simple_expansion option) @@ -49,8 +38,8 @@ module rec Module : sig type t = { id : Identifier.Module.t; - locs : Locations.t option; - (** Locations might not be set when the module is artificially constructed from a functor argument. *) + locs : Identifier.SourceLocation.t option; + (** Identifier.SourceLocation might not be set when the module is artificially constructed from a functor argument. *) doc : Comment.docs; type_ : decl; canonical : Path.Module.t option; @@ -127,7 +116,7 @@ and ModuleType : sig type t = { id : Identifier.ModuleType.t; - locs : Locations.t option; + locs : Identifier.SourceLocation.t option; (** Can be [None] for module types created by a type substitution. *) doc : Comment.docs; canonical : Path.ModuleType.t option; @@ -268,7 +257,7 @@ and TypeDecl : sig type t = { id : Identifier.Type.t; - locs : Locations.t option; + locs : Identifier.SourceLocation.t option; doc : Comment.docs; canonical : Path.Type.t option; equation : Equation.t; @@ -283,7 +272,7 @@ and Extension : sig module Constructor : sig type t = { id : Identifier.Extension.t; - locs : Locations.t option; + locs : Identifier.SourceLocation.t option; doc : Comment.docs; args : TypeDecl.Constructor.argument; res : TypeExpr.t option; @@ -305,7 +294,7 @@ end = and Exception : sig type t = { id : Identifier.Exception.t; - locs : Locations.t option; + locs : Identifier.SourceLocation.t option; doc : Comment.docs; args : TypeDecl.Constructor.argument; res : TypeExpr.t option; @@ -320,7 +309,7 @@ and Value : sig type t = { id : Identifier.Value.t; - locs : Locations.t option; + locs : Identifier.SourceLocation.t option; value : value; doc : Comment.docs; type_ : TypeExpr.t; @@ -337,7 +326,7 @@ and Class : sig type t = { id : Identifier.Class.t; - locs : Locations.t option; + locs : Identifier.SourceLocation.t option; doc : Comment.docs; virtual_ : bool; params : TypeDecl.param list; @@ -356,7 +345,7 @@ and ClassType : sig type t = { id : Identifier.ClassType.t; - locs : Locations.t option; + locs : Identifier.SourceLocation.t option; doc : Comment.docs; virtual_ : bool; params : TypeDecl.param list; diff --git a/src/model/names.ml b/src/model/names.ml index d415152e78..27997117bc 100644 --- a/src/model/names.ml +++ b/src/model/names.ml @@ -141,3 +141,4 @@ module MethodName = SimpleName module InstanceVariableName = SimpleName module LabelName = SimpleName module PageName = SimpleName +module DefName = SimpleName diff --git a/src/model/names.mli b/src/model/names.mli index 7f87c969cf..683d901480 100644 --- a/src/model/names.mli +++ b/src/model/names.mli @@ -95,3 +95,5 @@ module InstanceVariableName : SimpleName module LabelName : SimpleName module PageName : SimpleName + +module DefName : SimpleName diff --git a/src/model/paths.ml b/src/model/paths.ml index c03699c703..555fa3454a 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -51,14 +51,18 @@ module Identifier = struct | `Method (_, name) -> MethodName.to_string name | `InstanceVariable (_, name) -> InstanceVariableName.to_string name | `Label (_, name) -> LabelName.to_string name + | `SourcePage (_, name) -> name + | `SourceDir (_, name) -> name + | `SourceLocation (_, anchor) -> DefName.to_string anchor + | `SourceLocationMod x -> name_aux (x :> t) let name : [< t_pv ] id -> string = fun n -> name_aux (n :> t) let rec label_parent_aux = let open Id in - fun (n : t) -> + fun (n : non_src) -> match n with - | { iv = `Result i; _ } -> label_parent_aux (i :> any) + | { 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) @@ -79,7 +83,7 @@ module Identifier = struct | { iv = `Constructor (p, _); _ } -> (p : datatype :> label_parent) | { iv = `Field (p, _); _ } -> (p : parent :> label_parent) - let label_parent n = label_parent_aux (n :> t) + let label_parent n = label_parent_aux (n :> Id.non_src) let equal x y = x.ihash = y.ihash && x.ikey = y.ikey @@ -255,23 +259,27 @@ module Identifier = struct type t_pv = Id.container_page_pv end + module NonSrc = struct + type t = Paths_types.Identifier.non_src + type t_pv = Paths_types.Identifier.non_src_pv + end + module SourceDir = struct type t = Id.source_dir type t_pv = Id.source_dir_pv let equal = equal let hash = hash let compare = compare - let rec name = function - | { iv = `SourceDir (p, n); _ } -> name p ^ n ^ "/" - | { iv = `SourceRoot _; _ } -> "./" end module SourcePage = struct type t = Id.source_page type t_pv = Id.source_page_pv - let equal = equal - let name { iv = `SourcePage (p, name); _ } = SourceDir.name p ^ name - + end + + module SourceLocation = struct + type t = Paths_types.Identifier.source_location + type t_pv = Paths_types.Identifier.source_location_pv end module OdocId = struct @@ -367,12 +375,7 @@ module Identifier = struct let source_page (container_page, path) = let rec source_dir dir = match dir with - | [] -> - mk_parent - (fun () -> "") - "sr" - (fun (p, ()) -> `SourceRoot p) - (container_page, ()) + | [] -> (container_page : ContainerPage.t :> SourceDir.t) | a :: q -> let parent = source_dir q in mk_parent @@ -478,6 +481,20 @@ module Identifier = struct LabelParent.t * LabelName.t -> [> `Label of LabelParent.t * LabelName.t ] id = mk_parent LabelName.to_string "l" (fun (p, n) -> `Label (p, n)) + + let source_location : + SourcePage.t * DefName.t -> + [> `SourceLocation of SourcePage.t * DefName.t ] id = + mk_parent DefName.to_string "sl" (fun (p, n) -> `SourceLocation (p, n)) + + let source_location_mod : + SourcePage.t -> [> `SourceLocationMod of SourcePage.t ] id = + fun s -> + mk_parent + (fun () -> "__slm__") + "" + (fun (s, ()) -> `SourceLocationMod s) + (s, ()) end end diff --git a/src/model/paths.mli b/src/model/paths.mli index 1101747236..b086a6c54a 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -60,11 +60,8 @@ module Identifier : sig module Type : IdSig with type t = Id.type_ and type t_pv = Id.type_pv - module SourceDir : sig - - include IdSig with type t = Id.source_dir and type t_pv = Id.source_dir_pv - val name : t -> string - end + module SourceDir : + IdSig with type t = Id.source_dir and type t_pv = Id.source_dir_pv module Class : IdSig with type t = Id.class_ and type t_pv = Id.class_pv @@ -121,8 +118,8 @@ module Identifier : sig end module Label : IdSig - with type t = Paths_types.Identifier.label - and type t_pv = Paths_types.Identifier.label_pv + with type t = Id.label + and type t_pv = Id.label_pv module Page : sig type t = Id.page @@ -134,12 +131,21 @@ module Identifier : sig type t_pv = Id.container_page_pv end + module NonSrc : sig + type t = Id.non_src + type t_pv = Id.non_src_pv + end + module SourcePage : sig type t = Id.source_page type t_pv = Id.source_page_pv - val name : t -> string - val equal : t -> t -> bool end + + module SourceLocation : sig + type t = Id.source_location + type t_pv = Id.source_location_pv + end + module OdocId : sig type t = Id.odoc_id type t_pv = Id.odoc_id_pv @@ -177,7 +183,7 @@ module Identifier : sig val equal : ([< t_pv ] id as 'a) -> 'a -> bool - val label_parent : [< t_pv ] id -> LabelParent.t + val label_parent : [< NonSrc.t_pv ] id -> LabelParent.t module Maps : sig module Any : Map.S with type key = Any.t @@ -277,6 +283,13 @@ module Identifier : sig val label : LabelParent.t * LabelName.t -> [> `Label of LabelParent.t * LabelName.t ] id + + val source_location : + SourcePage.t * DefName.t -> + [> `SourceLocation of SourcePage.t * DefName.t ] id + + val source_location_mod : + SourcePage.t -> [> `SourceLocationMod of SourcePage.t ] id end end diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index 0a018de3e0..d12abdf8bd 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -18,10 +18,11 @@ module Identifier = struct and page = page_pv id (** @canonical Odoc_model.Paths.Identifier.Page.t *) - type source_dir_pv = - [ `SourceRoot of container_page | `SourceDir of source_dir * string ] + type source_dir_pv = [ container_page_pv | `SourceDir of source_dir * string ] + (** @canonical Odoc_model.Paths.Identifier.SourceDir.t_pv *) and source_dir = source_dir_pv id + (** @canonical Odoc_model.Paths.Identifier.SourceDir.t *) type source_page_pv = [ `SourcePage of source_dir * string ] (** The second argument is the filename. @@ -31,6 +32,14 @@ module Identifier = struct type source_page = source_page_pv id (** @canonical Odoc_model.Paths.Identifier.SourcePage.t *) + type source_location_pv = + [ `SourceLocationMod of source_page + | `SourceLocation of source_page * DefName.t ] + (** @canonical Odoc_model.Paths.Identifier.SourceLocation.t *) + + and source_location = source_location_pv id + (** @canonical Odoc_model.Paths.Identifier.SourceLocation.t_pv *) + type odoc_id_pv = [ page_pv | `Root of container_page option * ModuleName.t ] (** @canonical Odoc_model.Paths.Identifier.OdocId.t_pv *) @@ -177,7 +186,7 @@ module Identifier = struct and label = label_pv id (** @canonical Odoc_model.Paths.Identifier.Label.t *) - type any_pv = + type non_src_pv = [ signature_pv | class_signature_pv | datatype_pv @@ -199,6 +208,16 @@ module Identifier = struct | instance_variable_pv | label_pv | page_pv ] + (** @canonical Odoc_model.Paths.Identifier.NonSrc.t_pv *) + + and non_src = non_src_pv id + (** @canonical Odoc_model.Paths.Identifier.NonSrc.t *) + + type any_pv = + [ non_src_pv + | source_page_pv + | source_dir_pv + | source_location_pv ] (** @canonical Odoc_model.Paths.Identifier.t_pv *) and any = any_pv id diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index 8f9ea51506..56c96bc008 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -16,17 +16,9 @@ let inline_status = | `Closed -> C0 "`Closed" | `Inline -> C0 "`Inline") -let locations = - let open Lang.Locations in - Record - [ - F ("source_parent", (fun t -> t.source_parent), sourcepage_identifier); - F ("anchor", (fun t -> t.anchor), Option string); - ] - let source_info = let open Lang.Source_info in - Record [ F ("id", (fun t -> t.id), sourcepage_identifier) ] + Record [ F ("id", (fun t -> t.id), identifier) ] (** {3 Module} *) @@ -46,7 +38,7 @@ and module_t = Record [ F ("id", (fun t -> t.id), identifier); - F ("locs", (fun t -> t.locs), Option locations); + F ("locs", (fun t -> t.locs), Option identifier); F ("doc", (fun t -> t.doc), docs); F ("type_", (fun t -> t.type_), module_decl); F @@ -180,7 +172,7 @@ and moduletype_t = Record [ F ("id", (fun t -> t.id), identifier); - F ("locs", (fun t -> t.locs), Option locations); + F ("locs", (fun t -> t.locs), Option identifier); F ("doc", (fun t -> t.doc), docs); F ( "canonical", @@ -370,7 +362,7 @@ and typedecl_t = Record [ F ("id", (fun t -> t.id), identifier); - F ("locs", (fun t -> t.locs), Option locations); + F ("locs", (fun t -> t.locs), Option identifier); F ("doc", (fun t -> t.doc), docs); F ("equation", (fun t -> t.equation), typedecl_equation); F @@ -385,7 +377,7 @@ and extension_constructor = Record [ F ("id", (fun t -> t.id), identifier); - F ("locs", (fun t -> t.locs), Option locations); + F ("locs", (fun t -> t.locs), Option identifier); F ("doc", (fun t -> t.doc), docs); F ("args", (fun t -> t.args), typedecl_constructor_argument); F ("res", (fun t -> t.res), Option typeexpr_t); @@ -409,7 +401,7 @@ and exception_t = Record [ F ("id", (fun t -> t.id), identifier); - F ("locs", (fun t -> t.locs), Option locations); + F ("locs", (fun t -> t.locs), Option identifier); F ("doc", (fun t -> t.doc), docs); F ("args", (fun t -> t.args), typedecl_constructor_argument); F ("res", (fun t -> t.res), Option typeexpr_t); @@ -427,7 +419,7 @@ and value_t = Record [ F ("id", (fun t -> t.id), identifier); - F ("locs", (fun t -> t.locs), Option locations); + F ("locs", (fun t -> t.locs), Option identifier); F ("doc", (fun t -> t.doc), docs); F ("type_", (fun t -> t.type_), typeexpr_t); F ("value", (fun t -> t.value), value_value_t); @@ -451,7 +443,7 @@ and class_t = Record [ F ("id", (fun t -> t.id), identifier); - F ("locs", (fun t -> t.locs), Option locations); + F ("locs", (fun t -> t.locs), Option identifier); F ("doc", (fun t -> t.doc), docs); F ("virtual_", (fun t -> t.virtual_), bool); F ("params", (fun t -> t.params), List typedecl_param); @@ -474,7 +466,7 @@ and classtype_t = Record [ F ("id", (fun t -> t.id), identifier); - F ("locs", (fun t -> t.locs), Option locations); + F ("locs", (fun t -> t.locs), Option identifier); F ("doc", (fun t -> t.doc), docs); F ("virtual_", (fun t -> t.virtual_), bool); F ("params", (fun t -> t.params), List typedecl_param); @@ -712,8 +704,5 @@ and source_tree_page_t = F ("name", (fun t -> t.name), identifier); F ("root", (fun t -> t.root), root); F ("digest", (fun t -> t.digest), Digest.t); - F - ( "source_children", - (fun t -> t.source_children), - List sourcepage_identifier ); + F ("source_children", (fun t -> t.source_children), List identifier); ] diff --git a/src/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml index 8b23f6d163..fc8cd70c9c 100644 --- a/src/model_desc/paths_desc.ml +++ b/src/model_desc/paths_desc.ml @@ -37,6 +37,8 @@ module Names = struct let pagename = To_string PageName.to_string let parametername = To_string ModuleName.to_string + + let defname = To_string DefName.to_string end module General_paths = struct @@ -149,7 +151,21 @@ module General_paths = struct C ( "`Label", ((parent :> id_t), name), - Pair (identifier, Names.labelname) )) + Pair (identifier, Names.labelname) ) + | `SourceDir (parent, name) -> + C ("`SourceDir", ((parent :> id_t), name), Pair (identifier, string)) + | `SourcePage (parent, name) -> + C + ( "`SourcePage", + ((parent :> id_t), name), + Pair (identifier, string) ) + | `SourceLocation (parent, name) -> + C + ( "`SourceLocation", + ((parent :> id_t), name), + Pair (identifier, Names.defname) ) + | `SourceLocationMod parent -> + C ("`SourceLocationMod", (parent :> id_t), identifier)) let reference_tag : tag t = Variant @@ -434,25 +450,6 @@ let modulename = Names.modulename let identifier : [< Paths.Identifier.t_pv ] Paths.Identifier.id Type_desc.t = Indirect ((fun n -> (n :> Paths.Identifier.t)), General_paths.identifier) -let rec sourcedir_identifier : Paths.Identifier.SourceDir.t Type_desc.t = - Variant - (fun id -> - match id.iv with - | `SourceDir (parent, name) -> - C ("`SourceDir", (parent, name), Pair (sourcedir_identifier, string)) - | `SourceRoot parent -> - C - ( "`SourceRoot", - (parent :> Paths.Identifier.t), - General_paths.identifier )) - -let sourcepage_identifier : Paths.Identifier.SourcePage.t Type_desc.t = - Indirect - ( (fun id -> - let (`SourcePage (parent, name)) = id.iv in - (parent, name)), - Pair (sourcedir_identifier, string) ) - let resolved_path : [< Paths.Path.Resolved.t ] Type_desc.t = Indirect ((fun n -> (n :> General_paths.rp)), General_paths.resolved_path) diff --git a/src/model_desc/paths_desc.mli b/src/model_desc/paths_desc.mli index 8bdb184cf6..6dca564e62 100644 --- a/src/model_desc/paths_desc.mli +++ b/src/model_desc/paths_desc.mli @@ -6,8 +6,6 @@ val modulename : Odoc_model.Names.ModuleName.t Type_desc.t val identifier : [< Identifier.t_pv ] Odoc_model.Paths.Identifier.id Type_desc.t -val sourcepage_identifier : Odoc_model.Paths.Identifier.SourcePage.t Type_desc.t - val resolved_path : [< Path.Resolved.t ] Type_desc.t val path : [< Path.t ] Type_desc.t diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml index 89ae189ccf..0575e741ae 100644 --- a/src/odoc/compile.ml +++ b/src/odoc/compile.ml @@ -309,7 +309,9 @@ let compile ~resolver ~parent_cli_spec ~hidden ~children ~output | { Paths.Identifier.iv = `Page _; _ } as parent_id -> let name = Paths.Identifier.Mk.source_page (parent_id, name) in if - List.exists (Paths.Identifier.SourcePage.equal name) page.source_children + List.exists + (Paths.Identifier.equal name) + page.source_children then Ok (Some name) else err_not_parent () | { iv = `LeafPage _; _ } -> err_not_parent ()) diff --git a/src/odoc/html_page.ml b/src/odoc/html_page.ml index 56b5b38630..25a95c08da 100644 --- a/src/odoc/html_page.ml +++ b/src/odoc/html_page.ml @@ -37,7 +37,7 @@ let extra_documents args unit ~syntax = source_code; ]) | Some { id; _ }, None -> - let filename = Paths.Identifier.SourcePage.name id in + let filename = Paths.Identifier.name id in Error.raise_warning (Error.filename_only "The --source should be passed when generating documents from \ diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 6c3372c5f0..5034b92835 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -76,7 +76,7 @@ module rec Module : sig | ModuleType of ModuleType.expr type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; type_ : decl; canonical : Odoc_model.Paths.Path.Module.t option; @@ -148,7 +148,7 @@ and Extension : sig module Constructor : sig type t = { name : string; - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; args : TypeDecl.Constructor.argument; res : TypeExpr.t option; @@ -167,7 +167,7 @@ end = and Exception : sig type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; args : TypeDecl.Constructor.argument; res : TypeExpr.t option; @@ -231,7 +231,7 @@ and ModuleType : sig | TypeOf of typeof_t type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; canonical : Odoc_model.Paths.Path.ModuleType.t option; expr : expr option; @@ -279,7 +279,7 @@ and TypeDecl : sig end type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; canonical : Odoc_model.Paths.Path.Type.t option; equation : Equation.t; @@ -292,7 +292,7 @@ and Value : sig type value = Odoc_model.Lang.Value.value type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; type_ : TypeExpr.t; value : value; @@ -363,7 +363,7 @@ and Class : sig | Arrow of TypeExpr.label option * TypeExpr.t * decl type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; virtual_ : bool; params : TypeDecl.param list; @@ -379,7 +379,7 @@ and ClassType : sig | Signature of ClassSignature.t type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; virtual_ : bool; params : TypeDecl.param list; @@ -1247,6 +1247,17 @@ module Fmt = struct (ExtensionName.to_string name) | `Page (_, name) | `LeafPage (_, name) -> Format.fprintf ppf "%s" (PageName.to_string name) + | `SourcePage (p, name) | `SourceDir (p, name) -> + Format.fprintf ppf "%a/%s" model_identifier + (p :> Odoc_model.Paths.Identifier.t) + name + | `SourceLocation (p, def) -> + Format.fprintf ppf "%a#%s" model_identifier + (p :> Odoc_model.Paths.Identifier.t) + (DefName.to_string def) + | `SourceLocationMod p -> + Format.fprintf ppf "%a#" model_identifier + (p :> Odoc_model.Paths.Identifier.t) and model_fragment ppf (f : Odoc_model.Paths.Fragment.t) = match f with diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 483cb0c676..bc289ad73e 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -66,7 +66,7 @@ module rec Module : sig | ModuleType of ModuleType.expr type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; type_ : decl; canonical : Odoc_model.Paths.Path.Module.t option; @@ -134,7 +134,7 @@ and Extension : sig module Constructor : sig type t = { name : string; - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; args : TypeDecl.Constructor.argument; res : TypeExpr.t option; @@ -152,7 +152,7 @@ end and Exception : sig type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; args : TypeDecl.Constructor.argument; res : TypeExpr.t option; @@ -214,7 +214,7 @@ and ModuleType : sig | TypeOf of typeof_t type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; canonical : Odoc_model.Paths.Path.ModuleType.t option; expr : expr option; @@ -261,7 +261,7 @@ and TypeDecl : sig end type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; canonical : Odoc_model.Paths.Path.Type.t option; equation : Equation.t; @@ -326,7 +326,7 @@ and Value : sig type value = Odoc_model.Lang.Value.value type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; type_ : TypeExpr.t; value : value; @@ -339,7 +339,7 @@ and Class : sig | Arrow of TypeExpr.label option * TypeExpr.t * decl type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; virtual_ : bool; params : TypeDecl.param list; @@ -354,7 +354,7 @@ and ClassType : sig | Signature of ClassSignature.t type t = { - locs : Odoc_model.Lang.Locations.t option; + locs : Odoc_model.Paths.Identifier.SourceLocation.t option; doc : CComment.docs; virtual_ : bool; params : TypeDecl.param list; diff --git a/src/xref2/env.ml b/src/xref2/env.ml index 6a277a36ae..36c38be6fd 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -18,7 +18,7 @@ type resolver = { open_units : string list; lookup_unit : string -> lookup_unit_result; lookup_page : string -> lookup_page_result; - lookup_def : Identifier.t -> Lang.Locations.t option; + lookup_def : Identifier.NonSrc.t -> Identifier.SourceLocation.t option; } let unique_id = @@ -361,7 +361,7 @@ let module_of_unit : Lang.Compilation_unit.t -> Component.Module.t = let id = (unit.id :> Paths.Identifier.Module.t) in let locs = match unit.source_info with - | Some src -> Some { Lang.Locations.source_parent = src.id; anchor = None } + | Some src -> Some (Identifier.Mk.source_location_mod src.id) | None -> None in match unit.content with @@ -425,7 +425,7 @@ let lookup_root_module name env = result let lookup_def id env = - let id = (id :> Paths.Identifier.Any.t) in + let id = (id :> Paths.Identifier.NonSrc.t) in match env.resolver with Some r -> r.lookup_def id | None -> None let lookup_page name env = diff --git a/src/xref2/env.mli b/src/xref2/env.mli index b72fe8bcca..f4a1879d5a 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -19,7 +19,7 @@ type resolver = { open_units : string list; lookup_unit : string -> lookup_unit_result; lookup_page : string -> lookup_page_result; - lookup_def : Identifier.t -> Lang.Locations.t option; + lookup_def : Identifier.NonSrc.t -> Identifier.SourceLocation.t option; (** Lookup the source code location from an identifier. Returns [Some (source_parent, anchor)] when definition is found. *) } @@ -98,8 +98,7 @@ val module_of_unit : Lang.Compilation_unit.t -> Component.Module.t val lookup_root_module : string -> t -> root option -val lookup_def : - [< Identifier.t_pv ] Paths.Identifier.id -> t -> Lang.Locations.t option +val lookup_def : Identifier.NonSrc.t -> t -> Identifier.SourceLocation.t option (** Lookup the definition of the given identifier. Returns the root module and the anchor. *) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index bc4b56d0b5..dffdd2fc26 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -8,6 +8,7 @@ module Opt = struct end let locations env id locs = + let id = (id :> Id.NonSrc.t) in match locs with Some _ as locs -> locs | None -> Env.lookup_def id env (** Equivalent to {!Comment.synopsis}. *) @@ -360,7 +361,7 @@ and value_ env parent t = let open Value in { t with - locs = locations env (t.id :> Id.t) t.locs; + locs = locations env t.id t.locs; doc = comment_docs env parent t.doc; type_ = type_expression env parent [] t.type_; } @@ -541,7 +542,7 @@ and module_ : Env.t -> Module.t -> Module.t = else type_ | Alias _ | ModuleType _ -> type_ in - let locs = (locations env (m.id :> Id.t)) m.locs in + let locs = locations env m.id m.locs in let doc = comment_docs env sg_id m.doc in { m with locs; doc; type_ }