Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 102 lines (84 sloc) 3.658 kB
fccc685 Initial open-source release
MLstate authored
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
19 (**
20 Private module for DB-Schema manipulation.
21 @author Louis Gesbert
22 @author Vincent Benayoun (refactoring)
23 *)
24
25 (* This module is a library over OcamlGraph.
26 It gathers generic functions for graphs. *)
27
28 let internal_error fmt = OManager.i_error fmt
29
30 module SchemaGraph (Vertices: Graph.Sig.COMPARABLE) (Edges: Graph.Sig.ORDERED_TYPE_DFT) = struct
31
32 module SchemaGraph0 = Graph.Persistent.Digraph.ConcreteLabeled (Vertices) (Edges)
33 module V = SchemaGraph0.V
34 module E = SchemaGraph0.E
35
36 (* Returns an unspecified vertex from a graph *)
37 exception Vertex_found of V.t
38 let get_node t =
39 try ignore (SchemaGraph0.map_vertex (fun n -> raise (Vertex_found n)) t);
40 internal_error "get_node on empty graph"
41 with Vertex_found n -> n
42
43 (** Used for fresh nodeids. Starts from 1 (the root is 0) *)
44 let new_nodeid =
45 let z = ref 1 in
46 fun () ->
47 let a = !z in
48 let package_name = ObjectFiles.get_current_package_name() in
49 incr z; string_of_int(a) ^ package_name
50
51 let out_edge sch node = match SchemaGraph0.succ_e sch node with [e] -> e | _ -> assert false
52 let unique_next sch node = match SchemaGraph0.succ sch node with [n] -> n | _ -> assert false
53
54 let replace_node t n1 n2 =
55 let in_edges = SchemaGraph0.pred_e t n1 and out_edges = SchemaGraph0.succ_e t n1 in
56 let remove_edges = List.fold_left (fun t e -> SchemaGraph0.remove_edge_e t e) in
57 let t = remove_edges t in_edges in
58 let t = remove_edges t out_edges in
59 let t = SchemaGraph0.remove_vertex t n1 in
60 let t = SchemaGraph0.add_vertex t n2 in
61 let t = List.fold_left (fun t e -> SchemaGraph0.add_edge_e t (E.create (E.src e) (E.label e) n2)) t in_edges in
62 let t = List.fold_left (fun t e -> SchemaGraph0.add_edge_e t (E.create n2 (E.label e) (E.dst e))) t out_edges in
63 t
64
65 let rec find_tail cond = function
66 | x::r -> if cond x then Some (x::r) else find_tail cond r
67 | [] -> None
68
69 let detect_loops t root : E.t list list =
70 let rec aux t chain node =
71 List.fold_left
72 (fun acc succ ->
73 match find_tail (fun e -> E.src e = E.dst succ) chain with
74 | Some loop -> (loop@[succ])::acc
75 | None -> (aux t (chain@[succ]) (E.dst succ))@acc)
76 [] (SchemaGraph0.succ_e t node)
77 in aux t [] root
78
79 let filter f t =
80 (* TODO: improve complexity
81 * Note that this function is optimized for the case where the filter
82 * removes almost everything in the schema, because it is the common
83 * case *)
84 let added_everything = ref true in
85 let acc =
86 SchemaGraph0.fold_vertex
87 (fun n acc ->
88 if f n then SchemaGraph0.add_vertex acc n else (added_everything := false; acc)
89 ) t SchemaGraph0.empty in
90 if !added_everything then
91 t
92 else
93 SchemaGraph0.fold_edges_e
94 (fun edge acc ->
95 if f (E.src edge) && f (E.dst edge) then
96 SchemaGraph0.add_edge_e acc edge
97 else
98 acc
99 ) t acc
100
101 end
Something went wrong with that request. Please try again.