2403

Committed 02 Oct 2024 03:15PM UTC coverage: 72.971% (+0.1%) from 72.848%

Build # 2403

Build Type

Pull #1193

github

Committed by

web-flow

Commit Message

Merge 93aa604a2 into 0ba1fdbe6

Pull Request Pull Request #1193: Specify children order in frontmatter

Run Details

140 of 154 new or added lines in 10 files covered. (90.91%)

60 existing lines in 5 files now uncovered.

10248 of 14044 relevant lines covered (72.97%)

2965.35 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

78.26

/src/document/url.ml

open Odoc_model.Paths
open Odoc_model.Names
module Root = Odoc_model.Root

let render_path : Odoc_model.Paths.Path.t -> string =
  let open Odoc_model.Paths.Path in
  let rec render_resolved : Odoc_model.Paths.Path.Resolved.t -> string =
    let open Resolved in
    function
    | `Identifier id -> Identifier.name id
    | `OpaqueModule p -> render_resolved (p :> t)
    | `OpaqueModuleType p -> render_resolved (p :> t)
    | `Subst (_, p) -> render_resolved (p :> t)
    | `SubstT (_, p) -> render_resolved (p :> t)
    | `Alias (dest, `Resolved src) ->
        if Odoc_model.Paths.Path.Resolved.(is_hidden (src :> t)) then
          render_resolved (dest :> t)
        else render_resolved (src :> t)
    | `Alias (dest, src) ->
        if Odoc_model.Paths.Path.is_hidden (src :> Path.t) then
          render_resolved (dest :> t)
        else render_path (src :> Path.t)
    | `AliasModuleType (p1, p2) ->
        if Odoc_model.Paths.Path.Resolved.(is_hidden (p2 :> t)) then
          render_resolved (p1 :> t)
        else render_resolved (p2 :> t)
    | `Hidden p -> render_resolved (p :> t)
    | `Module (p, s) -> render_resolved (p :> t) ^ "." ^ ModuleName.to_string s
    | `Canonical (_, `Resolved p) -> render_resolved (p :> t)
    | `Canonical (p, _) -> render_resolved (p :> t)
    | `CanonicalModuleType (_, `Resolved p) -> render_resolved (p :> t)
    | `CanonicalModuleType (p, _) -> render_resolved (p :> t)
    | `CanonicalType (_, `Resolved p) -> render_resolved (p :> t)
    | `CanonicalType (p, _) -> render_resolved (p :> t)
    | `Substituted c -> render_resolved (c :> t)
    | `SubstitutedMT c -> render_resolved (c :> t)
    | `SubstitutedT c -> render_resolved (c :> t)
    | `SubstitutedCT c -> render_resolved (c :> t)
    | `Apply (rp, p) ->
        render_resolved (rp :> t)
        ^ "("
        ^ render_resolved (p :> Odoc_model.Paths.Path.Resolved.t)
        ^ ")"
    | `ModuleType (p, s) ->
        render_resolved (p :> t) ^ "." ^ ModuleTypeName.to_string s
    | `Type (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s
    | `Value (p, s) -> render_resolved (p :> t) ^ "." ^ ValueName.to_string s
    | `Class (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s
    | `ClassType (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s
  and dot p s =
    render_path (p : Odoc_model.Paths.Path.Module.t :> Odoc_model.Paths.Path.t)
    ^ "." ^ s
  and render_path : Odoc_model.Paths.Path.t -> string =
   fun x ->
    match x with
    | `Identifier (id, _) -> Identifier.name id
    | `Root root -> ModuleName.to_string root
    | `Forward root -> root
    | `Dot (p, s) -> dot p (ModuleName.to_string s)
    | `DotT (p, s) -> dot p (TypeName.to_string s)
    | `DotMT (p, s) -> dot p (ModuleTypeName.to_string s)
    | `DotV (p, s) -> dot p (ValueName.to_string s)
    | `Apply (p1, p2) ->
        render_path (p1 :> t) ^ "(" ^ render_path (p2 :> t) ^ ")"
    | `Resolved rp -> render_resolved rp
    | `Substituted m -> render_path (m :> t)
    | `SubstitutedMT m -> render_path (m :> t)
    | `SubstitutedT m -> render_path (m :> t)
    | `SubstitutedCT m -> render_path (m :> t)
  in

  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
    | Identifier.Signature.t_pv
    | Identifier.ClassSignature.t_pv ]

  type any_pv =
    [ nonsrc_pv | Identifier.SourcePage.t_pv | Identifier.AssetFile.t_pv ]

  and any = any_pv Odoc_model.Paths.Identifier.id

  type kind =
    [ `Module
    | `Page
    | `LeafPage
    | `ModuleType
    | `Parameter of int
    | `Class
    | `ClassType
    | `File
    | `SourcePage ]

  let string_of_kind : kind -> string = function
    | `Page -> "page"
    | `Module -> "module"
    | `LeafPage -> "leaf-page"
    | `ModuleType -> "module-type"
    | `Parameter arg_num -> Printf.sprintf "argument-%d" arg_num
    | `Class -> "class"
    | `ClassType -> "class-type"
    | `File -> "file"
    | `SourcePage -> "source"

  let pp_kind fmt kind = Format.fprintf fmt "%s" (string_of_kind kind)

  let pp_disambiguating_prefix fmt = function
    | `Module | `Page | `LeafPage | `File | `SourcePage -> ()
    | kind -> Format.fprintf fmt "%s-" (string_of_kind kind)

  type t = { kind : kind; parent : t option; name : string }

  let mk ?parent kind name = { kind; parent; name }

  let rec from_identifier : any -> t =
   fun x ->
    match x with
    | { iv = `Root (parent, unit_name); _ } ->
        let parent =
          match parent with
          | Some p -> Some (from_identifier (p :> any))
          | None -> None
        in
        let kind = `Module in
        let name = ModuleName.to_string unit_name in
        mk ?parent kind name
    | { iv = `Page (parent, page_name); _ } ->
        let parent =
          match parent with
          | Some p -> Some (from_identifier (p :> any))
          | None -> None
        in
        let kind = `Page in
        let name = PageName.to_string page_name in
        mk ?parent kind name
    | { iv = `LeafPage (parent, page_name); _ } ->
        let parent =
          match parent with
          | Some p -> Some (from_identifier (p :> any))
          | None -> None
        in
        let kind = `LeafPage in
        let name = PageName.to_string page_name in
        mk ?parent kind name
    | { iv = `Module (parent, mod_name); _ } ->
        let parent = from_identifier (parent :> any) in
        let kind = `Module in
        let name = ModuleName.to_string mod_name in
        mk ~parent kind name
    | { iv = `Parameter (functor_id, arg_name); _ } as p ->
        let parent = from_identifier (functor_id :> any) in
        let arg_num = Identifier.FunctorParameter.functor_arg_pos p in
        let kind = `Parameter arg_num in
        let name = ModuleName.to_string arg_name in
        mk ~parent kind name
    | { iv = `ModuleType (parent, modt_name); _ } ->
        let parent = from_identifier (parent :> any) in
        let kind = `ModuleType in
        let name = ModuleTypeName.to_string modt_name in
        mk ~parent kind name
    | { iv = `Class (parent, name); _ } ->
        let parent = from_identifier (parent :> any) in
        let kind = `Class in
        let name = TypeName.to_string name in
        mk ~parent kind name
    | { iv = `ClassType (parent, name); _ } ->
        let parent = from_identifier (parent :> any) in
        let kind = `ClassType in
        let name = TypeName.to_string name in
        mk ~parent kind name
    | { iv = `Result p; _ } -> from_identifier (p :> any)
    | { iv = `SourcePage (parent, name); _ } ->
        let parent = from_identifier (parent :> any) in
        let kind = `SourcePage in
        mk ~parent kind name
    | { iv = `AssetFile (parent, name); _ } ->
        let parent = from_identifier (parent :> any) in
        let kind = `File in
        let name = AssetName.to_string name in
        mk ~parent kind name

  let from_identifier p =
    from_identifier (p : [< any_pv ] Odoc_model.Paths.Identifier.id :> any)

  let to_list url =
    let rec loop acc { parent; name; kind } =
      match parent with
      | None -> (kind, name) :: acc
      | Some p -> loop ((kind, name) :: acc) p
    in
    loop [] url

  let of_list l =
    let rec inner parent = function
      | [] -> parent
      | (kind, name) :: xs -> inner (Some { parent; name; kind }) xs
    in
    inner None l

  let split :
      is_dir:(kind -> [ `Always | `Never | `IfNotLast ]) ->
      (kind * string) list ->
      (kind * string) list * (kind * string) list =
   fun ~is_dir l ->
    let rec inner dirs = function
      | [ ((kind, _) as x) ] when is_dir kind = `IfNotLast ->
          (List.rev dirs, [ x ])
      | ((kind, _) as x) :: xs when is_dir kind <> `Never ->
          inner (x :: dirs) xs
      | xs -> (List.rev dirs, xs)
    in
    inner [] l
end

module Anchor = struct
  type kind =
    [ Path.kind
    | `Section
    | `Type
    | `Extension
    | `ExtensionDecl
    | `Exception
    | `Method
    | `Val
    | `Constructor
    | `Field
    | `SourceAnchor ]

  let string_of_kind : kind -> string = function
    | #Path.kind as k -> Path.string_of_kind k
    | `Section -> "section"
    | `Type -> "type"
    | `Extension -> "extension"
    | `ExtensionDecl -> "extension-decl"
    | `Exception -> "exception"
    | `Method -> "method"
    | `Val -> "val"
    | `Constructor -> "constructor"
    | `Field -> "field"
    | `SourceAnchor -> "source-anchor"

  let pp_kind fmt kind = Format.fprintf fmt "%s" (string_of_kind kind)

  type t = { page : Path.t; anchor : string; kind : kind }

  let anchorify_path { Path.parent; name; kind } =
    match parent with
    | None -> assert false (* We got a root, should never happen *)
    | Some page ->
        let anchor = Printf.sprintf "%s-%s" (Path.string_of_kind kind) name in
        { page; anchor; kind = (kind :> kind) }

  let add_suffix ~kind { page; anchor; _ } suffix =
    { page; anchor = anchor ^ "." ^ suffix; kind }

  let mk ~kind parent str_name =
    let page = Path.from_identifier parent in
    Ok { 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
    | { iv = `Module (parent, mod_name); _ } ->
        let parent = Path.from_identifier (parent :> Path.any) in
        let kind = `Module in
        let anchor =
          Printf.sprintf "%s-%s" (Path.string_of_kind kind)
            (ModuleName.to_string mod_name)
        in
        Ok { page = parent; anchor; kind }
    | { iv = `Root _; _ } as p ->
        let page = Path.from_identifier (p :> Path.any) in
        Ok { page; kind = `Module; anchor = "" }
    | { iv = `Page _; _ } as p ->
        let page = Path.from_identifier (p :> Path.any) in
        Ok { page; kind = `Page; anchor = "" }
    | { iv = `LeafPage _; _ } as p ->
        let page = Path.from_identifier (p :> Path.any) in
        Ok { 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)
    | { 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))
    | { 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;
          }
    | { 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;
          }
    | { 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))
    | { 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;
          }
    | { 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 }
    | { 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 }
    | { iv = `Constructor (parent, name); _ } ->
        from_identifier (parent :> Identifier.t) >>= fun page ->
        let kind = `Constructor in
        let suffix = suffix_for_constructor (ConstructorName.to_string name) in
        Ok (add_suffix ~kind page suffix)
    | { iv = `Field (parent, name); _ } ->
        from_identifier (parent :> Identifier.t) >>= fun page ->
        let kind = `Field in
        let suffix = FieldName.to_string name in
        Ok (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 }
    | { iv = `SourceLocationInternal (parent, loc); _ } ->
        let page = Path.from_identifier (parent :> Path.any) in
        Ok { 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 = "" }
    | { iv = `SourcePage _; _ } as p ->
        let page = Path.from_identifier (p :> Path.any) in
        Ok { page; kind = `Page; anchor = "" }
    | { iv = `AssetFile _; _ } as p ->
        let page = Path.from_identifier p in
        Ok { page; kind = `File; anchor = "" }

  let polymorphic_variant ~type_ident elt =
    let name_of_type_constr te =
      match te with
      | Odoc_model.Lang.TypeExpr.Constr (path, _) ->
          render_path (path :> Odoc_model.Paths.Path.t)
      | _ ->
          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)

  (** The anchor looks like
      [extension-decl-"Path.target_type"-FirstConstructor]. *)
  let extension_decl (decl : Odoc_model.Lang.Extension.t) =
    let page = Path.from_identifier (decl.parent :> Path.any) in
    let kind = `ExtensionDecl in
    let first_cons = Identifier.name (List.hd decl.constructors).id in
    let anchor = Format.asprintf "%a-%s" pp_kind kind first_cons in
    { page; kind; anchor }

  let source_anchor path anchor = { page = path; anchor; kind = `SourceAnchor }
end

type kind = Anchor.kind

type t = Anchor.t

let from_path page =
  { Anchor.page; anchor = ""; kind = (page.kind :> Anchor.kind) }

let from_identifier ~stop_before = function
  | { Odoc_model.Paths.Identifier.iv = #Path.any_pv; _ } as p
    when not stop_before ->
      Ok (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

1	open Odoc_model.Paths
2	open Odoc_model.Names
3	module Root = Odoc_model.Root
4
5	let render_path : Odoc_model.Paths.Path.t -> string =
6	let open Odoc_model.Paths.Path in
7	let rec render_resolved : Odoc_model.Paths.Path.Resolved.t -> string =
8	let open Resolved in
9	function
10	\| `Identifier id -> Identifier.name id	4,482✔
11	\| `OpaqueModule p -> render_resolved (p :> t)	6✔
12	\| `OpaqueModuleType p -> render_resolved (p :> t)	150✔
13	\| `Subst (_, p) -> render_resolved (p :> t)	18✔
14	\| `SubstT (_, p) -> render_resolved (p :> t)	24✔
15	\| `Alias (dest, `Resolved src) ->	×
16	if Odoc_model.Paths.Path.Resolved.(is_hidden (src :> t)) then	×
17	render_resolved (dest :> t)	×
18	else render_resolved (src :> t)	×
19	\| `Alias (dest, src) ->	141✔
20	if Odoc_model.Paths.Path.is_hidden (src :> Path.t) then
21	render_resolved (dest :> t)	×
22	else render_path (src :> Path.t)	141✔
23	\| `AliasModuleType (p1, p2) ->	102✔
24	if Odoc_model.Paths.Path.Resolved.(is_hidden (p2 :> t)) then	102✔
25	render_resolved (p1 :> t)	×
26	else render_resolved (p2 :> t)	102✔
27	\| `Hidden p -> render_resolved (p :> t)	48✔
28	\| `Module (p, s) -> render_resolved (p :> t) ^ "." ^ ModuleName.to_string s	187✔
29	\| `Canonical (_, `Resolved p) -> render_resolved (p :> t)	89✔
30	\| `Canonical (p, _) -> render_resolved (p :> t)	×
31	\| `CanonicalModuleType (_, `Resolved p) -> render_resolved (p :> t)	×
32	\| `CanonicalModuleType (p, _) -> render_resolved (p :> t)	×
33	\| `CanonicalType (_, `Resolved p) -> render_resolved (p :> t)	3✔
34	\| `CanonicalType (p, _) -> render_resolved (p :> t)	×
35	\| `Substituted c -> render_resolved (c :> t)	24✔
36	\| `SubstitutedMT c -> render_resolved (c :> t)	×
37	\| `SubstitutedT c -> render_resolved (c :> t)	×
38	\| `SubstitutedCT c -> render_resolved (c :> t)	×
39	\| `Apply (rp, p) ->	54✔
40	render_resolved (rp :> t)	54✔
41	^ "("
42	^ render_resolved (p :> Odoc_model.Paths.Path.Resolved.t)	54✔
43	^ ")"
44	\| `ModuleType (p, s) ->	182✔
45	render_resolved (p :> t) ^ "." ^ ModuleTypeName.to_string s	182✔
46	\| `Type (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s	447✔
47	\| `Value (p, s) -> render_resolved (p :> t) ^ "." ^ ValueName.to_string s	×
48	\| `Class (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s	12✔
49	\| `ClassType (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s	×
50	and dot p s =
51	render_path (p : Odoc_model.Paths.Path.Module.t :> Odoc_model.Paths.Path.t)	84✔
52	^ "." ^ s
53	and render_path : Odoc_model.Paths.Path.t -> string =
54	fun x ->
55	match x with	4,818✔
56	\| `Identifier (id, _) -> Identifier.name id	153✔
57	\| `Root root -> ModuleName.to_string root	×
58	\| `Forward root -> root	×
59	\| `Dot (p, s) -> dot p (ModuleName.to_string s)	84✔
60	\| `DotT (p, s) -> dot p (TypeName.to_string s)	×
61	\| `DotMT (p, s) -> dot p (ModuleTypeName.to_string s)	×
62	\| `DotV (p, s) -> dot p (ValueName.to_string s)	×
63	\| `Apply (p1, p2) ->	12✔
64	render_path (p1 :> t) ^ "(" ^ render_path (p2 :> t) ^ ")"	12✔
65	\| `Resolved rp -> render_resolved rp	4,569✔
66	\| `Substituted m -> render_path (m :> t)	×
67	\| `SubstitutedMT m -> render_path (m :> t)	×
68	\| `SubstitutedT m -> render_path (m :> t)	×
69	\| `SubstitutedCT m -> render_path (m :> t)	×
70	in
71
72	render_path
73
74	module Error = struct
75	type nonrec t =
76	\| Not_linkable of string
77	\| Uncaught_exn of string
78	(* These should basicaly never happen *)
79	\| Unexpected_anchor of string
80
81	let to_string = function
82	\| Not_linkable s -> Printf.sprintf "Not_linkable %S" s	×
83	\| Uncaught_exn s -> Printf.sprintf "Uncaught_exn %S" s	×
84	\| Unexpected_anchor s -> Printf.sprintf "Unexpected_anchor %S" s	×
85	end
86
87	open Odoc_utils.ResultMonad
88
89	module Path = struct
90	type nonsrc_pv =
91	[ Identifier.Page.t_pv
92	\| Identifier.Signature.t_pv
93	\| Identifier.ClassSignature.t_pv ]
94
95	type any_pv =
96	[ nonsrc_pv \| Identifier.SourcePage.t_pv \| Identifier.AssetFile.t_pv ]
97
98	and any = any_pv Odoc_model.Paths.Identifier.id
99
100	type kind =
101	[ `Module
102	\| `Page
103	\| `LeafPage
104	\| `ModuleType
105	\| `Parameter of int
106	\| `Class
107	\| `ClassType
108	\| `File
109	\| `SourcePage ]
110
111	let string_of_kind : kind -> string = function
112	\| `Page -> "page"	3✔
113	\| `Module -> "module"	1,528✔
UNCOV 114	\| `LeafPage -> "leaf-page"	×
115	\| `ModuleType -> "module-type"	7,257✔
116	\| `Parameter arg_num -> Printf.sprintf "argument-%d" arg_num	1,489✔
117	\| `Class -> "class"	637✔
118	\| `ClassType -> "class-type"	219✔
119	\| `File -> "file"	×
120	\| `SourcePage -> "source"	2✔
121
UNCOV 122	let pp_kind fmt kind = Format.fprintf fmt "%s" (string_of_kind kind)	×
123
124	let pp_disambiguating_prefix fmt = function
UNCOV 125	\| `Module \| `Page \| `LeafPage \| `File \| `SourcePage -> ()	×
126	\| kind -> Format.fprintf fmt "%s-" (string_of_kind kind)	8,055✔
127
128	type t = { kind : kind; parent : t option; name : string }
129
130	let mk ?parent kind name = { kind; parent; name }	31,674✔
131
132	let rec from_identifier : any -> t =
133	fun x ->
134	match x with	32,196✔
135	\| { iv = `Root (parent, unit_name); _ } ->	13,593✔
136	let parent =
137	match parent with
138	\| Some p -> Some (from_identifier (p :> any))	239✔
139	\| None -> None	13,354✔
140	in
141	let kind = `Module in
142	let name = ModuleName.to_string unit_name in
143	mk ?parent kind name	13,593✔
144	\| { iv = `Page (parent, page_name); _ } ->	843✔
145	let parent =
146	match parent with
147	\| Some p -> Some (from_identifier (p :> any))	294✔
148	\| None -> None	549✔
149	in
150	let kind = `Page in
151	let name = PageName.to_string page_name in
152	mk ?parent kind name	843✔
153	\| { iv = `LeafPage (parent, page_name); _ } ->	146✔
154	let parent =
155	match parent with
156	\| Some p -> Some (from_identifier (p :> any))	138✔
157	\| None -> None	8✔
158	in
159	let kind = `LeafPage in
160	let name = PageName.to_string page_name in
161	mk ?parent kind name	146✔
162	\| { iv = `Module (parent, mod_name); _ } ->	8,993✔
163	let parent = from_identifier (parent :> any) in
164	let kind = `Module in	8,993✔
165	let name = ModuleName.to_string mod_name in
166	mk ~parent kind name	8,993✔
167	\| { iv = `Parameter (functor_id, arg_name); _ } as p ->	1,627✔
168	let parent = from_identifier (functor_id :> any) in
169	let arg_num = Identifier.FunctorParameter.functor_arg_pos p in	1,627✔
170	let kind = `Parameter arg_num in	1,627✔
171	let name = ModuleName.to_string arg_name in
172	mk ~parent kind name	1,627✔
173	\| { iv = `ModuleType (parent, modt_name); _ } ->	5,824✔
174	let parent = from_identifier (parent :> any) in
175	let kind = `ModuleType in	5,824✔
176	let name = ModuleTypeName.to_string modt_name in
177	mk ~parent kind name	5,824✔
178	\| { iv = `Class (parent, name); _ } ->	372✔
179	let parent = from_identifier (parent :> any) in
180	let kind = `Class in	372✔
181	let name = TypeName.to_string name in
182	mk ~parent kind name	372✔
183	\| { iv = `ClassType (parent, name); _ } ->	130✔
184	let parent = from_identifier (parent :> any) in
185	let kind = `ClassType in	130✔
186	let name = TypeName.to_string name in
187	mk ~parent kind name	130✔
188	\| { iv = `Result p; _ } -> from_identifier (p :> any)	522✔
189	\| { iv = `SourcePage (parent, name); _ } ->	136✔
190	let parent = from_identifier (parent :> any) in
191	let kind = `SourcePage in	136✔
192	mk ~parent kind name
193	\| { iv = `AssetFile (parent, name); _ } ->	10✔
194	let parent = from_identifier (parent :> any) in
195	let kind = `File in	10✔
196	let name = AssetName.to_string name in
197	mk ~parent kind name	10✔
198
199	let from_identifier p =
200	from_identifier (p : [< any_pv ] Odoc_model.Paths.Identifier.id :> any)	13,911✔
201
202	let to_list url =
203	let rec loop acc { parent; name; kind } =	18,154✔
204	match parent with	39,550✔
205	\| None -> (kind, name) :: acc	18,154✔
206	\| Some p -> loop ((kind, name) :: acc) p	21,396✔
207	in
208	loop [] url
209
210	let of_list l =
211	let rec inner parent = function	2,557✔
212	\| [] -> parent	2,557✔
213	\| (kind, name) :: xs -> inner (Some { parent; name; kind }) xs	4,993✔
214	in
215	inner None l
216
217	let split :
218	is_dir:(kind -> [ `Always \| `Never \| `IfNotLast ]) ->
219	(kind * string) list ->
220	(kind * string) list * (kind * string) list =
221	fun ~is_dir l ->
222	let rec inner dirs = function	15,956✔
223	\| [ ((kind, _) as x) ] when is_dir kind = `IfNotLast ->	7,648✔
224	(List.rev dirs, [ x ])	2✔
225	\| ((kind, _) as x) :: xs when is_dir kind <> `Never ->	19,315✔
226	inner (x :: dirs) xs	5,761✔
227	\| xs -> (List.rev dirs, xs)	15,954✔
228	in
229	inner [] l
230	end
231
232	module Anchor = struct
233	type kind =
234	[ Path.kind
235	\| `Section
236	\| `Type
237	\| `Extension
238	\| `ExtensionDecl
239	\| `Exception
240	\| `Method
241	\| `Val
242	\| `Constructor
243	\| `Field
244	\| `SourceAnchor ]
245
246	let string_of_kind : kind -> string = function
247	\| #Path.kind as k -> Path.string_of_kind k	66✔
UNCOV 248	\| `Section -> "section"	×
249	\| `Type -> "type"	4,944✔
250	\| `Extension -> "extension"	489✔
251	\| `ExtensionDecl -> "extension-decl"	99✔
252	\| `Exception -> "exception"	176✔
253	\| `Method -> "method"	66✔
254	\| `Val -> "val"	798✔
255	\| `Constructor -> "constructor"	915✔
256	\| `Field -> "field"	120✔
UNCOV 257	\| `SourceAnchor -> "source-anchor"	×
258
259	let pp_kind fmt kind = Format.fprintf fmt "%s" (string_of_kind kind)	6,208✔
260
261	type t = { page : Path.t; anchor : string; kind : kind }
262
263	let anchorify_path { Path.parent; name; kind } =
264	match parent with	1,532✔
265	\| None -> assert false (* We got a root, should never happen *)
266	\| Some page ->	1,532✔
267	let anchor = Printf.sprintf "%s-%s" (Path.string_of_kind kind) name in	1,532✔
268	{ page; anchor; kind = (kind :> kind) }	1,532✔
269
270	let add_suffix ~kind { page; anchor; _ } suffix =
271	{ page; anchor = anchor ^ "." ^ suffix; kind }	1,065✔
272
273	let mk ~kind parent str_name =
274	let page = Path.from_identifier parent in	188✔
275	Ok { page; anchor = str_name; kind }	188✔
276
277	(* This is needed to ensure that references to polymorphic constructors have
278	links that use the right suffix: those resolved references are turned into
279	_constructor_ identifiers. *)
280	let suffix_for_constructor x = x	927✔
281
282	let rec from_identifier : Identifier.t -> (t, Error.t) result =
283	let open Error in
284	function
285	\| { iv = `Module (parent, mod_name); _ } ->	1,463✔
286	let parent = Path.from_identifier (parent :> Path.any) in
287	let kind = `Module in	1,463✔
288	let anchor =
289	Printf.sprintf "%s-%s" (Path.string_of_kind kind)	1,463✔
290	(ModuleName.to_string mod_name)	1,463✔
291	in
292	Ok { page = parent; anchor; kind }	1,463✔
293	\| { iv = `Root _; _ } as p ->	6✔
294	let page = Path.from_identifier (p :> Path.any) in
295	Ok { page; kind = `Module; anchor = "" }	6✔
UNCOV 296	\| { iv = `Page _; _ } as p ->	×
297	let page = Path.from_identifier (p :> Path.any) in
UNCOV 298	Ok { page; kind = `Page; anchor = "" }	×
UNCOV 299	\| { iv = `LeafPage _; _ } as p ->	×
300	let page = Path.from_identifier (p :> Path.any) in
UNCOV 301	Ok { page; kind = `LeafPage; anchor = "" }	×
302	(* For all these identifiers, page names and anchors are the same *)
303	\| {
UNCOV 304	iv = `Parameter _ \| `Result _ \| `ModuleType _ \| `Class _ \| `ClassType _;	×
305	_;
306	} as p ->
307	Ok (anchorify_path @@ Path.from_identifier p)	1,532✔
308	\| { iv = `Type (parent, type_name); _ } ->	4,906✔
309	let page = Path.from_identifier (parent :> Path.any) in
310	let kind = `Type in	4,906✔
311	Ok
312	{
313	page;
314	anchor =
315	Format.asprintf "%a-%s" pp_kind kind	4,906✔
316	(TypeName.to_string type_name);	4,906✔
317	kind;
318	}
319	\| { iv = `CoreType ty_name; _ } ->	1,889✔
320	Error (Not_linkable ("core_type:" ^ TypeName.to_string ty_name))	1,889✔
321	\| { iv = `Extension (parent, name); _ } ->	252✔
322	let page = Path.from_identifier (parent :> Path.any) in
323	let kind = `Extension in	252✔
324	Ok
325	{
326	page;
327	anchor =
328	Format.asprintf "%a-%s" pp_kind kind	252✔
329	(ExtensionName.to_string name);	252✔
330	kind;
331	}
332	\| { iv = `ExtensionDecl (parent, name, _); _ } ->	4✔
333	let page = Path.from_identifier (parent :> Path.any) in
334	let kind = `ExtensionDecl in	4✔
335	Ok
336	{
337	page;
338	anchor =
339	Format.asprintf "%a-%s" pp_kind kind	4✔
340	(ExtensionName.to_string name);	4✔
341	kind;
342	}
343	\| { iv = `Exception (parent, name); _ } ->	124✔
344	let page = Path.from_identifier (parent :> Path.any) in
345	let kind = `Exception in	124✔
346	Ok
347	{
348	page;
349	anchor =
350	Format.asprintf "%a-%s" pp_kind kind	124✔
351	(ExceptionName.to_string name);	124✔
352	kind;
353	}
UNCOV 354	\| { iv = `CoreException name; _ } ->	×
UNCOV 355	Error (Not_linkable ("core_exception:" ^ ExceptionName.to_string name))	×
356	\| { iv = `Value (parent, name); _ } ->	749✔
357	let page = Path.from_identifier (parent :> Path.any) in
358	let kind = `Val in	749✔
359	Ok
360	{
361	page;
362	anchor =
363	Format.asprintf "%a-%s" pp_kind kind (ValueName.to_string name);	749✔
364	kind;
365	}
366	\| { iv = `Method (parent, name); _ } ->	66✔
367	let str_name = MethodName.to_string name in
368	let page = Path.from_identifier (parent :> Path.any) in	66✔
369	let kind = `Method in	66✔
370	Ok
371	{ page; anchor = Format.asprintf "%a-%s" pp_kind kind str_name; kind }	66✔
372	\| { iv = `InstanceVariable (parent, name); _ } ->	12✔
373	let str_name = InstanceVariableName.to_string name in
374	let page = Path.from_identifier (parent :> Path.any) in	12✔
375	let kind = `Val in	12✔
376	Ok
377	{ page; anchor = Format.asprintf "%a-%s" pp_kind kind str_name; kind }	12✔
378	\| { iv = `Constructor (parent, name); _ } ->	791✔
379	from_identifier (parent :> Identifier.t) >>= fun page ->	791✔
380	let kind = `Constructor in	791✔
381	let suffix = suffix_for_constructor (ConstructorName.to_string name) in	791✔
382	Ok (add_suffix ~kind page suffix)	791✔
383	\| { iv = `Field (parent, name); _ } ->	120✔
384	from_identifier (parent :> Identifier.t) >>= fun page ->	120✔
385	let kind = `Field in	120✔
386	let suffix = FieldName.to_string name in
387	Ok (add_suffix ~kind page suffix)	120✔
388	\| { iv = `Label (parent, anchor); _ } -> (	188✔
389	let str_name = LabelName.to_string anchor in
390	(* [Identifier.LabelParent.t] contains datatypes. [`CoreType] can't
391	happen, [`Type] may not happen either but just in case, use the
392	grand-parent. *)
393	match parent with	188✔
UNCOV 394	\| { iv = `CoreType _; _ } ->	×
395	Error (Unexpected_anchor "core_type label parent")
UNCOV 396	\| { iv = `Type (gp, _); _ } -> mk ~kind:`Section gp str_name	×
397	\| { iv = #Path.nonsrc_pv; _ } as p ->	188✔
398	mk ~kind:`Section (p :> Path.any) str_name)
399	\| { iv = `SourceLocation (parent, loc); _ } ->	70✔
400	let page = Path.from_identifier (parent :> Path.any) in
401	Ok { page; kind = `SourceAnchor; anchor = DefName.to_string loc }	70✔
402	\| { iv = `SourceLocationInternal (parent, loc); _ } ->	3✔
403	let page = Path.from_identifier (parent :> Path.any) in
404	Ok { page; kind = `SourceAnchor; anchor = LocalName.to_string loc }	3✔
405	\| { iv = `SourceLocationMod parent; _ } ->	37✔
406	let page = Path.from_identifier (parent :> Path.any) in
407	Ok { page; kind = `SourceAnchor; anchor = "" }	37✔
UNCOV 408	\| { iv = `SourcePage _; _ } as p ->	×
409	let page = Path.from_identifier (p :> Path.any) in
UNCOV 410	Ok { page; kind = `Page; anchor = "" }	×
UNCOV 411	\| { iv = `AssetFile _; _ } as p ->	×
412	let page = Path.from_identifier p in
UNCOV 413	Ok { page; kind = `File; anchor = "" }	×
414
415	let polymorphic_variant ~type_ident elt =
416	let name_of_type_constr te =	154✔
417	match te with	18✔
418	\| Odoc_model.Lang.TypeExpr.Constr (path, _) ->	18✔
419	render_path (path :> Odoc_model.Paths.Path.t)
UNCOV 420	\| _ ->	×
421	invalid_arg
422	"DocOckHtml.Url.Polymorphic_variant_decl.name_of_type_constr"
423	in
424	match from_identifier type_ident with
UNCOV 425	\| Error e -> failwith (Error.to_string e)	×
426	\| Ok url -> (	154✔
427	match elt with
428	\| Odoc_model.Lang.TypeExpr.Polymorphic_variant.Type te ->	18✔
429	let kind = `Type in
430	let suffix = name_of_type_constr te in
431	add_suffix ~kind url suffix	18✔
432	\| Constructor { name; _ } ->	136✔
433	let kind = `Constructor in
434	let suffix = suffix_for_constructor name in
435	add_suffix ~kind url suffix)	136✔
436
437	(** The anchor looks like
438	[extension-decl-"Path.target_type"-FirstConstructor]. *)
439	let extension_decl (decl : Odoc_model.Lang.Extension.t) =
440	let page = Path.from_identifier (decl.parent :> Path.any) in	95✔
441	let kind = `ExtensionDecl in	95✔
442	let first_cons = Identifier.name (List.hd decl.constructors).id in	95✔
443	let anchor = Format.asprintf "%a-%s" pp_kind kind first_cons in	95✔
444	{ page; kind; anchor }	95✔
445
UNCOV 446	let source_anchor path anchor = { page = path; anchor; kind = `SourceAnchor }	×
447	end
448
449	type kind = Anchor.kind
450
451	type t = Anchor.t
452
453	let from_path page =
454	{ Anchor.page; anchor = ""; kind = (page.kind :> Anchor.kind) }	8,562✔
455
456	let from_identifier ~stop_before = function
457	\| { Odoc_model.Paths.Identifier.iv = #Path.any_pv; _ } as p	1,824✔
458	when not stop_before ->
459	Ok (from_path @@ Path.from_identifier p)	1,641✔
460	\| p -> Anchor.from_identifier p	4,614✔
461
462	let from_asset_identifier p = from_path @@ Path.from_identifier p	9✔
463
464	let kind id =
465	match Anchor.from_identifier id with	554✔
UNCOV 466	\| Error e -> failwith (Error.to_string e)	×
467	\| Ok { kind; _ } -> kind	554✔

ocaml / odoc / 2403

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous