jon.recoil.org
this repo has no description
1open Odoc_model
2
3module Id = Odoc_model.Paths.Identifier
4module PageName = Odoc_model.Names.PageName
5
6module CPH = Id.Hashtbl.ContainerPage
7module LPH = Id.Hashtbl.LeafPage
8module RMH = Id.Hashtbl.RootModule
9module SPH = Id.Hashtbl.SourcePage
10
11type page = Id.Page.t
12type container_page = Id.ContainerPage.t
13
14type payload = Lang.Page.t
15
16type dir_content = {
17 leafs : payload LPH.t;
18 dirs : in_progress CPH.t;
19 modules : Skeleton.t RMH.t;
20 implementations : Lang.Implementation.t SPH.t;
21}
22and in_progress = container_page option * dir_content
23
24let empty_t dir_id =
25 ( dir_id,
26 {
27 leafs = LPH.create 10;
28 dirs = CPH.create 10;
29 modules = RMH.create 10;
30 implementations = SPH.create 10;
31 } )
32
33let get_parent id : container_page option =
34 let id :> page = id in
35 match id.iv with
36 | `Page (Some parent, _) -> Some parent
37 | `LeafPage (Some parent, _) -> Some parent
38 | `Page (None, _) | `LeafPage (None, _) -> None
39
40let find_leaf ((_, dir_content) : in_progress) leaf_page =
41 try Some (LPH.find dir_content.leafs leaf_page) with Not_found -> None
42
43let leafs (_, dir_content) =
44 LPH.fold
45 (fun id page acc ->
46 if Astring.String.equal "index" (Id.name id) then acc
47 else (id, page) :: acc)
48 dir_content.leafs []
49
50let dirs (_, dir_content) =
51 CPH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.dirs []
52
53let modules (_, dir_content) =
54 RMH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.modules []
55
56let implementations (_, dir_content) =
57 SPH.fold
58 (fun id payload acc -> (id, payload) :: acc)
59 dir_content.implementations []
60
61let rec get_or_create (dir : in_progress) (id : container_page) : in_progress =
62 let _, { dirs = parent_dirs; _ } =
63 match get_parent id with
64 | Some parent -> get_or_create dir parent
65 | None -> dir
66 in
67 let current_item =
68 try Some (CPH.find parent_dirs id) with Not_found -> None
69 in
70 match current_item with
71 | Some item -> item
72 | None ->
73 let new_ = empty_t (Some id) in
74 CPH.add parent_dirs id new_;
75 new_
76
77let add_page (dir : in_progress) page =
78 let id =
79 match page.Lang.Page.name with
80 | { iv = #Id.ContainerPage.t_pv; _ } as id ->
81 Id.Mk.leaf_page (Some id, PageName.make_std "index")
82 | { iv = #Id.LeafPage.t_pv; _ } as id -> id
83 in
84 let _, dir_content =
85 match get_parent id with
86 | Some parent -> get_or_create dir parent
87 | None -> dir
88 in
89 LPH.replace dir_content.leafs id page
90
91let add_module (dir : in_progress) m =
92 let _, dir_content =
93 match m.Lang.Compilation_unit.id.iv with
94 | `Root (Some parent, _) -> get_or_create dir parent
95 | `Root (None, _) -> dir
96 in
97 let skel = Skeleton.from_unit m in
98 RMH.replace dir_content.modules m.id skel
99
100let add_implementation (dir : in_progress) (i : Lang.Implementation.t) =
101 match i.id with
102 | None -> ()
103 | Some ({ iv = `SourcePage (parent, _); _ } as id) ->
104 let _, dir_content = get_or_create dir parent in
105 SPH.replace dir_content.implementations id i
106
107let index ((parent_id, _) as dir) =
108 let index_id = Id.Mk.leaf_page (parent_id, PageName.make_std "index") in
109 match find_leaf dir index_id with
110 | Some payload -> Some (index_id, payload)
111 | None -> None
112
113let root_dir (parent_id, _) = parent_id