Commit 0dac1448 authored by Bruno Guillaume's avatar Bruno Guillaume

add new_edges in pattern syntax

parent 7bad63c8
......@@ -122,12 +122,30 @@ module Ast = struct
let grewpy_compare (n1,_) (n2,_) = Id.grewpy_compare n1.node_id n2.node_id
type atom_edge_label_cst =
| Atom_eq of string * string list (* 1=subj|obj *)
| Atom_diseq of string * string list (* 1<>subj|obj *)
| Atom_absent of string (* !2 *)
let string_of_atom_edge_label_cst = function
| Atom_eq (lfeat, values) -> sprintf "%s=%s" lfeat (String.concat "|" values)
| Atom_diseq (lfeat, values) -> sprintf "%s<>%s" lfeat (String.concat "|" values)
| Atom_absent name -> sprintf "!%s" name
type edge_label = string
type edge_label_cst =
| Pos_list of edge_label list (* X|Y|Z *)
| Neg_list of edge_label list (* ^X|Y|Z *)
| Regexp of string (* re"a.*" *)
| Pos_list of edge_label list (* X|Y|Z *)
| Neg_list of edge_label list (* ^X|Y|Z *)
| Regexp of string (* re"a.*" *)
| Atom_list of atom_edge_label_cst list (* 1=subj, 2 *)
let string_of_edge_label_cst = function
| Neg_list [] -> ""
| Pos_list labels -> sprintf "[%s]" (List_.to_string (fun x->x) "|" labels)
| Neg_list labels -> sprintf "[^%s]" (List_.to_string (fun x->x) "|" labels)
| Regexp re -> sprintf "[re\"%s\"]" re
| Atom_list l -> String.concat "," (List.map string_of_atom_edge_label_cst l)
type u_edge = {
edge_id: Id.name option;
......@@ -268,35 +286,14 @@ module Ast = struct
| Add_edge (n1,n2,label) ->
sprintf "add_edge %s -[%s]-> %s" n1 label n2
| Add_edge_expl (n1,n2,name) ->
sprintf "add_edge %s: %s -> %s" name n1 n2
| Shift_in (n1,n2,Neg_list []) ->
sprintf "shift_in %s ==> %s" n1 n2
| Shift_in (n1,n2,Pos_list labels) ->
sprintf "shift_in %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Shift_in (n1,n2,Neg_list labels) ->
sprintf "shift_in %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Shift_in (n1,n2,Regexp re) ->
sprintf "shift_in %s =[re\"%s\"]=> %s" n1 re n2
| Shift_out (n1,n2,Neg_list []) ->
sprintf "shift_out %s ==> %s" n1 n2
| Shift_out (n1,n2,Pos_list labels) ->
sprintf "shift_out %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Shift_out (n1,n2,Neg_list labels) ->
sprintf "shift_out %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Shift_out (n1,n2,Regexp re) ->
sprintf "shift_out %s =[re\"%s\"]=> %s" n1 re n2
| Shift_edge (n1,n2,Neg_list []) ->
sprintf "shift %s ==> %s" n1 n2
| Shift_edge (n1,n2,Pos_list labels) ->
sprintf "shift %s =[%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Shift_edge (n1,n2,Neg_list labels) ->
sprintf "shift %s =[^%s]=> %s" n1 n2 (List_.to_string (fun x->x) "|" labels)
| Shift_edge (n1,n2,Regexp re) ->
sprintf "shift %s =[re\"%s\"]=> %s" n1 re n2
sprintf "add_edge %s: %s -> %s" name n1 n2
| Shift_in (n1,n2,edge_label_cst) ->
sprintf "shift_in %s =%s=> %s" n1 (string_of_edge_label_cst edge_label_cst) n2
| Shift_out (n1,n2,edge_label_cst) ->
sprintf "shift_out %s =%s=> %s" n1 (string_of_edge_label_cst edge_label_cst) n2
| Shift_edge (n1,n2,edge_label_cst) ->
sprintf "shift %s =%s=> %s" n1 (string_of_edge_label_cst edge_label_cst) n2
| New_node (n) -> sprintf "add_node %s" n
| New_before (n1,n2) -> sprintf "add_node %s :< %s" n1 n2
......
......@@ -76,12 +76,18 @@ module Ast : sig
val grewpy_compare: node -> node -> int
type edge_label = string (* p_obj.agt:suj *)
type atom_edge_label_cst =
| Atom_eq of string * string list (* 1=subj|obj *)
| Atom_diseq of string * string list (* 1<>subj|obj *)
| Atom_absent of string (* !2 *)
type edge_label = string
type edge_label_cst =
| Pos_list of edge_label list (* X|Y|Z *)
| Neg_list of edge_label list (* ^X|Y|Z *)
| Regexp of string (* re"a.*" *)
| Pos_list of edge_label list (* X|Y|Z *)
| Neg_list of edge_label list (* ^X|Y|Z *)
| Regexp of string (* re"a.*" *)
| Atom_list of atom_edge_label_cst list (* 1=subj, 2 *)
type u_edge = {
edge_id: Id.name option;
......
......@@ -282,6 +282,12 @@ module List_ = struct
| (k,_)::t when key>k -> sort_assoc key t
| (_,v)::_ -> Some v
let rec sort_mem_assoc key = function
| [] -> false
| (k,_)::_ when key<k -> false
| (k,_)::t when key>k -> sort_mem_assoc key t
| (_,v)::_ -> true
let rec sort_remove_assoc key = function
| [] -> []
| (k,_)::_ as t when key<k -> t
......
......@@ -171,6 +171,7 @@ module List_: sig
val sort_diff: 'a list -> 'a list -> 'a list
val sort_assoc: 'a -> ('a * 'b) list -> 'b option
val sort_mem_assoc: 'a -> ('a * 'b) list -> bool
(* [sort_remove_assoc k ass_list] returns the input list without the [key] element,
if [key] not found, the unchanged input list is returned *)
......
......@@ -21,6 +21,7 @@ module Label_domain : sig
val to_dep: ?deco:bool -> style -> string
val to_dot: ?deco:bool -> style -> string
val default: style
type t
(* [decl] is the type for a label declaration: the name and a list of display options *)
......
......@@ -18,24 +18,14 @@ open Grew_domain
(* ================================================================================ *)
module G_edge = struct
(** Internal representation of labels *)
type t = Dom of int | Local of string
type t = (string * string) list
let to_string ?domain = function
| Local s -> s
| Dom i ->
match Domain.get_label_name ?domain i with
| Some s -> s
| None -> Log.bug "Inconsistency in [G_edge.to_string]"; exit 1
let to_string ?domain edge =
String.concat "," (List.map (fun (x,y) -> x^"="^y) edge)
let get_style ?domain = function
| Local s -> Label_domain.parse_option s []
| Dom i ->
match Domain.get_label_style ?domain i with
| Some s -> s
| None -> Log.bug "Inconsistency in [G_edge.get_style]"; exit 1
let is_void ?domain edge = failwith "TODO [G_edge.is_void]"
let is_void ?domain t = Label_domain.is_void (get_style ?domain t)
let get_style ?domain edge = Label_domain.default
let to_dep ?domain ?(deco=false) t =
let style = get_style ?domain t in
......@@ -45,10 +35,17 @@ module G_edge = struct
let style = get_style ?domain t in
Label_domain.to_dot ~deco style
let split l = CCList.mapi
(fun i elt -> (string_of_int (i+1), elt)) l
let from_string ?loc ?domain str =
match Domain.edge_id_from_string ?loc ?domain str with
| Some id -> Dom id
| None -> Local str
let unsorted =
match Str.split (Str.regexp_string ":") str with
| "S" :: l -> ("kind","surf") :: (split l)
| "D" :: l -> ("kind","deep") :: (split l)
| "E" :: l -> ("kind","enhanced") :: (split l)
| l -> split l in
List.sort (Pervasives.compare) unsorted
let to_json ?domain t = `String (to_string ?domain t)
......@@ -60,25 +57,38 @@ module G_edge = struct
| Ast.Neg_list _ -> Error.build "Negative edge spec are forbidden in graphs%s" (Loc.to_string loc)
| Ast.Pos_list _ -> Error.build "Only atomic edge values are allowed in graphs%s" (Loc.to_string loc)
| Ast.Regexp _ -> Error.build "Regexp are not allowed in graphs%s" (Loc.to_string loc)
| Ast.Atom_list _ -> Error.build "Non atomic edge are not allowed in graphs%s" (Loc.to_string loc)
let color_of_option = function
| [] -> None
| c::_ -> Some (String_.rm_first_char c)
end (* module G_edge *)
(* ================================================================================ *)
(** The module [Label_cst] defines contraints on label edges *)
module Label_cst = struct
type atom_cst =
| Eq of (string * string list)
| Diseq of (string * string list)
| Absent of string
type t =
| Pos of G_edge.t list
| Neg of G_edge.t list
| Regexp of (Str.regexp * string)
| Atom_list of atom_cst list
let to_string ?domain = function
| Pos l -> (List_.to_string (G_edge.to_string ?domain) "|" l)
| Neg l -> "^"^(List_.to_string (G_edge.to_string ?domain) "|" l)
| Regexp (_,re) -> "re\""^re^"\""
| Atom_list l ->
String.concat ","
(List.map
(function
| Eq (name,al) -> sprintf "%s=%s" name (String.concat "|" al)
| Diseq (name,al) -> sprintf "%s<>%s" name (String.concat "|" al)
| Absent name -> sprintf "!%s" name
) l
)
let to_json ?domain = function
| Pos l -> `Assoc
......@@ -91,18 +101,41 @@ module Label_cst = struct
]
| Regexp (_,re) -> `Assoc
["regexp", `String re]
| Atom_list l -> failwith "TODO json"
let all = Neg []
let match_atom g_label = function
| Eq (name, l) ->
begin
match List_.sort_assoc name g_label with
| None -> false
| Some v -> List_.sort_mem v l
end
| Diseq (name, l) ->
begin
match List_.sort_assoc name g_label with
| None -> false
| Some v -> not (List_.sort_mem v l)
end
| Absent name -> not (List_.sort_mem_assoc name g_label)
let match_ ?domain cst g_label = match cst with
| Pos labels -> List.exists (fun p_label -> p_label = g_label) labels
| Neg labels -> not (List.exists (fun p_label -> p_label = g_label) labels)
| Regexp (re,_) -> String_.re_match re (G_edge.to_string ?domain g_label)
| Atom_list l -> List.for_all (match_atom g_label) l
let build_atom = function
| Ast.Atom_eq (name, atoms) -> Eq (name, atoms)
| Ast.Atom_diseq (name, atoms) -> Diseq (name, atoms)
| Ast.Atom_absent name -> Absent name
let build ?loc ?domain = function
| Ast.Neg_list p_labels -> Neg (List.sort compare (List.map (G_edge.from_string ?loc ?domain) p_labels))
| Ast.Pos_list p_labels -> Pos (List.sort compare (List.map (G_edge.from_string ?loc ?domain) p_labels))
| Ast.Regexp re -> Regexp (Str.regexp re, re)
| Ast.Atom_list l -> Atom_list (List.map build_atom l)
end (* module Label_cst *)
(* ================================================================================ *)
......
......@@ -43,7 +43,7 @@ let letter = ['a'-'z' 'A'-'Z']
The first characted cannot be a digit, or a colon (to avoid confusion).
*)
let label_ident =
(letter | '_' | '-' | '.' | '*') (letter | digit | '_' | '\'' | '-' | '.' | ':' | '*')*
(letter | digit | '_' | '-' | '.' | '*') (letter | digit | '_' | '\'' | '-' | '.' | ':' | '*')*
let general_ident =
(letter | '_' ) |
......@@ -137,10 +137,14 @@ and label_parser target = parse
| '{' { LACC }
| '}' { Global.label_flag := false; RACC }
| ',' { COMA }
| ',' { COMMA }
| '|' { PIPE }
| '/' { SLASH }
| '=' { EQUAL }
| "!" { BANG }
| "<>" { DISEQUAL }
| '@' general_ident as cmd_var { AROBAS_ID cmd_var }
| "@#" color as col { COLOR col }
......@@ -226,7 +230,7 @@ and standard target = parse
| ')' { RPAREN }
| ':' { DDOT }
| ';' { SEMIC }
| ',' { COMA }
| ',' { COMMA }
| '+' { PLUS }
| '#' { SHARP }
| '=' { EQUAL }
......
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment