Commit 203d3238 authored by bguillaum's avatar bguillaum

Use the same notion of regexp in feature constraints or in edge constraints

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8969 7838e531-6607-4d57-9587-6c381814729c
parent a5d53f31
......@@ -98,8 +98,10 @@ module Ast = struct
type edge_label = string
(* (list of edge_label separated by '|', bool true iff it is a negative constraint) *)
type edge_label_cst = edge_label list * bool
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.*" *)
type u_edge = {
edge_id: Id.name option;
......@@ -222,26 +224,33 @@ module Ast = struct
| Add_edge (n1,n2,label) ->
sprintf "add_edge %s -[%s]-> %s" n1 label n2
| Shift_in (n1,n2,([],true)) ->
| Shift_in (n1,n2,Neg_list []) ->
sprintf "shift_in %s ==> %s" n1 n2
| Shift_in (n1,n2,(labels,false)) ->
| 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,(labels,true)) ->
| 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,([],true)) ->
| Shift_out (n1,n2,Neg_list []) ->
sprintf "shift_out %s ==> %s" n1 n2
| Shift_out (n1,n2,(labels,false)) ->
| 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,(labels,true)) ->
| 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,([],true)) ->
| Shift_edge (n1,n2,Neg_list []) ->
sprintf "shift %s ==> %s" n1 n2
| Shift_edge (n1,n2,(labels,false)) ->
| 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,(labels,true)) ->
| 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
| Merge_node (n1,n2) -> sprintf "merge %s ==> %s" n1 n2
| New_neighbour (n1,n2,label) -> sprintf "add_node %s: <-[%s]- %s" n1 label n2
......
......@@ -66,8 +66,10 @@ module Ast : sig
type edge_label = string (* p_obj.agt:suj *)
(* (list of edge_label separated by '|', bool true iff it is a negative constraint) *)
type edge_label_cst = edge_label list * bool
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.*" *)
type u_edge = {
edge_id: Id.name option;
......
......@@ -71,37 +71,7 @@ module String_ = struct
|> (Str.global_replace (Str.regexp "\\( \\|\t\\)*$") "")
|> (Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "")
let rec match_star_re re s =
let star_re = Str.full_split (Str.regexp "\\*+") re in
let len = String.length s in
let rec loop pos = function
| [] -> pos = len
| [Str.Delim "*"] -> true
| Str.Text t :: tail ->
if Str.string_match (Str.regexp_string t) s pos
then loop (pos+(String.length t)) tail
else false
(* if the [re] ends with some text jump to the end and test for the text *)
| [Str.Delim "*"; Str.Text t] ->
(String.length t <= String.length s) &&
(Str.string_match (Str.regexp_string t) s (len - (String.length t)))
(* if the [re] required for some text [t],
we consider the first occurence which is more general than other occurences *)
| Str.Delim "*" :: Str.Text t :: tail ->
begin
try
let new_pos = Str.search_forward (Str.regexp_string t) s pos in
loop (new_pos+(String.length t)) tail
with Not_found -> false
end
| _ -> Error.build "Ill formed regular expression \"%s\"" re
in
loop 0 star_re
let re_match re s = (Str.string_match re s 0) && (Str.matched_string s = s)
end (* module String_ *)
......
......@@ -23,6 +23,8 @@ module String_: sig
(* [to_float]: robust conversion of float to string whatever is the locale *)
val of_float: float -> string
val re_match: Str.regexp -> string -> bool
(* [rm_first_char s] returns the string [s] without the first charater if s is not empty.
If s in empty, the empty string is returned *)
val rm_first_char: string -> string
......@@ -30,9 +32,6 @@ module String_: sig
(* [rm_peripheral_white s] returns the string [s] without any white space ot tab
at the beginning or at the end of the string. *)
val rm_peripheral_white: string -> string
(** [match_star_re star_re string] returns true iff the string match the [star_re] *)
val match_star_re: string -> string -> bool
end
......
......@@ -95,8 +95,8 @@ module Command = struct
| (Ast.Del_edge_expl (act_i, act_j, lab), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
let edge = G_edge.make ~loc label_domain ~locals lab in
((DEL_EDGE_EXPL (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
let edge = G_edge.make ~loc label_domain lab in
((DEL_EDGE_EXPL (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
| (Ast.Del_edge_name id, loc) ->
check_edge loc id kei;
......@@ -105,37 +105,37 @@ module Command = struct
| (Ast.Add_edge (act_i, act_j, lab), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
let edge = G_edge.make ~loc label_domain ~locals lab in
((ADD_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
let edge = G_edge.make ~loc label_domain lab in
((ADD_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
| (Ast.Shift_edge (act_i, act_j, label_cst), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
((SHIFT_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ~loc label_domain ~locals label_cst), loc), (kai, kei))
((SHIFT_EDGE (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build ~loc label_domain label_cst), loc), (kai, kei))
| (Ast.Shift_in (act_i, act_j, label_cst), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
((SHIFT_IN (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build label_domain ~loc ~locals label_cst), loc), (kai, kei))
((SHIFT_IN (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build label_domain ~loc label_cst), loc), (kai, kei))
| (Ast.Shift_out (act_i, act_j, label_cst), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
((SHIFT_OUT (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build label_domain ~loc ~locals label_cst), loc), (kai, kei))
((SHIFT_OUT (pid_of_act_id loc act_i, pid_of_act_id loc act_j, Label_cst.build label_domain ~loc label_cst), loc), (kai, kei))
| (Ast.Merge_node (act_i, act_j), loc) ->
check_node_id loc act_i kai;
check_node_id loc act_j kai;
((MERGE_NODE (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (List_.rm act_i kai, kei))
((MERGE_NODE (pid_of_act_id loc act_i, pid_of_act_id loc act_j), loc), (List_.rm act_i kai, kei))
| (Ast.New_neighbour (new_id, ancestor, label), loc) ->
check_node_id loc ancestor kai;
if List.mem new_id kai
then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
let edge = G_edge.make ~loc label_domain ~locals label in
begin
try
let edge = G_edge.make ~loc label_domain label in
begin
try
(
(NEW_NEIGHBOUR
(new_id,
......@@ -144,12 +144,12 @@ module Command = struct
), loc),
(new_id::kai, kei)
)
with not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
(G_edge.to_string label_domain edge)
ancestor
(Loc.to_string loc)
end
with Not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
(G_edge.to_string label_domain edge)
ancestor
(Loc.to_string loc)
end
| (Ast.New_node new_id, loc) ->
if List.mem new_id kai
......
......@@ -15,19 +15,46 @@ open Grew_base
open Grew_types
open Grew_ast
(* ================================================================================ *)
(** The module [Label_cst] defines contraints on label edges *)
module Label_cst = struct
type t =
| Pos of Label.t list
| Neg of Label.t list
| Regexp of (Str.regexp * string)
let to_string label_domain = function
| Pos l -> (List_.to_string (Label.to_string label_domain) "|" l)
| Neg l -> "^"^(List_.to_string (Label.to_string label_domain) "|" l)
| Regexp (_,re) -> "re\""^re^"\""
let all = Neg []
let match_ label_domain cst g_label = match cst with
| Pos labels -> Label.match_list labels g_label
| Neg labels -> not (Label.match_list labels g_label)
| Regexp (re,_) -> String_.re_match re (Label.to_string label_domain g_label)
let build ?loc label_domain = function
| Ast.Neg_list p_labels -> Neg (List.sort compare (List.map (Label.from_string ?loc label_domain) p_labels))
| Ast.Pos_list p_labels -> Pos (List.sort compare (List.map (Label.from_string ?loc label_domain) p_labels))
| Ast.Regexp re -> Regexp (Str.regexp re, re)
end (* module Label_cst *)
(* ================================================================================ *)
module G_edge = struct
type t = Label.t
let to_string label_domain ?(locals=[||]) t = Label.to_string label_domain ~locals t
let to_string label_domain t = Label.to_string label_domain t
let make ?loc label_domain ?(locals=[||]) string = Label.from_string ?loc label_domain ~locals string
let make ?loc label_domain string = Label.from_string ?loc label_domain string
let build label_domain ?locals (ast_edge, loc) =
let build label_domain (ast_edge, loc) =
match ast_edge.Ast.edge_label_cst with
| ([one], false) -> Label.from_string ~loc label_domain ?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)
| Ast.Pos_list [one] -> Label.from_string ~loc label_domain one
| 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)
let to_dep label_domain ?(deco=false) t = Label.to_dep label_domain ~deco t
let to_dot label_domain ?(deco=false) t = Label.to_dot label_domain ~deco t
......@@ -40,52 +67,43 @@ end (* module G_edge *)
(* ================================================================================ *)
module P_edge = struct
type t = {
id: string option; (* an identifier for naming under_label in patterns *)
u_label: Label_cst.t;
}
id: string option; (* an identifier for naming under_label in patterns *)
label_cst: Label_cst.t;
}
let all = {id=None; u_label= Label_cst.all }
let all = {id=None; label_cst=Label_cst.all }
let get_id t = t.id
let build label_domain ?locals (ast_edge, loc) =
let build label_domain (ast_edge, loc) =
{ id = ast_edge.Ast.edge_id;
u_label = Label_cst.build ~loc label_domain ?locals ast_edge.Ast.edge_label_cst
label_cst = Label_cst.build ~loc label_domain ast_edge.Ast.edge_label_cst
}
let to_string label_domain t =
match t.id with
| None -> Label_cst.to_string label_domain t.u_label
| Some i -> sprintf "%s:%s" i (Label_cst.to_string label_domain t.u_label)
| None -> Label_cst.to_string label_domain t.label_cst
| Some i -> sprintf "%s:%s" i (Label_cst.to_string label_domain t.label_cst)
type edge_matcher =
| Fail
| Ok of Label.t
| Binds of string * Label.t list
let match_ label_domain pattern_edge graph_label =
match pattern_edge with
| {id = Some i; u_label = Label_cst.Pos l} when Label.match_list label_domain l graph_label -> Binds (i, [graph_label])
| {id = None; u_label = Label_cst.Pos l} when Label.match_list label_domain l graph_label -> Ok graph_label
| {id = Some i; u_label = Label_cst.Neg l} when not (Label.match_list label_domain l graph_label) -> Binds (i, [graph_label])
| {id = None; u_label = Label_cst.Neg l} when not (Label.match_list label_domain l graph_label) -> Ok graph_label
let match_ label_domain p_edge g_edge =
match p_edge with
| {id = None; label_cst } when Label_cst.match_ label_domain label_cst g_edge -> Ok g_edge
| {id = Some i; label_cst } when Label_cst.match_ label_domain label_cst g_edge -> Binds (i, [g_edge])
| _ -> Fail
let match_list label_domain pattern_edge graph_edge_list =
match pattern_edge with
| {id = None; u_label = Label_cst.Pos l} when List.exists (fun label -> Label.match_list label_domain l label) graph_edge_list ->
Ok (List.hd graph_edge_list)
| {id = None; u_label = Label_cst.Neg l} when List.exists (fun label -> not (Label.match_list label_domain l label)) graph_edge_list ->
Ok (List.hd graph_edge_list)
| {id = Some i; u_label = Label_cst.Pos l} ->
( match List.filter (fun label -> Label.match_list label_domain l label) graph_edge_list with
let match_list label_domain p_edge g_edge_list =
match p_edge with
| {id = None; label_cst} when List.exists (fun g_edge -> Label_cst.match_ label_domain label_cst g_edge) g_edge_list ->
Ok (List.hd g_edge_list)
| {id = None} -> Fail
| {id = Some i; label_cst } ->
( match List.filter (fun g_edge -> Label_cst.match_ label_domain label_cst g_edge) g_edge_list with
| [] -> Fail
| list -> Binds (i, list)
)
| {id = Some i; u_label = Label_cst.Neg l} ->
( match List.filter (fun label -> not (Label.match_list label_domain l label)) graph_edge_list with
| [] -> Fail
| list -> Binds (i, list)
)
| _ -> Fail
end (* module P_edge *)
......@@ -13,16 +13,31 @@ open Grew_types
open Grew_ast
(* ================================================================================ *)
(** The module [Label_cst] defines contraints on label edges *)
module Label_cst : sig
type t =
| Pos of Label.t list
| Neg of Label.t list
| Regexp of (Str.regexp * string)
val to_string: Domain.t -> t -> string
val all: t
val match_: Domain.t -> t -> Label.t -> bool
val build: ?loc:Loc.t -> Domain.t -> Ast.edge_label_cst -> t
end (* module Label_cst *)
(* ================================================================================ *)
(** The module [G_edge] defines the type of Graph label edges: atomic edges *)
module G_edge: sig
type t = Label.t
val to_string: Domain.t -> ?locals:Label_domain.decl array -> t -> string
val to_string: Domain.t -> t -> string
val make: ?loc:Loc.t -> Domain.t -> ?locals:Label_domain.decl array -> string -> t
val make: ?loc:Loc.t -> Domain.t -> string -> t
val build: Domain.t -> ?locals:Label_domain.decl array -> Ast.edge -> t
val build: Domain.t -> Ast.edge -> t
val to_dot: Domain.t -> ?deco:bool -> t -> string
val to_dep: Domain.t -> ?deco:bool -> t -> string
......@@ -40,7 +55,7 @@ module P_edge: sig
val to_string: Domain.t -> t -> string
val build: Domain.t -> ?locals:Label_domain.decl array -> Ast.edge -> t
val build: Domain.t -> Ast.edge -> t
type edge_matcher =
| Fail
......
......@@ -88,7 +88,7 @@ module P_graph = struct
(fun acc (ast_edge, loc) ->
let i1 = Id.build ~loc ast_edge.Ast.src pos_table in
let i2 = Id.build ~loc ast_edge.Ast.tar pos_table in
let edge = P_edge.build domain ~locals (ast_edge, loc) in
let edge = P_edge.build domain (ast_edge, loc) in
(match map_add_edge acc (Pid.Pos i1) edge (Pid.Pos i2) with
| Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
......@@ -155,7 +155,7 @@ module P_graph = struct
match Id.build_opt tar pos_table with
| Some i -> Pid.Pos i
| None -> Pid.Neg (Id.build ~loc tar new_table) in
let edge = P_edge.build domain ~locals (ast_edge, loc) in
let edge = P_edge.build domain (ast_edge, loc) in
match map_add_edge acc i1 edge i2 with
| Some map -> map
| None -> Log.fbug "[GRS] [Graph.build_extension] add_edge cannot fail in pattern extension"; exit 2
......@@ -242,7 +242,7 @@ module G_graph = struct
(* is there an edge e out of node i ? *)
let edge_out domain graph node_id label_cst =
let node = Gid_map.find node_id graph.map in
Massoc_gid.exists (fun _ e -> Label_cst.match_ domain e label_cst) (G_node.get_next node)
Massoc_gid.exists (fun _ e -> Label_cst.match_ domain label_cst e) (G_node.get_next node)
let get_annot_info graph =
let annot_info =
......@@ -300,7 +300,7 @@ module G_graph = struct
(fun acc (ast_edge, loc) ->
let i1 = List.assoc ast_edge.Ast.src table in
let i2 = List.assoc ast_edge.Ast.tar table in
let edge = G_edge.build domain ~locals (ast_edge, loc) in
let edge = G_edge.build domain (ast_edge, loc) in
(match map_add_edge acc i1 edge i2 with
| Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
......@@ -487,14 +487,14 @@ module G_graph = struct
let src_tar_edges = Massoc_gid.assoc tar_gid src_next in
let _ =
try
let loop_edge = List.find (fun edge -> Label_cst.match_ domain edge label_cst) src_tar_edges in
let loop_edge = List.find (fun edge -> Label_cst.match_ domain label_cst edge) src_tar_edges in
Error.run ~loc "The shfit_out command tries to build a loop (with label %s)" (Label.to_string domain loop_edge)
with Not_found -> () in
let (new_src_next,new_tar_next) =
Massoc_gid.fold
(fun (acc_src_next,acc_tar_next) next_gid edge ->
if Label_cst.match_ domain edge label_cst
if Label_cst.match_ domain label_cst edge
then
match Massoc_gid.add next_gid edge acc_tar_next with
| Some new_acc_tar_next -> (Massoc_gid.remove next_gid edge acc_src_next, new_acc_tar_next)
......@@ -519,7 +519,7 @@ module G_graph = struct
let tar_src_edges = Massoc_gid.assoc src_gid tar_next in
let _ =
try
let loop_edge = List.find (fun edge -> Label_cst.match_ domain edge label_cst) tar_src_edges in
let loop_edge = List.find (fun edge -> Label_cst.match_ domain label_cst edge) tar_src_edges in
Error.run ~loc "The [shift_in] command tries to build a loop (with label \"%s\")" (Label.to_string domain loop_edge)
with Not_found -> () in
......@@ -534,7 +534,7 @@ module G_graph = struct
let (new_node_src_edges, new_node_tar_edges) =
List.fold_left
(fun (acc_node_src_edges,acc_node_tar_edges) edge ->
if Label_cst.match_ domain edge label_cst
if Label_cst.match_ domain label_cst edge
then
match List_.usort_insert edge acc_node_tar_edges with
| None -> Error.run ~loc "The [shift_in] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string domain edge)
......
......@@ -74,25 +74,30 @@ module Html_doc = struct
bprintf buff " ";
bprintf buff "%s" (match u_edge.Ast.edge_id with Some n -> n^": " | None -> "");
match u_edge.Ast.edge_label_cst with
| (l,true) -> bprintf buff "%s -[^%s]-> %s;\n" u_edge.Ast.src (List_.to_string (fun x->x) "|" l) u_edge.Ast.tar
| (l,false) -> bprintf buff "%s -[%s]-> %s;\n" u_edge.Ast.src (List_.to_string (fun x->x) "|" l) u_edge.Ast.tar
| Ast.Pos_list l -> bprintf buff "%s -[%s]-> %s;\n" u_edge.Ast.src (List_.to_string (fun x->x) "|" l) u_edge.Ast.tar
| Ast.Neg_list l -> bprintf buff "%s -[^%s]-> %s;\n" u_edge.Ast.src (List_.to_string (fun x->x) "|" l) u_edge.Ast.tar
| Ast.Regexp re -> bprintf buff "%s -[re\"%s\"]-> %s;\n" u_edge.Ast.src re u_edge.Ast.tar
let buff_html_const buff (u_const,_) =
bprintf buff " ";
(match u_const with
| Ast.Cst_out (ident, ([],false)) ->
| Ast.Cst_out (ident, Ast.Neg_list []) ->
bprintf buff "%s -> *" ident
| Ast.Cst_out (ident, (labels,false)) ->
| Ast.Cst_out (ident, Ast.Pos_list labels) ->
bprintf buff "%s -[%s]-> *" ident (List_.to_string (fun x->x) "|" labels)
| Ast.Cst_out (ident, (labels,true)) ->
| Ast.Cst_out (ident, Ast.Neg_list labels) ->
bprintf buff "%s -[^%s]-> *" ident (List_.to_string (fun x->x) "|" labels)
| Ast.Cst_out (ident, Ast.Regexp re) ->
bprintf buff "%s -[re\"%s\"]-> *" ident re
| Ast.Cst_in (ident, ([],false)) ->
| Ast.Cst_in (ident, Ast.Neg_list []) ->
bprintf buff "* -> %s" ident
| Ast.Cst_in (ident, (labels,false)) ->
| Ast.Cst_in (ident, Ast.Pos_list labels) ->
bprintf buff "* -[%s]-> %s" (List_.to_string (fun x->x) "|" labels) ident
| Ast.Cst_in (ident, (labels,true)) ->
| Ast.Cst_in (ident, Ast.Neg_list labels) ->
bprintf buff "* -[^%s]-> %s" (List_.to_string (fun x->x) "|" labels) ident
| Ast.Cst_in (ident, Ast.Regexp re) ->
bprintf buff "* -[re\"%s\"]-> %s" re ident
| Ast.Feature_eq (feat_id_l, feat_id_r) ->
bprintf buff "%s = %s" (Ast.dump_feature_ident feat_id_l) (Ast.dump_feature_ident feat_id_r);
......
......@@ -77,23 +77,23 @@ and comment_multi target = parse
| '\n' { incr Global.current_line; Lexing.new_line lexbuf; comment_multi target lexbuf }
| _ { comment_multi target lexbuf }
and string_lex target = parse
and string_lex re target = parse
| '\\' {
if !escaped
then (bprintf buff "\\"; escaped := false; string_lex target lexbuf)
else (escaped := true; string_lex target lexbuf)
then (bprintf buff "\\"; escaped := false; string_lex re target lexbuf)
else (escaped := true; string_lex re target lexbuf)
}
| '\n' { incr Global.current_line; Lexing.new_line lexbuf; bprintf buff "\n"; string_lex target lexbuf }
| '\n' { incr Global.current_line; Lexing.new_line lexbuf; bprintf buff "\n"; string_lex re target lexbuf }
| '\"' {
if !escaped
then (bprintf buff "\""; escaped := false; string_lex target lexbuf)
else (STRING(Buffer.contents buff) )
then (bprintf buff "\""; escaped := false; string_lex re target lexbuf)
else (if re then REGEXP (Buffer.contents buff) else STRING (Buffer.contents buff))
}
| _ as c {
if !escaped then bprintf buff "\\";
escaped := false;
bprintf buff "%c" c;
string_lex target lexbuf
string_lex re target lexbuf
}
(* a dedicated lexer for lexical parameter: read everything until "#END" *)
......@@ -131,7 +131,8 @@ and label_parser target = parse
| "@#" color as col { COLOR col }
| label_ident as id { ID id }
| '"' { Buffer.clear buff; string_lex global lexbuf }
| '"' { Buffer.clear buff; string_lex false global lexbuf }
| "re\"" { Buffer.clear buff; string_lex true global lexbuf }
| "]->" { Global.label_flag := false; LTR_EDGE_RIGHT }
| "]-" { Global.label_flag := false; RTL_EDGE_RIGHT }
......@@ -200,7 +201,6 @@ and standard target = parse
| '+' { PLUS }
| '#' { SHARP }
| '=' { EQUAL }
| "==" { REGEXP }
| "!" { BANG }
| "<>" { DISEQUAL }
......@@ -228,7 +228,8 @@ and standard target = parse
| "=[^" { Global.label_flag := true; ARROW_LEFT_NEG }
| "]=>" { ARROW_RIGHT }
| '"' { Buffer.clear buff; string_lex global lexbuf }
| '"' { Buffer.clear buff; string_lex false global lexbuf }
| "re\"" { Buffer.clear buff; string_lex true global lexbuf }
| eof { EOF }
| _ as c { raise (Error (sprintf "unexpected character '%c'" c)) }
This diff is collapsed.
......@@ -100,13 +100,13 @@ module Rule = struct
| Prec of Pid.t * Pid.t
| Lprec of Pid.t * Pid.t
let build_pos_constraint domain ?locals pos_table const =
let build_pos_constraint domain pos_table const =
let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
match const with
| (Ast.Cst_out (id,label_cst), loc) ->
Cst_out (pid_of_name loc id, Label_cst.build ~loc domain ?locals label_cst)
Cst_out (pid_of_name loc id, Label_cst.build ~loc domain label_cst)
| (Ast.Cst_in (id,label_cst), loc) ->
Cst_in (pid_of_name loc id, Label_cst.build ~loc domain ?locals label_cst)
Cst_in (pid_of_name loc id, Label_cst.build ~loc domain label_cst)
| (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Domain.check_feature_name domain ~loc feat_name1;
......@@ -144,26 +144,26 @@ module Rule = struct
let build_pos_basic domain ?pat_vars ?(locals=[||]) basic_ast =
let (graph, pos_table) =
P_graph.build domain ?pat_vars ~locals basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
P_graph.build domain ?pat_vars basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
(
{
graph = graph;
constraints = List.map (build_pos_constraint domain ~locals pos_table) basic_ast.Ast.pat_const
constraints = List.map (build_pos_constraint domain pos_table) basic_ast.Ast.pat_const
},
pos_table
)
(* the neg part *)
let build_neg_constraint domain ?locals pos_table neg_table const =
let build_neg_constraint domain pos_table neg_table const =
let pid_of_name loc node_name =
match Id.build_opt node_name pos_table with
| Some i -> Pid.Pos i
| None -> Pid.Neg (Id.build ~loc node_name neg_table) in
match const with
| (Ast.Cst_out (id,label_cst), loc) ->
Cst_out (pid_of_name loc id, Label_cst.build ~loc domain ?locals label_cst)
Cst_out (pid_of_name loc id, Label_cst.build ~loc domain label_cst)
| (Ast.Cst_in (id,label_cst), loc) ->
Cst_in (pid_of_name loc id, Label_cst.build ~loc domain ?locals label_cst)
Cst_in (pid_of_name loc id, Label_cst.build ~loc domain label_cst)
| (Ast.Feature_eq (feat_id1, feat_id2), loc) ->
let (node_name1, feat_name1) = feat_id1
......@@ -205,12 +205,12 @@ module Rule = struct
(* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
let build_neg_basic domain ?pat_vars ?(locals=[||]) pos_table basic_ast =
let (extension, neg_table) =
P_graph.build_extension domain ?pat_vars ~locals pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
P_graph.build_extension domain ?pat_vars pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
let filters = Pid_map.fold (fun id node acc -> Filter (id, P_node.get_fs node) :: acc) extension.P_graph.old_map [] in
{
graph = extension.P_graph.ext_map;
constraints = filters @ List.map (build_neg_constraint domain ~locals pos_table neg_table) basic_ast.Ast.pat_const ;
constraints = filters @ List.map (build_neg_constraint domain pos_table neg_table) basic_ast.Ast.pat_const ;
}
let get_edge_ids basic =
......@@ -362,11 +362,11 @@ module Rule = struct
| _ -> ()
);
let (pos, pos_table) = build_pos_basic domain ~pat_vars ~locals rule_ast.Ast.pattern.Ast.pat_pos in
let (pos, pos_table) = build_pos_basic domain ~pat_vars rule_ast.Ast.pattern.Ast.pat_pos in
let (negs,_) =
List.fold_left
(fun (acc,pos) basic_ast ->
try ((build_neg_basic domain ~pat_vars ~locals pos_table basic_ast) :: acc, pos+1)
try ((build_neg_basic domain ~pat_vars pos_table basic_ast) :: acc, pos+1)
with P_fs.Fail_unif ->
Log.fwarning "In rule \"%s\" [%s], the wihtout number %d cannot be satisfied, it is skipped"
rule_ast.Ast.rule_id (Loc.to_string rule_ast.Ast.rule_loc) pos;
......@@ -375,7 +375,7 @@ module Rule = struct
{
name = rule_ast.Ast.rule_id;
pattern = (pos, negs);
commands = build_commands domain ~param:(pat_vars,cmd_vars) ~locals pos pos_table rule_ast.Ast.commands;
commands = build_commands domain ~param:(pat_vars,cmd_vars) pos pos_table rule_ast.Ast.commands;
loc = rule_ast.Ast.rule_loc;
param = param;
param_names = (pat_vars,cmd_vars)
......@@ -507,7 +507,7 @@ module Rule = struct
let gid = Pid_map.find pid matching.n_match in
if G_graph.node_exists
(fun node ->
List.exists (fun e -> Label_cst.match_ domain e label_cst) (Massoc_gid.assoc gid (G_node.get_next node))
List.exists (fun e -> Label_cst.match_ domain label_cst e) (Massoc_gid.assoc gid (G_node.get_next node))
) graph
then matching
else raise Fail
......@@ -556,12 +556,7 @@ module Rule = struct
| None -> raise Fail
| Some string_feat ->
let re = Str.regexp regexp in
if Str.string_match re string_feat 0
then
if Str.matched_string string_feat = string_feat
then matching
else raise Fail
else raise Fail
if String_.re_match re string_feat then matching else raise Fail
end
| Prec (pid1, pid2) ->
let gid1 = Pid_map.find pid1 matching.n_match in
......
......@@ -280,33 +280,13 @@ end
(* ================================================================================ *)
module Label = struct
(** Internal representation of labels *)
type t =
| Global of int (* globally defined labels: their names are in the domain *)
| Local of int (* locally defined labels: names array should be provided! UNTESTED *)
| Pattern of string
let match_ ((table,_),_) p_label g_label = match (p_label, g_label) with
| (Global p, Global g) when p=g -> true
| (Pattern p, Global i) when String_.match_star_re p table.(i) -> true
| _ -> false
let match_list domain p_label_list g_label =
List.exists (fun p_label -> match_ domain p_label g_label) p_label_list
type t = int
(** [to_string label_domain t] returns a string for the label *)
let to_string ((table,_),_) ?(locals=[||]) = function
| Global i -> table.(i)
| Local i -> fst locals.(i)
| Pattern s -> s
let match_list p_label_list g_label = List.exists (fun p_label -> p_label = g_label) p_label_list
let to_int = function
| Global i -> Some i
| _ -> None
let to_string ((table,_),_) i = table.(i)