2108

Committed 03 Jul 2024 07:23AM UTC coverage: 71.946% (+0.2%) from 71.774%

Build # 2108

Build Type

Pull #1145

github

Committed by

web-flow

Commit Message

Merge 0b753d1e4 into 7e1e6ac92

Pull Request Pull Request #1145: "Global" Sidebar

Run Details

197 of 230 new or added lines in 12 files covered. (85.65%)

627 existing lines in 13 files now uncovered.

9835 of 13670 relevant lines covered (71.95%)

3555.77 hits per line

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

92.59

/src/html/generator.ml

(*
 * Copyright (c) 2016 Thomas Refis <trefis@janestreet.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open Odoc_document.Types
module Html = Tyxml.Html
module Doctree = Odoc_document.Doctree
module Url = Odoc_document.Url

type any = Html_types.flow5

type item = Html_types.flow5_without_header_footer

type flow = Html_types.flow5_without_sectioning_heading_header_footer

type phrasing = Html_types.phrasing

type non_link_phrasing = Html_types.phrasing_without_interactive

let mk_anchor_link id =
  [ Html.a ~a:[ Html.a_href ("#" ^ id); Html.a_class [ "anchor" ] ] [] ]

let mk_anchor config anchor =
  match anchor with
  | None -> ([], [], [])
  | _ when Config.search_result config ->
      (* When displaying for a search result, anchor are not added as it would
         make no sense to add them. *)
      ([], [], [])
  | Some { Url.Anchor.anchor; _ } ->
      let link = mk_anchor_link anchor in
      let extra_attr = [ Html.a_id anchor ] in
      let extra_class = [ "anchored" ] in
      (extra_attr, extra_class, link)

let mk_link_to_source ~config ~resolve anchor =
  match anchor with
  | None -> []
  | Some url ->
      let href = Link.href ~config ~resolve url in
      [
        Html.a
          ~a:[ Html.a_href href; Html.a_class [ "source_link" ] ]
          [ Html.txt "Source" ];
      ]

let class_ (l : Class.t) = if l = [] then [] else [ Html.a_class l ]

let inline_math (s : Math.t) =
  Html.code ~a:[ Html.a_class [ "odoc-katex-math" ] ] [ Html.txt s ]

let block_math (s : Math.t) =
  Html.pre ~a:[ Html.a_class [ "odoc-katex-math"; "display" ] ] [ Html.txt s ]

and raw_markup (t : Raw_markup.t) =
  let target, content = t in
  match Astring.String.Ascii.lowercase target with
  | "html" ->
      (* This is OK because we output *textual* HTML.
         In theory, we should try to parse the HTML with lambdasoup and rebuild
         the HTML tree from there.
      *)
      [ Html.Unsafe.data content ]
  | _ -> []

and source k ?a (t : Source.t) =
  let rec token (x : Source.token) =
    match x with
    | Elt i -> k i
    | Tag (None, l) ->
        let content = tokens l in
        if content = [] then [] else [ Html.span content ]
    | Tag (Some s, l) -> [ Html.span ~a:[ Html.a_class [ s ] ] (tokens l) ]
  and tokens t = Utils.list_concat_map t ~f:token in
  Utils.optional_elt Html.code ?a (tokens t)

and styled style ~emph_level =
  match style with
  | `Emphasis ->
      let a = if emph_level mod 2 = 0 then [] else [ Html.a_class [ "odd" ] ] in
      (emph_level + 1, Html.em ~a)
  | `Bold -> (emph_level, Html.b ~a:[])
  | `Italic -> (emph_level, Html.i ~a:[])
  | `Superscript -> (emph_level, Html.sup ~a:[])
  | `Subscript -> (emph_level, Html.sub ~a:[])

let rec internallink ~config ~emph_level ~resolve ?(a = [])
    { InternalLink.target; content; tooltip } =
  let a = match tooltip with Some s -> Html.a_title s :: a | None -> a in
  let elt =
    match target with
    | Resolved uri ->
        let href = Link.href ~config ~resolve uri in
        let content = inline_nolink ~emph_level content in
        if Config.search_result config then
          (* When displaying for a search result, links are displayed as regular
             text. *)
          Html.span ~a content
        else
          let a =
            Html.a_href href :: (a :> Html_types.a_attrib Html.attrib list)
          in
          Html.a ~a content
    | Unresolved ->
        (* let title =
         *   Html.a_title (Printf.sprintf "unresolved reference to %S"
         *       (ref_to_string ref)
         * in *)
        let a = Html.a_class [ "xref-unresolved" ] :: a in
        Html.span ~a (inline ~config ~emph_level ~resolve content)
  in
  [ (elt :> phrasing Html.elt) ]

and inline ~config ?(emph_level = 0) ~resolve (l : Inline.t) :
    phrasing Html.elt list =
  let one (t : Inline.one) =
    let a = class_ t.attr in
    match t.desc with
    | Text "" -> []
    | Text s ->
        if a = [] then [ Html.txt s ] else [ Html.span ~a [ Html.txt s ] ]
    | Entity s ->
        if a = [] then [ Html.entity s ] else [ Html.span ~a [ Html.entity s ] ]
    | Linebreak -> [ Html.br ~a () ]
    | Styled (style, c) ->
        let emph_level, app_style = styled style ~emph_level in
        [ app_style @@ inline ~config ~emph_level ~resolve c ]
    | Link (_, c) when Config.search_result config ->
        (* When displaying for a search result, links are displayed as regular
           text. *)
        let content = inline_nolink ~emph_level c in
        [ Html.span ~a content ]
    | Link (href, c) ->
        let a = (a :> Html_types.a_attrib Html.attrib list) in
        let content = inline_nolink ~emph_level c in
        [ Html.a ~a:(Html.a_href href :: a) content ]
    | InternalLink c -> internallink ~config ~emph_level ~resolve ~a c
    | Source c -> source (inline ~config ~emph_level ~resolve) ~a c
    | Math s -> [ inline_math s ]
    | Raw_markup r -> raw_markup r
  in
  Utils.list_concat_map ~f:one l

and inline_nolink ?(emph_level = 0) (l : Inline.t) :
    non_link_phrasing Html.elt list =
  let one (t : Inline.one) =
    let a = class_ t.attr in
    match t.desc with
    | Text "" -> []
    | Text s ->
        if a = [] then [ Html.txt s ] else [ Html.span ~a [ Html.txt s ] ]
    | Entity s ->
        if a = [] then [ Html.entity s ] else [ Html.span ~a [ Html.entity s ] ]
    | Linebreak -> [ Html.br ~a () ]
    | Styled (style, c) ->
        let emph_level, app_style = styled style ~emph_level in
        [ app_style @@ inline_nolink ~emph_level c ]
    | Link _ -> assert false
    | InternalLink _ -> assert false
    | Source c -> source (inline_nolink ~emph_level) ~a c
    | Math s -> [ inline_math s ]
    | Raw_markup r -> raw_markup r
  in
  Utils.list_concat_map ~f:one l

let heading ~config ~resolve (h : Heading.t) =
  let a, anchor =
    match h.label with
    | Some _ when Config.search_result config ->
        (* When displaying for a search result, anchor are not added as it would
           make no sense to add them. *)
        ([], [])
    | Some id -> ([ Html.a_id id ], mk_anchor_link id)
    | None -> ([], [])
  in
  let content = inline ~config ~resolve h.title in
  let source_link = mk_link_to_source ~config ~resolve h.source_anchor in
  let mk =
    match h.level with
    | 0 -> Html.h1
    | 1 -> Html.h2
    | 2 -> Html.h3
    | 3 -> Html.h4
    | 4 -> Html.h5
    | _ -> Html.h6
  in
  mk ~a (anchor @ content @ source_link)

let text_align = function
  | Table.Left -> [ Html.a_style "text-align:left" ]
  | Center -> [ Html.a_style "text-align:center" ]
  | Right -> [ Html.a_style "text-align:right" ]
  | Default -> []

let cell_kind = function `Header -> Html.th | `Data -> Html.td

let rec block ~config ~resolve (l : Block.t) : flow Html.elt list =
  let as_flow x = (x : phrasing Html.elt list :> flow Html.elt list) in
  let one (t : Block.one) =
    let mk_block ?(extra_class = []) mk content =
      let a = Some (class_ (extra_class @ t.attr)) in
      [ mk ?a content ]
    in
    match t.desc with
    | Inline i ->
        if t.attr = [] then as_flow @@ inline ~config ~resolve i
        else mk_block Html.span (inline ~config ~resolve i)
    | Paragraph i -> mk_block Html.p (inline ~config ~resolve i)
    | List (typ, l) ->
        let mk = match typ with Ordered -> Html.ol | Unordered -> Html.ul in
        mk_block mk (List.map (fun x -> Html.li (block ~config ~resolve x)) l)
    | Table t ->
        mk_block ~extra_class:[ "odoc-table" ]
          (fun ?a x -> Html.table ?a x)
          (mk_rows ~config ~resolve t)
    | Description l ->
        let item i =
          let a = class_ i.Description.attr in
          let term =
            (inline ~config ~resolve i.Description.key
              : phrasing Html.elt list
              :> flow Html.elt list)
          in
          let def = block ~config ~resolve i.Description.definition in
          Html.li ~a (term @ (Html.txt " " :: def))
        in
        mk_block Html.ul (List.map item l)
    | Raw_markup r -> raw_markup r
    | Verbatim s -> mk_block Html.pre [ Html.txt s ]
    | Source (lang_tag, c) ->
        let extra_class = [ "language-" ^ lang_tag ] in
        mk_block ~extra_class Html.pre (source (inline ~config ~resolve) c)
    | Math s -> mk_block Html.div [ block_math s ]
  in
  Utils.list_concat_map l ~f:one

and mk_rows ~config ~resolve { align; data } =
  let mk_row row =
    let mk_cell ~align (x, h) =
      let a = text_align align in
      cell_kind ~a h (block ~config ~resolve x)
    in
    let alignment align =
      match align with align :: q -> (align, q) | [] -> (Table.Default, [])
      (* Second case is for recovering from a too short alignment list. A
         warning should have been raised when loading the doc-comment. *)
    in
    let acc, _align =
      List.fold_left
        (fun (acc, aligns) (x, h) ->
          let align, aligns = alignment aligns in
          let cell = mk_cell ~align (x, h) in
          (cell :: acc, aligns))
        ([], align) row
    in
    Html.tr (List.rev acc)
  in
  List.map mk_row data

(* This coercion is actually sound, but is not currently accepted by Tyxml.
   See https://github.com/ocsigen/tyxml/pull/265 for details
   Can be replaced by a simple type coercion once this is fixed
*)
let flow_to_item : flow Html.elt list -> item Html.elt list =
 fun x -> Html.totl @@ Html.toeltl x

let div : ([< Html_types.div_attrib ], [< item ], [> Html_types.div ]) Html.star
    =
  Html.Unsafe.node "div"

let spec_class attr = class_ ("spec" :: attr)

let spec_doc_div ~config ~resolve = function
  | [] -> []
  | docs ->
      let a = [ Html.a_class [ "spec-doc" ] ] in
      [ div ~a (flow_to_item @@ block ~config ~resolve docs) ]

let rec documentedSrc ~config ~resolve (t : DocumentedSrc.t) :
    item Html.elt list =
  let open DocumentedSrc in
  let take_code l =
    Doctree.Take.until l ~classify:(function
      | Code code -> Accum code
      | Alternative (Expansion { summary; _ }) -> Accum summary
      | _ -> Stop_and_keep)
  in
  let take_descr l =
    Doctree.Take.until l ~classify:(function
      | Documented { attrs; anchor; code; doc; markers } ->
          Accum
            [ { DocumentedSrc.attrs; anchor; code = `D code; doc; markers } ]
      | Nested { attrs; anchor; code; doc; markers } ->
          Accum
            [ { DocumentedSrc.attrs; anchor; code = `N code; doc; markers } ]
      | _ -> Stop_and_keep)
  in
  let rec to_html t : item Html.elt list =
    match t with
    | [] -> []
    | (Code _ | Alternative _) :: _ ->
        let code, _, rest = take_code t in
        source (inline ~config ~resolve) code @ to_html rest
    | Subpage subp :: _ -> subpage ~config ~resolve subp
    | (Documented _ | Nested _) :: _ ->
        let l, _, rest = take_descr t in
        let one { DocumentedSrc.attrs; anchor; code; doc; markers } =
          let content =
            match code with
            | `D code -> (inline ~config ~resolve code :> item Html.elt list)
            | `N n -> to_html n
          in
          let doc =
            match doc with
            | [] -> []
            | doc ->
                let opening, closing = markers in
                let delim s =
                  [ Html.span ~a:(class_ [ "comment-delim" ]) [ Html.txt s ] ]
                in
                [
                  Html.div ~a:(class_ [ "def-doc" ])
                    (delim opening @ block ~config ~resolve doc @ delim closing);
                ]
          in
          let extra_attr, extra_class, link = mk_anchor config anchor in
          let content = (content :> any Html.elt list) in
          Html.li
            ~a:(extra_attr @ class_ (attrs @ extra_class))
            (link @ content @ doc)
        in
        Html.ol (List.map one l) :: to_html rest
  in
  to_html t

and subpage ~config ~resolve (subp : Subpage.t) : item Html.elt list =
  items ~config ~resolve subp.content.items

and items ~config ~resolve l : item Html.elt list =
  let rec walk_items acc (t : Item.t list) : item Html.elt list =
    let continue_with rest elts =
      (walk_items [@tailcall]) (List.rev_append elts acc) rest
    in
    match t with
    | [] -> List.rev acc
    | Text _ :: _ as t ->
        let text, _, rest =
          Doctree.Take.until t ~classify:(function
            | Item.Text text -> Accum text
            | _ -> Stop_and_keep)
        in
        let content = flow_to_item @@ block ~config ~resolve text in
        (continue_with [@tailcall]) rest content
    | Heading h :: rest ->
        (continue_with [@tailcall]) rest [ heading ~config ~resolve h ]
    | Include
        {
          attr;
          anchor;
          source_anchor;
          doc;
          content = { summary; status; content };
        }
      :: rest ->
        let doc = spec_doc_div ~config ~resolve doc in
        let included_html = (items content :> item Html.elt list) in
        let a_class =
          if List.length content = 0 then [ "odoc-include"; "shadowed-include" ]
          else [ "odoc-include" ]
        in
        let content : item Html.elt list =
          let details ~open' =
            let open' = if open' then [ Html.a_open () ] else [] in
            let summary =
              let extra_attr, extra_class, anchor_link =
                mk_anchor config anchor
              in
              let link_to_source =
                mk_link_to_source ~config ~resolve source_anchor
              in
              let a = spec_class (attr @ extra_class) @ extra_attr in
              Html.summary ~a @@ anchor_link @ link_to_source
              @ source (inline ~config ~resolve) summary
            in
            let inner =
              [
                Html.details ~a:open' summary
                  (included_html :> any Html.elt list);
              ]
            in
            [ Html.div ~a:[ Html.a_class a_class ] (doc @ inner) ]
          in
          match status with
          | `Inline -> doc @ included_html
          | `Closed -> details ~open':false
          | `Open -> details ~open':true
          | `Default -> details ~open':(Config.open_details config)
        in
        (continue_with [@tailcall]) rest content
    | Declaration { Item.attr; anchor; source_anchor; content; doc } :: rest ->
        let extra_attr, extra_class, anchor_link = mk_anchor config anchor in
        let link_to_source = mk_link_to_source ~config ~resolve source_anchor in
        let a = spec_class (attr @ extra_class) @ extra_attr in
        let content =
          anchor_link @ link_to_source @ documentedSrc ~config ~resolve content
        in
        let spec =
          let doc = spec_doc_div ~config ~resolve doc in
          [ div ~a:[ Html.a_class [ "odoc-spec" ] ] (div ~a content :: doc) ]
        in
        (continue_with [@tailcall]) rest spec
  and items l = walk_items [] l in
  items l

module Toc = struct
  open Odoc_document.Doctree
  open Types

  let on_sub : Subpage.status -> bool = function
    | `Closed | `Open | `Default -> false
    | `Inline -> true

  let gen_toc ~config ~resolve ~path i =
    let toc = Toc.compute path ~on_sub i in
    let rec section { Toc.url; text; children } =
      let text = inline_nolink text in
      let title =
        (text
          : non_link_phrasing Html.elt list
          :> Html_types.flow5_without_interactive Html.elt list)
      in
      let title_str =
        List.map (Format.asprintf "%a" (Tyxml.Html.pp_elt ())) text
        |> String.concat ""
      in
      let href = Link.href ~config ~resolve url in
      { title; title_str; href; children = List.map section children }
    in
    List.map section toc
end

module Breadcrumbs = struct
  open Types

  let gen_breadcrumbs ~config ~url =
    let rec get_parent_paths x =
      match x with
      | [] -> []
      | x :: xs -> (
          match Odoc_document.Url.Path.of_list (List.rev (x :: xs)) with
          | Some x -> x :: get_parent_paths xs
          | None -> get_parent_paths xs)
    in
    let to_breadcrumb path =
      let href =
        Link.href ~config ~resolve:(Current url)
          (Odoc_document.Url.from_path path)
      in
      { href; name = path.name; kind = path.kind }
    in
    get_parent_paths (List.rev (Odoc_document.Url.Path.to_list url))
    |> List.rev |> List.map to_breadcrumb
end

module Page = struct
  let on_sub = function
    | `Page _ -> None
    | `Include x -> (
        match x.Include.status with
        | `Closed | `Open | `Default -> None
        | `Inline -> Some 0)

  let rec include_ ~config { Subpage.content; _ } = page ~config content

  and subpages ~config subpages = List.map (include_ ~config) subpages

  and page ~config p : Odoc_document.Renderer.page =
    let { Page.preamble; items = i; url; source_anchor; sidebar } =
      Doctree.Labels.disambiguate_page ~enter_subpages:false p
    in
    let subpages = subpages ~config @@ Doctree.Subpages.compute p in
    let resolve = Link.Current url in
    let sidebar =
      match sidebar with
      | None -> None
      | Some x -> (Some (block ~config ~resolve x) :> any Html.elt list option)
    in
    let i = Doctree.Shift.compute ~on_sub i in
    let uses_katex = Doctree.Math.has_math_elements p in
    let toc = Toc.gen_toc ~config ~resolve ~path:url i in
    let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~url in
    let content = (items ~config ~resolve i :> any Html.elt list) in
    if Config.as_json config then
      let source_anchor =
        match source_anchor with
        | Some url -> Some (Link.href ~config ~resolve url)
        | None -> None
      in
      Html_fragment_json.make ~config
        ~preamble:(items ~config ~resolve preamble :> any Html.elt list)
        ~breadcrumbs ~toc ~url ~uses_katex ~source_anchor content subpages
    else
      let header =
        items ~config ~resolve
          (Doctree.PageTitle.render_title ?source_anchor p @ preamble)
      in
      Html_page.make ~sidebar ~config ~header ~toc ~breadcrumbs ~url ~uses_katex
        content subpages

  and source_page ~config sp =
    let { Source_page.url; contents } = sp in
    let resolve = Link.Current sp.url in
    let title = url.Url.Path.name
    and doc = Html_source.html_of_doc ~config ~resolve contents in
    let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~url in
    let header =
      items ~config ~resolve (Doctree.PageTitle.render_src_title sp)
    in
    if Config.as_json config then
      Html_fragment_json.make_src ~config ~url ~breadcrumbs [ doc ]
    else Html_page.make_src ~breadcrumbs ~header ~config ~url title [ doc ]

  let asset ~config { Asset.url; src } =
    let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in
    let content ppf =
      let ic = open_in_bin (Fpath.to_string src) in
      let len = 1024 in
      let buf = Bytes.create len in
      let rec loop () =
        let read = input ic buf 0 len in
        if read = len then (
          Format.fprintf ppf "%s" (Bytes.to_string buf);
          loop ())
        else if len > 0 then
          let buf = Bytes.sub buf 0 read in
          Format.fprintf ppf "%s" (Bytes.to_string buf)
      in
      loop ();
      close_in ic
    in
    { Odoc_document.Renderer.filename; content; children = [] }
end

let render ~config = function
  | Document.Page page -> [ Page.page ~config page ]
  | Source_page src -> [ Page.source_page ~config src ]
  | Asset asset -> [ Page.asset ~config asset ]

let doc ~config ~xref_base_uri b =
  let resolve = Link.Base xref_base_uri in
  block ~config ~resolve b

1	(*
2	* Copyright (c) 2016 Thomas Refis <trefis@janestreet.com>
3	*
4	* Permission to use, copy, modify, and distribute this software for any
5	* purpose with or without fee is hereby granted, provided that the above
6	* copyright notice and this permission notice appear in all copies.
7	*
8	* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9	* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10	* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11	* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12	* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13	* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14	* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15	*)
16
17	open Odoc_document.Types
18	module Html = Tyxml.Html
19	module Doctree = Odoc_document.Doctree
20	module Url = Odoc_document.Url
21
22	type any = Html_types.flow5
23
24	type item = Html_types.flow5_without_header_footer
25
26	type flow = Html_types.flow5_without_sectioning_heading_header_footer
27
28	type phrasing = Html_types.phrasing
29
30	type non_link_phrasing = Html_types.phrasing_without_interactive
31
32	let mk_anchor_link id =
33	[ Html.a ~a:[ Html.a_href ("#" ^ id); Html.a_class [ "anchor" ] ] [] ]	2,688✔
34
35	let mk_anchor config anchor =
36	match anchor with	2,409✔
37	\| None -> ([], [], [])	63✔
38	\| _ when Config.search_result config ->	2,346✔
39	(* When displaying for a search result, anchor are not added as it would
40	make no sense to add them. *)
41	([], [], [])	×
42	\| Some { Url.Anchor.anchor; _ } ->	2,346✔
43	let link = mk_anchor_link anchor in
44	let extra_attr = [ Html.a_id anchor ] in	2,346✔
45	let extra_class = [ "anchored" ] in
46	(extra_attr, extra_class, link)
47
48	let mk_link_to_source ~config ~resolve anchor =
49	match anchor with	3,440✔
50	\| None -> []	3,321✔
51	\| Some url ->	119✔
52	let href = Link.href ~config ~resolve url in
53	[	119✔
54	Html.a	119✔
55	~a:[ Html.a_href href; Html.a_class [ "source_link" ] ]	119✔
56	[ Html.txt "Source" ];	119✔
57	]
58
59	let class_ (l : Class.t) = if l = [] then [] else [ Html.a_class l ]	2,896✔
60
61	let inline_math (s : Math.t) =
62	Html.code ~a:[ Html.a_class [ "odoc-katex-math" ] ] [ Html.txt s ]	10✔
63
64	let block_math (s : Math.t) =
65	Html.pre ~a:[ Html.a_class [ "odoc-katex-math"; "display" ] ] [ Html.txt s ]	2✔
66
67	and raw_markup (t : Raw_markup.t) =
68	let target, content = t in	11✔
69	match Astring.String.Ascii.lowercase target with
70	\| "html" ->	9✔
71	(* This is OK because we output textual HTML.
72	In theory, we should try to parse the HTML with lambdasoup and rebuild
73	the HTML tree from there.
74	*)
75	[ Html.Unsafe.data content ]	9✔
76	\| _ -> []	2✔
77
78	and source k ?a (t : Source.t) =
79	let rec token (x : Source.token) =	4,206✔
80	match x with	69,107✔
81	\| Elt i -> k i	55,323✔
82	\| Tag (None, l) ->	8,816✔
83	let content = tokens l in
84	if content = [] then [] else [ Html.span content ]	2,896✔
85	\| Tag (Some s, l) -> [ Html.span ~a:[ Html.a_class [ s ] ] (tokens l) ]	4,968✔
86	and tokens t = Utils.list_concat_map t ~f:token in	17,990✔
87	Utils.optional_elt Html.code ?a (tokens t)	4,206✔
88
89	and styled style ~emph_level =
90	match style with	174✔
91	\| `Emphasis ->	65✔
92	let a = if emph_level mod 2 = 0 then [] else [ Html.a_class [ "odd" ] ] in	6✔
93	(emph_level + 1, Html.em ~a)
94	\| `Bold -> (emph_level, Html.b ~a:[])	51✔
95	\| `Italic -> (emph_level, Html.i ~a:[])	26✔
96	\| `Superscript -> (emph_level, Html.sup ~a:[])	16✔
97	\| `Subscript -> (emph_level, Html.sub ~a:[])	16✔
98
99	let rec internallink ~config ~emph_level ~resolve ?(a = [])	×
100	{ InternalLink.target; content; tooltip } =
101	let a = match tooltip with Some s -> Html.a_title s :: a \| None -> a in	86✔
102	let elt =
103	match target with
104	\| Resolved uri ->	2,093✔
105	let href = Link.href ~config ~resolve uri in
106	let content = inline_nolink ~emph_level content in	2,093✔
107	if Config.search_result config then	2,093✔
108	(* When displaying for a search result, links are displayed as regular
109	text. *)
110	Html.span ~a content	3✔
111	else
112	let a =	2,090✔
113	Html.a_href href :: (a :> Html_types.a_attrib Html.attrib list)	2,090✔
114	in
115	Html.a ~a content	2,090✔
116	\| Unresolved ->	11✔
117	(* let title =
118	* Html.a_title (Printf.sprintf "unresolved reference to %S"
119	* (ref_to_string ref)
120	* in *)
121	let a = Html.a_class [ "xref-unresolved" ] :: a in	11✔
122	Html.span ~a (inline ~config ~emph_level ~resolve content)	11✔
123	in
124	[ (elt :> phrasing Html.elt) ]
125
126	and inline ~config ?(emph_level = 0) ~resolve (l : Inline.t) :	54,263✔
127	phrasing Html.elt list =
128	let one (t : Inline.one) =	58,116✔
129	let a = class_ t.attr in	71,499✔
130	match t.desc with	71,499✔
131	\| Text "" -> []	35,804✔
132	\| Text s ->	31,566✔
133	if a = [] then [ Html.txt s ] else [ Html.span ~a [ Html.txt s ] ]	98✔
134	\| Entity s ->	336✔
135	if a = [] then [ Html.entity s ] else [ Html.span ~a [ Html.entity s ] ]	×
136	\| Linebreak -> [ Html.br ~a () ]	×
137	\| Styled (style, c) ->	142✔
138	let emph_level, app_style = styled style ~emph_level in
139	[ app_style @@ inline ~config ~emph_level ~resolve c ]	142✔
140	\| Link (_, c) when Config.search_result config ->	38✔
141	(* When displaying for a search result, links are displayed as regular
142	text. *)
143	let content = inline_nolink ~emph_level c in	3✔
144	[ Html.span ~a content ]	3✔
145	\| Link (href, c) ->	35✔
146	let a = (a :> Html_types.a_attrib Html.attrib list) in
147	let content = inline_nolink ~emph_level c in
148	[ Html.a ~a:(Html.a_href href :: a) content ]	35✔
149	\| InternalLink c -> internallink ~config ~emph_level ~resolve ~a c	2,104✔
150	\| Source c -> source (inline ~config ~emph_level ~resolve) ~a c	1,490✔
151	\| Math s -> [ inline_math s ]	10✔
152	\| Raw_markup r -> raw_markup r	9✔
153	in
154	Utils.list_concat_map ~f:one l
155
156	and inline_nolink ?(emph_level = 0) (l : Inline.t) :	304✔
157	non_link_phrasing Html.elt list =
158	let one (t : Inline.one) =	2,637✔
159	let a = class_ t.attr in	3,539✔
160	match t.desc with	3,539✔
161	\| Text "" -> []	×
162	\| Text s ->	3,337✔
163	if a = [] then [ Html.txt s ] else [ Html.span ~a [ Html.txt s ] ]	×
164	\| Entity s ->	×
165	if a = [] then [ Html.entity s ] else [ Html.span ~a [ Html.entity s ] ]	×
166	\| Linebreak -> [ Html.br ~a () ]	×
167	\| Styled (style, c) ->	32✔
168	let emph_level, app_style = styled style ~emph_level in
169	[ app_style @@ inline_nolink ~emph_level c ]	32✔
170	\| Link _ -> assert false
171	\| InternalLink _ -> assert false
172	\| Source c -> source (inline_nolink ~emph_level) ~a c	170✔
173	\| Math s -> [ inline_math s ]	×
174	\| Raw_markup r -> raw_markup r	×
175	in
176	Utils.list_concat_map ~f:one l
177
178	let heading ~config ~resolve (h : Heading.t) =
179	let a, anchor =	1,305✔
180	match h.label with
181	\| Some _ when Config.search_result config ->	342✔
182	(* When displaying for a search result, anchor are not added as it would
183	make no sense to add them. *)
184	([], [])	×
185	\| Some id -> ([ Html.a_id id ], mk_anchor_link id)	342✔
186	\| None -> ([], [])	963✔
187	in
188	let content = inline ~config ~resolve h.title in
189	let source_link = mk_link_to_source ~config ~resolve h.source_anchor in	1,305✔
190	let mk =	1,305✔
191	match h.level with
192	\| 0 -> Html.h1	995✔
193	\| 1 -> Html.h2	237✔
194	\| 2 -> Html.h3	31✔
195	\| 3 -> Html.h4	34✔
196	\| 4 -> Html.h5	6✔
197	\| _ -> Html.h6	2✔
198	in
199	mk ~a (anchor @ content @ source_link)
200
201	let text_align = function
202	\| Table.Left -> [ Html.a_style "text-align:left" ]	10✔
203	\| Center -> [ Html.a_style "text-align:center" ]	10✔
204	\| Right -> [ Html.a_style "text-align:right" ]	10✔
205	\| Default -> []	34✔
206
207	let cell_kind = function `Header -> Html.th \| `Data -> Html.td	24✔
208
209	let rec block ~config ~resolve (l : Block.t) : flow Html.elt list =
210	let as_flow x = (x : phrasing Html.elt list :> flow Html.elt list) in	212✔
211	let one (t : Block.one) =
212	let mk_block ?(extra_class = []) mk content =	1,341✔
213	let a = Some (class_ (extra_class @ t.attr)) in	1,374✔
214	[ mk ?a content ]	1,374✔
215	in
216	match t.desc with
217	\| Inline i ->	218✔
218	if t.attr = [] then as_flow @@ inline ~config ~resolve i	212✔
219	else mk_block Html.span (inline ~config ~resolve i)	6✔
220	\| Paragraph i -> mk_block Html.p (inline ~config ~resolve i)	1,149✔
221	\| List (typ, l) ->	73✔
222	let mk = match typ with Ordered -> Html.ol \| Unordered -> Html.ul in	8✔
223	mk_block mk (List.map (fun x -> Html.li (block ~config ~resolve x)) l)	73✔
224	\| Table t ->	10✔
225	mk_block ~extra_class:[ "odoc-table" ]
226	(fun ?a x -> Html.table ?a x)	10✔
227	(mk_rows ~config ~resolve t)	10✔
228	\| Description l ->	88✔
229	let item i =
230	let a = class_ i.Description.attr in	98✔
231	let term =	98✔
232	(inline ~config ~resolve i.Description.key	98✔
233	: phrasing Html.elt list
234	:> flow Html.elt list)
235	in
236	let def = block ~config ~resolve i.Description.definition in
237	Html.li ~a (term @ (Html.txt " " :: def))	98✔
238	in
239	mk_block Html.ul (List.map item l)	88✔
240	\| Raw_markup r -> raw_markup r	2✔
241	\| Verbatim s -> mk_block Html.pre [ Html.txt s ]	23✔
242	\| Source (lang_tag, c) ->	23✔
243	let extra_class = [ "language-" ^ lang_tag ] in
244	mk_block ~extra_class Html.pre (source (inline ~config ~resolve) c)	23✔
245	\| Math s -> mk_block Html.div [ block_math s ]	2✔
246	in
247	Utils.list_concat_map l ~f:one
248
249	and mk_rows ~config ~resolve { align; data } =
250	let mk_row row =	10✔
251	let mk_cell ~align (x, h) =	22✔
252	let a = text_align align in	64✔
253	cell_kind ~a h (block ~config ~resolve x)	64✔
254	in
255	let alignment align =
256	match align with align :: q -> (align, q) \| [] -> (Table.Default, [])	×
257	(* Second case is for recovering from a too short alignment list. A
258	warning should have been raised when loading the doc-comment. *)
259	in
260	let acc, _align =
261	List.fold_left
262	(fun (acc, aligns) (x, h) ->
263	let align, aligns = alignment aligns in	64✔
264	let cell = mk_cell ~align (x, h) in	64✔
265	(cell :: acc, aligns))	64✔
266	([], align) row
267	in
268	Html.tr (List.rev acc)	22✔
269	in
270	List.map mk_row data
271
272	(* This coercion is actually sound, but is not currently accepted by Tyxml.
273	See https://github.com/ocsigen/tyxml/pull/265 for details
274	Can be replaced by a simple type coercion once this is fixed
275	*)
276	let flow_to_item : flow Html.elt list -> item Html.elt list =
277	fun x -> Html.totl @@ Html.toeltl x	806✔
278
279	let div : ([< Html_types.div_attrib ], [< item ], [> Html_types.div ]) Html.star
280	=
281	Html.Unsafe.node "div"	908✔
282
283	let spec_class attr = class_ ("spec" :: attr)	2,135✔
284
285	let spec_doc_div ~config ~resolve = function
286	\| [] -> []	1,722✔
287	\| docs ->	432✔
288	let a = [ Html.a_class [ "spec-doc" ] ] in	432✔
289	[ div ~a (flow_to_item @@ block ~config ~resolve docs) ]	432✔
290
291	let rec documentedSrc ~config ~resolve (t : DocumentedSrc.t) :
292	item Html.elt list =
293	let open DocumentedSrc in	2,078✔
294	let take_code l =
295	Doctree.Take.until l ~classify:(function	2,466✔
296	\| Code code -> Accum code	6,297✔
297	\| Alternative (Expansion { summary; _ }) -> Accum summary	812✔
298	\| _ -> Stop_and_keep)	154✔
299	in
300	let take_descr l =
301	Doctree.Take.until l ~classify:(function	154✔
302	\| Documented { attrs; anchor; code; doc; markers } ->	40✔
303	Accum
304	[ { DocumentedSrc.attrs; anchor; code = `D code; doc; markers } ]
305	\| Nested { attrs; anchor; code; doc; markers } ->	234✔
306	Accum
307	[ { DocumentedSrc.attrs; anchor; code = `N code; doc; markers } ]
308	\| _ -> Stop_and_keep)	154✔
309	in
310	let rec to_html t : item Html.elt list =
311	match t with	4,932✔
312	\| [] -> []	2,312✔
313	\| (Code _ \| Alternative _) :: _ ->	×
314	let code, _, rest = take_code t in
315	source (inline ~config ~resolve) code @ to_html rest	2,466✔
316	\| Subpage subp :: _ -> subpage ~config ~resolve subp	×
317	\| (Documented _ \| Nested _) :: _ ->	24✔
318	let l, _, rest = take_descr t in
319	let one { DocumentedSrc.attrs; anchor; code; doc; markers } =	154✔
320	let content =	274✔
321	match code with
322	\| `D code -> (inline ~config ~resolve code :> item Html.elt list)	40✔
323	\| `N n -> to_html n	234✔
324	in
325	let doc =
326	match doc with
327	\| [] -> []	217✔
328	\| doc ->	57✔
329	let opening, closing = markers in
330	let delim s =
331	[ Html.span ~a:(class_ [ "comment-delim" ]) [ Html.txt s ] ]	114✔
332	in
333	[
334	Html.div ~a:(class_ [ "def-doc" ])	57✔
335	(delim opening @ block ~config ~resolve doc @ delim closing);	57✔
336	]
337	in
338	let extra_attr, extra_class, link = mk_anchor config anchor in
339	let content = (content :> any Html.elt list) in	274✔
340	Html.li
341	~a:(extra_attr @ class_ (attrs @ extra_class))	274✔
342	(link @ content @ doc)
343	in
344	Html.ol (List.map one l) :: to_html rest	154✔
345	in
346	to_html t
347
348	and subpage ~config ~resolve (subp : Subpage.t) : item Html.elt list =
349	items ~config ~resolve subp.content.items	×
350
351	and items ~config ~resolve l : item Html.elt list =
352	let rec walk_items acc (t : Item.t list) : item Html.elt list =	1,996✔
353	let continue_with rest elts =	5,905✔
354	(walk_items [@tailcall]) (List.rev_append elts acc) rest	3,833✔
355	in
356	match t with
357	\| [] -> List.rev acc	2,072✔
358	\| Text _ :: _ as t ->	374✔
359	let text, _, rest =
360	Doctree.Take.until t ~classify:(function
361	\| Item.Text text -> Accum text	450✔
362	\| _ -> Stop_and_keep)	114✔
363	in
364	let content = flow_to_item @@ block ~config ~resolve text in	374✔
365	(continue_with [@tailcall]) rest content	374✔
366	\| Heading h :: rest ->	1,305✔
367	(continue_with [@tailcall]) rest [ heading ~config ~resolve h ]	1,305✔
368	\| Include	76✔
369	{
370	attr;
371	anchor;
372	source_anchor;
373	doc;
374	content = { summary; status; content };
375	}
376	:: rest ->
377	let doc = spec_doc_div ~config ~resolve doc in
378	let included_html = (items content :> item Html.elt list) in	76✔
379	let a_class =
380	if List.length content = 0 then [ "odoc-include"; "shadowed-include" ]	10✔
381	else [ "odoc-include" ]	66✔
382	in
383	let content : item Html.elt list =
384	let details ~open' =
385	let open' = if open' then [ Html.a_open () ] else [] in	2✔
386	let summary =
387	let extra_attr, extra_class, anchor_link =
388	mk_anchor config anchor
389	in
390	let link_to_source =	57✔
391	mk_link_to_source ~config ~resolve source_anchor
392	in
393	let a = spec_class (attr @ extra_class) @ extra_attr in	57✔
394	Html.summary ~a @@ anchor_link @ link_to_source	57✔
395	@ source (inline ~config ~resolve) summary	57✔
396	in
397	let inner =
398	[
399	Html.details ~a:open' summary	57✔
400	(included_html :> any Html.elt list);
401	]
402	in
403	[ Html.div ~a:[ Html.a_class a_class ] (doc @ inner) ]	57✔
404	in
405	match status with
406	\| `Inline -> doc @ included_html	19✔
407	\| `Closed -> details ~open':false	2✔
408	\| `Open -> details ~open':true	2✔
409	\| `Default -> details ~open':(Config.open_details config)	53✔
410	in
411	(continue_with [@tailcall]) rest content
412	\| Declaration { Item.attr; anchor; source_anchor; content; doc } :: rest ->	2,078✔
413	let extra_attr, extra_class, anchor_link = mk_anchor config anchor in
414	let link_to_source = mk_link_to_source ~config ~resolve source_anchor in	2,078✔
415	let a = spec_class (attr @ extra_class) @ extra_attr in	2,078✔
416	let content =
417	anchor_link @ link_to_source @ documentedSrc ~config ~resolve content	2,078✔
418	in
419	let spec =
420	let doc = spec_doc_div ~config ~resolve doc in
421	[ div ~a:[ Html.a_class [ "odoc-spec" ] ] (div ~a content :: doc) ]	2,078✔
422	in
423	(continue_with [@tailcall]) rest spec
424	and items l = walk_items [] l in	2,072✔
425	items l
426
427	module Toc = struct
428	open Odoc_document.Doctree
429	open Types
430
431	let on_sub : Subpage.status -> bool = function
432	\| `Closed \| `Open \| `Default -> false	2✔
433	\| `Inline -> true	18✔
434
435	let gen_toc ~config ~resolve ~path i =
436	let toc = Toc.compute path ~on_sub i in	985✔
437	let rec section { Toc.url; text; children } =	985✔
438	let text = inline_nolink text in	304✔
439	let title =	304✔
440	(text
441	: non_link_phrasing Html.elt list
442	:> Html_types.flow5_without_interactive Html.elt list)
443	in
444	let title_str =
445	List.map (Format.asprintf "%a" (Tyxml.Html.pp_elt ())) text	304✔
446	\|> String.concat ""	304✔
447	in
448	let href = Link.href ~config ~resolve url in	304✔
449	{ title; title_str; href; children = List.map section children }	304✔
450	in
451	List.map section toc
452	end
453
454	module Breadcrumbs = struct
455	open Types
456
457	let gen_breadcrumbs ~config ~url =
458	let rec get_parent_paths x =	1,011✔
459	match x with	3,536✔
460	\| [] -> []	1,011✔
461	\| x :: xs -> (	2,525✔
462	match Odoc_document.Url.Path.of_list (List.rev (x :: xs)) with	2,525✔
463	\| Some x -> x :: get_parent_paths xs	2,525✔
464	\| None -> get_parent_paths xs)	×
465	in
466	let to_breadcrumb path =
467	let href =	2,525✔
468	Link.href ~config ~resolve:(Current url)
469	(Odoc_document.Url.from_path path)	2,525✔
470	in
471	{ href; name = path.name; kind = path.kind }	2,525✔
472	in
473	get_parent_paths (List.rev (Odoc_document.Url.Path.to_list url))	1,011✔
474	\|> List.rev \|> List.map to_breadcrumb	1,011✔
475	end
476
477	module Page = struct
478	let on_sub = function
479	\| `Page _ -> None	793✔
480	\| `Include x -> (	71✔
481	match x.Include.status with
482	\| `Closed \| `Open \| `Default -> None	2✔
483	\| `Inline -> Some 0)	18✔
484
485	let rec include_ ~config { Subpage.content; _ } = page ~config content	812✔
486
487	and subpages ~config subpages = List.map (include_ ~config) subpages	985✔
488
489	and page ~config p : Odoc_document.Renderer.page =
490	let { Page.preamble; items = i; url; source_anchor; sidebar } =	985✔
491	Doctree.Labels.disambiguate_page ~enter_subpages:false p
492	in
493	let subpages = subpages ~config @@ Doctree.Subpages.compute p in	985✔
494	let resolve = Link.Current url in	985✔
495	let sidebar =
496	match sidebar with
497	\| None -> None	980✔
498	\| Some x -> (Some (block ~config ~resolve x) :> any Html.elt list option)	5✔
499	in
500	let i = Doctree.Shift.compute ~on_sub i in
501	let uses_katex = Doctree.Math.has_math_elements p in	985✔
502	let toc = Toc.gen_toc ~config ~resolve ~path:url i in	985✔
503	let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~url in	985✔
504	let content = (items ~config ~resolve i :> any Html.elt list) in	985✔
505	if Config.as_json config then
506	let source_anchor =	16✔
507	match source_anchor with
508	\| Some url -> Some (Link.href ~config ~resolve url)	6✔
509	\| None -> None	10✔
510	in
511	Html_fragment_json.make ~config
512	~preamble:(items ~config ~resolve preamble :> any Html.elt list)	16✔
513	~breadcrumbs ~toc ~url ~uses_katex ~source_anchor content subpages
514	else
515	let header =	969✔
516	items ~config ~resolve
517	(Doctree.PageTitle.render_title ?source_anchor p @ preamble)	969✔
518	in
519	Html_page.make ~sidebar ~config ~header ~toc ~breadcrumbs ~url ~uses_katex	969✔
520	content subpages
521
522	and source_page ~config sp =
523	let { Source_page.url; contents } = sp in	26✔
524	let resolve = Link.Current sp.url in
525	let title = url.Url.Path.name
526	and doc = Html_source.html_of_doc ~config ~resolve contents in	26✔
527	let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~url in
528	let header =
529	items ~config ~resolve (Doctree.PageTitle.render_src_title sp)	26✔
530	in
531	if Config.as_json config then	26✔
532	Html_fragment_json.make_src ~config ~url ~breadcrumbs [ doc ]	4✔
533	else Html_page.make_src ~breadcrumbs ~header ~config ~url title [ doc ]	22✔
534
535	let asset ~config { Asset.url; src } =
536	let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in	2✔
537	let content ppf =	2✔
538	let ic = open_in_bin (Fpath.to_string src) in	1✔
539	let len = 1024 in	1✔
540	let buf = Bytes.create len in
541	let rec loop () =	1✔
542	let read = input ic buf 0 len in	1✔
UNCOV 543	if read = len then (	×
UNCOV 544	Format.fprintf ppf "%s" (Bytes.to_string buf);	×
UNCOV 545	loop ())	×
546	else if len > 0 then	1✔
547	let buf = Bytes.sub buf 0 read in	1✔
548	Format.fprintf ppf "%s" (Bytes.to_string buf)	1✔
549	in
550	loop ();
551	close_in ic	1✔
552	in
553	{ Odoc_document.Renderer.filename; content; children = [] }
554	end
555
556	let render ~config = function
557	\| Document.Page page -> [ Page.page ~config page ]	173✔
558	\| Source_page src -> [ Page.source_page ~config src ]	26✔
559	\| Asset asset -> [ Page.asset ~config asset ]	2✔
560
561	let doc ~config ~xref_base_uri b =
562	let resolve = Link.Base xref_base_uri in	143✔
563	block ~config ~resolve b

ocaml / odoc / 2108

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