Source file dependencyManager.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
open Utils

module type Manager_sig = sig
  type t
  type elt

  val empty : t
  val add_dependency : elt -> elt -> t -> t
  val dependencies : elt -> t -> elt list
  val merge : t -> t -> t
  val roots : t -> elt list
end

(*module Make(O:sig type t val compare:t->t->int val to_string:t->string end) = *)
module Make (O : Map.OrderedType) = struct
  module EltSet = Set.Make (O)
  module EltMap = Map.Make (O)

  type t = { depends_on : EltSet.t EltMap.t; dependants : EltSet.t EltMap.t }
  type elt = O.t

  let empty = { depends_on = EltMap.empty; dependants = EltMap.empty }

  let add_dependency e1 e2 man =
    let depends_on =
      try EltMap.find e1 man.depends_on with Not_found -> EltSet.empty
    in
    let dependants =
      try EltMap.find e2 man.dependants with Not_found -> EltSet.empty
    in
    {
      depends_on = EltMap.add e1 (EltSet.add e2 depends_on) man.depends_on;
      dependants = EltMap.add e2 (EltSet.add e1 dependants) man.dependants;
    }

  let rec dependencies_rec elt man depth depthMap =
    try
      let dependants = EltMap.find elt man.dependants in
      let new_depthMap =
        EltSet.fold
          (fun elt depthMap ->
            let depth =
              try max (depth + 1) (EltMap.find elt depthMap)
              with Not_found -> depth + 1
            in
            EltMap.add elt depth depthMap)
          dependants depthMap
      in
      EltSet.fold
        (fun elt depthMap ->
          dependencies_rec elt man (EltMap.find elt depthMap) depthMap)
        dependants new_depthMap
    with Not_found -> depthMap

  let dependencies elt man =
    let depthMap = dependencies_rec elt man 0 EltMap.empty in
    let orderedElt =
      EltMap.fold
        (fun elt depth acc ->
          try IntMap.add depth (elt :: IntMap.find depth acc) acc
          with Not_found -> IntMap.add depth [ elt ] acc)
        depthMap IntMap.empty
    in
    (* let () =
            IntMap.iter
       (fun depth elts ->
        Printf.printf
          "at depth %i from %s we have the following elements: %s\n"
          depth
          (O.to_string elt)
          (string_of_list " " O.to_string elts))
       orderedElt
          in *)
    List.rev (IntMap.fold (fun _ elts acc -> elts @ acc) orderedElt [])

  let set_merge elt dep map =
    let new_set =
      try EltSet.union dep (EltMap.find elt map) with Not_found -> dep
    in
    EltMap.add elt new_set map

  let merge m1 m2 =
    {
      depends_on = EltMap.fold set_merge m1.depends_on m2.depends_on;
      dependants = EltMap.fold set_merge m1.dependants m2.dependants;
    }

  let roots m =
    let rec roots_rec elt roots =
      try
        let depends_on = EltMap.find elt m.depends_on in
        EltSet.fold
          (fun elt acc -> roots_rec elt acc)
          depends_on (EltSet.remove elt roots)
      with Not_found -> EltSet.add elt roots
    in
    EltSet.elements
      (EltMap.fold
         (fun elt _ acc -> roots_rec elt acc)
         m.depends_on EltSet.empty)
end