Skip to content

GitLab

Commit 2c5bb671 authored by bguillaum's avatar bguillaum
Browse files

reuse Label.cst type in P_edge 

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8632 7838e531-6607-4d57-9587-6c381814729c
parent a1221055
Hide whitespace changes
Inline Side-by-side
src/grew_ast.ml
View file @ 2c5bb671
......@@ -127,9 +127,8 @@ module Ast = struct
type u_edge = {
edge_id: Id.name option;
src: Id.name;
edge_labels: edge_label list;
edge_label_cst: edge_label_cst;
tar: Id.name;
negative: bool;
}
type edge = u_edge * Loc.t
......
src/grew_ast.mli
View file @ 2c5bb671
......@@ -82,9 +82,8 @@ module Ast : sig
type u_edge = {
edge_id: Id.name option;
src: Id.name;
edge_labels: edge_label list;
edge_label_cst: edge_label_cst;
tar: Id.name;
negative: bool;
}
type edge = u_edge * Loc.t
......
src/grew_edge.ml
View file @ 2c5bb671
......@@ -24,10 +24,10 @@ module G_edge = struct
let make ?loc ?(locals=[||]) string = Label.from_string ?loc ~locals string
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)
match ast_edge.Ast.edge_label_cst with
| ([one], false) -> 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)
let to_dep ?(deco=false) t = Label.to_dep ~deco t
let to_dot ?(deco=false) t = Label.to_dot ~deco t
......@@ -39,41 +39,30 @@ end (* module G_edge *)
(* ================================================================================ *)
module P_edge = struct
type u_label =
| Pos of Label.t list
| Neg of Label.t list
type t = {
id: string option; (* an identifier for naming under_label in patterns *)
u_label: u_label;
u_label: Label_cst.t;
}
let all = {id=None; u_label=Neg []}
let all = {id=None; u_label= Label_cst.all }
let get_id t = t.id
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))}
| l when neg -> {id=id; u_label=Label_cst.Neg (List.sort compare (List.map (Label.from_string ?loc ~locals) l))}
| l -> {id=id; u_label=Label_cst.Pos (List.sort compare (List.map (Label.from_string ?loc ~locals) l))}
let build ?locals (ast_edge, loc) =
{ id = ast_edge.Ast.edge_id;
u_label =
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))
u_label = Label_cst.build ~loc ?locals ast_edge.Ast.edge_label_cst
}
let to_string t =
let pref = match t.id with None -> "" | Some i -> sprintf "%s:" i in
match t.u_label with
| Pos l -> pref^(List_.to_string Label.to_string "|" l)
| Neg l -> pref^"^"^(List_.to_string Label.to_string "|" l)
match t.id with
| None -> Label_cst.to_string t.u_label
| Some i -> sprintf "%s:%s" i (Label_cst.to_string t.u_label)
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)
let compatible t g_edge = Label_cst.match_ g_edge t.u_label
type edge_matcher =
| Fail
......@@ -82,23 +71,23 @@ module P_edge = struct
let match_ pattern_edge graph_label =
match pattern_edge with
| {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
| {id = Some i; u_label = Label_cst.Pos l} when Label.match_list l graph_label -> Binds (i, [graph_label])
| {id = None; u_label = Label_cst.Pos l} when Label.match_list l graph_label -> Ok graph_label
| {id = Some i; u_label = Label_cst.Neg l} when not (Label.match_list l graph_label) -> Binds (i, [graph_label])
| {id = None; u_label = Label_cst.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 -> Label.match_list l label) graph_edge_list ->
| {id = None; u_label = Label_cst.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 (Label.match_list l label)) graph_edge_list ->
| {id = None; u_label = Label_cst.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} ->
| {id = Some i; u_label = Label_cst.Pos l} ->
(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} ->
| {id = Some i; u_label = Label_cst.Neg l} ->
(match List.filter (fun label -> not (Label.match_list l label)) graph_edge_list with
| [] -> Fail
| list -> Binds (i, list))
......
src/grew_edge.mli
View file @ 2c5bb671
......@@ -37,6 +37,7 @@ module P_edge: sig
val all: t
val get_id: t -> string option
val to_string: t -> string
val build: ?locals:Label.decl array -> Ast.edge -> t
......
src/grew_html.ml
View file @ 2c5bb671
......@@ -109,11 +109,9 @@ module Html_doc = struct
let buff_html_edge buff (u_edge,_) =
bprintf buff " ";
bprintf buff "%s" (match u_edge.Ast.edge_id with Some n -> n^": " | None -> "");
bprintf buff "%s -[%s%s]-> %s;\n"
u_edge.Ast.src
(if u_edge.Ast.negative then "^" else "")
(List_.to_string (fun x->x) "|" u_edge.Ast.edge_labels)
u_edge.Ast.tar
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
let buff_html_const buff (u_const,_) =
bprintf buff " ";
......
src/grew_types.ml
View file @ 2c5bb671
......@@ -234,17 +234,19 @@ module Label_cst = struct
| Pos of Label.t list
| Neg of Label.t list
let to_string = function
| Pos l -> (List_.to_string Label.to_string "|" l)
| Neg l -> "^"^(List_.to_string Label.to_string "|" l)
let all = Neg []
let positive list = Pos list
let negative list = Neg list
let match_ edge = function
| Pos labels -> Label.match_list labels edge
| Neg labels -> not (Label.match_list labels edge)
let build ?loc ?locals = function
| (edge_labels, true) -> Neg (List.map (Label.from_string ?loc ?locals) edge_labels)
| (edge_labels, false) -> Pos (List.map (Label.from_string ?loc ?locals) edge_labels)
| (edge_labels, true) -> Neg (List.sort compare (List.map (Label.from_string ?loc ?locals) edge_labels))
| (edge_labels, false) -> Pos (List.sort compare (List.map (Label.from_string ?loc ?locals) edge_labels))
end (* module Label_cst *)
......
src/grew_types.mli
View file @ 2c5bb671
......@@ -94,10 +94,12 @@ end (* module Label *)
(* ================================================================================ *)
(** The module [Label_cst] defines contraints on label edges *)
module Label_cst : sig
type t
type t =
| Pos of Label.t list
| Neg of Label.t list
val to_string: t -> string
val all: t
val positive: Label.t list -> t
val negative: Label.t list -> t
val match_: Label.t -> t -> bool
val build: ?loc:Loc.t -> ?locals:Label.decl array -> (string list * bool) -> t
end (* module Label_cst *)
......
src/parser/gr_grs_parser.mly
View file @ 2c5bb671
......@@ -186,9 +186,9 @@ gr_item:
{ let (id,loc) = id_loc in
Graph_node ({Ast.node_id = id; position=position; fs=feats}, loc) }
(* A -[x]-> B*)
(* A -[x]-> B *)
| n1_loc=simple_id_with_loc label=delimited(LTR_EDGE_LEFT,label_ident,LTR_EDGE_RIGHT) n2=simple_id
{ Graph_edge ({Ast.edge_id = None; src=fst n1_loc; edge_labels=[label]; tar=n2; negative=false }, snd n1_loc) }
{ Graph_edge ({Ast.edge_id = None; src=fst n1_loc; edge_label_cst=([label],false); tar=n2}, snd n1_loc) }
/*=============================================================================================*/
/* GREW GRAPH REWRITING SYSTEM */
......@@ -403,15 +403,15 @@ node_features:
pat_edge_or_const:
(* "e: A -> B" *)
| id_loc=simple_id_with_loc DDOT n1=simple_id EDGE n2=simple_id
{ let (id,loc) = id_loc in Pat_edge ({Ast.edge_id = Some id; src=n1; edge_labels=[]; tar=n2; negative=true}, loc) }
{ let (id,loc) = id_loc in Pat_edge ({Ast.edge_id = Some id; src=n1; edge_label_cst=([],true); tar=n2}, loc) }
(* "e: A -[X|Y]-> B" *)
| id_loc=simple_id_with_loc DDOT n1=simple_id labels=delimited(LTR_EDGE_LEFT,separated_nonempty_list(PIPE,pattern_label_ident),LTR_EDGE_RIGHT) n2=simple_id
{ let (id,loc) = id_loc in Pat_edge ({Ast.edge_id = Some id; src=n1; edge_labels=labels; tar=n2; negative=false}, loc) }
{ let (id,loc) = id_loc in Pat_edge ({Ast.edge_id = Some id; src=n1; edge_label_cst=(labels,false); tar=n2}, loc) }
(* "e: A -[^X|Y]-> B" *)
| id_loc=simple_id_with_loc DDOT n1=simple_id labels=delimited(LTR_EDGE_LEFT_NEG,separated_nonempty_list(PIPE,pattern_label_ident),LTR_EDGE_RIGHT) n2=simple_id
{ let (id,loc) = id_loc in Pat_edge ({Ast.edge_id = Some id; src=n1; edge_labels=labels; tar=n2; negative=true}, loc) }
{ let (id,loc) = id_loc in Pat_edge ({Ast.edge_id = Some id; src=n1; edge_label_cst=(labels,false); tar=n2}, loc) }
(* "A -> B" *)
......@@ -423,7 +423,7 @@ pat_edge_or_const:
| ("*", "*") -> Error.build ~loc "Source and target cannot be both underspecified"
| ("*", _) -> Pat_const (Ast.Cst_in n2, loc)
| (_, "*") -> Pat_const (Ast.Cst_out n1, loc)
| _ -> Pat_edge ({Ast.edge_id = None; src=n1; edge_labels=[]; tar=n2; negative=true}, loc)
| _ -> Pat_edge ({Ast.edge_id = None; src=n1; edge_label_cst=([],true); tar=n2}, loc)
}
(* "A -[X|Y]-> B" *)
......@@ -435,7 +435,7 @@ pat_edge_or_const:
| ("*", "*") -> Error.build ~loc "Source and target cannot be both underspecified"
| ("*", _) -> Pat_const (Ast.End (n2,labels), loc)
| (_, "*") -> Pat_const (Ast.Start (n1,labels), loc)
| _ -> Pat_edge ({Ast.edge_id = None; src=n1; edge_labels=labels; tar=n2; negative=false}, loc) }
| _ -> Pat_edge ({Ast.edge_id = None; src=n1; edge_label_cst=(labels,false); tar=n2}, loc) }
(* "A -[^X|Y]-> B"*)
| n1_loc=id_with_loc labels=delimited(LTR_EDGE_LEFT_NEG,separated_nonempty_list(PIPE,pattern_label_ident),LTR_EDGE_RIGHT) n2=ID
......@@ -444,7 +444,7 @@ pat_edge_or_const:
| ("*", "*") -> Error.build ~loc "Source and target cannot be both underspecified"
| ("*", _)
| (_, "*") -> Error.bug ~loc "Not implemented: pat edge constraint with negative labels"
| _ -> Pat_edge ({Ast.edge_id = None; src=n1; edge_labels=labels; tar=n2; negative=true}, loc) }
| _ -> Pat_edge ({Ast.edge_id = None; src=n1; edge_label_cst=(labels,true); tar=n2}, loc) }
(* "X.cat = Y.cat" *)
| feat_id1_loc=feature_ident_with_loc EQUAL feat_id2=feature_ident
......
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