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 6.52 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
module Label = struct
9 10
  (* [decl] is the type for a label declaration: the name and a list of display options *)
  type decl = string * string list
pj2m's avatar
pj2m committed
11

12
  (* Global names and display options are recorded in two aligned arrays *)
bguillaum's avatar
bguillaum committed
13
  let full = ref None
14
  let options = ref [||]
bguillaum's avatar
bguillaum committed
15 16 17 18 19

  (* Internal representation of labels *)
  type t =
    | Global of int
    | Local of int
bguillaum's avatar
bguillaum committed
20
    | No_domain of string
bguillaum's avatar
bguillaum committed
21

22
  (* [init string_edge_list] updates global arrays [full] and [options] *)
bguillaum's avatar
bguillaum committed
23
  let init string_edge_list =
pj2m's avatar
pj2m committed
24
    let slist = List.sort (fun (x,_) (y,_) -> compare x y) string_edge_list in
25
    let (labels, opts) = List.split slist in
bguillaum's avatar
bguillaum committed
26
    full := Some (Array.of_list labels);
27
    options := Array.of_list opts
pj2m's avatar
pj2m committed
28

bguillaum's avatar
bguillaum committed
29 30 31 32 33 34
  let to_string ?(locals=[||]) t =
    match (!full, t) with
      | (None, No_domain s) -> s
      | (Some table, Global i) -> table.(i)
      | (Some _, Local i) -> fst locals.(i)
      | _ -> Error.bug "[Label.to_string] inconsistent data"
pj2m's avatar
pj2m committed
35

bguillaum's avatar
bguillaum committed
36 37
  let to_int = function
    | Global i -> Some i
bguillaum's avatar
bguillaum committed
38
    | _ -> None
bguillaum's avatar
bguillaum committed
39 40

  let from_string ?loc ?(locals=[||]) string =
bguillaum's avatar
bguillaum committed
41 42 43 44 45 46 47
    match !full with
      | None -> No_domain string
      | Some table ->
        try Global (Id.build ?loc string table)
        with Not_found ->
          try Local (Array_.dicho_find_assoc string locals)
          with Not_found -> Error.build "[Label.from_string] unknown edge label '%s'" string
pj2m's avatar
pj2m committed
48

49 50 51
  let get_options = function
    | Global l -> !options.(l)
    | _ -> []
bguillaum's avatar
bguillaum committed
52
end (* module Label *)
pj2m's avatar
pj2m committed
53 54


55 56 57 58
(* ================================================================================ *)
module G_edge = struct
  type t = Label.t

bguillaum's avatar
bguillaum committed
59
  let to_string ?(locals=[||]) t = Label.to_string ~locals t
60

bguillaum's avatar
bguillaum committed
61
  let make ?loc ?(locals=[||]) string = Label.from_string ?loc ~locals string
62 63 64 65 66 67 68

  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)

69 70 71 72
  let color_of_option = function
    | [] -> None
    | c::_ -> Some (String.sub c 1 ((String.length c) - 1))

73
  let to_dot ?(deco=false) l =
74
    match color_of_option (Label.get_options l) with
75 76 77
    | 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")

78 79 80 81 82
  let position_of_option options = 
    if List.mem "@bottom" options
    then "bottom; "
    else ""

83
  let to_dep ?(deco=false) l =
84 85 86 87 88 89
    let pos = position_of_option (Label.get_options l) in
    match (deco,color_of_option (Label.get_options l)) with
    | (false,None) -> Printf.sprintf "{ label = \"%s\"%s}" (Label.to_string l) pos
    | (false,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=%s%s}" (Label.to_string l) c c pos
    | (true,None) -> Printf.sprintf "{ label = \"%s\"; color=red%s}" (Label.to_string l) pos
    | (true,Some c) -> Printf.sprintf "{ label = \"%s\"; forecolor=%s; color=red%s}" (Label.to_string l) c pos
90

91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
  let to_dep ?(deco=false) l =
    let string = Label.to_string l in
    let options = Label.get_options l in
    let (prefix, label) = match Str.bounded_split (Str.regexp ":") string 2 with
      | ["S"; l] -> (Some "S", l)
      | ["D"; l] -> (Some "D", l)
      | _ -> (None, string) in
    let pos = if List.mem "@bottom" options || prefix = Some "D" then "; bottom" else "" in
    let style = if deco then "style=dot; " else "" in
    let color = match (List.filter (fun x -> x <> "@bottom") options, prefix) with
      | (c::_, _) -> "; color="^c
      | ([], Some "S") -> "; color=red; forecolor=red"
      | ([], Some "D") -> "; color=blue; forecolor=blue"
      | _ -> "" in
    sprintf "{ label = \"%s\"%s%s%s}" label pos style color 
bguillaum's avatar
bguillaum committed
106 107
end (* module G_edge *)

108 109 110

(* ================================================================================ *)
module P_edge = struct
bguillaum's avatar
bguillaum committed
111
  type u_label =
112 113 114
    | Pos of Label.t list
    | Neg of Label.t list

pj2m's avatar
pj2m committed
115 116
  type t = {
      id: string option; (* an identifier for naming under_label in patterns *)
117
      u_label: u_label;
pj2m's avatar
pj2m committed
118 119
    }

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

122
  let get_id t = t.id
pj2m's avatar
pj2m committed
123 124

  let make ?(id=None) ?(neg=false) ?(locals=[||]) = function
125 126
    | 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
127 128 129

  let build ?locals (ast_edge, loc) =
    { id = ast_edge.Ast.edge_id;
bguillaum's avatar
bguillaum committed
130
      u_label =
pj2m's avatar
pj2m committed
131 132 133 134 135
      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))
    }

136 137 138
  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
139 140 141 142
    | Pos l -> pref^(List_.to_string Label.to_string "|" l)
    | Neg l -> pref^"^"^(List_.to_string Label.to_string "|" l)


143 144 145
  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
146 147 148 149 150 151

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

152
  let match_ pattern_edge graph_label =
pj2m's avatar
pj2m committed
153 154

    match pattern_edge with
155 156 157 158
    | {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
159 160 161 162
    | _ -> Fail

  let match_list pattern_edge graph_edge_list =
    match pattern_edge with
bguillaum's avatar
bguillaum committed
163
    | {id = None; u_label = Pos l} when List.exists (fun label -> List.mem label l) graph_edge_list ->
164 165 166 167 168
        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
169 170
	| [] -> Fail
	| list -> Binds (i, list))
171 172
    | {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
173 174 175 176
	| [] -> Fail
	| list -> Binds (i, list))
    | _ -> Fail

bguillaum's avatar
bguillaum committed
177 178
end (* module P_edge *)