2403

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

Build # 2403

Build Type

Pull #1193

github

Committed by

web-flow

Commit Message

Merge 93aa604a2 into 0ba1fdbe6

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

Run Details

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

60 existing lines in 5 files now uncovered.

10248 of 14044 relevant lines covered (72.97%)

2965.35 hits per line

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

85.16

/src/odoc/compile.ml

open Astring
open Odoc_model
open Odoc_model.Names
open Or_error

(*
 * 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
    (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
        |> Error.raise_errors_and_warnings
    | `Cmt ->
        Odoc_loader.read_cmt ~make_root ~parent ~filename
        |> Error.raise_errors_and_warnings
    | `Cmi ->
        Odoc_loader.read_cmi ~make_root ~parent ~filename
        |> 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); _ } ->
      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 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 name ->
  let resolve content =
    let zero_heading = Comment.find_zero_heading content in
    let frontmatter, content = Comment.extract_frontmatter content in
    if (not (is_index_page name)) && has_children_order frontmatter then
      Error.raise_warning
        (Error.filename_only
           "Non-index page cannot specify (children _) in the frontmatter."
           input_s);
    let root =
      let file =
        Root.Odoc_file.create_page root_name zero_heading frontmatter
      in
      { Root.id = (name :> Paths.Identifier.OdocId.t); file; digest }
    in
    let page =
      Lang.Page.
        { name; 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 (name :> Paths.Identifier.LabelParent.t) input_s str
  |> Error.raise_errors_and_warnings
  |> function
  | `Stop -> resolve [] (* TODO: Error? *)
  | `Docs content -> resolve content

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 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 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 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 Astring
2	open Odoc_model
3	open Odoc_model.Names
4	open Or_error
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	122✔
46	\| None -> Fpath.v output_dir	36✔
47	\| Some id -> (	86✔
48	match (id : Paths.Identifier.ContainerPage.t).iv with
49	\| `Page (parent, p) ->	86✔
50	let d = path_of_id output_dir parent in
51	Fpath.(d / PageName.to_string p))	86✔
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]	30✔
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 =	46✔
69	let len = String.length s in	16✔
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	16✔
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) ->	8✔
77	Ok (Module_child (unquote (String.Ascii.capitalize n)))	8✔
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	23✔
84	\| Lang.Page.Page_child p -> (	22✔
85	match Resolver.lookup_page resolver p with
86	\| Some r -> Ok r	22✔
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	22✔
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 ->	23✔
96	find_parent r >>= fun page ->	23✔
97	extract_parent page.name >>= fun parent -> Ok (parent, page.children)	22✔
98
99	let mk_id str =
100	match str with	61✔
101	\| "" -> None	1✔
102	\| str -> (	60✔
103	let l = String.cuts ~sep:"/" str in
104	List.fold_left	60✔
105	(fun acc id ->
106	Some (Paths.Identifier.Mk.page (acc, PageName.make_std id)))	115✔
107	None l
108	\|> function	60✔
109	\| Some x -> Some x	60✔
110	\| None -> failwith "Failed to create ID")	×
111
112	let resolve_imports resolver imports =
113	List.map	247✔
114	(function
115	\| Lang.Compilation_unit.Import.Resolved _ as resolved -> resolved	×
116	\| Unresolved (name, _) as unresolved -> (	712✔
117	match Resolver.resolve_import resolver name with
118	\| Some root -> Resolved (root, Names.ModuleName.make_std name)	171✔
119	\| None -> unresolved))	541✔
120	imports
121
122	(** Raises warnings and errors. *)
123	let resolve_and_substitute ~resolver ~make_root ~hidden
124	(parent : Paths.Identifier.ContainerPage.t option) input_file input_type =
125	let filename = Fs.File.to_string input_file in	217✔
126	let unit =	217✔
127	match input_type with
128	\| `Cmti ->	145✔
129	Odoc_loader.read_cmti ~make_root ~parent ~filename
130	\|> Error.raise_errors_and_warnings	144✔
131	\| `Cmt ->	72✔
132	Odoc_loader.read_cmt ~make_root ~parent ~filename
133	\|> Error.raise_errors_and_warnings	72✔
134	\| `Cmi ->	×
135	Odoc_loader.read_cmi ~make_root ~parent ~filename
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	216✔
146	let env = Resolver.build_compile_env_for_unit resolver unit in
147	let compiled =	216✔
148	Odoc_xref2.Compile.compile ~filename env unit \|> Error.raise_warnings	216✔
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	216✔
158
159	let root_of_compilation_unit ~parent_id ~parents_children ~hidden ~output
160	~module_name ~digest =
161	let open Root in	217✔
162	let result parent =
163	let file = Odoc_file.create_unit ~force_hidden:hidden module_name in	216✔
164	Ok	216✔
165	{
166	id = Paths.Identifier.Mk.root (parent, ModuleName.make_std module_name);	216✔
167	file;
168	digest;
169	}
170	in
171	let check_child = function
172	\| Lang.Page.Module_child n ->	20✔
173	let filename =
174	Filename.chop_extension Fs.File.(to_string @@ basename output)	20✔
175	in
176	String.Ascii.(uncapitalize n = uncapitalize filename)	20✔
177	\| Page_child _ -> false	1✔
178	in
179	match parents_children with
180	\| Some parents_children ->	14✔
181	if List.exists check_child parents_children then result parent_id	13✔
182	else Error (`Msg "Specified parent is not a parent of this file")	1✔
183	\| None -> result parent_id	203✔
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 =	89✔
198	Filename.chop_extension Fs.File.(to_string @@ basename output)	89✔
199	in
200	String.drop ~max:(String.length prefix) page_dash_root	89✔
201
202	let page_name_of_output output = name_of_output ~prefix:"page-" output	54✔
203
204	let is_index_page = function
205	\| { Paths.Identifier.iv = `Page _; _ } -> false	17✔
206	\| { iv = `LeafPage (_, p); _ } ->	37✔
207	String.equal (Names.PageName.to_string p) "index"	37✔
208
209	let has_children_order { Frontmatter.children_order } =
210	Option.is_some children_order	45✔
211
212	let mld ~parent_id ~parents_children ~output ~children ~warnings_options input =
213	List.fold_left	54✔
214	(fun acc child_str ->
215	match (acc, parse_parent_child_reference child_str) with	23✔
216	\| Ok acc, Ok r -> Ok (r :: acc)	23✔
217	\| Error m, _ -> Error m	×
218	\| _, Error (`Msg m) ->	×
219	Error (`Msg ("Failed to parse child reference: " ^ m))
220	\| _, Error _ -> Error (`Msg "Unknown failure parsing child reference"))	×
221	(Ok []) children
222	>>= fun children ->
223	let root_name = page_name_of_output output in	54✔
224	let input_s = Fs.File.to_string input in	54✔
225	let digest = Digest.file input_s in	54✔
226	let page_name = PageName.make_std root_name in	54✔
227	let check_child = function	54✔
228	\| Lang.Page.Page_child n -> root_name = n	6✔
229	\| Module_child _ -> false	1✔
230	in
231	(if children = [] then
232	(* No children, this is a leaf page. *)
233	Ok (Paths.Identifier.Mk.leaf_page (parent_id, page_name))	37✔
234	else
235	(* Has children, this is a container page. *)
236	let check parents_children =	17✔
237	if List.exists check_child parents_children then Ok ()	5✔
238	else Error (`Msg "Specified parent is not a parent of this file")	×
239	in
240	(match parents_children with
241	\| Some parents_children ->	5✔
242	check parents_children >>= fun () ->	5✔
243	Ok (Paths.Identifier.Mk.page (parent_id, page_name))	5✔
244	\| None -> Ok (Paths.Identifier.Mk.page (parent_id, page_name)))	12✔
245	>>= fun id -> Ok (id :> Paths.Identifier.Page.t))	17✔
246	>>= fun name ->
247	let resolve content =	54✔
248	let zero_heading = Comment.find_zero_heading content in	54✔
249	let frontmatter, content = Comment.extract_frontmatter content in	54✔
250	if (not (is_index_page name)) && has_children_order frontmatter then	45✔
251	Error.raise_warning	1✔
252	(Error.filename_only	1✔
253	"Non-index page cannot specify (children _) in the frontmatter."
254	input_s);
255	let root =	54✔
256	let file =
257	Root.Odoc_file.create_page root_name zero_heading frontmatter
258	in
259	{ Root.id = (name :> Paths.Identifier.OdocId.t); file; digest }	54✔
260	in
261	let page =
262	Lang.Page.
263	{ name; root; children; content; digest; linked = false; frontmatter }
264	in
265	Odoc_file.save_page output ~warnings:[] page;
266	()	54✔
267	in
268	Fs.File.read input >>= fun str ->	54✔
269	Error.handle_errors_and_warnings ~warnings_options	54✔
270	@@ Error.catch_errors_and_warnings	54✔
271	@@ fun () ->
272	Odoc_loader.read_string (name :> Paths.Identifier.LabelParent.t) input_s str	54✔
273	\|> Error.raise_errors_and_warnings	54✔
274	\|> function	54✔
UNCOV 275	\| `Stop -> resolve [] (* TODO: Error? *)	×
276	\| `Docs content -> resolve content	54✔
277
278	let handle_file_ext ext =
279	match ext with	217✔
280	\| ".cmti" -> Ok `Cmti	145✔
281	\| ".cmt" -> Ok `Cmt	72✔
282	\| ".cmi" -> Ok `Cmi	×
283	\| _ ->	×
284	Error (`Msg "Unknown extension, expected one of: cmti, cmt, cmi or mld.")
285
286	let resolve_spec ~input resolver cli_spec =
287	match cli_spec with	272✔
288	\| CliParent { parent; children; output } ->	35✔
289	(let root_name = name_of_output ~prefix:"page-" output in
290	match root_name with	35✔
291	\| "index" ->	×
292	Format.eprintf	×
293	"Warning: Potential name clash - child page named 'index'\n%!"
294	\| _ -> ());	35✔
295	let parent =
296	match parent with
297	\| Some parent -> (	23✔
298	match resolve_parent_page resolver parent with
299	\| Ok (parent_id, parents_children) ->	22✔
300	Ok (Some parent_id, Some parents_children)
301	\| Error e -> Error e)	1✔
302	\| None -> Ok (None, None)	12✔
303	in
304	parent >>= fun (parent_id, parents_children) ->
305	Ok { parent_id; parents_children; children; output }	34✔
306	\| CliPackage { package; output } ->	66✔
307	Ok
308	{
309	parent_id =
310	Some (Paths.Identifier.Mk.page (None, PageName.make_std package));	66✔
311	output;
312	parents_children = None;
313	children = [];
314	}
315	\| CliParentId { parent_id; output_dir } ->	31✔
316	let parent_id = mk_id parent_id in
317	let directory =	31✔
318	path_of_id output_dir parent_id
319	\|> Fpath.to_string \|> Fs.Directory.of_string	31✔
320	in
321	let name =	31✔
322	let ext = Fs.File.get_ext input in
323	let name = Fs.File.set_ext ".odoc" input in	31✔
324	let name = Fs.File.basename name in	31✔
325	if ext = ".mld" then "page-" ^ Fs.File.to_string name	24✔
326	else name \|> Fpath.to_string \|> String.Ascii.uncapitalize	7✔
327	in
328	let output = Fs.File.create ~directory ~name in
329	Ok { parent_id; output; parents_children = None; children = [] }
330	\| CliNoParent output ->	140✔
331	Ok { output; parent_id = None; parents_children = None; children = [] }
332
333	let compile ~resolver ~hidden ~cli_spec ~warnings_options input =
334	resolve_spec ~input resolver cli_spec	272✔
335	>>= fun { parent_id; output; parents_children; children } ->
336	let ext = Fs.File.get_ext input in	271✔
337	if ext = ".mld" then	271✔
338	mld ~parent_id ~parents_children ~output ~warnings_options ~children input	54✔
339	else
340	check_is_empty "Not expecting children (--child) when compiling modules."	217✔
341	children
342	>>= fun () ->
343	handle_file_ext ext >>= fun input_type ->	217✔
344	let make_root =	217✔
345	root_of_compilation_unit ~parent_id ~parents_children ~hidden ~output
346	in
347	let result =
348	Error.catch_errors_and_warnings (fun () ->
349	resolve_and_substitute ~resolver ~make_root ~hidden parent_id input	217✔
350	input_type)
351	in
352	(* Extract warnings to write them into the output file *)
353	let _, warnings = Error.unpack_warnings result in	217✔
354	Error.handle_errors_and_warnings ~warnings_options result >>= fun unit ->	217✔
355	Odoc_file.save_unit output ~warnings unit;	214✔
356	Ok ()	214✔

ocaml / odoc / 2403

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

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