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

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

bguillaum's avatar
bguillaum committed
7 8 9

let rm_first_char = function "" -> "" | s -> String.sub s 1 ((String.length s) - 1)

10
(* ================================================================================ *)
pj2m's avatar
pj2m committed
11
module Label = struct
bguillaum's avatar
bguillaum committed
12
  (** Global names and display styles are recorded in two aligned arrays *)
bguillaum's avatar
bguillaum committed
13
  let full = ref None
bguillaum's avatar
bguillaum committed
14

bguillaum's avatar
bguillaum committed
15
  (** Internal representation of labels *)
bguillaum's avatar
bguillaum committed
16
  type t =
bguillaum's avatar
bguillaum committed
17 18 19
    | Global of int       (* globally defined labels: their names are in the [full] array *)
    | Local of int        (* locally defined labels: names array should be provided! UNTESTED *)
    | No_domain of string (* out of domain label: name in not constrained *)
pj2m's avatar
pj2m committed
20

bguillaum's avatar
bguillaum committed
21
  (** [to_string t] returns a string for the label *)
bguillaum's avatar
bguillaum committed
22 23
  let to_string ?(locals=[||]) t =
    match (!full, t) with
bguillaum's avatar
bguillaum committed
24
      | (_, No_domain s) -> s
bguillaum's avatar
bguillaum committed
25 26 27
      | (Some table, Global i) -> table.(i)
      | (Some _, Local i) -> fst locals.(i)
      | _ -> Error.bug "[Label.to_string] inconsistent data"
pj2m's avatar
pj2m committed
28

bguillaum's avatar
bguillaum committed
29 30
  let to_int = function
    | Global i -> Some i
bguillaum's avatar
bguillaum committed
31
    | _ -> None
bguillaum's avatar
bguillaum committed
32

bguillaum's avatar
bguillaum committed
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 102 103 104 105
  (** describe the display style of a label *)
  type line = Solid | Dot | Dash
  type style = {
    text: string;
    bottom: bool;
    color: string option;
    bgcolor: string option;
    line: line;
  }

  (** The [default] style value *)
  let default = { text="UNSET"; bottom=false; color=None; bgcolor=None; line=Solid }

  let styles = ref ([||] : style array)

  let get_style = function
    | Global i -> !styles.(i)
    | Local i -> Log.warning "Style of locally defined labels is not implemented"; default
    | No_domain s -> { default with text=s }

  (** Computes the style of a label from its options and maybe its shape (like I:...). *)
  let parse_option string_label options =
    let init_style = match Str.bounded_split (Str.regexp ":") string_label 2 with
      | ["S"; l] -> {default with text=l; color=Some "red"}
      | ["D"; l] -> {default with text=l; color=Some "blue"; bottom=true}
      | ["I"; l] -> {default with text=l; color=Some "grey"}
      | _ -> {default with text=string_label} in
      List.fold_left
        (fun acc_style -> function
            | "@bottom" -> {acc_style with bottom=true}
            | "@dash" -> {acc_style with line=Dash}
            | "@dot" -> {acc_style with line=Dot}
            | s when String.length s > 4 && String.sub s 0 4 = "@bg_" ->
              let color = String.sub s 4 ((String.length s) - 4) in
              {acc_style with bgcolor=Some color}
            | s -> {acc_style with color=Some (rm_first_char s)}
        ) init_style options

  (** [decl] is the type for a label declaration: the name and a list of display styles *)
  type decl = string * string list

  (* [init decl_list] updates global arrays [full] and [styles] *)
  let init decl_list =
    let slist = List.sort (fun (x,_) (y,_) -> compare x y) decl_list in
    let (labels, opts) = List.split slist in
    let labels_array = Array.of_list labels in
    full := Some labels_array;
    styles := Array.mapi (fun i opt -> parse_option labels_array.(i) opt) (Array.of_list opts)

  let to_dep ?(deco=false) t =
    let style = get_style t in
    let dep_items =
      (if style.bottom then ["bottom"] else [])
      @ (match style.color with Some c -> ["color="^c; "forecolor="^c] | None -> [])
      @ (match style.bgcolor with Some c -> ["bgcolor="^c] | None -> [])
      @ (match style.line with
        | Dot -> ["style=dot"]
        | Dash -> ["style=dash"]
        | Solid when deco -> ["style=dot"]
        | Solid -> []) in
    sprintf "{ label = \"%s\"; %s}" style.text (String.concat "; " dep_items)

  let to_dot ?(deco=false) t =
    let style = get_style t in
    let dot_items =
      (match style.color with Some c -> ["color="^c; "fontcolor="^c] | None -> [])
      @ (match style.line with
        | Dot -> ["style=dotted"]
        | Dash -> ["style=dashed"]
        | Solid when deco -> ["style=dotted"]
        | Solid -> []) in
    sprintf "[label=\"%s\", %s}" style.text (String.concat ", " dot_items)

bguillaum's avatar
bguillaum committed
106
  let from_string ?loc ?(locals=[||]) string =
bguillaum's avatar
bguillaum committed
107 108 109 110 111 112 113
    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
bguillaum's avatar
bguillaum committed
114
end (* module Label *)
pj2m's avatar
pj2m committed
115 116


117 118 119 120
(* ================================================================================ *)
module G_edge = struct
  type t = Label.t

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

bguillaum's avatar
bguillaum committed
123 124
  let root = Label.No_domain "root"

bguillaum's avatar
bguillaum committed
125
  let make ?loc ?(locals=[||]) string = Label.from_string ?loc ~locals string
126 127 128 129 130 131 132

  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)

bguillaum's avatar
bguillaum committed
133 134
  let to_dep ?(deco=false) t = Label.to_dep ~deco t
  let to_dot ?(deco=false) t = Label.to_dot ~deco t
bguillaum's avatar
bguillaum committed
135

136 137
  let color_of_option = function
    | [] -> None
bguillaum's avatar
bguillaum committed
138
    | c::_ -> Some (rm_first_char c)
139

bguillaum's avatar
bguillaum committed
140

bguillaum's avatar
bguillaum committed
141 142
end (* module G_edge *)

143 144 145

(* ================================================================================ *)
module P_edge = struct
bguillaum's avatar
bguillaum committed
146
  type u_label =
147 148 149
    | Pos of Label.t list
    | Neg of Label.t list

pj2m's avatar
pj2m committed
150 151
  type t = {
      id: string option; (* an identifier for naming under_label in patterns *)
152
      u_label: u_label;
pj2m's avatar
pj2m committed
153 154
    }

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

157
  let get_id t = t.id
pj2m's avatar
pj2m committed
158

bguillaum's avatar
bguillaum committed
159 160 161
  let make ?loc ?(id=None) ?(neg=false) ?(locals=[||]) = function
    | l when neg -> {id=id; u_label=Neg (List.sort compare (List.map (Label.from_string ?loc ~locals) l))}
    | l -> {id=id; u_label=Pos (List.sort compare (List.map (Label.from_string ?loc ~locals) l))}
pj2m's avatar
pj2m committed
162 163 164

  let build ?locals (ast_edge, loc) =
    { id = ast_edge.Ast.edge_id;
bguillaum's avatar
bguillaum committed
165
      u_label =
pj2m's avatar
pj2m committed
166 167 168 169 170
      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))
    }

171 172 173
  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
174 175 176 177
    | Pos l -> pref^(List_.to_string Label.to_string "|" l)
    | Neg l -> pref^"^"^(List_.to_string Label.to_string "|" l)


178 179 180
  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
181 182 183 184 185 186

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

187
  let match_ pattern_edge graph_label =
pj2m's avatar
pj2m committed
188 189

    match pattern_edge with
190 191 192 193
    | {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
194 195 196 197
    | _ -> Fail

  let match_list pattern_edge graph_edge_list =
    match pattern_edge with
bguillaum's avatar
bguillaum committed
198
    | {id = None; u_label = Pos l} when List.exists (fun label -> List.mem label l) graph_edge_list ->
199 200 201 202 203
        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
204 205
	| [] -> Fail
	| list -> Binds (i, list))
206 207
    | {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
208 209 210 211
	| [] -> Fail
	| list -> Binds (i, list))
    | _ -> Fail

bguillaum's avatar
bguillaum committed
212 213
end (* module P_edge *)