Fetching contributors…
Cannot retrieve contributors at this time
157 lines (143 sloc) 5.12 KB
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <>.
(* CF mli *)
(* depends *)
module List = Base.List
module type ItemType =
type t
val index : t -> string
val depends : t -> string list
module type S =
type t
exception CyclicDep of t
exception IndexConflict of t * t
exception Not_found_index of string
val sort : t list -> t list * (string * t list) list
type env
val compute : t list -> env
val get_order : env -> t list * (string * t list) list
val transitive_dependencies : env -> t -> t list
module Make (Elemt: ItemType) : S with type t = Elemt.t =
type t = Elemt.t
exception CyclicDep of t
exception IndexConflict of t * t
exception Not_found_index of string
type infos_elt =
tri_topo_elt : Elemt.t;
tri_topo_depends : StringSet.t
type env = infos_elt StringMap.t * (t list * (string * t list) list)
let compute elt_list =
(* Creation des environnements *)
let f_fold (accu_map, accu_list) elt =
let index = Elemt.index elt and depends = Elemt.depends elt in
let topo_elt =
match StringMap.find_opt index accu_map with
| None -> { tri_topo_elt = elt; tri_topo_depends = StringSet.from_list depends }
| Some infos -> raise (IndexConflict (elt, infos.tri_topo_elt))
(StringMap.add index topo_elt accu_map),
((index, topo_elt)::accu_list)
let map_dep, rev_list_dep = List.fold_left f_fold (StringMap.empty, []) elt_list in
let list_dep = List.rev rev_list_dep in
(* On lance le tri *)
let not_referenced = Stack.create () in
let visited = Hashtbl.create 10 in
let detect_cycle = Hashtbl.create 10 in
let ordered = Stack.create () in
let rec visite s infos_elt =
if Hashtbl.mem visited s
then ()
if Hashtbl.mem detect_cycle s
then raise (CyclicDep infos_elt.tri_topo_elt)
let tri_topo_elt = infos_elt.tri_topo_elt in
(* se dire visité *)
Hashtbl.add detect_cycle s ();
(* visiter les voisins *)
(* creer la liste des voisins viables *)
let safe_voisins =
let f_fold v accu =
let voisin = StringMap.find v map_dep in
(v, voisin)::accu
| Not_found -> Stack.push (v, tri_topo_elt) not_referenced; accu
in StringSet.fold f_fold infos_elt.tri_topo_depends []
List.iter (fun (a, b) -> visite a b) safe_voisins;
(* se mettre dans le tri *)
Hashtbl.add visited s ();
Stack.push tri_topo_elt ordered
(* Faire le parcours dans l'ordre donne : stabilite du tri topo *)
List.iter (fun (a, b) -> visite a b) list_dep;
(* StringMap.iter visite map_dep; : posait probleme *)
(* acceder aux listes des index not_referenced, et de l'association ordered, elt *)
let list_not_referenced =
let rec aux accu =
if Stack.is_empty not_referenced then accu
let missing, from = Stack.pop not_referenced in
let was = Option.default [] (StringMap.find_opt missing accu) in
let accu = StringMap.add missing (from::was) accu in
aux accu
let accu = aux StringMap.empty in
let fold key set accu = (key, set)::accu in
StringMap.fold fold accu []
let list_assoc =
let rec aux accu =
if Stack.is_empty ordered then accu
let index = Stack.pop ordered in
aux (index::accu)
in aux []
map_dep, (list_assoc, list_not_referenced)
let get_order (_, order) = order
let sort elt_list = get_order (compute elt_list)
let transitive_dependencies (map, (_, not_referenced)) t =
(* since the order has been done, there are no loop *)
let rec gather_children index acc =
if StringMap.mem index acc then
(* this shorcut gives a big speedup *)
match StringMap.find_opt index map with
| Some elt ->
let depends = elt.tri_topo_depends in
let acc = StringMap.add index elt.tri_topo_elt acc in
StringSet.fold gather_children depends acc
| None ->
if List.StringAssoc.mem index not_referenced
then acc
else raise (Not_found_index index)
let index = Elemt.index t in
let all = gather_children index StringMap.empty in
let children = StringMap.remove index all in
StringMap.elts children