src/tree_alg.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

exception Incompatible_union
exception Nonexistent_child

module type Data = sig
    type t
end

module type Tree = sig
    module D: Data
    type t = D.t Vytree.t
end

module Tree_impl (D: Data): Tree with module D = D = struct
    module D = D
    type t = D.t Vytree.t
end

module Alg (D: Data) (T: Tree with module D = D) = struct
    module TreeOrd = struct
        type t = T.t
        let compare a b =
            Util.lexical_numeric_compare (Vytree.name_of_node a) (Vytree.name_of_node b)
    end
    module SetT = Set.Make(TreeOrd)

    let union_of_children n m =
        let set_n = SetT.of_list (Vytree.children_of_node n) in
        let set_m = SetT.of_list (Vytree.children_of_node m) in
        SetT.elements (SetT.union set_n set_m)

    let find_child n c = Vytree.find n (Vytree.name_of_node c)

    let insert_child n c = Vytree.insert ~position:Vytree.Lexical ~children:(Vytree.children_of_node c) n [(Vytree.name_of_node c)] (Vytree.data_of_node c)

    let replace_child n c =
        Vytree.replace n c

    let rec tree_union s t f =
        if (Vytree.name_of_node s) <> (Vytree.name_of_node t) then
            raise Incompatible_union
        else
        let child_of_union s t c =
            let s_c = find_child s c in
            let t_c = find_child t c in
            match s_c, t_c with
            | Some child, None ->
                insert_child t child
            | None, Some _ -> t
            | Some u, Some v ->
                    if (Vytree.data_of_node u <> Vytree.data_of_node v) then
                        replace_child t (tree_union u (f u v) f)
                    else
                        replace_child t (tree_union u v f)
            | None, None -> raise Nonexistent_child
        in
        List.fold_left (fun x c -> child_of_union s x c) t (union_of_children s t)
end

module ConfigData: Data with type t = Config_tree.config_node_data = struct
    type t = Config_tree.config_node_data
end

module RefData: Data with type t = Reference_tree.ref_node_data = struct
    type t = Reference_tree.ref_node_data
end

module ConfigAlg = Alg(ConfigData)(Tree_impl(ConfigData))
module RefAlg = Alg(RefData)(Tree_impl(RefData))