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