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

93.75

/src/model/sidebar.ml

open Odoc_utils
open Paths.Identifier

module CPH = Hashtbl.ContainerPage
module LPH = Hashtbl.LeafPage

type page = Page.t
type leaf_page = LeafPage.t
type container_page = ContainerPage.t

module PageToc = struct
  type title = Comment.link_content
  type children_order = Frontmatter.child list Location_.with_location

  type payload = { title : title; children_order : children_order option }

  type dir_content = { leafs : payload LPH.t; dirs : in_progress CPH.t }
  and in_progress = container_page option * dir_content

  let empty_t dir_id = (dir_id, { leafs = LPH.create 10; dirs = CPH.create 10 })

  let get_parent id : container_page option =
    let id :> page = id in
    match id.iv with
    | `Page (Some parent, _) -> Some parent
    | `LeafPage (Some parent, _) -> Some parent
    | `Page (None, _) | `LeafPage (None, _) -> None

  let find_leaf ((_, dir_content) : in_progress) leaf_page =
    try Some (LPH.find dir_content.leafs leaf_page) with Not_found -> None

  let leafs (_, dir_content) =
    LPH.fold
      (fun id { title = payload; _ } acc ->
        if Astring.String.equal "index" (Paths.Identifier.name id) then acc
        else (id, payload) :: acc)
      dir_content.leafs []

  let dirs (_, dir_content) =
    CPH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.dirs []

  let rec get_or_create (dir : in_progress) (id : container_page) : in_progress
      =
    let _, { dirs = parent_dirs; _ } =
      match get_parent id with
      | Some parent -> get_or_create dir parent
      | None -> dir
    in
    let current_item =
      try Some (CPH.find parent_dirs id) with Not_found -> None
    in
    match current_item with
    | Some item -> item
    | None ->
        let new_ = empty_t (Some id) in
        CPH.add parent_dirs id new_;
        new_

  let add (dir : in_progress) ((id : leaf_page), title, children_order) =
    let _, dir_content =
      match get_parent id with
      | Some parent -> get_or_create dir parent
      | None -> dir
    in
    LPH.replace dir_content.leafs id { title; children_order }

  let dir_index ((parent_id, _) as dir) =
    let index_id =
      Paths.Identifier.Mk.leaf_page (parent_id, Names.PageName.make_std "index")
    in
    match find_leaf dir index_id with
    | Some payload -> Some (payload, index_id, payload.title)
    | None -> None

  type index = Page.t * title
  type t = (Page.t * content) list * index option
  and content = Entry of title | Dir of t

  let rec t_of_in_progress (dir : in_progress) =
    let children_order, index =
      match dir_index dir with
      | Some ({ children_order; _ }, index_id, index_title) ->
          (children_order, Some (index_id, index_title))
      | None -> (None, None)
    in
    let ordered, unordered =
      let contents =
        let leafs =
          leafs dir
          |> List.map (fun (id, payload) -> ((id :> Page.t), Entry payload))
        in
        let dirs =
          dirs dir
          |> List.map (fun (id, payload) ->
                 ((id :> Page.t), Dir (t_of_in_progress payload)))
        in
        leafs @ dirs
      in
      match children_order with
      | None -> ([], contents)
      | Some children_order ->
          List.partition_map
            (fun (((id : Page.t), _) as entry) ->
              match
                List.find_index
                  (fun ch ->
                    match (ch, id.iv) with
                    | Frontmatter.Dir c, `Page (_, name) ->
                        String.equal (Names.PageName.to_string name) c
                    | Page c, `LeafPage (_, name) ->
                        String.equal (Names.PageName.to_string name) c
                    | _ -> false)
                  children_order.value
              with
              | Some i -> `Left (i, entry)
              | None -> `Right entry)
            contents
    in
    let () =
      match (children_order, unordered) with
      | Some x, (_ :: _ as l) ->
          let pp fmt (id, _) =
            match id.iv with
            | `LeafPage (_, name) ->
                Format.fprintf fmt "'%s'" (Names.PageName.to_string name)
            | `Page (_, name) ->
                Format.fprintf fmt "'%s/'" (Names.PageName.to_string name)
          in
          Error.raise_warning
            (Error.make "(children) doesn't include %a."
               (Format.pp_print_list pp) l (Location_.location x))
      | _ -> ()
    in
    let ordered =
      ordered
      |> List.sort (fun (i, _) (j, _) -> Int.compare i j)
      |> List.map snd
    in
    let unordered =
      List.sort
        (fun (x, _) (y, _) ->
          String.compare (Paths.Identifier.name x) (Paths.Identifier.name y))
        unordered
    in
    let contents = ordered @ unordered in
    (contents, index)

  let of_list l =
    let dir = empty_t None in
    List.iter (add dir) l;
    t_of_in_progress dir
end

type toc = PageToc.t

type library = { name : string; units : Paths.Identifier.RootModule.t list }

type page_hierarchy = { hierarchy_name : string; pages : toc }

type t = { pages : page_hierarchy list; libraries : library list }

1	open Odoc_utils
2	open Paths.Identifier
3
4	module CPH = Hashtbl.ContainerPage
5	module LPH = Hashtbl.LeafPage
6
7	type page = Page.t
8	type leaf_page = LeafPage.t
9	type container_page = ContainerPage.t
10
11	module PageToc = struct
12	type title = Comment.link_content
13	type children_order = Frontmatter.child list Location_.with_location
14
15	type payload = { title : title; children_order : children_order option }
16
17	type dir_content = { leafs : payload LPH.t; dirs : in_progress CPH.t }
18	and in_progress = container_page option * dir_content
19
20	let empty_t dir_id = (dir_id, { leafs = LPH.create 10; dirs = CPH.create 10 })	15✔
21
22	let get_parent id : container_page option =
23	let id :> page = id in	35✔
24	match id.iv with
25	\| `Page (Some parent, _) -> Some parent	15✔
26	\| `LeafPage (Some parent, _) -> Some parent	10✔
NEW 27	\| `Page (None, _) \| `LeafPage (None, _) -> None	×
28
29	let find_leaf ((_, dir_content) : in_progress) leaf_page =
30	try Some (LPH.find dir_content.leafs leaf_page) with Not_found -> None	4✔
31
32	let leafs (_, dir_content) =
33	LPH.fold	15✔
34	(fun id { title = payload; _ } acc ->
35	if Astring.String.equal "index" (Paths.Identifier.name id) then acc	4✔
36	else (id, payload) :: acc)	6✔
37	dir_content.leafs []
38
39	let dirs (_, dir_content) =
40	CPH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.dirs []	6✔
41
42	let rec get_or_create (dir : in_progress) (id : container_page) : in_progress
43	=
44	let _, { dirs = parent_dirs; _ } =	25✔
45	match get_parent id with
46	\| Some parent -> get_or_create dir parent	15✔
47	\| None -> dir	10✔
48	in
49	let current_item =
50	try Some (CPH.find parent_dirs id) with Not_found -> None	6✔
51	in
52	match current_item with
53	\| Some item -> item	19✔
54	\| None ->	6✔
55	let new_ = empty_t (Some id) in
56	CPH.add parent_dirs id new_;	6✔
57	new_	6✔
58
59	let add (dir : in_progress) ((id : leaf_page), title, children_order) =
60	let _, dir_content =	10✔
61	match get_parent id with
62	\| Some parent -> get_or_create dir parent	10✔
NEW 63	\| None -> dir	×
64	in
65	LPH.replace dir_content.leafs id { title; children_order }
66
67	let dir_index ((parent_id, _) as dir) =
68	let index_id =	15✔
69	Paths.Identifier.Mk.leaf_page (parent_id, Names.PageName.make_std "index")	15✔
70	in
71	match find_leaf dir index_id with	15✔
72	\| Some payload -> Some (payload, index_id, payload.title)	4✔
73	\| None -> None	11✔
74
75	type index = Page.t * title
76	type t = (Page.t * content) list * index option
77	and content = Entry of title \| Dir of t
78
79	let rec t_of_in_progress (dir : in_progress) =
80	let children_order, index =	15✔
81	match dir_index dir with
82	\| Some ({ children_order; _ }, index_id, index_title) ->	4✔
83	(children_order, Some (index_id, index_title))
84	\| None -> (None, None)	11✔
85	in
86	let ordered, unordered =
87	let contents =
88	let leafs =
89	leafs dir
90	\|> List.map (fun (id, payload) -> ((id :> Page.t), Entry payload))	6✔
91	in
92	let dirs =	15✔
93	dirs dir
94	\|> List.map (fun (id, payload) ->	15✔
95	((id :> Page.t), Dir (t_of_in_progress payload)))	6✔
96	in
97	leafs @ dirs	15✔
98	in
99	match children_order with
100	\| None -> ([], contents)	14✔
101	\| Some children_order ->	1✔
102	List.partition_map	1✔
103	(fun (((id : Page.t), _) as entry) ->
104	match	3✔
105	List.find_index
106	(fun ch ->
107	match (ch, id.iv) with	6✔
108	\| Frontmatter.Dir c, `Page (_, name) ->	1✔
109	String.equal (Names.PageName.to_string name) c	1✔
110	\| Page c, `LeafPage (_, name) ->	3✔
111	String.equal (Names.PageName.to_string name) c	3✔
112	\| _ -> false)	2✔
113	children_order.value
114	with
115	\| Some i -> `Left (i, entry)	2✔
116	\| None -> `Right entry)	1✔
117	contents
118	in
119	let () =
120	match (children_order, unordered) with
121	\| Some x, (_ :: _ as l) ->	1✔
122	let pp fmt (id, _) =
123	match id.iv with	1✔
124	\| `LeafPage (_, name) ->	1✔
125	Format.fprintf fmt "'%s'" (Names.PageName.to_string name)	1✔
NEW 126	\| `Page (_, name) ->	×
NEW 127	Format.fprintf fmt "'%s/'" (Names.PageName.to_string name)	×
128	in
129	Error.raise_warning	1✔
130	(Error.make "(children) doesn't include %a."	1✔
131	(Format.pp_print_list pp) l (Location_.location x))	1✔
132	\| _ -> ()	14✔
133	in
134	let ordered =
135	ordered
136	\|> List.sort (fun (i, _) (j, _) -> Int.compare i j)	1✔
137	\|> List.map snd	15✔
138	in
139	let unordered =	15✔
140	List.sort
141	(fun (x, _) (y, _) ->
142	String.compare (Paths.Identifier.name x) (Paths.Identifier.name y))	2✔
143	unordered
144	in
145	let contents = ordered @ unordered in	15✔
146	(contents, index)
147
148	let of_list l =
149	let dir = empty_t None in	9✔
150	List.iter (add dir) l;	9✔
151	t_of_in_progress dir	9✔
152	end
153
154	type toc = PageToc.t
155
156	type library = { name : string; units : Paths.Identifier.RootModule.t list }
157
158	type page_hierarchy = { hierarchy_name : string; pages : toc }
159
160	type t = { pages : page_hierarchy list; libraries : library list }

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