3129

Committed 01 May 2026 03:36PM UTC coverage: 71.05% (-0.1%) from 71.191%

Build # 3129

Build Type

Pull #1407

github

Committed by

web-flow

Commit Message

Merge 1ee25b106 into 27216c784

Pull Request Pull Request #1407: OxCaml: Support for unboxed named types

Coverage Stats

1 of 31 new or added lines in 10 files covered. (3.23%)

11 existing lines in 3 files now uncovered.

10411 of 14653 relevant lines covered (71.05%)

5889.64 hits per line

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

82.02

/src/document/url.ml

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

let render_path : Path.t -> string =
  let rec render_resolved : Path.Resolved.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)
    | `SubstT (_, p) -> render_resolved (p :> t)
    | `Alias (dest, `Resolved src) ->
        if Path.Resolved.(is_hidden (src :> t)) then render_resolved (dest :> t)
        else render_resolved (src :> t)
    | `Alias (dest, src) ->
        if Path.is_hidden (src :> Path.t) then render_resolved (dest :> t)
        else render_path (src :> Path.t)
    | `AliasModuleType (p1, p2) ->
        if 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 :> 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
    | `Unbox p -> render_resolved (p :> t) ^ "#"
  and dot p s = render_path (p : Path.Module.t :> Path.t) ^ "." ^ s
  and render_path : 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 :> Path.t) ^ "(" ^ render_path (p2 :> Path.t) ^ ")"
    | `Resolved rp -> render_resolved rp
    | `Substituted m -> render_path (m :> Path.t)
    | `SubstitutedMT m -> render_path (m :> Path.t)
    | `SubstitutedT m -> render_path (m :> Path.t)
    | `SubstitutedCT m -> render_path (m :> Path.t)
    | `Unbox t -> render_path (t :> Path.t)
  in

  render_path

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 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 ] 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

  let rec is_prefix (url1 : t) (url2 : t) =
    match url1 with
    | { kind = `LeafPage; parent = None; name = "index" } -> true
    | { kind = `LeafPage; parent = Some p; name = "index" } -> is_prefix p url2
    | _ -> (
        if url1 = url2 then true
        else
          match url2 with
          | { parent = Some parent; _ } -> is_prefix url1 parent
          | { parent = None; _ } -> false)
end

module Anchor = struct
  type kind =
    [ Path.kind
    | `Section
    | `Type
    | `Extension
    | `ExtensionDecl
    | `Exception
    | `Method
    | `Val
    | `Constructor
    | `Field
    | `UnboxedField
    | `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"
    | `UnboxedField -> "unboxed-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
    { 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 = 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
        { page = parent; anchor; kind }
    | { iv = `Root _; _ } as p ->
        let page = Path.from_identifier (p :> Path.any) in
        { page; kind = `Module; anchor = "" }
    | { iv = `Page _; _ } as p ->
        let page = Path.from_identifier (p :> Path.any) in
        { page; kind = `Page; anchor = "" }
    | { iv = `LeafPage _; _ } as p ->
        let page = Path.from_identifier (p :> Path.any) in
        { page; kind = `LeafPage; anchor = "" }
    (* For all these identifiers, page names and anchors are the same *)
    | {
        iv = `Parameter _ | `Result _ | `ModuleType _ | `Class _ | `ClassType _;
        _;
      } as 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
        let name = TypeName.to_string type_name in
        { page; anchor = Format.asprintf "%a-%s" pp_kind kind name; kind }
    | { iv = `Extension (parent, name); _ } ->
        let page = Path.from_identifier (parent :> Path.any) in
        let kind = `Extension in
        {
          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
        {
          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
        {
          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
        {
          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
        { 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
        { page; anchor = Format.asprintf "%a-%s" pp_kind kind str_name; kind }
    | { iv = `Constructor (parent, name); _ } ->
        let page = from_identifier (parent :> Identifier.t) in
        let kind = `Constructor in
        let suffix = suffix_for_constructor (ConstructorName.to_string name) in
        add_suffix ~kind page suffix
    | { iv = `Field (parent, name); _ } ->
        let page = from_identifier (parent :> Identifier.t) in
        let kind = `Field in
        let suffix = FieldName.to_string name in
        add_suffix ~kind page suffix
    | { iv = `UnboxedField (parent, name); _ } ->
        let page = from_identifier (parent :> Identifier.t) in
        let kind = `UnboxedField in
        let suffix = UnboxedFieldName.to_string name in
        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 = `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
        { page; kind = `SourceAnchor; anchor = DefName.to_string loc }
    | { iv = `SourceLocationInternal (parent, loc); _ } ->
        let page = Path.from_identifier (parent :> Path.any) in
        { page; kind = `SourceAnchor; anchor = LocalName.to_string loc }
    | { iv = `SourceLocationMod parent; _ } ->
        let page = Path.from_identifier (parent :> Path.any) in
        { page; kind = `SourceAnchor; anchor = "" }
    | { iv = `SourcePage _; _ } as p ->
        let page = Path.from_identifier (p :> Path.any) in
        { page; kind = `Page; anchor = "" }
    | { iv = `AssetFile _; _ } as p ->
        let page = Path.from_identifier p in
        { 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
    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]. *)
  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 x =
  match x with
  | { Identifier.iv = #Path.any_pv; _ } as p when not stop_before ->
      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 =
  let { Anchor.kind; _ } = Anchor.from_identifier id in
  kind

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

ocaml / odoc / 3129

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