Commit d1bdd7f2 authored by bguillaum's avatar bguillaum

New type Domain.t to generalize Feature_domain and Label.domain.

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8837 7838e531-6607-4d57-9587-6c381814729c
parent c107b8b4
......@@ -169,7 +169,7 @@ module Command = struct
if feat_name = "position"
then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
check_act_id loc act_id kai;
Feature_domain.check_feature_name ~loc domain feat_name;
Domain.check_feature_name ~loc domain feat_name;
((DEL_FEAT (pid_of_act_id loc act_id, feat_name), loc), (kai, kei))
| (Ast.Update_feat ((act_id, feat_name), ast_items), loc) ->
......@@ -178,7 +178,7 @@ module Command = struct
(function
| Ast.Qfn_item (node_id,feature_name) ->
check_node_id loc node_id kai;
Feature_domain.check_feature_name ~loc domain feature_name;
Domain.check_feature_name ~loc domain feature_name;
Feat (pid_of_node_id loc node_id, feature_name)
| Ast.String_item s -> String s
| Ast.Param_item var ->
......@@ -192,9 +192,9 @@ module Command = struct
) ast_items in
(* check for consistency *)
(match items with
| _ when Feature_domain.is_open domain feat_name -> ()
| _ when Domain.is_open_feature domain feat_name -> ()
| [Param_out _] -> () (* TODO: check that lexical parameters are compatible with the feature domain *)
| [String s] -> Feature_domain.check_feature ~loc domain feat_name s
| [String s] -> Domain.check_feature ~loc domain feat_name s
| [Feat (_,fn)] -> ()
| _ -> Error.build ~loc "[Update_feat] Only open features can be modified with the concat operator '+' but \"%s\" is not declared as an open feature" feat_name);
((UPDATE_FEAT (pid_of_act_id loc act_id, feat_name, items), loc), (kai, kei))
......
......@@ -58,8 +58,8 @@ module Command : sig
| H_ACT_NODE of (Gid.t * string)
val build:
Feature_domain.t ->
Label_domain.t ->
Domain.t ->
Domain.t ->
?param: (string list * string list) ->
(Ast.command_node_ident list * string list) ->
Id.table ->
......
......@@ -18,14 +18,14 @@ open Grew_ast
module G_edge: sig
type t = Label.t
val to_string: Label_domain.t -> ?locals:Label_domain.decl array -> t -> string
val to_string: Domain.t -> ?locals:Label_domain.decl array -> t -> string
val make: ?loc:Loc.t -> Label_domain.t -> ?locals:Label_domain.decl array -> string -> t
val make: ?loc:Loc.t -> Domain.t -> ?locals:Label_domain.decl array -> string -> t
val build: Label_domain.t -> ?locals:Label_domain.decl array -> Ast.edge -> t
val build: Domain.t -> ?locals:Label_domain.decl array -> Ast.edge -> t
val to_dot: Label_domain.t -> ?deco:bool -> t -> string
val to_dep: Label_domain.t -> ?deco:bool -> t -> string
val to_dot: Domain.t -> ?deco:bool -> t -> string
val to_dep: Domain.t -> ?deco:bool -> t -> string
end (* module G_edge *)
(* ================================================================================ *)
......@@ -38,16 +38,16 @@ module P_edge: sig
val get_id: t -> string option
val to_string: Label_domain.t -> t -> string
val to_string: Domain.t -> t -> string
val build: Label_domain.t -> ?locals:Label_domain.decl array -> Ast.edge -> t
val build: Domain.t -> ?locals:Label_domain.decl array -> Ast.edge -> t
type edge_matcher =
| Fail
| Ok of Label.t
| Binds of string * Label.t list
val match_: Label_domain.t -> t -> G_edge.t -> edge_matcher
val match_: Domain.t -> t -> G_edge.t -> edge_matcher
val match_list: Label_domain.t -> t -> G_edge.t list -> edge_matcher
val match_list: Domain.t -> t -> G_edge.t list -> edge_matcher
end (* module P_edge *)
......@@ -35,7 +35,7 @@ module G_feature = struct
let build domain = function
| ({Ast.kind=Ast.Equality [atom]; name=name},loc) ->
(name, Feature_domain.build_value ~loc domain name atom)
(name, Feature_value.build_value ~loc domain name atom)
| _ -> Error.build "Illegal feature declaration in Graph (must be '=' and atomic)"
let to_string (feat_name, feat_val) = sprintf "%s=%s" feat_name (string_of_value feat_val)
......@@ -132,12 +132,12 @@ module P_feature = struct
let build domain ?pat_vars = function
| ({Ast.kind=Ast.Absent; name=name}, loc) ->
Feature_domain.check_feature_name ~loc domain name;
Domain.check_feature_name ~loc domain name;
(name, {cst=Absent;in_param=[];})
| ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) ->
let values = Feature_domain.build_disj ~loc domain name unsorted_values in (name, {cst=Equal values;in_param=[];})
let values = Feature_value.build_disj ~loc domain name unsorted_values in (name, {cst=Equal values;in_param=[];})
| ({Ast.kind=Ast.Disequality unsorted_values; name=name}, loc) ->
let values = Feature_domain.build_disj ~loc domain name unsorted_values in (name, {cst=Different values;in_param=[];})
let values = Feature_value.build_disj ~loc domain name unsorted_values in (name, {cst=Different values;in_param=[];})
| ({Ast.kind=Ast.Equal_param var; name=name}, loc) ->
begin
match pat_vars with
......@@ -162,7 +162,7 @@ module G_fs = struct
(* ---------------------------------------------------------------------- *)
let set_feat ?loc domain feature_name atom t =
let new_value = Feature_domain.build_value ?loc domain feature_name atom in
let new_value = Feature_value.build_value ?loc domain feature_name atom in
let rec loop = function
| [] -> [(feature_name, new_value)]
| ((fn,_)::_) as t when feature_name < fn -> (feature_name, new_value)::t
......@@ -210,15 +210,15 @@ module G_fs = struct
(* ---------------------------------------------------------------------- *)
let of_conll ?loc domain line =
let raw_list0 =
("phon", Feature_domain.build_value ?loc domain "phon" line.Conll.phon)
:: ("cat", Feature_domain.build_value ?loc domain "cat" line.Conll.pos1)
:: (List.map (fun (f,v) -> (f, Feature_domain.build_value ?loc domain f v)) line.Conll.morph) in
("phon", Feature_value.build_value ?loc domain "phon" line.Conll.phon)
:: ("cat", Feature_value.build_value ?loc domain "cat" line.Conll.pos1)
:: (List.map (fun (f,v) -> (f, Feature_value.build_value ?loc domain f v)) line.Conll.morph) in
let raw_list1 = match line.Conll.pos2 with
| "" | "_" -> raw_list0
| s -> ("pos", Feature_domain.build_value ?loc domain "pos" s) :: raw_list0 in
| s -> ("pos", Feature_value.build_value ?loc domain "pos" s) :: raw_list0 in
let raw_list2 = match line.Conll.lemma with
| "" | "_" -> raw_list1
| s -> ("lemma", Feature_domain.build_value ?loc domain "lemma" s) :: raw_list1 in
| s -> ("lemma", Feature_value.build_value ?loc domain "lemma" s) :: raw_list1 in
List.sort G_feature.compare raw_list2
(* ---------------------------------------------------------------------- *)
......
......@@ -21,7 +21,7 @@ module G_fs: sig
(** [set_feat domain feature_name atom t] adds the feature ([feature_name],[atom]) in [t].
If [t] already contains a feature named [feature_name], the old value is erased by the new one. *)
val set_feat: ?loc:Loc.t -> Feature_domain.t -> feature_name -> string -> t -> t
val set_feat: ?loc:Loc.t -> Domain.t -> feature_name -> string -> t -> t
(** [del_feat feature_name t] remove the feature with name [feature_name] in [t].
If [t] does not contain such a feature, [t] is returned unchanged. *)
......@@ -46,9 +46,9 @@ module G_fs: sig
val to_string: t -> string
val build: Feature_domain.t -> Ast.feature list -> t
val build: Domain.t -> Ast.feature list -> t
val of_conll: ?loc:Loc.t -> Feature_domain.t -> Conll.line -> t
val of_conll: ?loc:Loc.t -> Domain.t -> Conll.line -> t
(** [unif t1 t2] returns [Some t] if [t] is the unification of two graph feature structures
[None] is returned if the two feature structures cannot be unified. *)
......@@ -62,7 +62,7 @@ module P_fs: sig
val empty: t
val build: Feature_domain.t -> ?pat_vars: string list -> Ast.feature list -> t
val build: Domain.t -> ?pat_vars: string list -> Ast.feature list -> t
val to_string: t -> string
......
This diff is collapsed.
......@@ -53,8 +53,7 @@ module P_graph: sig
}
val build:
Feature_domain.t ->
Label_domain.t ->
Domain.t ->
?pat_vars: string list ->
?locals: Label_domain.decl array ->
Ast.node list ->
......@@ -62,8 +61,7 @@ module P_graph: sig
(t * Id.table)
val build_extension:
Feature_domain.t ->
Label_domain.t ->
Domain.t ->
?pat_vars: string list ->
?locals: Label_domain.decl array ->
Id.table ->
......@@ -94,7 +92,7 @@ module G_graph: sig
val max_binding: t -> int
(** [edge_out label_domain t id label_cst] returns true iff there is an out-edge from the node [id] with a label compatible with [label_cst] *)
val edge_out: Label_domain.t -> t -> Gid.t -> Label_cst.t -> bool
val edge_out: Domain.t -> t -> Gid.t -> Label_cst.t -> bool
(** [get_annot_info graph] searches for exactly one node with an annot-feature (with name starting with "__").
It returns the annot-feature name without the prefix "__" together with the position.
......@@ -105,15 +103,15 @@ module G_graph: sig
(* Build functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
val build: Feature_domain.t -> Label_domain.t -> ?locals: Label_domain.decl array -> Ast.gr -> t
val build: Domain.t -> ?locals: Label_domain.decl array -> Ast.gr -> t
val of_conll: ?loc:Loc.t -> Feature_domain.t -> Label_domain.t -> Conll.t -> t
val of_conll: ?loc:Loc.t -> Domain.t -> Conll.t -> t
(** input : "Le/DET/le petit/ADJ/petit chat/NC/chat dort/V/dormir ./PONCT/."
It supposes that "SUC" is defined in current relations *)
val of_brown: Feature_domain.t -> Label_domain.t -> ?sentid: string -> string -> t
val of_brown: Domain.t -> ?sentid: string -> string -> t
val of_xml: Feature_domain.t -> Label_domain.t -> Xml.xml -> t
val of_xml: Domain.t -> Xml.xml -> t
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Update functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
......@@ -129,32 +127,32 @@ module G_graph: sig
(** [del_edge ?edge_ident loc graph id_src label id_tar] removes the edge (id_src -[label]-> id_tar) from graph.
Log.critical if the edge is not in graph *)
val del_edge: Label_domain.t -> ?edge_ident: string -> Loc.t -> t -> Gid.t -> G_edge.t -> Gid.t -> t
val del_edge: Domain.t -> ?edge_ident: string -> Loc.t -> t -> Gid.t -> G_edge.t -> Gid.t -> t
(** [del_node graph id] remove node [id] from [graph], with all its incoming and outcoming edges.
[graph] is unchanged if the node is not in it. *)
val del_node: t -> Gid.t -> t
val add_neighbour: Loc.t -> Label_domain.t -> t -> Gid.t -> G_edge.t -> (Gid.t * t)
val add_neighbour: Loc.t -> Domain.t -> t -> Gid.t -> G_edge.t -> (Gid.t * t)
val activate: Loc.t -> Gid.t -> string -> t -> (Gid.t * t)
val merge_node: Loc.t -> Label_domain.t -> t -> Gid.t -> Gid.t -> t option
val merge_node: Loc.t -> Domain.t -> t -> Gid.t -> Gid.t -> t option
(** move all in arcs to id_src are moved to in arcs on node id_tar from graph, with all its incoming edges *)
val shift_in: Loc.t -> Label_domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
val shift_in: Loc.t -> Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
(** move all out-edges from id_src are moved to out-edges out off node id_tar *)
val shift_out: Loc.t -> Label_domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
val shift_out: Loc.t -> Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
(** move all incident arcs from/to id_src are moved to incident arcs on node id_tar from graph, with all its incoming and outcoming edges *)
val shift_edges: Loc.t -> Label_domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
val shift_edges: Loc.t -> Domain.t -> Gid.t -> Gid.t -> Label_cst.t -> t -> t
(** [update_feat domain tar_id tar_feat_name concat_items] sets the feature of the node [tar_id]
with feature name [tar_feat_name] to be the contatenation of values described by the [concat_items].
It returns both the new graph and the new feature value produced as the second element *)
val update_feat: ?loc:Loc.t -> Feature_domain.t -> t -> Gid.t -> string -> Concat_item.t list -> (t * string)
val update_feat: ?loc:Loc.t -> Domain.t -> t -> Gid.t -> string -> Concat_item.t list -> (t * string)
val set_feat: ?loc:Loc.t -> Feature_domain.t -> t -> Gid.t -> string -> string -> t
val set_feat: ?loc:Loc.t -> Domain.t -> t -> Gid.t -> string -> string -> t
(** [del_feat graph node_id feat_name] returns [graph] where the feat [feat_name] of [node_id] is deleted
If the feature is not present, [graph] is returned. *)
......@@ -163,13 +161,13 @@ module G_graph: sig
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Output functions *)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
val to_gr: Label_domain.t -> t -> string
val to_dot: Label_domain.t -> ?main_feat:string -> ?deco:G_deco.t -> t -> string
val to_gr: Domain.t -> t -> string
val to_dot: Domain.t -> ?main_feat:string -> ?deco:G_deco.t -> t -> string
val to_sentence: ?main_feat:string -> t -> string
val to_dep: Label_domain.t -> ?filter : string list -> ?main_feat:string -> ?deco:G_deco.t -> t -> string
val to_conll: Label_domain.t -> t -> string
val to_dep: Domain.t -> ?filter : string list -> ?main_feat:string -> ?deco:G_deco.t -> t -> string
val to_conll: Domain.t -> t -> string
val to_raw: Label_domain.t -> t ->
val to_raw: Domain.t -> t ->
(string * string) list *
(string * string) list list *
(int * string * int) list
......
......@@ -163,11 +163,11 @@ module Modul = struct
| r::tail -> loop ((Rule.get_name r) :: already_defined) tail in
loop [] t.rules
let build domain label_domain ast_module =
let build domain ast_module =
let locals = Array.of_list ast_module.Ast.local_labels in
Array.sort compare locals;
let suffixes = ast_module.Ast.suffixes in
let rules_or_filters = List.map (Rule.build domain label_domain ~locals suffixes ast_module.Ast.mod_dir) ast_module.Ast.rules in
let rules_or_filters = List.map (Rule.build domain ~locals suffixes ast_module.Ast.mod_dir) ast_module.Ast.rules in
let (filters, rules) = List.partition Rule.is_filter rules_or_filters in
let modul =
{
......@@ -218,8 +218,7 @@ end (* module Sequence *)
module Grs = struct
type t = {
domain: Feature_domain.t;
label_domain: Label_domain.t;
domain: Domain.t;
modules: Modul.t list; (* the ordered list of modules used from rewriting *)
sequences: Sequence.t list;
filename: string;
......@@ -230,10 +229,9 @@ module Grs = struct
let get_ast t = t.ast
let get_filename t = t.filename
let get_domain t = t.domain
let get_label_domain t = t.label_domain
let sequence_names t = List.map (fun s -> s.Sequence.name) t.sequences
let empty = {domain=Feature_domain.empty; label_domain = Label_domain.empty; modules=[]; sequences=[]; ast=Ast.empty_grs; filename=""; }
let empty = {domain=Domain.empty; modules=[]; sequences=[]; ast=Ast.empty_grs; filename=""; }
let check t =
(* check for duplicate modules *)
......@@ -254,10 +252,11 @@ module Grs = struct
let build filename =
let ast = Loader.grs filename in
let domain = Feature_domain.build ast.Ast.domain in
let label_domain = Label_domain.build ast.Ast.labels in
let modules = List.map (Modul.build domain label_domain) ast.Ast.modules in
let grs = {domain; label_domain; sequences = List.map (Sequence.build modules) ast.Ast.sequences; modules; ast; filename} in
let domain = Domain.build
(Label_domain.build ast.Ast.labels)
(Feature_domain.build ast.Ast.domain) in
let modules = List.map (Modul.build domain) ast.Ast.modules in
let grs = {domain; sequences = List.map (Sequence.build modules) ast.Ast.sequences; modules; ast; filename} in
check grs;
grs
......@@ -290,7 +289,6 @@ module Grs = struct
let (good_set, bad_set) =
Rule.normalize
grs.domain
grs.label_domain
next.Modul.name
~confluent: next.Modul.confluent
next.Modul.rules
......@@ -318,7 +316,6 @@ module Grs = struct
let (good_set, bad_set) =
Rule.normalize
grs.domain
grs.label_domain
next.Modul.name
~confluent: next.Modul.confluent
next.Modul.rules
......
......@@ -32,7 +32,7 @@ module Rewrite_history: sig
- returns a list of couples (rules, file)
*)
val save_nfs:
Label_domain.t ->
Domain.t ->
?filter: string list ->
?main_feat: string ->
dot: bool ->
......@@ -41,26 +41,26 @@ module Rewrite_history: sig
((string * string list) list * string) list
(** [save_annot out_dir base_name t] writes a set of svg_file for an annotation folder. *)
val save_annot: Label_domain.t -> string -> string -> t -> (string * int * (string*float) * (string*float) * (float option * float option)) list
val save_annot: Domain.t -> string -> string -> t -> (string * int * (string*float) * (string*float) * (float option * float option)) list
(** [save_gr base_name t] saves one gr_file for each normal form defined in [t].
Output files are named according to [base_name] and the Gorn adress in the rewriting tree. *)
val save_gr: Label_domain.t -> string -> t -> unit
val save_conll: Label_domain.t -> string -> t -> unit
val save_gr: Domain.t -> string -> t -> unit
val save_conll: Domain.t -> string -> t -> unit
(** [save_full_conll base_name t] saves one conll_file for each normal form defined in [t].
Output files are named according to [base_name] and a secondary index after "__".
The number of conll file produced is returned. *)
val save_full_conll: Label_domain.t -> string -> t -> int
val save_full_conll: Domain.t -> string -> t -> int
(** [save_det_gr base_name t] supposes that the current GRS is deterministic.
It writes exactly one output file named [base_name].gr with the unique normal form. *)
val save_det_gr: Label_domain.t ->string -> t -> unit
val save_det_conll: Label_domain.t -> ?header:string -> string -> t -> unit
val save_det_gr: Domain.t ->string -> t -> unit
val save_det_conll: Domain.t -> ?header:string -> string -> t -> unit
val det_dep_string: Label_domain.t -> t -> string option
val det_dep_string: Domain.t -> t -> string option
val conll_dep_string: Label_domain.t -> ?keep_empty_rh:bool -> t -> string option
val conll_dep_string: Domain.t -> ?keep_empty_rh:bool -> t -> string option
end (* module Rewrite_history *)
(* ================================================================================ *)
......@@ -86,8 +86,7 @@ module Grs: sig
val get_ast: t -> Ast.grs
val get_domain: t -> Feature_domain.t
val get_label_domain: t -> Label_domain.t
val get_domain: t -> Domain.t
val get_filename: t -> string
......
......@@ -28,7 +28,7 @@ end (* module Html_sentences *)
module Html_rh: sig
val build:
Label_domain.t ->
Domain.t ->
?filter: string list ->
?main_feat: string ->
?dot: bool ->
......@@ -41,7 +41,7 @@ module Html_rh: sig
unit
val error:
Label_domain.t ->
Domain.t ->
?main_feat: string ->
?dot: bool ->
?init_graph:bool ->
......@@ -81,5 +81,5 @@ end (* module Corpus_stat *)
(* ================================================================================ *)
module Html_annot: sig
val build: Label_domain.t -> title:string -> string -> string -> (string * Rewrite_history.t) list -> unit
val build: Domain.t -> title:string -> string -> string -> (string * Rewrite_history.t) list -> unit
end (* module Html_annot *)
......@@ -20,7 +20,7 @@ module G_node: sig
val empty: t
val to_string: Label_domain.t -> t -> string
val to_string: Domain.t -> t -> string
val to_gr: t -> string
val get_fs: t -> G_fs.t
......@@ -42,8 +42,8 @@ module G_node: sig
val rm_out_edges: t -> t
val add_edge: G_edge.t -> Gid.t -> t -> t option
val build: Feature_domain.t -> ?def_position: float -> Ast.node -> (Id.name * t)
val of_conll: ?loc:Loc.t -> Feature_domain.t -> Conll.line -> t
val build: Domain.t -> ?def_position: float -> Ast.node -> (Id.name * t)
val of_conll: ?loc:Loc.t -> Domain.t -> Conll.line -> t
val get_position: t -> float
......@@ -77,7 +77,7 @@ module P_node: sig
*)
val unif_fs: P_fs.t -> t -> t
val build: Feature_domain.t -> ?pat_vars: string list -> Ast.node -> (Id.name * t)
val build: Domain.t -> ?pat_vars: string list -> Ast.node -> (Id.name * t)
val add_edge: P_edge.t -> Pid.t -> t -> t option
......
This diff is collapsed.
......@@ -40,18 +40,18 @@ module Instance : sig
val flatten: t -> t
(** [to_gr t] returns a string which contains the "gr" code of the current graph *)
val to_gr: Label_domain.t -> t -> string
val to_gr: Domain.t -> t -> string
(** [to_conll t] returns a string which contains the "conll" code of the current graph *)
val to_conll: Label_domain.t -> t -> string
val to_conll: Domain.t -> t -> string
(** [save_dep_png base t] writes a file "base.png" with the dep representation of [t].
NB: if the Dep2pict is not available, nothing is done *)
val save_dep_png: Label_domain.t -> ?filter: string list -> ?main_feat: string -> string -> t -> float option
val save_dep_svg: Label_domain.t -> ?filter: string list -> ?main_feat: string -> string -> t -> float option
val save_dep_png: Domain.t -> ?filter: string list -> ?main_feat: string -> string -> t -> float option
val save_dep_svg: Domain.t -> ?filter: string list -> ?main_feat: string -> string -> t -> float option
(** [save_dot_png base t] writes a file "base.png" with the dot representation of [t] *)
val save_dot_png: Label_domain.t -> ?filter: string list -> ?main_feat: string -> string -> t -> unit
val save_dot_png: Domain.t -> ?filter: string list -> ?main_feat: string -> string -> t -> unit
end (* module Instance *)
(* ================================================================================ *)
......@@ -71,17 +71,16 @@ module Rule : sig
val is_filter: t -> bool
(** [to_dep t] returns a string in the [dep] language describing the match basic of the rule *)
val to_dep: Label_domain.t -> t -> string
val to_dep: Domain.t -> t -> string
(** [build domain ?local dir ast_rule] returns the Rule.t value corresponding to [ast_rule].
[dir] is used for localisation of lp files *)
val build: Feature_domain.t -> Label_domain.t -> ?locals:Label_domain.decl array -> string list -> string -> Ast.rule -> t
val build: Domain.t -> ?locals:Label_domain.decl array -> string list -> string -> Ast.rule -> t
(** [normalize domain module_name ?confluent rule_list filter_list instance] returns two sets of good normal forms and bad normal forms *)
(* raise Stop if some command fails to apply *)
val normalize:
Feature_domain.t ->
Label_domain.t ->
Domain.t ->
string -> (* module name *)
?confluent:bool ->
t list -> (* rule list *)
......@@ -94,10 +93,10 @@ module Rule : sig
type matching
type pattern
val build_pattern: Feature_domain.t -> Label_domain.t -> Ast.pattern -> pattern
val build_pattern: Domain.t -> Ast.pattern -> pattern
(** [match_in_graph rule graph] returns the list of matching of the pattern of the rule into the graph *)
val match_in_graph: Label_domain.t -> ?param:Lex_par.t -> pattern -> G_graph.t -> matching list
val match_in_graph: Domain.t -> ?param:Lex_par.t -> pattern -> G_graph.t -> matching list
(** [match_deco rule matching] builds the decoration of the [graph] illustrating the given [matching] of the [rule] *)
(* NB: it can be computed independly from the graph itself! *)
......
......@@ -186,79 +186,6 @@ module Label_domain = struct
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 label_domain p_label_list g_label =
List.exists (fun p_label -> match_ label_domain p_label g_label) p_label_list
(** [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 to_int = function
| Global i -> Some i
| _ -> None
let get_style (_,styles) = function
| Global i -> styles.(i)
| Local i -> Log.warning "Style of locally defined labels is not implemented"; Label_domain.default
| Pattern _ -> Label_domain.default
let to_dep label_domain ?(deco=false) t =
let style = get_style label_domain t in
Label_domain.to_dep ~deco style
let to_dot label_domain ?(deco=false) t =
let style = get_style label_domain t in
Label_domain.to_dot ~deco style
let from_string ?loc (table, _) ?(locals=[||]) str =
if String.contains str '*'
then Pattern str
else
try Global (Id.build ?loc str table)
with Not_found (* TODO (CANNOT BE RAISED) *) ->
try Local (Array_.dicho_find_assoc str locals)
with Not_found -> Error.build "[Label.from_string] unknown edge label '%s'" str
end (* module Label *)
(* ================================================================================ *)
(** 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
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)
let all = Neg []
let match_ label_domain edge = function
| Pos labels -> Label.match_list label_domain labels edge
| Neg labels -> not (Label.match_list label_domain labels edge)
let build ?loc label_domain ?locals = function
| (edge_labels, true) -> Neg (List.sort compare (List.map (Label.from_string ?loc label_domain ?locals) edge_labels))
| (edge_labels, false) -> Pos (List.sort compare (List.map (Label.from_string ?loc label_domain ?locals) edge_labels))
end (* module Label_cst *)
(* ================================================================================ *)
module Feature_domain = struct
type feature_spec =
......@@ -288,6 +215,9 @@ module Feature_domain = struct
Error.build "[Feature_domain] The feature named \"%s\" is defined several times" fn
| x :: tail -> x :: (build tail)
let feature_names domain =
Some (List.map (function Closed (fn, _) | Open fn | Num fn -> fn) domain)
let get feature_name domain =
List.find (function
| Closed (fn,_) when fn = feature_name -> true
......@@ -296,13 +226,17 @@ module Feature_domain = struct
| _ -> false
) domain
let check_feature_name ?loc domain name =
if not (is_defined name domain)
then Error.build ?loc "The feature name \"%s\" in not defined in the domain" name
let sub domain name1 name2 =
match (get name1 domain, get name2 domain) with
| (_, Open _) -> true
| (Closed (_,l1), Closed (_,l2)) -> List_.sort_include l1 l2
| (Num _, Num _) -> true
| _ -> false
let is_open domain name =
List.exists (function Open n when n=name -> true | _ -> false) domain
(* This function is defined here because it is used by check_feature *)
let build_disj ?loc domain name unsorted_values =
let values = List.sort Pervasives.compare unsorted_values in