Attention une mise à jour du service Gitlab va être effectuée le mardi 30 novembre entre 17h30 et 18h00. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes. Cette mise à jour intermédiaire en version 14.0.12 nous permettra de rapidement pouvoir mettre à votre disposition une version plus récente.

grew_edge.ml 5.5 KB
Newer Older
pj2m's avatar
pj2m committed
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
open Log

open Utils
open Ast

module Label = struct
  type decl = string * string option

  type t = int
  
  let full = ref [||]
  let colors = ref [||]
      
  let init string_edge_list = 
    let slist = List.sort (fun (x,_) (y,_) -> compare x y) string_edge_list in
    let (labels, cols) = List.split slist in
    full := Array.of_list labels;
    colors := Array.of_list cols

  let to_string t = !full.(t)
  let to_int t = t

  let from_string ?loc ?(locals=[||]) string = 
    try Id.build ?loc string !full
    with Not_found -> 
      try -1 - (Array_.dicho_find_assoc string locals)
      with Not_found ->	Error.build "[Label.from_string] unknown edge label '%s'" string

  let get_color l = !colors.(l)
end


module Edge = struct

  (* the type of underspecified labels: a positive or negative constraint on a disjunction *)
  type under_label =
    | Pos of int list
    | Neg of int list
	 
  type t = {
      id: string option; (* an identifier for naming under_label in patterns *)
      under_label: under_label;
    }

45 46
  let get_id t = t.id

bguillaum's avatar
bguillaum committed
47 48
  let all = {id=None; under_label=Neg []}

pj2m's avatar
pj2m committed
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 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148
  let compare = Pervasives.compare

  let make ?(id=None) ?(neg=false) ?(locals=[||]) = function
    | l when neg -> {id=id; under_label=Neg (List.sort compare (List.map (Label.from_string ~locals) l))}
    | l -> {id=id; under_label=Pos (List.sort compare (List.map (Label.from_string ~locals) l))}

  let build ?locals (ast_edge, loc) =
    { id = ast_edge.Ast.edge_id;
      under_label = 
      if ast_edge.Ast.negative
      then Neg (List.sort compare (List.map (Label.from_string ~loc ?locals) ast_edge.Ast.edge_labels))
      else Pos (List.sort compare (List.map (Label.from_string ~loc ?locals) ast_edge.Ast.edge_labels))
    }


  let from_string string_label =
    match string_label with
    | s when s.[0] = '^' -> 
	let s' = String.sub s 1 ((String.length s) - 1) in
	{id=None; under_label=Neg (List.map Label.from_string (Str.split (Str.regexp "|") s'))}
    | _ -> {id=None; under_label=Pos (List.map Label.from_string (Str.split (Str.regexp "|") string_label))}

  let build_edge line =
    try
      let _ = Str.search_forward(Str.regexp("N\\(.*\\)->")) line 0 in
      let i = int_of_string (Str.matched_group 1 line) in
      let _ = Str.search_forward(Str.regexp("->N\\(.*\\)\\[")) line 0 in
      let j = int_of_string (Str.matched_group 1 line) in
      let _ = Str.search_forward(Str.regexp("label=\"\\([\\^|a-zA-Z0-9_\\-]*\\)\"")) line 0 in
      let string_label = Str.matched_group 1 line in
      (i,j,from_string string_label)
    with Not_found | Invalid_argument _ -> failwith (Printf.sprintf "%s is not an edge declaration" line)

  let to_string t = 
    let pref = match t.id with None -> "" | Some i -> "i:" in
    match t.under_label with
    | Pos l -> pref^(List_.to_string Label.to_string "|" l)
    | Neg l -> pref^"^"^(List_.to_string Label.to_string "|" l)

  let as_label t = match t.under_label with
    | Pos [one] -> one
    | _ -> failwith (Printf.sprintf "[Edge.as_label] edge '%s\' is not a label" (to_string t))

  let of_label l = {id=None; under_label=Pos [l]}

  let to_dot ?(deco=false) x =
    let l = as_label x in 
    match Label.get_color l with
    | None -> Printf.sprintf "[label=\"%s\", color=%s]" (Label.to_string l) (if deco then "red" else "black")
    | Some c -> Printf.sprintf "[label=\"%s\", fontcolor=%s, color=%s]" (Label.to_string l) c (if deco then "red" else "black")

  let to_dep ?(deco=false) x =
    let l = as_label x in 
    match (deco,Label.get_color l) with
    | (false,None) -> Printf.sprintf "{ label = \"%s\"; }" (Label.to_string l)
    | (false,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=%s; bottom; }" (Label.to_string l) c c
    | (true,None) -> Printf.sprintf "{ label = \"%s\"; color=red}" (Label.to_string l)
    | (true,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=red; bottom; }" (Label.to_string l) c

  let compatible edge1 edge2 = match (edge1.under_label,edge2.under_label) with
  | Pos l1, Pos l2 -> not (List_.sort_is_empty_inter l1 l2)
  | Pos p, Neg n | Neg n, Pos p -> not (List_.sort_include p n)
  | Neg l1, Neg l2 -> failwith "Cannot compare two negative sets"

  let is_in graph_edge list = 
    List.mem (as_label graph_edge) list 


  type edge_matcher =
    | Fail
    | Ok of Label.t
    | Binds of string * Label.t list

  let match_ pattern_edge graph_edge =
    let graph_label = as_label graph_edge in

    match pattern_edge with
    | {id = Some i; under_label = Pos l} when List.mem graph_label l -> Binds (i, [graph_label])
    | {id = None; under_label = Pos l} when List.mem graph_label l -> Ok graph_label
    | {id = Some i; under_label = Neg l} when not (List.mem graph_label l) -> Binds (i, [graph_label])
    | {id = None; under_label = Neg l} when not (List.mem graph_label l) -> Ok graph_label
    | _ -> Fail

  let match_list pattern_edge graph_edge_list =
    let graph_labels = List.map as_label graph_edge_list in
    match pattern_edge with
    | {id = None; under_label = Pos l} when List.exists (fun label -> List.mem label l) graph_labels -> Ok (List.hd graph_labels)
    | {id = None; under_label = Neg l} when List.exists (fun label -> not (List.mem label l)) graph_labels -> Ok (List.hd graph_labels)
    | {id = Some i; under_label = Pos l} ->
	(match List.filter (fun label -> List.mem label l) graph_labels with
	| [] -> Fail
	| list -> Binds (i, list))
    | {id = Some i; under_label = Neg l} ->
	(match List.filter (fun label -> not (List.mem label l)) graph_labels with
	| [] -> Fail
	| list -> Binds (i, list))
    | _ -> Fail


end