Skip to content
This repository
Newer
Older
100644 156 lines (143 sloc) 5.245 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* CF mli *)
19
20 (* depends *)
21 module List = Base.List
22
23 module type ItemType =
24 sig
25 type t
26 val index : t -> string
27 val depends : t -> string list
28 end
29
30 module type S =
31 sig
32 type t
33 exception CyclicDep of t
34 exception IndexConflict of t * t
35 exception Not_found_index of string
36 val sort : t list -> t list * (string * t list) list
37
38 type env
39 val compute : t list -> env
40 val get_order : env -> t list * (string * t list) list
41 val transitive_dependencies : env -> t -> t list
42 end
43
44 module Make (Elemt: ItemType) : S with type t = Elemt.t =
45 struct
46 type t = Elemt.t
47 exception CyclicDep of t
48 exception IndexConflict of t * t
49 exception Not_found_index of string
50 type infos_elt =
51 {
52 tri_topo_elt : Elemt.t;
53 tri_topo_depends : StringSet.t
54 }
55
56 type env = infos_elt StringMap.t * (t list * (string * t list) list)
57
58 let compute elt_list =
59 (* Creation des environnements *)
60 let f_fold (accu_map, accu_list) elt =
61 let index = Elemt.index elt and depends = Elemt.depends elt in
62 let topo_elt =
63 match StringMap.find_opt index accu_map with
64 | None -> { tri_topo_elt = elt; tri_topo_depends = StringSet.from_list depends }
65 | Some infos -> raise (IndexConflict (elt, infos.tri_topo_elt))
66 in
67 (StringMap.add index topo_elt accu_map),
68 ((index, topo_elt)::accu_list)
69 in
70 let map_dep, rev_list_dep = List.fold_left f_fold (StringMap.empty, []) elt_list in
71 let list_dep = List.rev rev_list_dep in
72 (* On lance le tri *)
73 let not_referenced = Stack.create () in
74 let visited = Hashtbl.create 10 in
75 let detect_cycle = Hashtbl.create 10 in
76 let ordered = Stack.create () in
77 let rec visite s infos_elt =
78 if Hashtbl.mem visited s
79 then ()
80 else
81 if Hashtbl.mem detect_cycle s
82 then raise (CyclicDep infos_elt.tri_topo_elt)
83 else
84 let tri_topo_elt = infos_elt.tri_topo_elt in
85 begin
86 (* se dire visité *)
87 Hashtbl.add detect_cycle s ();
88 (* visiter les voisins *)
89 (* creer la liste des voisins viables *)
90 let safe_voisins =
91 let f_fold v accu =
92 try
93 let voisin = StringMap.find v map_dep in
94 (v, voisin)::accu
95 with
96 | Not_found -> Stack.push (v, tri_topo_elt) not_referenced; accu
97 in StringSet.fold f_fold infos_elt.tri_topo_depends []
98 in
99 List.iter (fun (a, b) -> visite a b) safe_voisins;
100 (* se mettre dans le tri *)
101 Hashtbl.add visited s ();
102 Stack.push tri_topo_elt ordered
103 end
104 in
105 (* Faire le parcours dans l'ordre donne : stabilite du tri topo *)
106 List.iter (fun (a, b) -> visite a b) list_dep;
107 (* StringMap.iter visite map_dep; : posait probleme *)
108 (* acceder aux listes des index not_referenced, et de l'association ordered, elt *)
109 let list_not_referenced =
110 let rec aux accu =
111 if Stack.is_empty not_referenced then accu
112 else
113 let missing, from = Stack.pop not_referenced in
114 let was = Option.default [] (StringMap.find_opt missing accu) in
115 let accu = StringMap.add missing (from::was) accu in
116 aux accu
117 in
118 let accu = aux StringMap.empty in
119 let fold key set accu = (key, set)::accu in
120 StringMap.fold fold accu []
121 in
122 let list_assoc =
123 let rec aux accu =
124 if Stack.is_empty ordered then accu
125 else
126 let index = Stack.pop ordered in
127 aux (index::accu)
128 in aux []
129 in
130 map_dep, (list_assoc, list_not_referenced)
131
132 let get_order (_, order) = order
133 let sort elt_list = get_order (compute elt_list)
134
135 let transitive_dependencies (map, (_, not_referenced)) t =
136 (* since the order has been done, there are no loop *)
137 let rec gather_children index acc =
138 if StringMap.mem index acc then
139 (* this shorcut gives a big speedup *)
140 acc
141 else
142 match StringMap.find_opt index map with
143 | Some elt ->
144 let depends = elt.tri_topo_depends in
145 let acc = StringMap.add index elt.tri_topo_elt acc in
146 StringSet.fold gather_children depends acc
147 | None ->
148 if List.StringAssoc.mem index not_referenced
149 then acc
150 else raise (Not_found_index index)
151 in
152 let index = Elemt.index t in
153 let all = gather_children index StringMap.empty in
154 let children = StringMap.remove index all in
155 StringMap.elts children
156 end
Something went wrong with that request. Please try again.