Commit 7bad63c8 authored by Bruno Guillaume's avatar Bruno Guillaume

Simplify modules in grew_edge.ml*

parent 75d67efb
......@@ -7,7 +7,7 @@ digraph grew {
grew_domain [label="grew_domain|Label_domain\nFeature_domain\nDomain"]
grew_loader [label="grew_loader|Loader\nParser"]
grew_fs [label="grew_fs|Feature_value\nG_feature\nP_feature\nG_fs\nP_fs"]
grew_edge [label="grew_edge|Label\nLabel_cst\nG_edge\nP_edge"]
grew_edge [label="grew_edge|G_edge\nLabel_cst\nP_edge"]
grew_node [label="grew_node|G_node\nP_node"]
grew_command [label="grew_command|Command"]
grew_graph [label="grew_graph|P_deco\nP_graph\nG_deco\nG_graph\nDelta\nGraph_with_history\nGraph_with_history_set"]
......
......@@ -174,7 +174,7 @@ module Command = struct
| (Ast.Del_edge_expl (node_i, node_j, lab), loc) ->
check_node_id loc node_i kni;
check_node_id loc node_j kni;
let edge = G_edge.make ~loc ?domain lab in
let edge = G_edge.from_string ~loc ?domain lab in
((DEL_EDGE_EXPL (cn_of_node_id node_i, cn_of_node_id node_j, edge), loc), (kni, kei))
| (Ast.Del_edge_name id, loc) ->
......@@ -184,7 +184,7 @@ module Command = struct
| (Ast.Add_edge (node_i, node_j, lab), loc) ->
check_node_id loc node_i kni;
check_node_id loc node_j kni;
let edge = G_edge.make ~loc ?domain lab in
let edge = G_edge.from_string ~loc ?domain lab in
((ADD_EDGE (cn_of_node_id node_i, cn_of_node_id node_j, edge), loc), (kni, kei))
| (Ast.Add_edge_expl (node_i, node_j, name), loc) ->
......
......@@ -17,25 +17,23 @@ open Grew_ast
open Grew_domain
(* ================================================================================ *)
module Label = struct
module G_edge = struct
(** Internal representation of labels *)
type t = Dom of int | Local of string
let match_list p_label_list g_label = List.exists (fun p_label -> p_label = g_label) p_label_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 [Label.to_string]"; exit 1
| None -> Log.bug "Inconsistency in [G_edge.to_string]"; exit 1
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 [Label.get_style]"; exit 1
| None -> Log.bug "Inconsistency in [G_edge.get_style]"; exit 1
let is_void ?domain t = Label_domain.is_void (get_style ?domain t)
......@@ -51,30 +49,45 @@ module Label = struct
match Domain.edge_id_from_string ?loc ?domain str with
| Some id -> Dom id
| None -> Local str
end (* module Label *)
let to_json ?domain t = `String (to_string ?domain t)
let sub = from_string "__SUB__"
let build ?domain (ast_edge, loc) =
match ast_edge.Ast.edge_label_cst with
| Ast.Pos_list [one] -> from_string ~loc ?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 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 t =
| Pos of Label.t list
| Neg of Label.t list
| Pos of G_edge.t list
| Neg of G_edge.t list
| Regexp of (Str.regexp * string)
let to_string ?domain = function
| Pos l -> (List_.to_string (Label.to_string ?domain) "|" l)
| Neg l -> "^"^(List_.to_string (Label.to_string ?domain) "|" l)
| 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^"\""
let to_json ?domain = function
| Pos l -> `Assoc
["pos",
`List (List.map (fun lab -> `String (Label.to_string ?domain lab)) l)
`List (List.map (fun lab -> `String (G_edge.to_string ?domain lab)) l)
]
| Neg l -> `Assoc
["neg",
`List (List.map (fun lab -> `String (Label.to_string ?domain lab)) l)
`List (List.map (fun lab -> `String (G_edge.to_string ?domain lab)) l)
]
| Regexp (_,re) -> `Assoc
["regexp", `String re]
......@@ -82,44 +95,16 @@ module Label_cst = struct
let all = Neg []
let match_ ?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 ?domain g_label)
| 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)
let build ?loc ?domain = function
| Ast.Neg_list p_labels -> Neg (List.sort compare (List.map (Label.from_string ?loc ?domain) p_labels))
| Ast.Pos_list p_labels -> Pos (List.sort compare (List.map (Label.from_string ?loc ?domain) p_labels))
| 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)
end (* module Label_cst *)
(* ================================================================================ *)
module G_edge = struct
type t = Label.t
let to_string ?domain t = Label.to_string ?domain t
let to_json ?domain t = `String (Label.to_string ?domain t)
let make ?loc ?domain string = Label.from_string ?loc ?domain string
let sub = make "__SUB__"
let build ?domain (ast_edge, loc) =
match ast_edge.Ast.edge_label_cst with
| Ast.Pos_list [one] -> Label.from_string ~loc ?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 is_void ?domain t = Label.is_void ?domain t
let to_dep ?domain ?(deco=false) t = Label.to_dep ?domain ~deco t
let to_dot ?domain ?(deco=false) t = Label.to_dot ?domain ~deco t
let color_of_option = function
| [] -> None
| c::_ -> Some (String_.rm_first_char c)
end (* module G_edge *)
(* ================================================================================ *)
module P_edge = struct
type t = {
......@@ -152,7 +137,7 @@ module P_edge = struct
type edge_matcher =
| Fail
| Binds of string * Label.t list
| Binds of string * G_edge.t list
let match_ ?domain p_edge g_edge =
match p_edge with
......
......@@ -14,13 +14,10 @@ open Grew_ast
open Grew_domain
(* ================================================================================ *)
(** The module [Label] defines the type of atomic label edges *)
module Label : sig
(** The module [G_edge] defines the type of Graph label edges: atomic edges *)
module G_edge: sig
type t
(** [match_list p_label_list g_label] returns [true] iff [g_label] match at least one of the p_label of [p_label_list] *)
val match_list: t list -> t -> bool
val to_string: ?domain:Domain.t -> t -> string
val is_void: ?domain: Domain.t -> t -> bool
......@@ -30,47 +27,32 @@ module Label : sig
val to_dot: ?domain: Domain.t -> ?deco:bool -> t -> string
val from_string: ?loc:Loc.t -> ?domain: Domain.t -> string -> t
end (* module Label *)
val to_json: ?domain:Domain.t -> t -> Yojson.Basic.json
val sub: t
val build: ?domain:Domain.t -> Ast.edge -> t
val is_void: ?domain:Domain.t -> t -> bool
end (* module G_edge *)
(* ================================================================================ *)
(** 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)
type t
val to_string: ?domain:Domain.t -> t -> string
val to_json: ?domain:Domain.t -> t -> Yojson.Basic.json
val all: t
val match_: ?domain:Domain.t -> t -> Label.t -> bool
val match_: ?domain:Domain.t -> t -> G_edge.t -> bool
val build: ?loc:Loc.t -> ?domain: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:Domain.t -> t -> string
val to_json: ?domain:Domain.t -> t -> Yojson.Basic.json
val make: ?loc:Loc.t -> ?domain:Domain.t -> string -> t
val sub: t
val build: ?domain:Domain.t -> Ast.edge -> t
val is_void: ?domain:Domain.t -> t -> bool
val to_dot: ?domain:Domain.t -> ?deco:bool -> t -> string
val to_dep: ?domain:Domain.t -> ?deco:bool -> t -> string
end (* module G_edge *)
(* ================================================================================ *)
(** The module [G_edge] defines the type of Graph label edges: atomic edges *)
(** The module [P_edge] defines the type of pattern label edges: atomic edges *)
module P_edge: sig
type t
......@@ -87,7 +69,7 @@ module P_edge: sig
type edge_matcher =
| Fail
| Binds of string * Label.t list
| Binds of string * G_edge.t list
val match_: ?domain:Domain.t -> t -> G_edge.t -> edge_matcher
......
......@@ -410,7 +410,7 @@ module G_graph = struct
List.fold_left
(fun acc2 (gov, dep_lab) ->
let gov_id = Id.gbuild ~loc gov gtable in
let edge = G_edge.make ?domain ~loc dep_lab in
let edge = G_edge.from_string ?domain ~loc dep_lab in
(match map_add_edge_opt acc2 gov_id edge dep_id with
| Some g -> g
| None -> Error.build "[GRS] [Graph.of_conll] try to build a graph with twice the same edge %s %s"
......@@ -450,19 +450,19 @@ module G_graph = struct
(* add a new node *)
let new_map_1 = (Gid_map.add free_index new_node acc) in
(* add a link to the first component *)
let new_map_2 = map_add_edge new_map_1 free_index (G_edge.make ?domain kind) (Id.gbuild (fst mwe.Mwe.first) gtable) in
let new_map_2 = map_add_edge new_map_1 free_index (G_edge.from_string ?domain kind) (Id.gbuild (fst mwe.Mwe.first) gtable) in
let new_map_3 = match snd mwe.Mwe.first with
| None -> new_map_2
| Some i -> map_add_edge new_map_2 free_index (G_edge.make ?domain (sprintf "%d" i)) (Id.gbuild (fst mwe.Mwe.first) gtable) in
| Some i -> map_add_edge new_map_2 free_index (G_edge.from_string ?domain (sprintf "%d" i)) (Id.gbuild (fst mwe.Mwe.first) gtable) in
(* add a link to each other component *)
let new_map_4 =
Id_with_proj_set.fold (
fun item acc2 ->
let tmp = map_add_edge acc2 free_index (G_edge.make ?domain kind) (Id.gbuild (fst item) gtable) in
let tmp = map_add_edge acc2 free_index (G_edge.from_string ?domain kind) (Id.gbuild (fst item) gtable) in
match snd item with
| None -> tmp
| Some i -> map_add_edge tmp free_index (G_edge.make ?domain (sprintf "%d" i)) (Id.gbuild (fst item) gtable)
| Some i -> map_add_edge tmp free_index (G_edge.from_string ?domain (sprintf "%d" i)) (Id.gbuild (fst item) gtable)
) mwe.Mwe.items new_map_3 in
(* (match map_add_edge_opt acc2 gov_id edge dep_id with
......@@ -675,7 +675,7 @@ module G_graph = struct
if Label_cst.match_ ?domain label_cst edge && not (is_gid_local next_gid)
then
match Massoc_gid.add_opt next_gid edge acc_tar_next with
| None when !Global.safe_commands -> Error.run ~loc "The [shift_out] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string ?domain edge)
| None when !Global.safe_commands -> Error.run ~loc "The [shift_out] command tries to build a duplicate edge (with label \"%s\")" (G_edge.to_string ?domain edge)
| None ->
del_edges := (src_gid,edge,next_gid) :: !del_edges;
(Massoc_gid.remove next_gid edge acc_src_next, acc_tar_next)
......@@ -717,7 +717,7 @@ module G_graph = struct
then
match List_.usort_insert edge acc_node_tar_edges with
| None when !Global.safe_commands ->
Error.run ~loc "The [shift_in] command tries to build a duplicate edge (with label \"%s\")" (Label.to_string ?domain edge)
Error.run ~loc "The [shift_in] command tries to build a duplicate edge (with label \"%s\")" (G_edge.to_string ?domain edge)
| None ->
del_edges := (node_id,edge,src_gid) :: !del_edges;
(List_.usort_remove edge acc_node_src_edges, acc_node_tar_edges)
......@@ -1327,7 +1327,7 @@ module Delta = struct
(* the three list are ordered *)
type t = {
del_nodes: Gid.t list;
edges: ((Gid.t * Label.t * Gid.t) * status) list;
edges: ((Gid.t * G_edge.t * Gid.t) * status) list;
feats: ((Gid.t * feature_name) * (value option)) list;
}
......
......@@ -215,8 +215,8 @@ module Delta : sig
val empty: t
val del_node: Gid.t -> t -> t
val add_edge: Gid.t -> Label.t -> Gid.t -> t -> t
val del_edge: Gid.t -> Label.t -> Gid.t -> t -> t
val add_edge: Gid.t -> G_edge.t -> Gid.t -> t -> t
val del_edge: Gid.t -> G_edge.t -> Gid.t -> t -> t
val set_feat: G_graph.t -> Gid.t -> feature_name -> value option -> t -> t
end (* module Delta *)
......
......@@ -552,7 +552,7 @@ module Rule = struct
(* ====================================================================== *)
type matching = {
n_match: Gid.t Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *)
e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident |--> (src,label,tar) *)
e_match: (string*(Gid.t*G_edge.t*Gid.t)) list; (* edge matching: edge ident |--> (src,label,tar) *)
l_param: Lexicons.t; (* *)
}
......@@ -563,7 +563,7 @@ module Rule = struct
(P_node.get_name pnode, `String (node_name gid))::acc
) m.n_match [] in
let edges = List.map (fun (id, (src,lab,tar)) ->
(id, `String (sprintf "%s/%s/%s" (node_name src) (Label.to_string lab) (node_name tar)))
(id, `String (sprintf "%s/%s/%s" (node_name src) (G_edge.to_string lab) (node_name tar)))
) m.e_match in
`Assoc (nodes @ edges)
......
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