3283

Committed 23 Jul 2026 03:59PM UTC coverage: 70.503%. First build

Build # 3283

Build Type

Pull #1467

github

Committed by

web-flow

Commit Message

Merge f7bd5c194 into 17e9ae9da

Pull Request Pull Request #1467: OxCaml: support for kind abbreviations

Coverage Stats

11 of 109 new or added lines in 17 files covered. (10.09%)

10462 of 14839 relevant lines covered (70.5%)

5822.37 hits per line

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

81.74

/src/document/comment.ml

(*
 * Copyright (c) 2016, 2017 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_utils
open Types
module Comment = Odoc_model.Comment
open Odoc_model.Names

let default_lang_tag = "ocaml"

let source_of_code s =
  if s = "" then [] else [ Source.Elt [ inline @@ Inline.Text s ] ]

module Reference = struct
  open Odoc_model.Paths

  let rec render_resolved : Reference.Resolved.t -> string =
   fun r ->
    let open Reference.Resolved in
    match r with
    | `Identifier id -> Identifier.name id
    | `Alias (_, r) -> render_resolved (r :> t)
    | `AliasModuleType (_, r) -> render_resolved (r :> t)
    | `Module (r, s) -> render_resolved (r :> t) ^ "." ^ ModuleName.to_string s
    | `Hidden p -> render_resolved (p :> t)
    | `ModuleType (r, s) ->
        render_resolved (r :> t) ^ "." ^ ModuleTypeName.to_string s
    | `Type (r, s) -> render_resolved (r :> t) ^ "." ^ TypeName.to_string s
    | `Constructor (r, s) ->
        render_resolved (r :> t) ^ "." ^ ConstructorName.to_string s
    | `PolyConstructor (r, s) ->
        render_resolved (r :> t) ^ ".`" ^ ConstructorName.to_string s
    | `Field (r, s) -> render_resolved (r :> t) ^ "." ^ FieldName.to_string s
    | `UnboxedField (r, s) ->
        render_resolved (r :> t) ^ "." ^ UnboxedFieldName.to_string s
    | `Extension (r, s) ->
        render_resolved (r :> t) ^ "." ^ ExtensionName.to_string s
    | `ExtensionDecl (r, _, s) ->
        render_resolved (r :> t) ^ "." ^ ExtensionName.to_string s
    | `Exception (r, s) ->
        render_resolved (r :> t) ^ "." ^ ExceptionName.to_string s
    | `Value (r, s) -> render_resolved (r :> t) ^ "." ^ ValueName.to_string s
    | `Class (r, s) -> render_resolved (r :> t) ^ "." ^ TypeName.to_string s
    | `ClassType (r, s) -> render_resolved (r :> t) ^ "." ^ TypeName.to_string s
    | `Method (r, s) ->
        (* CR trefis: do we really want to print anything more than [s] here?  *)
        render_resolved (r :> t) ^ "." ^ MethodName.to_string s
    | `InstanceVariable (r, s) ->
        (* CR trefis: the following makes no sense to me... *)
        render_resolved (r :> t) ^ "." ^ InstanceVariableName.to_string s
    | `Label (_, s) -> LabelName.to_string s

  let render_path (tag, cs) =
    let tag =
      match tag with
      | `TRelativePath -> "./"
      | `TAbsolutePath -> "/"
      | `TCurrentPackage -> "//"
    in
    tag ^ String.concat ~sep:"/" cs

  let rec render_unresolved : Reference.t -> string =
    let open Reference in
    function
    | `Resolved r -> render_resolved r
    | `Root (n, _) -> n
    | `Dot (p, f) -> render_unresolved (p :> t) ^ "." ^ f
    | `Page_path p -> render_path p
    | `Asset_path p -> render_path p
    | `Module_path p -> render_path p
    | `Any_path p -> render_path p
    | `Module (p, f) ->
        render_unresolved (p :> t) ^ "." ^ ModuleName.to_string f
    | `ModuleType (p, f) ->
        render_unresolved (p :> t) ^ "." ^ ModuleTypeName.to_string f
    | `Type (p, f) -> render_unresolved (p :> t) ^ "." ^ TypeName.to_string f
    | `KindAbbreviation (p, f) ->
        render_unresolved (p :> t) ^ "." ^ TypeName.to_string f
    | `Constructor (p, f) ->
        render_unresolved (p :> t) ^ "." ^ ConstructorName.to_string f
    | `Field (p, f) -> render_unresolved (p :> t) ^ "." ^ FieldName.to_string f
    | `UnboxedField (p, f) ->
        render_unresolved (p :> t) ^ "." ^ UnboxedFieldName.to_string f
    | `Extension (p, f) ->
        render_unresolved (p :> t) ^ "." ^ ExtensionName.to_string f
    | `ExtensionDecl (p, f) ->
        render_unresolved (p :> t) ^ "." ^ ExtensionName.to_string f
    | `Exception (p, f) ->
        render_unresolved (p :> t) ^ "." ^ ExceptionName.to_string f
    | `Value (p, f) -> render_unresolved (p :> t) ^ "." ^ ValueName.to_string f
    | `Class (p, f) -> render_unresolved (p :> t) ^ "." ^ TypeName.to_string f
    | `ClassType (p, f) ->
        render_unresolved (p :> t) ^ "." ^ TypeName.to_string f
    | `Method (p, f) ->
        render_unresolved (p :> t) ^ "." ^ MethodName.to_string f
    | `InstanceVariable (p, f) ->
        render_unresolved (p :> t) ^ "." ^ InstanceVariableName.to_string f
    | `Label (p, f) -> render_unresolved (p :> t) ^ "." ^ LabelName.to_string f

  (* This is the entry point. *)
  let to_ir : ?text:Inline.t -> Reference.t -> Inline.t =
   fun ?text ref ->
    match ref with
    | `Resolved r ->
        (* IDENTIFIER MUST BE RENAMED TO DEFINITION. *)
        let id = Reference.Resolved.identifier r in
        let rendered = render_resolved r in
        let content =
          match text with
          | None -> [ inline @@ Inline.Source (source_of_code rendered) ]
          | Some s -> s
        and tooltip =
          (* Add a tooltip if the content is not the rendered reference. *)
          match text with
          | None -> None
          | Some _ -> Some rendered
        in
        let target =
          match id with
          | Some id ->
              let url = Url.from_identifier ~stop_before:false id in
              Target.Internal (Resolved url)
          | None -> Internal Unresolved
        in
        let link = { Link.target; content; tooltip } in
        [ inline @@ Inline.Link link ]
    | _ -> (
        let s = render_unresolved ref in
        match text with
        | None ->
            let s = source_of_code s in
            [ inline @@ Inline.Source s ]
        | Some content ->
            let link =
              { Link.target = Internal Unresolved; content; tooltip = Some s }
            in
            [ inline @@ Inline.Link link ])
end

let leaf_inline_element : Comment.leaf_inline_element -> Inline.one = function
  | `Space -> inline @@ Text " "
  | `Word s -> inline @@ Text s
  | `Code_span s -> inline @@ Source (source_of_code s)
  | `Math_span s -> inline @@ Math s
  | `Raw_markup (target, s) -> inline @@ Raw_markup (target, s)

let rec non_link_inline_element : Comment.non_link_inline_element -> Inline.one
    = function
  | #Comment.leaf_inline_element as e -> leaf_inline_element e
  | `Styled (style, content) ->
      inline @@ Styled (style, non_link_inline_element_list content)

and non_link_inline_element_list : _ -> Inline.t =
 fun elements ->
  List.map
    (fun elt -> non_link_inline_element elt.Odoc_model.Location_.value)
    elements

let link_content = non_link_inline_element_list

let rec inline_element : Comment.inline_element -> Inline.t = function
  | #Comment.leaf_inline_element as e -> [ leaf_inline_element e ]
  | `Styled (style, content) ->
      [ inline @@ Styled (style, inline_element_list content) ]
  | `Reference (path, content) ->
      (* TODO Rework that ugly function. *)
      (* TODO References should be set in code style, if they are to code
              elements. *)
      let content =
        match content with
        | [] -> None
        | _ -> Some (non_link_inline_element_list content)
        (* XXX Span *)
      in
      Reference.to_ir ?text:content path
  | `Link (target, content) ->
      let content =
        match content with
        | [] -> [ inline @@ Text target ]
        | _ -> non_link_inline_element_list content
      in
      [ inline @@ Link { target = External target; content; tooltip = None } ]

and inline_element_list elements =
  List.concat
  @@ List.map
       (fun elt -> inline_element elt.Odoc_model.Location_.value)
       elements

let module_references ms =
  let module_reference (m : Comment.module_reference) =
    let reference =
      Reference.to_ir (m.module_reference :> Odoc_model.Paths.Reference.t)
    and synopsis =
      match m.module_synopsis with
      | Some synopsis ->
          [
            block ~attr:[ "synopsis" ] @@ Inline (inline_element_list synopsis);
          ]
      | None -> []
    in
    { Description.attr = []; key = reference; definition = synopsis }
  in
  let items = List.map module_reference ms in
  block ~attr:[ "modules" ] @@ Description items

let rec nestable_block_element :
    Comment.nestable_block_element -> Block.one list =
 fun content ->
  match content with
  | `Paragraph p -> [ paragraph p ]
  | `Code_block (lang_tag, code, outputs) ->
      let lang_tag =
        match lang_tag with None -> default_lang_tag | Some t -> t
      in
      let rest =
        match outputs with
        | Some xs -> nestable_block_element_list xs
        | None -> []
      in
      [
        block
        @@ Source (lang_tag, source_of_code (Odoc_model.Location_.value code));
      ]
      @ rest
  | `Math_block s -> [ block @@ Math s ]
  | `Verbatim s -> [ block @@ Verbatim s ]
  | `Modules ms -> [ module_references ms ]
  | `List (kind, items) ->
      let kind =
        match kind with
        | `Unordered -> Block.Unordered
        | `Ordered -> Block.Ordered
      in
      let f = function
        | [ { Odoc_model.Location_.value = `Paragraph content; _ } ] ->
            [ block @@ Block.Inline (inline_element_list content) ]
        | item -> nestable_block_element_list item
      in
      let items = List.map f items in
      [ block @@ Block.List (kind, items) ]
  | `Table { data; align } ->
      let data =
        List.map
          (List.map (fun (cell, cell_type) ->
               (nestable_block_element_list cell, cell_type)))
          data
      in
      let generate_align data =
        let max (a : int) b = if a < b then b else a in
        (* Length of the longest line of the table *)
        let max_length =
          List.fold_left (fun m l -> max m (List.length l)) 0 data
        in
        let rec list_init i =
          if i <= 0 then [] else Table.Default :: list_init (i - 1)
        in
        list_init max_length
      in
      let align =
        match align with
        | None -> generate_align data
        | Some align ->
            List.map
              (function
                | None -> Table.Default
                | Some `Right -> Right
                | Some `Left -> Left
                | Some `Center -> Center)
              align
        (* We should also check wellness of number of table cells vs alignment,
           and raise warnings *)
      in
      [ block @@ Table { data; align } ]
  | `Media (href, media, content) ->
      let content =
        match (content, href) with
        | "", `Reference path ->
            Reference.render_unresolved (path :> Comment.Reference.t)
        | "", `Link href -> href
        | _ -> content
      in
      let url =
        match href with
        | `Reference (`Resolved r) -> (
            let id =
              Odoc_model.Paths.Reference.Resolved.Asset.(identifier (r :> t))
            in
            match Url.from_asset_identifier id with
            | url -> Target.Internal (Resolved url))
        | `Reference _ -> Internal Unresolved
        | `Link href -> External href
      in
      let i =
        match media with
        | `Audio -> Block.Audio (url, content)
        | `Video -> Video (url, content)
        | `Image -> Image (url, content)
      in
      [ block i ]

and paragraph : Comment.paragraph -> Block.one = function
  | [ { value = `Raw_markup (target, s); _ } ] ->
      block @@ Block.Raw_markup (target, s)
  | p -> block @@ Block.Paragraph (inline_element_list p)

and nestable_block_element_list :
    Comment.nestable_block_element Comment.with_location list -> Block.one list
    =
 fun elements ->
  elements
  |> List.map Odoc_model.Location_.value
  |> List.map nestable_block_element
  |> List.concat

let tag : Comment.tag -> Description.one =
 fun t ->
  let sp = inline (Text " ") in
  let item ?value ~tag definition =
    let tag_name = inline ~attr:[ "at-tag" ] (Text tag) in
    let tag_value = match value with None -> [] | Some t -> sp :: t in
    let key = tag_name :: tag_value in
    { Description.attr = [ tag ]; key; definition }
  in
  let mk_value desc = [ inline ~attr:[ "value" ] desc ] in
  let text_def s = [ block (Block.Inline [ inline @@ Text s ]) ] in
  let content_to_inline ?(prefix = []) content =
    match content with
    | None -> []
    | Some content -> prefix @ [ inline @@ Text content ]
  in
  match t with
  | `Author s -> item ~tag:"author" (text_def s)
  | `Deprecated content ->
      item ~tag:"deprecated" (nestable_block_element_list content)
  | `Param (name, content) ->
      let value = mk_value (Inline.Text name) in
      item ~tag:"parameter" ~value (nestable_block_element_list content)
  | `Raise (kind, content) ->
      let value = inline_element (kind :> Comment.inline_element) in
      item ~tag:"raises" ~value (nestable_block_element_list content)
  | `Return content -> item ~tag:"returns" (nestable_block_element_list content)
  | `See (kind, target, content) ->
      let value =
        match kind with
        | `Url ->
            mk_value
              (Inline.Link
                 {
                   target = External target;
                   content = [ inline @@ Text target ];
                   tooltip = None;
                 })
        | `File -> mk_value (Inline.Source (source_of_code target))
        | `Document -> mk_value (Inline.Text target)
      in
      item ~tag:"see" ~value (nestable_block_element_list content)
  | `Since s -> item ~tag:"since" (text_def s)
  | `Before (version, content) ->
      let value = mk_value (Inline.Text version) in
      item ~tag:"before" ~value (nestable_block_element_list content)
  | `Version s -> item ~tag:"version" (text_def s)
  | `Alert ("deprecated", content) ->
      let content = content_to_inline content in
      item ~tag:"deprecated" [ block (Block.Inline content) ]
  | `Alert (tag, content) ->
      let content = content_to_inline ~prefix:[ sp ] content in
      item ~tag:"alert"
        [ block (Block.Inline ([ inline @@ Text tag ] @ content)) ]

let attached_block_element : Comment.attached_block_element -> Block.t =
  function
  | #Comment.nestable_block_element as e -> nestable_block_element e
  | `Tag t -> [ block ~attr:[ "at-tags" ] @@ Description [ tag t ] ]

(* TODO collaesce tags *)

let block_element : Comment.block_element -> Block.t = function
  | #Comment.attached_block_element as e -> attached_block_element e
  | `Heading (_, _, text) ->
      (* We are not supposed to receive Heading in this context.
         TODO: Remove heading in attached documentation in the model *)
      [ block @@ Paragraph (inline_element_list text) ]

let heading_level_to_int = function
  | `Title -> 0
  | `Section -> 1
  | `Subsection -> 2
  | `Subsubsection -> 3
  | `Paragraph -> 4
  | `Subparagraph -> 5

let heading
    (attrs, { Odoc_model.Paths.Identifier.iv = `Label (_, label); _ }, text) =
  let label = Odoc_model.Names.LabelName.to_string label in
  let title = inline_element_list text in
  let level = heading_level_to_int attrs.Comment.heading_level in
  let label = Some label in
  let source_anchor = None in
  Item.Heading { label; level; title; source_anchor }

let item_element : Comment.block_element -> Item.t list = function
  | #Comment.attached_block_element as e ->
      [ Item.Text (attached_block_element e) ]
  | `Heading h -> [ heading h ]

(** The documentation of the expansion is used if there is no comment attached
    to the declaration. *)
let synopsis ~decl_doc ~expansion_doc =
  let ([], Some docs | docs, _) = (decl_doc, expansion_doc) in
  match Comment.synopsis docs with Some p -> [ paragraph p ] | None -> []

let standalone docs =
  List.concat_map item_element
  @@ List.map (fun x -> x.Odoc_model.Location_.value) docs

let to_ir (docs : Comment.elements) =
  List.concat_map block_element
  @@ List.map (fun x -> x.Odoc_model.Location_.value) docs

let has_doc docs = docs <> []

1	(*
2	* Copyright (c) 2016, 2017 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_utils
18	open Types
19	module Comment = Odoc_model.Comment
20	open Odoc_model.Names
21
22	let default_lang_tag = "ocaml"
23
24	let source_of_code s =
25	if s = "" then [] else [ Source.Elt [ inline @@ Inline.Text s ] ]	×
26
27	module Reference = struct
28	open Odoc_model.Paths
29
30	let rec render_resolved : Reference.Resolved.t -> string =
31	fun r ->
32	let open Reference.Resolved in	3,947✔
33	match r with
34	\| `Identifier id -> Identifier.name id	3,202✔
35	\| `Alias (_, r) -> render_resolved (r :> t)	77✔
36	\| `AliasModuleType (_, r) -> render_resolved (r :> t)	2✔
37	\| `Module (r, s) -> render_resolved (r :> t) ^ "." ^ ModuleName.to_string s	160✔
38	\| `Hidden p -> render_resolved (p :> t)	×
39	\| `ModuleType (r, s) ->	78✔
40	render_resolved (r :> t) ^ "." ^ ModuleTypeName.to_string s	78✔
41	\| `Type (r, s) -> render_resolved (r :> t) ^ "." ^ TypeName.to_string s	194✔
42	\| `Constructor (r, s) ->	5✔
43	render_resolved (r :> t) ^ "." ^ ConstructorName.to_string s	5✔
44	\| `PolyConstructor (r, s) ->	8✔
45	render_resolved (r :> t) ^ ".`" ^ ConstructorName.to_string s	8✔
46	\| `Field (r, s) -> render_resolved (r :> t) ^ "." ^ FieldName.to_string s	×
47	\| `UnboxedField (r, s) ->	×
48	render_resolved (r :> t) ^ "." ^ UnboxedFieldName.to_string s	×
49	\| `Extension (r, s) ->	3✔
50	render_resolved (r :> t) ^ "." ^ ExtensionName.to_string s	3✔
51	\| `ExtensionDecl (r, _, s) ->	2✔
52	render_resolved (r :> t) ^ "." ^ ExtensionName.to_string s	2✔
53	\| `Exception (r, s) ->	126✔
54	render_resolved (r :> t) ^ "." ^ ExceptionName.to_string s	126✔
55	\| `Value (r, s) -> render_resolved (r :> t) ^ "." ^ ValueName.to_string s	36✔
56	\| `Class (r, s) -> render_resolved (r :> t) ^ "." ^ TypeName.to_string s	×
57	\| `ClassType (r, s) -> render_resolved (r :> t) ^ "." ^ TypeName.to_string s	×
58	\| `Method (r, s) ->	×
59	(* CR trefis: do we really want to print anything more than [s] here? *)
60	render_resolved (r :> t) ^ "." ^ MethodName.to_string s	×
61	\| `InstanceVariable (r, s) ->	×
62	(* CR trefis: the following makes no sense to me... *)
63	render_resolved (r :> t) ^ "." ^ InstanceVariableName.to_string s	×
64	\| `Label (_, s) -> LabelName.to_string s	54✔
65
66	let render_path (tag, cs) =
67	let tag =	8✔
68	match tag with
69	\| `TRelativePath -> "./"	8✔
70	\| `TAbsolutePath -> "/"	×
71	\| `TCurrentPackage -> "//"	×
72	in
73	tag ^ String.concat ~sep:"/" cs	8✔
74
75	let rec render_unresolved : Reference.t -> string =
76	let open Reference in
77	function
78	\| `Resolved r -> render_resolved r	6✔
79	\| `Root (n, _) -> n	381✔
80	\| `Dot (p, f) -> render_unresolved (p :> t) ^ "." ^ f	505✔
81	\| `Page_path p -> render_path p	×
82	\| `Asset_path p -> render_path p	7✔
83	\| `Module_path p -> render_path p	×
84	\| `Any_path p -> render_path p	1✔
85	\| `Module (p, f) ->	×
86	render_unresolved (p :> t) ^ "." ^ ModuleName.to_string f	×
87	\| `ModuleType (p, f) ->	×
88	render_unresolved (p :> t) ^ "." ^ ModuleTypeName.to_string f	×
89	\| `Type (p, f) -> render_unresolved (p :> t) ^ "." ^ TypeName.to_string f	×
NEW 90	\| `KindAbbreviation (p, f) ->	×
NEW 91	render_unresolved (p :> t) ^ "." ^ TypeName.to_string f	×
92	\| `Constructor (p, f) ->	1✔
93	render_unresolved (p :> t) ^ "." ^ ConstructorName.to_string f	1✔
94	\| `Field (p, f) -> render_unresolved (p :> t) ^ "." ^ FieldName.to_string f	×
95	\| `UnboxedField (p, f) ->	×
96	render_unresolved (p :> t) ^ "." ^ UnboxedFieldName.to_string f	×
97	\| `Extension (p, f) ->	×
98	render_unresolved (p :> t) ^ "." ^ ExtensionName.to_string f	×
99	\| `ExtensionDecl (p, f) ->	×
100	render_unresolved (p :> t) ^ "." ^ ExtensionName.to_string f	×
101	\| `Exception (p, f) ->	×
102	render_unresolved (p :> t) ^ "." ^ ExceptionName.to_string f	×
103	\| `Value (p, f) -> render_unresolved (p :> t) ^ "." ^ ValueName.to_string f	×
104	\| `Class (p, f) -> render_unresolved (p :> t) ^ "." ^ TypeName.to_string f	×
105	\| `ClassType (p, f) ->	×
106	render_unresolved (p :> t) ^ "." ^ TypeName.to_string f	×
107	\| `Method (p, f) ->	×
108	render_unresolved (p :> t) ^ "." ^ MethodName.to_string f	×
109	\| `InstanceVariable (p, f) ->	×
110	render_unresolved (p :> t) ^ "." ^ InstanceVariableName.to_string f	×
111	\| `Label (p, f) -> render_unresolved (p :> t) ^ "." ^ LabelName.to_string f	×
112
113	(* This is the entry point. *)
114	let to_ir : ?text:Inline.t -> Reference.t -> Inline.t =
115	fun ?text ref ->
116	match ref with	3,632✔
117	\| `Resolved r ->	3,250✔
118	(* IDENTIFIER MUST BE RENAMED TO DEFINITION. *)
119	let id = Reference.Resolved.identifier r in
120	let rendered = render_resolved r in	3,250✔
121	let content =	3,250✔
122	match text with
123	\| None -> [ inline @@ Inline.Source (source_of_code rendered) ]	1,955✔
124	\| Some s -> s	1,295✔
125	and tooltip =
126	(* Add a tooltip if the content is not the rendered reference. *)
127	match text with
128	\| None -> None	1,955✔
129	\| Some _ -> Some rendered	1,295✔
130	in
131	let target =
132	match id with
133	\| Some id ->	3,250✔
134	let url = Url.from_identifier ~stop_before:false id in
135	Target.Internal (Resolved url)	3,250✔
136	\| None -> Internal Unresolved	×
137	in
138	let link = { Link.target; content; tooltip } in
139	[ inline @@ Inline.Link link ]	3,250✔
140	\| _ -> (	382✔
141	let s = render_unresolved ref in
142	match text with	382✔
143	\| None ->	380✔
144	let s = source_of_code s in
145	[ inline @@ Inline.Source s ]	380✔
146	\| Some content ->	2✔
147	let link =
148	{ Link.target = Internal Unresolved; content; tooltip = Some s }
149	in
150	[ inline @@ Inline.Link link ])	2✔
151	end
152
153	let leaf_inline_element : Comment.leaf_inline_element -> Inline.one = function
154	\| `Space -> inline @@ Text " "	135,350✔
155	\| `Word s -> inline @@ Text s	145,743✔
156	\| `Code_span s -> inline @@ Source (source_of_code s)	5,500✔
157	\| `Math_span s -> inline @@ Math s	15✔
158	\| `Raw_markup (target, s) -> inline @@ Raw_markup (target, s)	17✔
159
160	let rec non_link_inline_element : Comment.non_link_inline_element -> Inline.one
161	= function
162	\| #Comment.leaf_inline_element as e -> leaf_inline_element e	2,722✔
163	\| `Styled (style, content) ->	96✔
164	inline @@ Styled (style, non_link_inline_element_list content)	96✔
165
166	and non_link_inline_element_list : _ -> Inline.t =
167	fun elements ->
168	List.map	1,518✔
169	(fun elt -> non_link_inline_element elt.Odoc_model.Location_.value)	2,818✔
170	elements
171
172	let link_content = non_link_inline_element_list
173
174	let rec inline_element : Comment.inline_element -> Inline.t = function
175	\| #Comment.leaf_inline_element as e -> [ leaf_inline_element e ]	283,903✔
176	\| `Styled (style, content) ->	653✔
177	[ inline @@ Styled (style, inline_element_list content) ]	653✔
178	\| `Reference (path, content) ->	3,552✔
179	(* TODO Rework that ugly function. *)
180	(* TODO References should be set in code style, if they are to code
181	elements. *)
182	let content =
183	match content with
184	\| [] -> None	2,255✔
185	\| _ -> Some (non_link_inline_element_list content)	1,297✔
186	(* XXX Span *)
187	in
188	Reference.to_ir ?text:content path
189	\| `Link (target, content) ->	129✔
190	let content =
191	match content with
192	\| [] -> [ inline @@ Text target ]	34✔
193	\| _ -> non_link_inline_element_list content	95✔
194	in
195	[ inline @@ Link { target = External target; content; tooltip = None } ]	129✔
196
197	and inline_element_list elements =
198	List.concat	14,122✔
199	@@ List.map	14,122✔
200	(fun elt -> inline_element elt.Odoc_model.Location_.value)	288,079✔
201	elements
202
203	let module_references ms =
204	let module_reference (m : Comment.module_reference) =	40✔
205	let reference =	80✔
206	Reference.to_ir (m.module_reference :> Odoc_model.Paths.Reference.t)	80✔
207	and synopsis =
208	match m.module_synopsis with
209	\| Some synopsis ->	24✔
210	[
211	block ~attr:[ "synopsis" ] @@ Inline (inline_element_list synopsis);	24✔
212	]
213	\| None -> []	56✔
214	in
215	{ Description.attr = []; key = reference; definition = synopsis }
216	in
217	let items = List.map module_reference ms in
218	block ~attr:[ "modules" ] @@ Description items	40✔
219
220	let rec nestable_block_element :
221	Comment.nestable_block_element -> Block.one list =
222	fun content ->
223	match content with	11,367✔
224	\| `Paragraph p -> [ paragraph p ]	10,836✔
225	\| `Code_block (lang_tag, code, outputs) ->	117✔
226	let lang_tag =
227	match lang_tag with None -> default_lang_tag \| Some t -> t	2✔
228	in
229	let rest =
230	match outputs with
231	\| Some xs -> nestable_block_element_list xs	×
232	\| None -> []	117✔
233	in
234	[
235	block	117✔
236	@@ Source (lang_tag, source_of_code (Odoc_model.Location_.value code));	117✔
237	]
238	@ rest
239	\| `Math_block s -> [ block @@ Math s ]	9✔
240	\| `Verbatim s -> [ block @@ Verbatim s ]	94✔
241	\| `Modules ms -> [ module_references ms ]	40✔
242	\| `List (kind, items) ->	188✔
243	let kind =
244	match kind with
245	\| `Unordered -> Block.Unordered	153✔
246	\| `Ordered -> Block.Ordered	35✔
247	in
248	let f = function
249	\| [ { Odoc_model.Location_.value = `Paragraph content; _ } ] ->	791✔
250	[ block @@ Block.Inline (inline_element_list content) ]	791✔
251	\| item -> nestable_block_element_list item	45✔
252	in
253	let items = List.map f items in
254	[ block @@ Block.List (kind, items) ]	188✔
255	\| `Table { data; align } ->	42✔
256	let data =
257	List.map
258	(List.map (fun (cell, cell_type) ->	42✔
259	(nestable_block_element_list cell, cell_type)))	268✔
260	data
261	in
262	let generate_align data =	42✔
263	let max (a : int) b = if a < b then b else a in	25✔
264	(* Length of the longest line of the table *)
265	let max_length =
266	List.fold_left (fun m l -> max m (List.length l)) 0 data	51✔
267	in
268	let rec list_init i =	25✔
269	if i <= 0 then [] else Table.Default :: list_init (i - 1)	25✔
270	in
271	list_init max_length
272	in
273	let align =
274	match align with
275	\| None -> generate_align data	25✔
276	\| Some align ->	17✔
277	List.map	17✔
278	(function
279	\| None -> Table.Default	18✔
280	\| Some `Right -> Right	16✔
281	\| Some `Left -> Left	16✔
282	\| Some `Center -> Center)	16✔
283	align
284	(* We should also check wellness of number of table cells vs alignment,
285	and raise warnings *)
286	in
287	[ block @@ Table { data; align } ]	42✔
288	\| `Media (href, media, content) ->	41✔
289	let content =
290	match (content, href) with
291	\| "", `Reference path ->	13✔
292	Reference.render_unresolved (path :> Comment.Reference.t)	13✔
293	\| "", `Link href -> href	13✔
294	\| _ -> content	15✔
295	in
296	let url =
297	match href with
298	\| `Reference (`Resolved r) -> (	9✔
299	let id =
300	Odoc_model.Paths.Reference.Resolved.Asset.(identifier (r :> t))	9✔
301	in
302	match Url.from_asset_identifier id with
303	\| url -> Target.Internal (Resolved url))	9✔
304	\| `Reference _ -> Internal Unresolved	10✔
305	\| `Link href -> External href	22✔
306	in
307	let i =
308	match media with
309	\| `Audio -> Block.Audio (url, content)	9✔
310	\| `Video -> Video (url, content)	9✔
311	\| `Image -> Image (url, content)	23✔
312	in
313	[ block i ]	41✔
314
315	and paragraph : Comment.paragraph -> Block.one = function
316	\| [ { value = `Raw_markup (target, s); _ } ] ->	9✔
317	block @@ Block.Raw_markup (target, s)
318	\| p -> block @@ Block.Paragraph (inline_element_list p)	11,583✔
319
320	and nestable_block_element_list :
321	Comment.nestable_block_element Comment.with_location list -> Block.one list
322	=
323	fun elements ->
324	elements	1,054✔
325	\|> List.map Odoc_model.Location_.value
326	\|> List.map nestable_block_element	1,054✔
327	\|> List.concat	1,054✔
328
329	let tag : Comment.tag -> Description.one =
330	fun t ->
331	let sp = inline (Text " ") in	846✔
332	let item ?value ~tag definition =	846✔
333	let tag_name = inline ~attr:[ "at-tag" ] (Text tag) in	846✔
334	let tag_value = match value with None -> [] \| Some t -> sp :: t in	189✔
335	let key = tag_name :: tag_value in
336	{ Description.attr = [ tag ]; key; definition }
337	in
338	let mk_value desc = [ inline ~attr:[ "value" ] desc ] in	499✔
339	let text_def s = [ block (Block.Inline [ inline @@ Text s ]) ] in	49✔
340	let content_to_inline ?(prefix = []) content =	40✔
341	match content with	56✔
342	\| None -> []	24✔
343	\| Some content -> prefix @ [ inline @@ Text content ]	32✔
344	in
345	match t with
346	\| `Author s -> item ~tag:"author" (text_def s)	16✔
347	\| `Deprecated content ->	59✔
348	item ~tag:"deprecated" (nestable_block_element_list content)	59✔
349	\| `Param (name, content) ->	24✔
350	let value = mk_value (Inline.Text name) in
351	item ~tag:"parameter" ~value (nestable_block_element_list content)	24✔
352	\| `Raise (kind, content) ->	158✔
353	let value = inline_element (kind :> Comment.inline_element) in
354	item ~tag:"raises" ~value (nestable_block_element_list content)	158✔
355	\| `Return content -> item ~tag:"returns" (nestable_block_element_list content)	25✔
356	\| `See (kind, target, content) ->	443✔
357	let value =
358	match kind with
359	\| `Url ->	403✔
360	mk_value	403✔
361	(Inline.Link
362	{
363	target = External target;
364	content = [ inline @@ Text target ];	403✔
365	tooltip = None;
366	})
367	\| `File -> mk_value (Inline.Source (source_of_code target))	16✔
368	\| `Document -> mk_value (Inline.Text target)	24✔
369	in
370	item ~tag:"see" ~value (nestable_block_element_list content)	443✔
371	\| `Since s -> item ~tag:"since" (text_def s)	17✔
372	\| `Before (version, content) ->	32✔
373	let value = mk_value (Inline.Text version) in
374	item ~tag:"before" ~value (nestable_block_element_list content)	32✔
375	\| `Version s -> item ~tag:"version" (text_def s)	16✔
376	\| `Alert ("deprecated", content) ->	40✔
377	let content = content_to_inline content in
378	item ~tag:"deprecated" [ block (Block.Inline content) ]	40✔
379	\| `Alert (tag, content) ->	16✔
380	let content = content_to_inline ~prefix:[ sp ] content in
381	item ~tag:"alert"	16✔
382	[ block (Block.Inline ([ inline @@ Text tag ] @ content)) ]	16✔
383
384	let attached_block_element : Comment.attached_block_element -> Block.t =
385	function
386	\| #Comment.nestable_block_element as e -> nestable_block_element e	10,276✔
387	\| `Tag t -> [ block ~attr:[ "at-tags" ] @@ Description [ tag t ] ]	846✔
388
389	(* TODO collaesce tags *)
390
391	let block_element : Comment.block_element -> Block.t = function
392	\| #Comment.attached_block_element as e -> attached_block_element e	8,863✔
393	\| `Heading (_, _, text) ->	202✔
394	(* We are not supposed to receive Heading in this context.
395	TODO: Remove heading in attached documentation in the model *)
396	[ block @@ Paragraph (inline_element_list text) ]	202✔
397
398	let heading_level_to_int = function
399	\| `Title -> 0	70✔
400	\| `Section -> 1	522✔
401	\| `Subsection -> 2	126✔
402	\| `Subsubsection -> 3	124✔
403	\| `Paragraph -> 4	19✔
404	\| `Subparagraph -> 5	8✔
405
406	let heading
407	(attrs, { Odoc_model.Paths.Identifier.iv = `Label (_, label); _ }, text) =
408	let label = Odoc_model.Names.LabelName.to_string label in	869✔
409	let title = inline_element_list text in	869✔
410	let level = heading_level_to_int attrs.Comment.heading_level in	869✔
411	let label = Some label in	869✔
412	let source_anchor = None in
413	Item.Heading { label; level; title; source_anchor }
414
415	let item_element : Comment.block_element -> Item.t list = function
416	\| #Comment.attached_block_element as e ->	980✔
417	[ Item.Text (attached_block_element e) ]	980✔
418	\| `Heading h -> [ heading h ]	32✔
419
420	(** The documentation of the expansion is used if there is no comment attached
421	to the declaration. *)
422	let synopsis ~decl_doc ~expansion_doc =
423	let ([], Some docs \| docs, _) = (decl_doc, expansion_doc) in	3,445✔
424	match Comment.synopsis docs with Some p -> [ paragraph p ] \| None -> []	756✔
425
426	let standalone docs =
427	List.concat_map item_element	6,628✔
428	@@ List.map (fun x -> x.Odoc_model.Location_.value) docs	1,012✔
429
430	let to_ir (docs : Comment.elements) =
431	List.concat_map block_element	10,305✔
432	@@ List.map (fun x -> x.Odoc_model.Location_.value) docs	9,065✔
433
434	let has_doc docs = docs <> []	591✔

ocaml / odoc / 3283

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