Commit 74a9f052 authored by bguillaum's avatar bguillaum

handling of "*" in pattern edge labels

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8579 7838e531-6607-4d57-9587-6c381814729c
parent c350c1f0
......@@ -68,6 +68,37 @@ 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] ->
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
end (* module String_ *)
(* ================================================================================ *)
......
......@@ -30,6 +30,9 @@ 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
......
......@@ -81,26 +81,25 @@ module P_edge = struct
| Binds of string * Label.t list
let match_ pattern_edge graph_label =
match pattern_edge with
| {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
| {id = Some i; u_label = Pos l} when Label.match_list l graph_label -> Binds (i, [graph_label])
| {id = None; u_label = Pos l} when Label.match_list l graph_label -> Ok graph_label
| {id = Some i; u_label = Neg l} when not (Label.match_list l graph_label) -> Binds (i, [graph_label])
| {id = None; u_label = Neg l} when not (Label.match_list l graph_label) -> Ok graph_label
| _ -> Fail
let match_list pattern_edge graph_edge_list =
match pattern_edge with
| {id = None; u_label = Pos l} when List.exists (fun label -> List.mem label l) graph_edge_list ->
| {id = None; u_label = Pos l} when List.exists (fun label -> Label.match_list l label) 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 ->
| {id = None; u_label = Neg l} when List.exists (fun label -> not (Label.match_list l label)) 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
(match List.filter (fun label -> Label.match_list l label) graph_edge_list with
| [] -> Fail
| list -> Binds (i, list))
| {id = Some i; u_label = Neg l} ->
(match List.filter (fun label -> not (List.mem label l)) graph_edge_list with
(match List.filter (fun label -> not (Label.match_list l label)) graph_edge_list with
| [] -> Fail
| list -> Binds (i, list))
| _ -> Fail
......
......@@ -132,12 +132,21 @@ module Label = struct
type t =
| 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 *)
| Pattern of string
let match_ p_label g_label = match (p_label, g_label, !full) with
| (Global p, Global g, _) when p=g -> true
| (Pattern p, Global i, Some table) when String_.match_star_re p table.(i) -> true
| _ -> false
let match_list p_label_list g_label = List.exists (fun p_label -> match_ p_label g_label) p_label_list
(** [to_string t] returns a string for the label *)
let to_string ?(locals=[||]) t =
match (!full, t) with
| (Some table, Global i) -> table.(i)
| (Some _, Local i) -> fst locals.(i)
| (_, Pattern s) -> s
| _ -> Error.bug "[Label.to_string] labels were not properly initialized"
let to_int = function
......@@ -150,6 +159,7 @@ module Label = struct
let get_style = function
| Global i -> !styles.(i)
| Local i -> Log.warning "Style of locally defined labels is not implemented"; default
| Pattern _ -> default
(** Computes the style of a label from its options and maybe its shape (like I:...). *)
let parse_option string_label options =
......@@ -205,13 +215,16 @@ module Label = struct
sprintf "[label=\"%s\", %s]" style.text (String.concat ", " dot_items)
let from_string ?loc ?(locals=[||]) string =
match !full with
| None -> Error.bug "[Label.from_string] labels were not properly initialized"
| 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
if String.contains string '*'
then Pattern string
else
match !full with
| None -> Error.bug "[Label.from_string] labels were not properly initialized"
| Some table ->
try Global (Id.build ?loc string table)
with Not_found (* TODO (CANNOT BE RAISED) *) ->
try Local (Array_.dicho_find_assoc string locals)
with Not_found -> Error.build "[Label.from_string] unknown edge label '%s'" string
end (* module Label *)
(* ================================================================================ *)
......
......@@ -74,6 +74,10 @@ module Label : sig
type t
val match_: t -> t -> bool
val match_list: t list -> t -> bool
val init: decl list -> unit
val to_string: ?locals:decl array -> t -> string
......
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