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 4.93 KB
Newer Older
pj2m's avatar
pj2m committed
1
open Log
2
open Printf
pj2m's avatar
pj2m committed
3

bguillaum's avatar
bguillaum committed
4 5
open Grew_utils
open Grew_ast
pj2m's avatar
pj2m committed
6

7
(* ================================================================================ *)
pj2m's avatar
pj2m committed
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
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
33
(* ================================================================================ *)
pj2m's avatar
pj2m committed
34 35


36 37 38 39 40 41
(* ================================================================================ *)
module G_edge = struct
  type t = Label.t

  let to_string = Label.to_string

bguillaum's avatar
bguillaum committed
42
  let make ?loc ?(locals=[||]) string = Label.from_string ?loc ~locals string
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

  let build ?locals (ast_edge, loc) =
    match ast_edge.Ast.negative, ast_edge.Ast.edge_labels with
    | (false, [one]) -> Label.from_string ~loc ?locals one
    | (true, _) -> Error.build "Negative edge spec are forbidden in graphs%s" (Loc.to_string loc)
    | (false, _) -> Error.build "Only atomic edge valus are allowed in graphs%s" (Loc.to_string loc)

  let to_dot ?(deco=false) l =
    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) l =
    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

end
(* ================================================================================ *)

(* ================================================================================ *)
module P_edge = struct
  type u_label = 
    | Pos of Label.t list
    | Neg of Label.t list

pj2m's avatar
pj2m committed
71 72
  type t = {
      id: string option; (* an identifier for naming under_label in patterns *)
73
      u_label: u_label;
pj2m's avatar
pj2m committed
74 75
    }

76
  let all = {id=None; u_label=Neg []}
bguillaum's avatar
bguillaum committed
77

78
  let get_id t = t.id
pj2m's avatar
pj2m committed
79 80

  let make ?(id=None) ?(neg=false) ?(locals=[||]) = function
81 82
    | l when neg -> {id=id; u_label=Neg (List.sort compare (List.map (Label.from_string ~locals) l))}
    | l -> {id=id; u_label=Pos (List.sort compare (List.map (Label.from_string ~locals) l))}
pj2m's avatar
pj2m committed
83 84 85

  let build ?locals (ast_edge, loc) =
    { id = ast_edge.Ast.edge_id;
86
      u_label = 
pj2m's avatar
pj2m committed
87 88 89 90 91
      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))
    }

92 93 94
  let to_string t =
    let pref = match t.id with None -> "" | Some i -> sprintf "%s:" i in
    match t.u_label with
pj2m's avatar
pj2m committed
95 96 97 98
    | Pos l -> pref^(List_.to_string Label.to_string "|" l)
    | Neg l -> pref^"^"^(List_.to_string Label.to_string "|" l)


99 100 101
  let compatible t g_edge = match t.u_label with
  | Pos p -> List_.sort_mem g_edge p
  | Neg n -> not (List_.sort_mem g_edge n)
pj2m's avatar
pj2m committed
102 103 104 105 106 107

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

108
  let match_ pattern_edge graph_label =
pj2m's avatar
pj2m committed
109 110

    match pattern_edge with
111 112 113 114
    | {id = Some i; u_label = Pos l} when List.mem graph_label l -> Binds (i, [graph_label])
    | {id = None; u_label = Pos l} when List.mem graph_label l -> Ok graph_label
    | {id = Some i; u_label = Neg l} when not (List.mem graph_label l) -> Binds (i, [graph_label])
    | {id = None; u_label = Neg l} when not (List.mem graph_label l) -> Ok graph_label
pj2m's avatar
pj2m committed
115 116 117 118
    | _ -> Fail

  let match_list pattern_edge graph_edge_list =
    match pattern_edge with
119 120 121 122 123 124
    | {id = None; u_label = Pos l} when List.exists (fun label -> List.mem label l) graph_edge_list -> 
        Ok (List.hd graph_edge_list)
    | {id = None; u_label = Neg l} when List.exists (fun label -> not (List.mem label l)) graph_edge_list ->
        Ok (List.hd graph_edge_list)
    | {id = Some i; u_label = Pos l} ->
	(match List.filter (fun label -> List.mem label l) graph_edge_list with
pj2m's avatar
pj2m committed
125 126
	| [] -> Fail
	| list -> Binds (i, list))
127 128
    | {id = Some i; u_label = Neg l} ->
	(match List.filter (fun label -> not (List.mem label l)) graph_edge_list with
pj2m's avatar
pj2m committed
129 130 131 132 133
	| [] -> Fail
	| list -> Binds (i, list))
    | _ -> Fail

end
134
(* ================================================================================ *)