diff --git a/src/grew_ast.ml b/src/grew_ast.ml index 1e53837709f1735015031cda8139209d10d215d7..3712103193ff877556bcd725507487d038a2acce 100644 --- a/src/grew_ast.ml +++ b/src/grew_ast.ml @@ -7,6 +7,7 @@ module Ast = struct type feature_spec = | Closed of string * string list (* (the name, the set of atomic values) *) | Open of string (* the name *) + | Int of string (* the name *) type domain = feature_spec list diff --git a/src/grew_ast.mli b/src/grew_ast.mli index 1df32bcdd24e73407062bcf29aff0c3c83ca4aa2..dd77a014cfa4a7f30a35ac255c86c9691d2c174b 100644 --- a/src/grew_ast.mli +++ b/src/grew_ast.mli @@ -4,7 +4,8 @@ module Ast : sig type feature_spec = | Closed of string * string list (* (the name, the set of atomic values) *) | Open of string (* the name *) - + | Int of string (* the name *) + type domain = feature_spec list type feature_kind = diff --git a/src/grew_fs.ml b/src/grew_fs.ml index 758ef5d3bbb6b3fd49ea2e0e5c310233032e49f1..6a9dc2637e6942f40160334085d65716b7508488 100644 --- a/src/grew_fs.ml +++ b/src/grew_fs.ml @@ -4,6 +4,13 @@ open Log open Grew_utils open Grew_ast + +type value = String of string | Int of int + +let string_of_value = function + | String s -> s + | Int i -> string_of_int i + (* ==================================================================================================== *) module Domain = struct let current = ref None @@ -31,30 +38,65 @@ module Domain = struct ) | _::t -> loop t in loop d + + let build ?loc name values = + match (name.[0], !current) with + | ('_', _) + | (_, None) -> List.map (fun s -> String s) values (* no check on feat_name starting with '_' *) + | (_, Some d) -> + let rec loop = function + | [] -> Error.build ?loc "[GRS] Unknown feature name '%s'" name + | ((Ast.Open n)::_) when n = name -> + List.map (fun s -> String s) values + | ((Ast.Int n)::_) when n = name -> + (try List.map (fun s -> Int (int_of_string s)) values + with Failure _ -> Error.build ?loc "[GRS] The feature '%s' is of type int" name) + | ((Ast.Closed (n,vs))::_) when n = name -> + (match List_.sort_diff values vs with + | [] -> List.map (fun s -> String s) values + | l -> Error.build ?loc "Unknown feature values '%s' for feature name '%s'" + (List_.to_string (fun x->x) ", " l) + name + ) + | _::t -> loop t in + loop d + + let build_one ?loc name value = + match build ?loc name [value] with + | [x] -> x + | _ -> Error.bug ?loc "[Domain.build_one]" end (* ==================================================================================================== *) module G_feature = struct - type t = string * string + + type t = string * value let get_name = fst let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2) - let build = function + let build (x : Ast.feature) = match x with | ({Ast.kind=Ast.Equality [atom]; name=name},loc) -> - Domain.check ~loc name [atom]; - (name, atom) + (* Domain.check ~loc name [atom]; *) + (* (name, atom) *) + (name, Domain.build_one ~loc 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 feat_val + let to_string (feat_name, feat_val) = sprintf "%s=%s" feat_name (string_of_value feat_val) - let to_gr (feat_name, feat_val) = sprintf "%s=\"%s\"" feat_name feat_val + let to_gr (feat_name, feat_val) = + match feat_val with + | String s -> sprintf "%s=\"%s\"" feat_name s + | Int i -> sprintf "%s=\"%d\"" feat_name i let to_dot (feat_name, feat_val) = - match Str.split (Str.regexp ":C:") feat_val with - | [] -> Error.bug "[G_feature.to_dot] feature value '%s'" feat_val - | fv::_ -> sprintf "%s=%s" feat_name fv + match feat_val with + | Int i -> sprintf "%s=%d" feat_name i + | String s -> + match Str.split (Str.regexp ":C:") s with + | [] -> Error.bug "[G_feature.to_dot] feature value '%s'" s + | fv::_ -> sprintf "%s=%s" feat_name fv end (* ==================================================================================================== *) @@ -62,8 +104,8 @@ module P_feature = struct (* feature= (feature_name, disjunction of atomic values) *) type v = - | Equal of string list (* with Equal constr, the list MUST never be empty *) - | Different of string list + | Equal of value list (* with Equal constr, the list MUST never be empty *) + | Different of value list | Param of int type t = string * v @@ -82,9 +124,9 @@ module P_feature = struct | _ -> Error.build "cannot unify heterogeneous pattern features" let to_string ?param_names = function - | (feat_name, Equal atoms) -> sprintf "%s=%s" feat_name (List_.to_string (fun x->x) "|" atoms) + | (feat_name, Equal atoms) -> sprintf "%s=%s" feat_name (List_.to_string string_of_value "|" atoms) | (feat_name, Different []) -> sprintf "%s=*" feat_name - | (feat_name, Different atoms) -> sprintf "%s<>%s" feat_name (List_.to_string (fun x->x) "|" atoms) + | (feat_name, Different atoms) -> sprintf "%s<>%s" feat_name (List_.to_string string_of_value "|" atoms) | (feat_name, Param index) -> match param_names with | None -> sprintf "%s=$%d" feat_name index @@ -92,13 +134,15 @@ module P_feature = struct let build ?pat_vars = function | ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) -> - let values = List.sort Pervasives.compare unsorted_values in - Domain.check ~loc name values; - (name, Equal values) + let values = Domain.build ~loc name unsorted_values in (name, Equal values) + (* let values = List.sort Pervasives.compare unsorted_values in *) + (* Domain.check ~loc name values; *) + (* (name, Equal values) *) | ({Ast.kind=Ast.Disequality unsorted_values; name=name}, loc) -> - let values = List.sort Pervasives.compare unsorted_values in - Domain.check ~loc name values; - (name, Different values) + let values = Domain.build ~loc name unsorted_values in (name, Different values) + (* let values = List.sort Pervasives.compare unsorted_values in *) + (* Domain.check ~loc name values; *) + (* (name, Different values) *) | ({Ast.kind=Ast.Param var; name=name}, loc) -> match pat_vars with | None -> Error.bug ~loc "[P_feature.build] param '%s' in an unparametrized rule" var @@ -113,16 +157,17 @@ module G_fs = struct (* list are supposed to be striclty ordered wrt compare*) type t = G_feature.t list - let to_raw t = t + let to_raw t = List.map (fun (name, value) -> (name, string_of_value value)) t let empty = [] let set_feat ?loc feature_name atom t = - Domain.check ?loc feature_name [atom]; + let new_value = Domain.build_one ?loc feature_name atom in + (* Domain.check ?loc feature_name [atom]; *) let rec loop = function - | [] -> [(feature_name, atom)] - | ((fn,_)::_) as t when feature_name < fn -> (feature_name, atom)::t - | (fn,_)::t when feature_name = fn -> (feature_name, atom)::t + | [] -> [(feature_name, new_value)] + | ((fn,_)::_) as t when feature_name < fn -> (feature_name, new_value)::t + | (fn,_)::t when feature_name = fn -> (feature_name, new_value)::t | (fn,a)::t -> (fn,a) :: (loop t) in loop t @@ -130,6 +175,11 @@ module G_fs = struct let get_atom = List_.sort_assoc + let get_string_atom feat_name t = + match List_.sort_assoc feat_name t with + | None -> None + | Some v -> Some (string_of_value v) + let to_string t = List_.to_string G_feature.to_string "," t let to_gr t = List_.to_string G_feature.to_gr ", " t @@ -138,7 +188,11 @@ module G_fs = struct List.sort G_feature.compare unsorted let of_conll line = - let unsorted = ("phon", line.Conll.phon) :: ("lemma", line.Conll.lemma) :: ("cat", line.Conll.pos2) :: line.Conll.morph in + let unsorted = + ("phon", String line.Conll.phon) + :: ("lemma", String line.Conll.lemma) + :: ("cat", String line.Conll.pos2) + :: (List.map (fun (f,v) -> (f, String v)) line.Conll.morph) in List.sort G_feature.compare unsorted exception Fail_unif @@ -169,19 +223,20 @@ module G_fs = struct let to_dot ?main_feat t = match get_main ?main_feat t with | (None, _) -> List_.to_string G_feature.to_dot "\\n" t - | (Some atom, sub) -> sprintf "{%s|%s}" atom (List_.to_string G_feature.to_dot "\\n" sub) + | (Some atom, sub) -> + sprintf "{%s|%s}" (string_of_value atom) (List_.to_string G_feature.to_dot "\\n" sub) let to_word ?main_feat t = match get_main ?main_feat t with | (None, _) -> "#" - | (Some atom, _) -> atom + | (Some atom, _) -> string_of_value atom let to_dep ?main_feat t = let (main_opt, sub) = get_main ?main_feat t in sprintf " word=\"%s\"; subword=\"%s\"; " - (match main_opt with Some atom -> atom | None -> "") + (match main_opt with Some atom -> string_of_value atom | None -> "") (List_.to_string G_feature.to_string "#" sub) -end +end (* module G_fs *) (* ==================================================================================================== *) module P_fs = struct @@ -221,7 +276,7 @@ module P_fs = struct (match acc with | None -> Log.bug "[P_fs.compatible] Illegal parametrized pattern feature"; exit 2 | Some param -> - (match Lex_par.filter index atom param with + (match Lex_par.filter index (string_of_value atom) param with | None -> raise Fail | Some new_param -> loop (Some new_param) (t_pat,t) ) diff --git a/src/grew_fs.mli b/src/grew_fs.mli index f86fda2efbaeec8f8ba178d3d84bba23f6f17bee..5f4030e9eaf487a1b2eef97c21738f0f60c77930 100644 --- a/src/grew_fs.mli +++ b/src/grew_fs.mli @@ -21,9 +21,9 @@ module G_fs: sig If [t] does not contain such a feature, [t] is returned unchanged. *) val del_feat: string -> t -> t - (** [get_atom f t] returns [Some v] if the fs [t] contains the feature (f,v). + (** [get_string_atom f t] returns [Some v] if the fs [t] contains the feature (f,v). It returns [None] if there is no feature named [f] in [t] *) - val get_atom: string -> t -> string option + val get_string_atom: string -> t -> string option val to_gr: t -> string val to_dot: ?main_feat: string -> t -> string diff --git a/src/grew_graph.ml b/src/grew_graph.ml index 9d6aab6f4f82ed0fb97e2db44fb9e28070d32174..4d3c99e732429087a5f5372a05cbdf6866db1581 100644 --- a/src/grew_graph.ml +++ b/src/grew_graph.ml @@ -481,7 +481,7 @@ module G_graph = struct (function | Concat_item.Feat (node_gid, feat_name) -> let node = Gid_map.find node_gid graph.map in - (match G_fs.get_atom feat_name (G_node.get_fs node) with + (match G_fs.get_string_atom feat_name (G_node.get_fs node) with | Some atom -> atom | None -> Error.run ?loc "Some feature (named \"%s\") is not defined" feat_name ) diff --git a/src/grew_html.ml b/src/grew_html.ml index 9825314e812705ce7f1f0856cdd0de4644ce75de..21e206cb719f4ac7ff1b736f2757c6b4f6a7bb11 100644 --- a/src/grew_html.ml +++ b/src/grew_html.ml @@ -333,8 +333,9 @@ module Html_doc = struct wnl " "; List.iter (function - | Ast.Open feat_name -> wnl " %s : *
" feat_name | Ast.Closed (feat_name,values) -> wnl "%s : %s
" feat_name (String.concat " | " values) + | Ast.Open feat_name -> wnl " %s : *
" feat_name + | Ast.Int feat_name -> wnl " %s : #
" feat_name ) ast.Ast.domain; wnl " "; diff --git a/src/grew_rule.ml b/src/grew_rule.ml index ae728e1632545db2c1cb777d329a9590f9ae6887..a1d5d99d73cc0f246e94a09f7433f1f167e47168 100644 --- a/src/grew_rule.ml +++ b/src/grew_rule.ml @@ -383,8 +383,8 @@ module Rule = struct | Feature_eq (pid1, feat_name1, pid2, feat_name2) -> let gnode1 = G_graph.find (Pid_map.find pid1 matching.n_match) graph in let gnode2 = G_graph.find (Pid_map.find pid2 matching.n_match) graph in - (match (G_fs.get_atom feat_name1 (G_node.get_fs gnode1), - G_fs.get_atom feat_name2 (G_node.get_fs gnode2) + (match (G_fs.get_string_atom feat_name1 (G_node.get_fs gnode1), + G_fs.get_string_atom feat_name2 (G_node.get_fs gnode2) ) with | Some fv1, Some fv2 when fv1 = fv2 -> true | _ -> false) diff --git a/src/parser/gr_grs_parser.mly b/src/parser/gr_grs_parser.mly index b159ebfa6579765e03ae2be70730aea5a96b29e6..510d33762d5adb72fddd29e5b6ba489ac8388c04 100644 --- a/src/parser/gr_grs_parser.mly +++ b/src/parser/gr_grs_parser.mly @@ -28,6 +28,7 @@ let localize t = (t,get_loc ()) %token COMA /* , */ %token SEMIC /* ; */ %token STAR /* * */ +%token SHARP /* # */ %token PLUS /* + */ %token EQUAL /* = */ %token DISEQUAL /* <> */ @@ -198,10 +199,11 @@ features_group: %inline feature: | name = feature_name DDOT values = features_values - { - if values = ["*"] - then Ast.Open name - else Ast.Closed (name, List.sort Pervasives.compare values) + { + match values with + | ["*"] -> Ast.Open name + | ["#"] -> Ast.Int name + | _ -> Ast.Closed (name, List.sort Pervasives.compare values) } feature_name: @@ -209,6 +211,7 @@ feature_name: features_values: | STAR { ["*"] } + | SHARP { ["#"] } | x = separated_nonempty_list(COMA,value) { x } diff --git a/src/parser/lexer.mll b/src/parser/lexer.mll index 37a5fe52fb651978905ce424e9e9e1fe0ea8d412..f3e217e675f98c24ce4ee25f491de2662d9a6d73 100644 --- a/src/parser/lexer.mll +++ b/src/parser/lexer.mll @@ -117,6 +117,7 @@ and global = parse | ',' { COMA } | '+' { PLUS } | '*' { STAR } +| '#' { SHARP } | '=' { EQUAL } | "<>" { DISEQUAL } | '|' { PIPE }