blob: 0e379ee084d99c6e4b73a490c2c9cef29cee0d60 (
plain)
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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
type 'a t = {
name: string;
data: 'a;
children: 'a t list
}
type position = Before of string | After of string | End | Default
exception Empty_path
exception Duplicate_child
exception Nonexistent_path
exception Insert_error of string
let make data name = { name = name; data = data; children = [] }
let make_full data name children = { name = name; data = data; children = children }
let name_of_node node = node.name
let data_of_node node = node.data
let children_of_node node = node.children
let insert_immediate ?(position=Default) node name data =
let new_node = make data name in
let children' =
match position with
| Default -> new_node :: node.children
| End -> node.children @ [new_node]
| Before s -> Vylist.insert_before (fun x -> x.name = s) new_node node.children
| After s -> Vylist.insert_after (fun x -> x.name = s) new_node node.children
in { node with children = children' }
let delete_immediate node name =
let children' = Vylist.remove (fun x -> x.name = name) node.children in
{ node with children = children' }
let adopt node child =
{ node with children = child :: node.children }
let replace node child =
let children = node.children in
let name = child.name in
let children' = Vylist.replace (fun x -> x.name = name) child children in
{ node with children = children' }
let find node name =
Vylist.find (fun x -> x.name = name) node.children
let find_or_fail node name =
let child = find node name in
match child with
| None -> raise Nonexistent_path
| Some child' -> child'
let list_children node =
List.map (fun x -> x.name) node.children
let rec do_with_child fn node path =
match path with
| [] -> raise Empty_path
| [name] -> fn node name
| name :: names ->
let next_child = find_or_fail node name in
let new_node = do_with_child fn next_child names in
replace node new_node
let rec insert ?(position=Default) node path data =
match path with
| [] -> raise Empty_path
| [name] ->
(let last_child = find node name in
match last_child with
| None -> insert_immediate ~position:position node name data
| (Some _) -> raise Duplicate_child)
| name :: names ->
let next_child = find node name in
match next_child with
| Some next_child' ->
let new_node = insert ~position:position next_child' names data in
replace node new_node
| None ->
raise (Insert_error "Path does not exist")
(* When inserting at a path that, entirely or partially,
does not exist yet, create missing nodes on the way with default data *)
let rec insert_multi_level default_data node path_done path_remaining data =
match path_remaining with
| [] | [_] -> insert node (path_done @ path_remaining) data
| name :: names ->
let path_done = path_done @ [name] in
let node = insert node path_done default_data in
insert_multi_level default_data node path_done names data
let delete node path =
do_with_child delete_immediate node path
let update node path data =
let update_data data' node' name =
let child = find_or_fail node' name in
let child = { child with data=data' } in
replace node' child
in do_with_child (update_data data) node path
let rec get node path =
match path with
| [] -> raise Empty_path
| [name] -> find_or_fail node name
| name :: names -> get (find_or_fail node name) names
let get_data node path = data_of_node @@ get node path
let exists node path =
try ignore (get node path); true
with Nonexistent_path -> false
let get_existent_path node path =
let rec aux node path acc =
match path with
| [] -> acc
| name :: names ->
let child = find node name in
match child with
| None -> acc
| Some c -> aux c names (name :: acc)
in List.rev (aux node path [])
let children_of_path node path =
let node' = get node path in
list_children node'
|
