2735

Committed 15 Jan 2025 05:29PM UTC coverage: 73.399% (-0.07%) from 73.471%

Build # 2735

Build Type

push

github

Committed by

jonludlam

Commit Message

Update test results

Run Details

10256 of 13973 relevant lines covered (73.4%)

9962.83 hits per line

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

77.19

/src/odoc/compile.ml

open Odoc_model
open Odoc_model.Names
open Or_error
open Odoc_utils

(*
 * Copyright (c) 2014 Leo White <leo@lpw25.net>
 *
 * 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.
 *)

type package_spec = { package : string; output : Fpath.t }
type parent_spec = {
  parent : string option;
  children : string list;
  output : Fpath.t;
}

type parent_id_spec = { parent_id : string; output_dir : string }

type cli_spec =
  | CliNoParent of Fpath.t
  | CliPackage of package_spec
  | CliParent of parent_spec
  | CliParentId of parent_id_spec

type spec = {
  parent_id : Paths.Identifier.ContainerPage.t option;
  output : Fpath.t;
  parents_children : Lang.Page.child list option;
  children : string list;
}

let rec path_of_id output_dir id =
  match id with
  | None -> Fpath.v output_dir
  | Some id -> (
      match (id : Paths.Identifier.ContainerPage.t).iv with
      | `Page (parent, p) ->
          let d = path_of_id output_dir parent in
          Fpath.(d / PageName.to_string p))

let check_is_empty msg = function [] -> Ok () | _ :: _ -> Error (`Msg msg)

(** Used to disambiguate child references. *)
let is_module_name n = String.length n > 0 && Char.Ascii.is_upper n.[0]

(** Accepted child references:

    - [asset-foo] child is an arbitrary asset
    - [module-Foo] child is a module.
    - [module-foo], [Foo] child is a module, for backward compatibility.
    - [page-foo] child is a container or leaf page.
    - [srctree-foo] child is a source tree

  Parses [...-"foo"] as [...-foo] for backward compatibility. *)
let parse_parent_child_reference s =
  let unquote s =
    let len = String.length s in
    if String.head s = Some '"' && String.head ~rev:true s = Some '"' && len > 1
    then String.with_range ~first:1 ~len:(len - 2) s
    else s
  in
  match String.cut ~sep:"-" s with
  | Some ("page", n) -> Ok (Lang.Page.Page_child (unquote n))
  | Some ("module", n) ->
      Ok (Module_child (unquote (String.Ascii.capitalize n)))
  | Some ("src", _) -> Error (`Msg "Implementation unexpected")
  | Some (k, _) -> Error (`Msg ("Unrecognized kind: " ^ k))
  | None -> if is_module_name s then Ok (Module_child s) else Ok (Page_child s)

let resolve_parent_page resolver f =
  let find_parent = function
    | Lang.Page.Page_child p -> (
        match Resolver.lookup_page resolver p with
        | Some r -> Ok r
        | None -> Error (`Msg "Couldn't find specified parent page"))
    | Module_child _ -> Error (`Msg "Expecting page as parent")
  in
  let extract_parent = function
    | { Paths.Identifier.iv = `Page _; _ } as container -> Ok container
    | { Paths.Identifier.iv = `LeafPage _; _ } ->
        Error (`Msg "Specified parent is not a parent of this file")
  in
  parse_parent_child_reference f >>= fun r ->
  find_parent r >>= fun page ->
  extract_parent page.name >>= fun parent -> Ok (parent, page.children)

let mk_id str =
  match str with
  | "" -> None
  | str -> (
      let l = String.cuts ~sep:"/" str in
      List.fold_left
        (fun acc id ->
          Some (Paths.Identifier.Mk.page (acc, PageName.make_std id)))
        None l
      |> function
      | Some x -> Some x
      | None -> failwith "Failed to create ID")

let resolve_imports resolver imports =
  List.map
    (function
      | Lang.Compilation_unit.Import.Resolved _ as resolved -> resolved
      | Unresolved (name, _) as unresolved -> (
          match Resolver.resolve_import resolver name with
          | Some root -> Resolved (root, Names.ModuleName.make_std name)
          | None -> unresolved))
    imports

(** Raises warnings and errors. *)
let resolve_and_substitute ~resolver ~make_root ~hidden ~suppress_warnings
    (parent : Paths.Identifier.ContainerPage.t option) input_file input_type =
  let filename = Fs.File.to_string input_file in
  let unit =
    match input_type with
    | `Cmti ->
        Odoc_loader.read_cmti ~make_root ~parent ~filename ~suppress_warnings
        |> Error.raise_errors_and_warnings
    | `Cmt ->
        Odoc_loader.read_cmt ~make_root ~parent ~filename ~suppress_warnings
        |> Error.raise_errors_and_warnings
    | `Cmi ->
        Odoc_loader.read_cmi ~make_root ~parent ~filename ~suppress_warnings
        |> Error.raise_errors_and_warnings
  in
  let unit = { unit with hidden = hidden || unit.hidden } in
  if not unit.Lang.Compilation_unit.interface then
    Printf.eprintf "WARNING: not processing the \"interface\" file.%s\n%!"
      (if not (Filename.check_suffix filename "cmt") then "" (* ? *)
       else
         Printf.sprintf " Using %S while you should use the .cmti file" filename);
  (* Resolve imports, used by the [link-deps] command. *)
  let unit = { unit with imports = resolve_imports resolver unit.imports } in
  let env = Resolver.build_compile_env_for_unit resolver unit in
  let compiled =
    Odoc_xref2.Compile.compile ~filename env unit |> Error.raise_warnings
  in
  (* [expand unit] fetches [unit] from [env] to get the expansion of local, previously
     defined, elements. We'd rather it got back the resolved bit so we rebuild an
     environment with the resolved unit.
     Note that this is bad and once rewritten expand should not fetch the unit it is
     working on. *)
  (*    let expand_env = Env.build env (`Unit resolved) in*)
  (*    let expanded = Odoc_xref2.Expand.expand (Env.expander expand_env) resolved in *)
  compiled

let root_of_compilation_unit ~parent_id ~parents_children ~hidden ~output
    ~module_name ~digest =
  let open Root in
  let result parent =
    let file = Odoc_file.create_unit ~force_hidden:hidden module_name in
    Ok
      {
        id = Paths.Identifier.Mk.root (parent, ModuleName.make_std module_name);
        file;
        digest;
      }
  in
  let check_child = function
    | Lang.Page.Module_child n ->
        let filename =
          Filename.chop_extension Fs.File.(to_string @@ basename output)
        in
        String.Ascii.(uncapitalize n = uncapitalize filename)
    | Page_child _ -> false
  in
  match parents_children with
  | Some parents_children ->
      if List.exists check_child parents_children then result parent_id
      else Error (`Msg "Specified parent is not a parent of this file")
  | None -> result parent_id

(*
     let d = path_of_id parent in
     Fs.Directory.mkdir_p (Fs.Directory.of_string (Fpath.to_string d));
     let file = Odoc_file.create_unit ~force_hidden:hidden module_name in
     Ok {
       id = Paths.Identifier.Mk.root (Some parent, ModuleName.make_std module_name);
       file;
       digest;
     }
   in *)

let name_of_output ~prefix output =
  let page_dash_root =
    Filename.chop_extension Fs.File.(to_string @@ basename output)
  in
  String.drop ~max:(String.length prefix) page_dash_root

let page_name_of_output output = name_of_output ~prefix:"page-" output

let is_index_page = function
  | { Paths.Identifier.iv = `Page _; _ } -> false
  | { iv = `LeafPage (_, p); _ } ->
      Astring.String.equal (Names.PageName.to_string p) "index"

let has_children_order { Frontmatter.children_order; _ } =
  Option.is_some children_order

let mld ~parent_id ~parents_children ~output ~children ~warnings_options
    ~short_title input =
  List.fold_left
    (fun acc child_str ->
      match (acc, parse_parent_child_reference child_str) with
      | Ok acc, Ok r -> Ok (r :: acc)
      | Error m, _ -> Error m
      | _, Error (`Msg m) ->
          Error (`Msg ("Failed to parse child reference: " ^ m))
      | _, Error _ -> Error (`Msg "Unknown failure parsing child reference"))
    (Ok []) children
  >>= fun children ->
  let root_name = page_name_of_output output in
  let input_s = Fs.File.to_string input in
  let digest = Digest.file input_s in
  let page_name = PageName.make_std root_name in
  let check_child = function
    | Lang.Page.Page_child n -> root_name = n
    | Module_child _ -> false
  in
  (if children = [] then
     (* No children, this is a leaf page. *)
     Ok (Paths.Identifier.Mk.leaf_page (parent_id, page_name))
   else
     (* Has children, this is a container page. *)
     let check parents_children =
       if List.exists check_child parents_children then Ok ()
       else Error (`Msg "Specified parent is not a parent of this file")
     in
     (match parents_children with
     | Some parents_children ->
         check parents_children >>= fun () ->
         Ok (Paths.Identifier.Mk.page (parent_id, page_name))
     | None -> Ok (Paths.Identifier.Mk.page (parent_id, page_name)))
     >>= fun id -> Ok (id :> Paths.Identifier.Page.t))
  >>= fun id ->
  let resolve content frontmatter =
    let zero_heading = Comment.find_zero_heading content.Comment.elements in
    if (not (is_index_page id)) && has_children_order frontmatter then
      Error.raise_warning
        (Error.filename_only "Non-index page cannot specify @children_order."
           input_s);
    let root =
      let file =
        Root.Odoc_file.create_page root_name zero_heading frontmatter
      in
      { Root.id = (id :> Paths.Identifier.OdocId.t); file; digest }
    in
    let rec conv :
        Comment.inline_element -> Comment.non_link_inline_element option =
      function
      | #Comment.leaf_inline_element as e -> Some e
      | `Styled (s, es) ->
          Some
            (`Styled
              ( s,
                List.filter_map
                  (function
                    | { Location_.location; value } -> (
                        match conv value with
                        | Some value -> Some { Location_.location; value }
                        | None -> None))
                  es ))
      | `Reference _ | `Link _ -> None
    in
    let frontmatter =
      match short_title with
      | None -> frontmatter
      | Some t -> (
          let t =
            Odoc_parser.parse_comment ~location:Lexing.dummy_pos ~text:t
          in
          let v = Odoc_parser.ast t in
          let parent_of_sections =
            Odoc_model.Paths.Identifier.Mk.page
              (None, Odoc_model.Names.PageName.make_std "None")
          in
          let v =
            Odoc_model.Semantics.ast_to_comment ~internal_tags:Expect_none
              ~tags_allowed:false ~parent_of_sections v []
          in
          let v, _ = Error.raise_warnings v in
          match v with
          | { location = _; value = `Paragraph ({ value = e; location } :: _) }
            :: _ -> (
              match conv e with
              | None -> frontmatter
              | Some e ->
                  {
                    frontmatter with
                    short_title = Some [ { value = e; location } ];
                  })
          | _ -> frontmatter)
    in
    let page =
      Lang.Page.
        {
          name = id;
          root;
          children;
          content;
          digest;
          linked = false;
          frontmatter;
        }
    in
    Odoc_file.save_page output ~warnings:[] page;
    ()
  in
  Fs.File.read input >>= fun str ->
  Error.handle_errors_and_warnings ~warnings_options
  @@ Error.catch_errors_and_warnings
  @@ fun () ->
  Odoc_loader.read_string (id :> Paths.Identifier.LabelParent.t) input_s str
  |> Error.raise_errors_and_warnings
  |> function
  | content, page_tags -> resolve content page_tags

let handle_file_ext ext =
  match ext with
  | ".cmti" -> Ok `Cmti
  | ".cmt" -> Ok `Cmt
  | ".cmi" -> Ok `Cmi
  | _ ->
      Error (`Msg "Unknown extension, expected one of: cmti, cmt, cmi or mld.")

let resolve_spec ~input resolver cli_spec =
  match cli_spec with
  | CliParent { parent; children; output } ->
      (let root_name = name_of_output ~prefix:"page-" output in
       match root_name with
       | "index" ->
           Format.eprintf
             "Warning: Potential name clash - child page named 'index'\n%!"
       | _ -> ());
      let parent =
        match parent with
        | Some parent -> (
            match resolve_parent_page resolver parent with
            | Ok (parent_id, parents_children) ->
                Ok (Some parent_id, Some parents_children)
            | Error e -> Error e)
        | None -> Ok (None, None)
      in
      parent >>= fun (parent_id, parents_children) ->
      Ok { parent_id; parents_children; children; output }
  | CliPackage { package; output } ->
      Ok
        {
          parent_id =
            Some (Paths.Identifier.Mk.page (None, PageName.make_std package));
          output;
          parents_children = None;
          children = [];
        }
  | CliParentId { parent_id; output_dir } ->
      let parent_id = mk_id parent_id in
      let directory =
        path_of_id output_dir parent_id
        |> Fpath.to_string |> Fs.Directory.of_string
      in
      let name =
        let ext = Fs.File.get_ext input in
        let name = Fs.File.set_ext ".odoc" input in
        let name = Fs.File.basename name in
        if ext = ".mld" then "page-" ^ Fs.File.to_string name
        else name |> Fpath.to_string |> String.Ascii.uncapitalize
      in
      let output = Fs.File.create ~directory ~name in
      Ok { parent_id; output; parents_children = None; children = [] }
  | CliNoParent output ->
      Ok { output; parent_id = None; parents_children = None; children = [] }

let compile ~resolver ~hidden ~cli_spec ~warnings_options ~short_title input =
  resolve_spec ~input resolver cli_spec
  >>= fun { parent_id; output; parents_children; children } ->
  let ext = Fs.File.get_ext input in
  if ext = ".mld" then
    mld ~parent_id ~parents_children ~output ~warnings_options ~children
      ~short_title input
  else
    check_is_empty "Not expecting children (--child) when compiling modules."
      children
    >>= fun () ->
    handle_file_ext ext >>= fun input_type ->
    let make_root =
      root_of_compilation_unit ~parent_id ~parents_children ~hidden ~output
    in
    let result =
      Error.catch_errors_and_warnings (fun () ->
          resolve_and_substitute ~resolver ~make_root ~hidden
            ~suppress_warnings:warnings_options.suppress_warnings parent_id
            input input_type)
    in
    (* Extract warnings to write them into the output file *)
    let _, warnings = Error.unpack_warnings result in
    Error.handle_errors_and_warnings ~warnings_options result >>= fun unit ->
    Odoc_file.save_unit output ~warnings unit;
    Ok ()

1	open Odoc_model
2	open Odoc_model.Names
3	open Or_error
4	open Odoc_utils
5
6	(*
7	* Copyright (c) 2014 Leo White <leo@lpw25.net>
8	*
9	* Permission to use, copy, modify, and distribute this software for any
10	* purpose with or without fee is hereby granted, provided that the above
11	* copyright notice and this permission notice appear in all copies.
12	*
13	* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
14	* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
15	* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
16	* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
17	* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
18	* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
19	* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
20	*)
21
22	type package_spec = { package : string; output : Fpath.t }
23	type parent_spec = {
24	parent : string option;
25	children : string list;
26	output : Fpath.t;
27	}
28
29	type parent_id_spec = { parent_id : string; output_dir : string }
30
31	type cli_spec =
32	\| CliNoParent of Fpath.t
33	\| CliPackage of package_spec
34	\| CliParent of parent_spec
35	\| CliParentId of parent_id_spec
36
37	type spec = {
38	parent_id : Paths.Identifier.ContainerPage.t option;
39	output : Fpath.t;
40	parents_children : Lang.Page.child list option;
41	children : string list;
42	}
43
44	let rec path_of_id output_dir id =
45	match id with	185✔
46	\| None -> Fpath.v output_dir	72✔
47	\| Some id -> (	113✔
48	match (id : Paths.Identifier.ContainerPage.t).iv with
49	\| `Page (parent, p) ->	113✔
50	let d = path_of_id output_dir parent in
51	Fpath.(d / PageName.to_string p))	113✔
52
53	let check_is_empty msg = function [] -> Ok () \| _ :: _ -> Error (`Msg msg)	×
54
55	(** Used to disambiguate child references. *)
56	let is_module_name n = String.length n > 0 && Char.Ascii.is_upper n.[0]	31✔
57
58	(** Accepted child references:
59
60	- [asset-foo] child is an arbitrary asset
61	- [module-Foo] child is a module.
62	- [module-foo], [Foo] child is a module, for backward compatibility.
63	- [page-foo] child is a container or leaf page.
64	- [srctree-foo] child is a source tree
65
66	Parses [...-"foo"] as [...-foo] for backward compatibility. *)
67	let parse_parent_child_reference s =
68	let unquote s =	48✔
69	let len = String.length s in	17✔
70	if String.head s = Some '"' && String.head ~rev:true s = Some '"' && len > 1	×
71	then String.with_range ~first:1 ~len:(len - 2) s	×
72	else s	17✔
73	in
74	match String.cut ~sep:"-" s with
75	\| Some ("page", n) -> Ok (Lang.Page.Page_child (unquote n))	8✔
76	\| Some ("module", n) ->	9✔
77	Ok (Module_child (unquote (String.Ascii.capitalize n)))	9✔
78	\| Some ("src", _) -> Error (`Msg "Implementation unexpected")	×
79	\| Some (k, _) -> Error (`Msg ("Unrecognized kind: " ^ k))	×
80	\| None -> if is_module_name s then Ok (Module_child s) else Ok (Page_child s)	7✔
81
82	let resolve_parent_page resolver f =
83	let find_parent = function	24✔
84	\| Lang.Page.Page_child p -> (	23✔
85	match Resolver.lookup_page resolver p with
86	\| Some r -> Ok r	23✔
87	\| None -> Error (`Msg "Couldn't find specified parent page"))	×
88	\| Module_child _ -> Error (`Msg "Expecting page as parent")	1✔
89	in
90	let extract_parent = function
91	\| { Paths.Identifier.iv = `Page _; _ } as container -> Ok container	23✔
92	\| { Paths.Identifier.iv = `LeafPage _; _ } ->	×
93	Error (`Msg "Specified parent is not a parent of this file")
94	in
95	parse_parent_child_reference f >>= fun r ->	24✔
96	find_parent r >>= fun page ->	24✔
97	extract_parent page.name >>= fun parent -> Ok (parent, page.children)	23✔
98
99	let mk_id str =
100	match str with	98✔
101	\| "" -> None	3✔
102	\| str -> (	95✔
103	let l = String.cuts ~sep:"/" str in
104	List.fold_left	95✔
105	(fun acc id ->
106	Some (Paths.Identifier.Mk.page (acc, PageName.make_std id)))	145✔
107	None l
108	\|> function	95✔
109	\| Some x -> Some x	95✔
110	\| None -> failwith "Failed to create ID")	×
111
112	let resolve_imports resolver imports =
113	List.map	267✔
114	(function
115	\| Lang.Compilation_unit.Import.Resolved _ as resolved -> resolved	×
116	\| Unresolved (name, _) as unresolved -> (	754✔
117	match Resolver.resolve_import resolver name with
118	\| Some root -> Resolved (root, Names.ModuleName.make_std name)	173✔
119	\| None -> unresolved))	581✔
120	imports
121
122	(** Raises warnings and errors. *)
123	let resolve_and_substitute ~resolver ~make_root ~hidden ~suppress_warnings
124	(parent : Paths.Identifier.ContainerPage.t option) input_file input_type =
125	let filename = Fs.File.to_string input_file in	236✔
126	let unit =	236✔
127	match input_type with
128	\| `Cmti ->	157✔
129	Odoc_loader.read_cmti ~make_root ~parent ~filename ~suppress_warnings
130	\|> Error.raise_errors_and_warnings	156✔
131	\| `Cmt ->	79✔
132	Odoc_loader.read_cmt ~make_root ~parent ~filename ~suppress_warnings
133	\|> Error.raise_errors_and_warnings	79✔
134	\| `Cmi ->	×
135	Odoc_loader.read_cmi ~make_root ~parent ~filename ~suppress_warnings
136	\|> Error.raise_errors_and_warnings	×
137	in
138	let unit = { unit with hidden = hidden \|\| unit.hidden } in	1✔
139	if not unit.Lang.Compilation_unit.interface then
140	Printf.eprintf "WARNING: not processing the \"interface\" file.%s\n%!"	×
141	(if not (Filename.check_suffix filename "cmt") then "" (* ? *)	×
142	else
143	Printf.sprintf " Using %S while you should use the .cmti file" filename);	×
144	(* Resolve imports, used by the [link-deps] command. *)
145	let unit = { unit with imports = resolve_imports resolver unit.imports } in	235✔
146	let env = Resolver.build_compile_env_for_unit resolver unit in
147	let compiled =	235✔
148	Odoc_xref2.Compile.compile ~filename env unit \|> Error.raise_warnings	235✔
149	in
150	(* [expand unit] fetches [unit] from [env] to get the expansion of local, previously
151	defined, elements. We'd rather it got back the resolved bit so we rebuild an
152	environment with the resolved unit.
153	Note that this is bad and once rewritten expand should not fetch the unit it is
154	working on. *)
155	(* let expand_env = Env.build env (`Unit resolved) in*)
156	(* let expanded = Odoc_xref2.Expand.expand (Env.expander expand_env) resolved in *)
157	compiled	235✔
158
159	let root_of_compilation_unit ~parent_id ~parents_children ~hidden ~output
160	~module_name ~digest =
161	let open Root in	236✔
162	let result parent =
163	let file = Odoc_file.create_unit ~force_hidden:hidden module_name in	235✔
164	Ok	235✔
165	{
166	id = Paths.Identifier.Mk.root (parent, ModuleName.make_std module_name);	235✔
167	file;
168	digest;
169	}
170	in
171	let check_child = function
172	\| Lang.Page.Module_child n ->	21✔
173	let filename =
174	Filename.chop_extension Fs.File.(to_string @@ basename output)	21✔
175	in
176	String.Ascii.(uncapitalize n = uncapitalize filename)	21✔
177	\| Page_child _ -> false	1✔
178	in
179	match parents_children with
180	\| Some parents_children ->	15✔
181	if List.exists check_child parents_children then result parent_id	14✔
182	else Error (`Msg "Specified parent is not a parent of this file")	1✔
183	\| None -> result parent_id	221✔
184
185	(*
186	let d = path_of_id parent in
187	Fs.Directory.mkdir_p (Fs.Directory.of_string (Fpath.to_string d));
188	let file = Odoc_file.create_unit ~force_hidden:hidden module_name in
189	Ok {
190	id = Paths.Identifier.Mk.root (Some parent, ModuleName.make_std module_name);
191	file;
192	digest;
193	}
194	in *)
195
196	let name_of_output ~prefix output =
197	let page_dash_root =	126✔
198	Filename.chop_extension Fs.File.(to_string @@ basename output)	126✔
199	in
200	String.drop ~max:(String.length prefix) page_dash_root	126✔
201
202	let page_name_of_output output = name_of_output ~prefix:"page-" output	89✔
203
204	let is_index_page = function
205	\| { Paths.Identifier.iv = `Page _; _ } -> false	18✔
206	\| { iv = `LeafPage (_, p); _ } ->	71✔
207	Astring.String.equal (Names.PageName.to_string p) "index"	71✔
208
209	let has_children_order { Frontmatter.children_order; _ } =
210	Option.is_some children_order	60✔
211
212	let mld ~parent_id ~parents_children ~output ~children ~warnings_options
213	~short_title input =
214	List.fold_left	89✔
215	(fun acc child_str ->
216	match (acc, parse_parent_child_reference child_str) with	24✔
217	\| Ok acc, Ok r -> Ok (r :: acc)	24✔
218	\| Error m, _ -> Error m	×
219	\| _, Error (`Msg m) ->	×
220	Error (`Msg ("Failed to parse child reference: " ^ m))
221	\| _, Error _ -> Error (`Msg "Unknown failure parsing child reference"))	×
222	(Ok []) children
223	>>= fun children ->
224	let root_name = page_name_of_output output in	89✔
225	let input_s = Fs.File.to_string input in	89✔
226	let digest = Digest.file input_s in	89✔
227	let page_name = PageName.make_std root_name in	89✔
228	let check_child = function	89✔
229	\| Lang.Page.Page_child n -> root_name = n	6✔
230	\| Module_child _ -> false	1✔
231	in
232	(if children = [] then
233	(* No children, this is a leaf page. *)
234	Ok (Paths.Identifier.Mk.leaf_page (parent_id, page_name))	71✔
235	else
236	(* Has children, this is a container page. *)
237	let check parents_children =	18✔
238	if List.exists check_child parents_children then Ok ()	5✔
239	else Error (`Msg "Specified parent is not a parent of this file")	×
240	in
241	(match parents_children with
242	\| Some parents_children ->	5✔
243	check parents_children >>= fun () ->	5✔
244	Ok (Paths.Identifier.Mk.page (parent_id, page_name))	5✔
245	\| None -> Ok (Paths.Identifier.Mk.page (parent_id, page_name)))	13✔
246	>>= fun id -> Ok (id :> Paths.Identifier.Page.t))	18✔
247	>>= fun id ->
248	let resolve content frontmatter =	89✔
249	let zero_heading = Comment.find_zero_heading content.Comment.elements in	89✔
250	if (not (is_index_page id)) && has_children_order frontmatter then	60✔
251	Error.raise_warning	3✔
252	(Error.filename_only "Non-index page cannot specify @children_order."	3✔
253	input_s);
254	let root =	89✔
255	let file =
256	Root.Odoc_file.create_page root_name zero_heading frontmatter
257	in
258	{ Root.id = (id :> Paths.Identifier.OdocId.t); file; digest }	89✔
259	in
260	let rec conv :
261	Comment.inline_element -> Comment.non_link_inline_element option =
262	function
263	\| #Comment.leaf_inline_element as e -> Some e	×
264	\| `Styled (s, es) ->	×
265	Some
266	(`Styled
267	( s,
268	List.filter_map	×
269	(function
270	\| { Location_.location; value } -> (	×
271	match conv value with
272	\| Some value -> Some { Location_.location; value }	×
273	\| None -> None))	×
274	es ))
275	\| `Reference _ \| `Link _ -> None	×
276	in
277	let frontmatter =
278	match short_title with
279	\| None -> frontmatter	89✔
280	\| Some t -> (	×
281	let t =
282	Odoc_parser.parse_comment ~location:Lexing.dummy_pos ~text:t
283	in
284	let v = Odoc_parser.ast t in
285	let parent_of_sections =	×
286	Odoc_model.Paths.Identifier.Mk.page
287	(None, Odoc_model.Names.PageName.make_std "None")	×
288	in
289	let v =	×
290	Odoc_model.Semantics.ast_to_comment ~internal_tags:Expect_none
291	~tags_allowed:false ~parent_of_sections v []
292	in
293	let v, _ = Error.raise_warnings v in	×
294	match v with	×
295	\| { location = _; value = `Paragraph ({ value = e; location } :: _) }	×
296	:: _ -> (
297	match conv e with
298	\| None -> frontmatter	×
299	\| Some e ->	×
300	{
301	frontmatter with
302	short_title = Some [ { value = e; location } ];
303	})
304	\| _ -> frontmatter)	×
305	in
306	let page =
307	Lang.Page.
308	{
309	name = id;
310	root;
311	children;
312	content;
313	digest;
314	linked = false;
315	frontmatter;
316	}
317	in
318	Odoc_file.save_page output ~warnings:[] page;
319	()	89✔
320	in
321	Fs.File.read input >>= fun str ->	89✔
322	Error.handle_errors_and_warnings ~warnings_options	89✔
323	@@ Error.catch_errors_and_warnings	89✔
324	@@ fun () ->
325	Odoc_loader.read_string (id :> Paths.Identifier.LabelParent.t) input_s str	89✔
326	\|> Error.raise_errors_and_warnings	89✔
327	\|> function	89✔
328	\| content, page_tags -> resolve content page_tags	89✔
329
330	let handle_file_ext ext =
331	match ext with	236✔
332	\| ".cmti" -> Ok `Cmti	157✔
333	\| ".cmt" -> Ok `Cmt	79✔
334	\| ".cmi" -> Ok `Cmi	×
335	\| _ ->	×
336	Error (`Msg "Unknown extension, expected one of: cmti, cmt, cmi or mld.")
337
338	let resolve_spec ~input resolver cli_spec =
339	match cli_spec with	326✔
340	\| CliParent { parent; children; output } ->	37✔
341	(let root_name = name_of_output ~prefix:"page-" output in
342	match root_name with	37✔
343	\| "index" ->	×
344	Format.eprintf	×
345	"Warning: Potential name clash - child page named 'index'\n%!"
346	\| _ -> ());	37✔
347	let parent =
348	match parent with
349	\| Some parent -> (	24✔
350	match resolve_parent_page resolver parent with
351	\| Ok (parent_id, parents_children) ->	23✔
352	Ok (Some parent_id, Some parents_children)
353	\| Error e -> Error e)	1✔
354	\| None -> Ok (None, None)	13✔
355	in
356	parent >>= fun (parent_id, parents_children) ->
357	Ok { parent_id; parents_children; children; output }	36✔
358	\| CliPackage { package; output } ->	67✔
359	Ok
360	{
361	parent_id =
362	Some (Paths.Identifier.Mk.page (None, PageName.make_std package));	67✔
363	output;
364	parents_children = None;
365	children = [];
366	}
367	\| CliParentId { parent_id; output_dir } ->	67✔
368	let parent_id = mk_id parent_id in
369	let directory =	67✔
370	path_of_id output_dir parent_id
371	\|> Fpath.to_string \|> Fs.Directory.of_string	67✔
372	in
373	let name =	67✔
374	let ext = Fs.File.get_ext input in
375	let name = Fs.File.set_ext ".odoc" input in	67✔
376	let name = Fs.File.basename name in	67✔
377	if ext = ".mld" then "page-" ^ Fs.File.to_string name	55✔
378	else name \|> Fpath.to_string \|> String.Ascii.uncapitalize	12✔
379	in
380	let output = Fs.File.create ~directory ~name in
381	Ok { parent_id; output; parents_children = None; children = [] }
382	\| CliNoParent output ->	155✔
383	Ok { output; parent_id = None; parents_children = None; children = [] }
384
385	let compile ~resolver ~hidden ~cli_spec ~warnings_options ~short_title input =
386	resolve_spec ~input resolver cli_spec	326✔
387	>>= fun { parent_id; output; parents_children; children } ->
388	let ext = Fs.File.get_ext input in	325✔
389	if ext = ".mld" then	325✔
390	mld ~parent_id ~parents_children ~output ~warnings_options ~children	89✔
391	~short_title input
392	else
393	check_is_empty "Not expecting children (--child) when compiling modules."	236✔
394	children
395	>>= fun () ->
396	handle_file_ext ext >>= fun input_type ->	236✔
397	let make_root =	236✔
398	root_of_compilation_unit ~parent_id ~parents_children ~hidden ~output
399	in
400	let result =
401	Error.catch_errors_and_warnings (fun () ->
402	resolve_and_substitute ~resolver ~make_root ~hidden	236✔
403	~suppress_warnings:warnings_options.suppress_warnings parent_id
404	input input_type)
405	in
406	(* Extract warnings to write them into the output file *)
407	let _, warnings = Error.unpack_warnings result in	236✔
408	Error.handle_errors_and_warnings ~warnings_options result >>= fun unit ->	236✔
409	Odoc_file.save_unit output ~warnings unit;	233✔
410	Ok ()	233✔

ocaml / odoc / 2735

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