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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
type 'a t = {
name: string;
data: 'a;
children: 'a t list
} [@@deriving yojson]
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")
(** Given a node N check if it has children with duplicate names,
and merge subsequent children's children into the first child by
that name.
While all insert functions maintain the "every child has unique name"
invariant, for nodes constructed manually with make/make_full and adopt
it may not hold, and constructing nodes this way is a sensible approach
for config parsing. Depending on the config format, duplicate node names
may be normal and even expected, such as "ethernet eth0" and "ethernet eth1"
in the "curly" format.
*)
let merge_children merge_data node =
(* Given a node N and a list of nodes NS, find all nodes in NS that
have the same name as N and merge their children into N *)
let rec merge_into n ns =
match ns with
| [] -> n
| n' :: ns' ->
if n.name = n'.name then
let children = List.append n.children n'.children in
let data = merge_data n.data n'.data in
let n = {n with children=children; data=data} in
merge_into n ns'
else merge_into n ns'
in
(* Given a list of nodes, for every node, find subsequent children with
the same name and merge them into the first node, then delete remaining
nodes from the list *)
let rec aux ns =
match ns with
| [] -> []
| n :: ns ->
let n = merge_into n ns in
let ns = List.filter (fun x -> x.name <> n.name) ns in
n :: (aux ns)
in {node with children=(aux node.children)}
(* 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'
let sorted_children_of_node cmp node =
let names = list_children node in
let names = List.sort cmp names in
List.map (find_or_fail node) names
|
