Skip to content
This repository
tag: v320
Fetching contributors…

Cannot retrieve contributors at this time

file 101 lines (84 sloc) 3.658 kb
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
(*
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 <http://www.gnu.org/licenses/>.
*)

(**
Private module for DB-Schema manipulation.
@author Louis Gesbert
@author Vincent Benayoun (refactoring)
*)

(* This module is a library over OcamlGraph.
It gathers generic functions for graphs. *)

let internal_error fmt = OManager.i_error fmt

module SchemaGraph (Vertices: Graph.Sig.COMPARABLE) (Edges: Graph.Sig.ORDERED_TYPE_DFT) = struct
  
  module SchemaGraph0 = Graph.Persistent.Digraph.ConcreteLabeled (Vertices) (Edges)
  module V = SchemaGraph0.V
  module E = SchemaGraph0.E

  (* Returns an unspecified vertex from a graph *)
  exception Vertex_found of V.t
  let get_node t =
    try ignore (SchemaGraph0.map_vertex (fun n -> raise (Vertex_found n)) t);
      internal_error "get_node on empty graph"
    with Vertex_found n -> n
    
  (** Used for fresh nodeids. Starts from 1 (the root is 0) *)
  let new_nodeid =
    let z = ref 1 in
    fun () ->
      let a = !z in
      let package_name = ObjectFiles.get_current_package_name() in
      incr z; string_of_int(a) ^ package_name

  let out_edge sch node = match SchemaGraph0.succ_e sch node with [e] -> e | _ -> assert false
  let unique_next sch node = match SchemaGraph0.succ sch node with [n] -> n | _ -> assert false

  let replace_node t n1 n2 =
    let in_edges = SchemaGraph0.pred_e t n1 and out_edges = SchemaGraph0.succ_e t n1 in
    let remove_edges = List.fold_left (fun t e -> SchemaGraph0.remove_edge_e t e) in
    let t = remove_edges t in_edges in
    let t = remove_edges t out_edges in
    let t = SchemaGraph0.remove_vertex t n1 in
    let t = SchemaGraph0.add_vertex t n2 in
    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
    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
    t
      
  let rec find_tail cond = function
    | x::r -> if cond x then Some (x::r) else find_tail cond r
    | [] -> None
        
  let detect_loops t root : E.t list list =
    let rec aux t chain node =
      List.fold_left
        (fun acc succ ->
           match find_tail (fun e -> E.src e = E.dst succ) chain with
           | Some loop -> (loop@[succ])::acc
           | None -> (aux t (chain@[succ]) (E.dst succ))@acc)
        [] (SchemaGraph0.succ_e t node)
    in aux t [] root

  let filter f t =
    (* TODO: improve complexity
* Note that this function is optimized for the case where the filter
* removes almost everything in the schema, because it is the common
* case *)
    let added_everything = ref true in
    let acc =
      SchemaGraph0.fold_vertex
        (fun n acc ->
           if f n then SchemaGraph0.add_vertex acc n else (added_everything := false; acc)
        ) t SchemaGraph0.empty in
    if !added_everything then
      t
    else
      SchemaGraph0.fold_edges_e
        (fun edge acc ->
           if f (E.src edge) && f (E.dst edge) then
             SchemaGraph0.add_edge_e acc edge
           else
             acc
        ) t acc

end
Something went wrong with that request. Please try again.