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
|
type 'a vyconf_tree = Node of string * 'a * ('a vyconf_tree list)
let name_of_node (Node (name, _, _)) = name
let children_of_node (Node (_, _, children)) = children
let data_of_node (Node (_, data, _)) = data
let destructure_node node =
name_of_node node,
data_of_node node,
children_of_node node
let rec find_child_in_list children name =
match children with
| [] -> None
| c :: cs -> if (name_of_node c) = name then (Some c)
else find_child_in_list cs name
let find_child node name =
find_child_in_list (children_of_node node) name
let rec remove_child_from_list children name =
match children with
| [] -> []
| c :: cs -> if (name_of_node c) = name then cs
else c :: (remove_child_from_list cs name)
let extract_child children name =
find_child_in_list children name,
remove_child_from_list children name
let insert_immediate_child node name data =
let new_node = Node (name, data, []) in
let (old_name, old_data, old_children) = destructure_node node in
Node (old_name, old_data, new_node :: old_children)
let adopt_child node child =
let (old_name, old_data, old_children) = destructure_node node in
Node (old_name, old_data, child :: old_children)
let replace_child node child =
let (old_name, old_data, old_children) = destructure_node node in
let child_name = name_of_node child in
let old_children' = remove_child_from_list old_children child_name in
Node (old_name, old_data, child :: old_children')
let rec insert_child default_data node path data =
match path with
| [] -> raise (Failure "Can't insert at empty path")
| [name] -> insert_immediate_child node name data
| name :: names ->
let next_child = find_child node name in
match next_child with
| Some next_child' ->
let new_node = insert_child default_data next_child' names data in
replace_child node new_node
| None ->
let next_child' = Node (name, default_data, []) in
let new_node = insert_child default_data next_child' names data in
adopt_child node new_node
|
