Skip to content

GitLab

L
libcaml-grew
Commit 188f89ad authored by Bruno Guillaume's avatar Bruno Guillaume
Browse files
Options

remove old lexicon implementation

parent ca3d349c
Hide whitespace changes
Inline Side-by-side
Showing with 80 additions and 287 deletions
src/grew_ast.ml
View file @ 188f89ad
......@@ -98,7 +98,6 @@ module Ast = struct
| Disequality of feature_value list
| Equal_lex of string * string
| Disequal_lex of string * string
| Equal_param of string (* $ident *)
| Absent
| Else of (feature_value * feature_name * feature_value)
......@@ -108,7 +107,6 @@ module Ast = struct
| Disequality fv_list -> sprintf " <> %s" (String.concat "|" fv_list)
| Equal_lex (lex,fn) -> sprintf " = %s.%s" lex fn
| Disequal_lex (lex,fn) -> sprintf " <> %s.%s" lex fn
| Equal_param param -> sprintf " = $%s" param
| Absent -> " <> *"
| Else (fv1, fn2, fv2) -> sprintf " = %s/%s = %s" fv1 fn2 fv2
......@@ -246,12 +244,10 @@ module Ast = struct
type concat_item =
| Qfn_or_lex_item of pointed
| String_item of string
| Param_item of string
let string_of_concat_item = function
| Qfn_or_lex_item pointed -> sprintf "%s.%s" (fst pointed) (snd pointed)
| String_item s -> sprintf "\"%s\"" s
| Param_item var -> var
type u_command =
| Del_edge_expl of (Id.name * Id.name * edge_label)
......@@ -326,16 +322,10 @@ module Ast = struct
type lexicon_info = (string * lexicon) list
(* the [rule] type is used for 3 kinds of module items:
- rule { param=None; ... }
- lex_rule
*)
type rule = {
rule_id: Id.name;
pattern: pattern;
commands: command list;
param: (string list * string list) option; (* (files, vars) *)
lex_par: string list option; (* lexical parameters in the file *)
lexicon_info: lexicon_info;
rule_doc: string list;
rule_loc: Loc.t;
......
src/grew_ast.mli
View file @ 188f89ad
......@@ -62,7 +62,6 @@ module Ast : sig
| Disequality of feature_value list
| Equal_lex of string * string
| Disequal_lex of string * string
| Equal_param of string (* $ident *)
| Absent
| Else of (feature_value * feature_name * feature_value)
......@@ -146,7 +145,6 @@ module Ast : sig
type concat_item =
| Qfn_or_lex_item of (string * string)
| String_item of string
| Param_item of string
type u_command =
| Del_edge_expl of (Id.name * Id.name * edge_label)
......@@ -180,8 +178,6 @@ module Ast : sig
rule_id:Id.name;
pattern: pattern;
commands: command list;
param: (string list * string list) option; (* (files, vars) *)
lex_par: string list option; (* lexical parameters in the file *)
lexicon_info: lexicon_info;
rule_doc:string list;
rule_loc: Loc.t;
......
src/grew_command.ml
View file @ 188f89ad
......@@ -33,7 +33,6 @@ module Command = struct
| Feat of (command_node * string)
| String of string
| Lexical_field of (string * string)
| Param of int
let item_to_json = function
| Feat (cn, feature_name) -> `Assoc [("copy_feat",
......@@ -44,7 +43,6 @@ module Command = struct
)]
| String s -> `Assoc [("string", `String s)]
| Lexical_field (lex,field) -> `Assoc [("lexical_filed", `String (lex ^ "." ^ field))]
| Param i -> `Assoc [("param", `Int i)]
(* the command in pattern *)
type p =
......@@ -153,7 +151,7 @@ module Command = struct
]
)]
let build ?domain ?param lexicons (kni, kei) table ast_command =
let build ?domain lexicons (kni, kei) table ast_command =
(* kni stands for "known node idents", kei for "known edge idents" *)
let cn_of_node_id node_id =
......@@ -256,18 +254,10 @@ module Command = struct
Feat (cn_of_node_id node_id_or_lex, feature_name_or_lex_field)
end
| Ast.String_item s -> String s
| Ast.Param_item var ->
match param with
| None -> Error.build ~loc "Unknown command variable '%s'" var
| Some par ->
match List_.index var par with
| Some index -> Param index
| _ -> Error.build ~loc "Unknown command variable '%s'" var
) ast_items in
(* check for consistency *)
(match items with
| _ when Domain.is_open_feature ?domain feat_name -> ()
| [Param _] -> () (* TODO: check that lexical parameters are compatible with the feature domain *)
| [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);
......
src/grew_command.mli
View file @ 188f89ad
......@@ -24,7 +24,6 @@ module Command : sig
| Feat of (command_node * string)
| String of string
| Lexical_field of (string * string)
| Param of int
type p =
| DEL_NODE of command_node
......@@ -49,7 +48,6 @@ module Command : sig
val build:
?domain: Domain.t ->
?param: string list ->
Lexicons.t ->
(Id.name list * string list) ->
Id.table ->
......
src/grew_fs.ml
View file @ 188f89ad
......@@ -82,14 +82,8 @@ module P_feature = struct
| Different_lex of string * string
| Else of (value * feature_name * value)
(* NB: in the current version, |in_param| ≤ 1 *)
type v = {
cst: cst;
in_param: int list; (* the list of parameters to which the value must belong *)
}
type t = string * v
let dump (feature_name, {cst; in_param}) =
type t = string * cst
let dump (feature_name, cst) =
printf "[P_feature.dump]\n";
printf "%s%s\n"
feature_name
......@@ -102,10 +96,9 @@ module P_feature = struct
| Absent -> " must be Absent!"
| Else (fv1,fn2,fv2) -> sprintf " = %s/%s = %s" (string_of_value fv1) fn2 (string_of_value fv2));
printf "in_param=[%s]\n" (String.concat "," (List.map string_of_int in_param));
printf "%!"
let to_json ?domain (feature_name, {cst}) =
let to_json ?domain (feature_name, cst) =
`Assoc [
("feature_name", `String feature_name);
( match cst with
......@@ -126,11 +119,11 @@ module P_feature = struct
(** raise [P_feature.Fail_unif] *)
let unif_value v1 v2 = match (v1, v2) with
| ({cst=Absent;in_param=[]},{cst=Absent;in_param=[]}) -> v1
| ({cst=Absent;in_param=[]},_)
| (_,{cst=Absent;in_param=[]}) -> raise Fail_unif
| (Absent, Absent) -> v1
| (Absent, _)
| (_, Absent) -> raise Fail_unif
| ({cst=cst1; in_param=in1}, {cst=cst2; in_param=in2}) ->
| (cst1, cst2) ->
let cst = match (cst1, cst2) with
| (Equal l1, Equal l2) ->
(match List_.sort_inter l1 l2 with
......@@ -143,56 +136,36 @@ module P_feature = struct
| l -> Equal l)
| (Different l1, Different l2) -> Different (List_.sort_union l1 l2)
| _ -> Error.bug "[P_feature.unif_value] inconsistent match case" in
let (in_) = match (in1,in2) with
| (_,[]) -> (in1)
| ([],_) -> (in2)
| _ -> Error.build "more than one parameter constraint for the same feature in not yet implemented" in
{cst; in_param=in_}
let to_string ?param_names t =
let param_string index = match param_names with
| None -> sprintf "$%d" index
| Some l -> sprintf "%s" (List.nth l index) in
cst
let to_string t =
match t with
| (feat_name, {cst=Absent ;in_param=[]}) -> sprintf "!%s" feat_name
| (feat_name, {cst=Equal atoms;in_param=[]}) -> sprintf "%s=%s" feat_name (List_.to_string string_of_value "|" atoms)
| (feat_name, {cst=Different [];in_param=[]}) -> sprintf "%s=*" feat_name
| (feat_name, {cst=Different atoms;in_param=[]}) -> sprintf "%s≠%s" feat_name (List_.to_string string_of_value "|" atoms)
| (feat_name, {cst=Equal atoms;in_param=[one_in]}) -> sprintf "%s=%s=$%s" feat_name (List_.to_string string_of_value "|" atoms) (param_string one_in)
| (feat_name, {cst=Different [];in_param=[one_in]}) -> sprintf "%s=$%s" feat_name (param_string one_in)
| (feat_name, {cst=Different atoms;in_param=[one_in]}) -> sprintf "%s≠%s^%s=%s" feat_name (List_.to_string string_of_value "|" atoms) feat_name (param_string one_in)
| _ -> Error.bug "[P_feature.to_string] multiple parameters are not handled"
let build ?domain ?pat_vars lexicons = function
| (feat_name, Absent) -> sprintf "!%s" feat_name
| (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 string_of_value "|" atoms)
| (feat_name, Equal_lex (lex,fn)) -> sprintf "%s=%s.%s" feat_name lex fn
| (feat_name, Different_lex (lex,fn)) -> sprintf "%s<>%s.%s" feat_name lex fn
| (feat_name, Else (fv1,fn2,fv2)) -> sprintf "%s=%s/%s=%s" feat_name (string_of_value fv1) fn2 (string_of_value fv2)
let build ?domain lexicons = function
| ({Ast.kind=Ast.Absent; name=name}, loc) ->
Domain.check_feature_name ~loc ?domain name;
(name, {cst=Absent;in_param=[];})
(name, Absent)
| ({Ast.kind=Ast.Equality unsorted_values; name=name}, loc) ->
let values = Feature_value.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, Equal values)
| ({Ast.kind=Ast.Disequality unsorted_values; name=name}, loc) ->
let values = Feature_value.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, Different values)
| ({Ast.kind=Ast.Equal_lex (lex,fn); name=name}, loc) ->
Lexicons.check ~loc lex fn lexicons;
(name, {cst=Equal_lex (lex,fn); in_param=[];})
(name, Equal_lex (lex,fn) )
| ({Ast.kind=Ast.Disequal_lex (lex,fn); name=name}, loc) ->
Lexicons.check ~loc lex fn lexicons;
(name, {cst=Different_lex (lex,fn); in_param=[];})
(name, Different_lex (lex,fn) )
| ({Ast.kind=Ast.Else (fv1,fn2,fv2); name=name}, loc) ->
let v1 = match Feature_value.build_disj ~loc ?domain name [fv1] with [one] -> one | _ -> failwith "BUG Else" in
let v2 = match Feature_value.build_disj ~loc ?domain name [fv2] with [one] -> one | _ -> failwith "BUG Else" in
(name, {cst=Else (v1,fn2,v2);in_param=[];})
| ({Ast.kind=Ast.Equal_param var; name=name}, loc) ->
begin
match pat_vars with
| None -> Error.bug ~loc "[P_feature.build] param '%s' in an unparametrized rule" var
| Some l ->
match List_.index var l with
| Some index -> (name, {cst=Different []; in_param = [index]})
| None -> Error.build ~loc "[P_feature.build] Unknown pattern variable '%s'" var
end
(name, Else (v1,fn2,v2))
end (* module P_feature *)
(* ================================================================================ *)
......@@ -433,35 +406,35 @@ module P_fs = struct
let to_json ?domain t = `List (List.map (P_feature.to_json ?domain) t)
let check_position ?param position t =
let check_position position t =
try
match (List.assoc "position" t, position) with
| ({P_feature.cst=P_feature.Equal pos_list; in_param=[]}, Some p) -> List.mem (Float p) pos_list
| ({P_feature.cst=P_feature.Equal pos_list; in_param=[]}, None) -> false
| ({P_feature.cst=P_feature.Different pos_list; in_param=[]}, Some p) -> not (List.mem (Float p) pos_list)
| ({P_feature.cst=P_feature.Different pos_list; in_param=[]}, None) -> false
| ({P_feature.cst=P_feature.Absent}, Some _) -> false
| ({P_feature.cst=P_feature.Absent}, None) -> true
| _ -> Error.bug "Position can't be parametrized"
| (P_feature.Equal pos_list, Some p) -> List.mem (Float p) pos_list
| (P_feature.Equal pos_list, None) -> false
| (P_feature.Different pos_list, Some p) -> not (List.mem (Float p) pos_list)
| (P_feature.Different pos_list, None) -> false
| (P_feature.Absent, Some _) -> false
| (P_feature.Absent, None) -> true
| _ -> true (* TODO : does positions in lexicons can be useful ??? *)
with Not_found -> true
let build ?domain ?pat_vars lexicons ast_fs =
let unsorted = List.map (P_feature.build lexicons ?domain ?pat_vars) ast_fs in
let build ?domain lexicons ast_fs =
let unsorted = List.map (P_feature.build lexicons ?domain) ast_fs in
List.sort P_feature.compare unsorted
let feat_list t =
List.map (function
| (fn, {P_feature.cst=P_feature.Else (_,fn2,_)}) -> (fn, Some fn2)
| (fn, P_feature.Else (_,fn2,_)) -> (fn, Some fn2)
| (fn, _) -> (fn, None)
) t
let to_string t = List_.to_string P_feature.to_string "\\n" t
let to_dep ?filter param_names t =
let to_dep ?filter t =
let reduced = match filter with
| None -> t
| Some test -> List.filter (fun (fn,_) -> test fn) t in
List_.to_string (P_feature.to_string ~param_names) "#" reduced
List_.to_string (P_feature.to_string) "#" reduced
let to_dot t = List_.to_string P_feature.to_string "\\n" t
......@@ -478,16 +451,16 @@ module P_fs = struct
| ((fn_pat, fv_pat)::t_pat, (fn, _)::t) when fn_pat > fn -> loop acc ((fn_pat, fv_pat)::t_pat, t)
(* Two next cases: p_fs requires for the absence of a feature -> OK *)
| ((fn_pat, {P_feature.cst=P_feature.Absent})::t_pat, []) -> loop acc (t_pat, [])
| ((fn_pat, {P_feature.cst=P_feature.Absent})::t_pat, (fn, fa)::t) when fn_pat < fn -> loop acc (t_pat, (fn, fa)::t)
| ((fn_pat, P_feature.Absent)::t_pat, []) -> loop acc (t_pat, [])
| ((fn_pat, P_feature.Absent)::t_pat, (fn, fa)::t) when fn_pat < fn -> loop acc (t_pat, (fn, fa)::t)
(* look for the second part of an Else construction*)
| ((_, {P_feature.cst=P_feature.Else (_,fn2,fv2)})::t_pat,[]) ->
| ((_, P_feature.Else (_,fn2,fv2))::t_pat,[]) ->
begin
try if (List.assoc fn2 g_fs) <> fv2 then raise Fail
with Not_found -> raise Fail
end; loop acc (t_pat, [])
| ((fn_pat, {P_feature.cst=P_feature.Else (_,fn2,fv2)})::t_pat,(fn, fv)::t) when fn_pat < fn ->
| ((fn_pat, P_feature.Else (_,fn2,fv2))::t_pat,(fn, fv)::t) when fn_pat < fn ->
begin
try if (List.assoc fn2 g_fs) <> fv2 then raise Fail
with Not_found -> raise Fail
......@@ -498,11 +471,11 @@ module P_fs = struct
| ((fn_pat, _)::_, (fn, _)::_) when fn_pat < fn -> raise Fail
(* Next cases: fn_pat = fn *)
| ((_, {P_feature.cst=P_feature.Absent})::_, (_, atom)::t) -> raise Fail
| ((_, {P_feature.cst=P_feature.Equal fv})::_, (_, atom)::t) when not (List_.sort_mem atom fv) -> raise Fail
| ((_, {P_feature.cst=P_feature.Different fv})::_, (_, atom)::t) when List_.sort_mem atom fv -> raise Fail
| ((_, P_feature.Absent)::_, (_, atom)::t) -> raise Fail
| ((_, P_feature.Equal fv)::_, (_, atom)::t) when not (List_.sort_mem atom fv) -> raise Fail
| ((_, P_feature.Different fv)::_, (_, atom)::t) when List_.sort_mem atom fv -> raise Fail
| ((_, {P_feature.cst=P_feature.Equal_lex (lex_name,field)})::t_pat, (_, atom)::t) ->
| ((_, P_feature.Equal_lex (lex_name,field))::t_pat, (_, atom)::t) ->
begin
try
let lexicon = List.assoc lex_name acc in
......
src/grew_fs.mli
View file @ 188f89ad
......@@ -76,11 +76,11 @@ module P_fs: sig
val empty: t
val build: ?domain:Domain.t -> ?pat_vars: string list -> Lexicons.t -> Ast.feature list -> t
val build: ?domain:Domain.t -> Lexicons.t -> Ast.feature list -> t
val to_string: t -> string
val to_dep: ?filter: (string -> bool) -> string list -> t -> string
val to_dep: ?filter: (string -> bool) -> t -> string
val to_dot: t -> string
......@@ -93,7 +93,7 @@ module P_fs: sig
(** [check_position ?parma position pfs] checks wheter [pfs] is compatible with a node at [position].
It returns [true] iff [pfs] has no requirement about position ok if the requirement is satisfied. *)
val check_position: ?param:Lex_par.t -> float option -> t -> bool
val check_position: float option -> t -> bool
exception Fail_unif
......
src/grew_graph.ml
View file @ 188f89ad
......@@ -62,15 +62,15 @@ module P_graph = struct
| Some new_node -> Some (Pid_map.add id_src new_node map)
(* -------------------------------------------------------------------------------- *)
let build ?domain ?pat_vars lexicons (full_node_list : Ast.node list) full_edge_list =
let build ?domain lexicons (full_node_list : Ast.node list) full_edge_list =
(* NB: insert searches for a previous node with the Same name and uses unification rather than constraint *)
(* NB: insertion of new node at the end of the list: not efficient but graph building is not the hard part. *)
let rec insert (ast_node, loc) = function
| [] -> [P_node.build ?domain ?pat_vars lexicons (ast_node, loc)]
| [] -> [P_node.build ?domain lexicons (ast_node, loc)]
| (node_id,fs)::tail when ast_node.Ast.node_id = node_id ->
begin
try (node_id, P_node.unif_fs (P_fs.build ?domain ?pat_vars lexicons ast_node.Ast.fs) fs) :: tail
try (node_id, P_node.unif_fs (P_fs.build ?domain lexicons ast_node.Ast.fs) fs) :: tail
with Error.Build (msg,_) -> raise (Error.Build (msg,Some loc))
end
| head :: tail -> head :: (insert (ast_node, loc) tail) in
......@@ -117,9 +117,9 @@ module P_graph = struct
(* -------------------------------------------------------------------------------- *)
(* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
let build_extension ?domain ?pat_vars lexicons pos_table full_node_list full_edge_list =
let build_extension ?domain lexicons pos_table full_node_list full_edge_list =
let built_nodes = List.map (P_node.build ?domain ?pat_vars lexicons) full_node_list in
let built_nodes = List.map (P_node.build ?domain lexicons) full_node_list in
let (old_nodes, new_nodes) =
List.partition
......
src/grew_graph.mli
View file @ 188f89ad
......@@ -65,7 +65,6 @@ module P_graph: sig
(** It raises [P_fs.Fail_unif] exception in case of inconsistent feature structures. *)
val build:
?domain:Domain.t ->
?pat_vars: string list ->
Lexicons.t ->
Ast.node list ->
Ast.edge list ->
......@@ -74,7 +73,6 @@ module P_graph: sig
(** It raises [P_fs.Fail_unif] exception in case of inconsistent feature structures. *)
val build_extension:
?domain:Domain.t ->
?pat_vars: string list ->
Lexicons.t ->
Id.table ->
Ast.node list ->
......
src/grew_lexer.mll
View file @ 188f89ad
......@@ -98,7 +98,7 @@ and string_lex re target = parse
string_lex re target lexbuf
}
(* a dedicated lexer for lexical parameter: read everything until "#END" *)
(* a dedicated lexer for local lexicons: read everything until "#END" *)
and lp_lex name target = parse
| '\n' { (match Global.get_line () with
| None -> raise (Error "no loc in lexer")
......
src/grew_node.ml
View file @ 188f89ad
......@@ -159,11 +159,11 @@ module P_node = struct
let empty = { fs = P_fs.empty; next = Massoc_pid.empty; name = ""; loc=None }
let build ?domain ?pat_vars lexicons (ast_node, loc) =
let build ?domain lexicons (ast_node, loc) =
(ast_node.Ast.node_id,
{
name = ast_node.Ast.node_id;
fs = P_fs.build ?domain ?pat_vars lexicons ast_node.Ast.fs;
fs = P_fs.build ?domain lexicons ast_node.Ast.fs;
next = Massoc_pid.empty;
loc = Some loc;
} )
......@@ -175,7 +175,6 @@ module P_node = struct
let match_ ?lexicons p_node g_node =
(* (match param with None -> printf "<None>" | Some p -> printf "<Some>"; Lex_par.dump p); *)
match G_node.get_position g_node with
| G_node.Unordered _ -> raise P_fs.Fail (* TOOO: check this return !! *)
| G_node.Ordered p ->
......
src/grew_node.mli
View file @ 188f89ad
......@@ -102,7 +102,7 @@ module P_node: sig
It raises [P_fs.Fail_unif] exception in case of Failure. *)
val unif_fs: P_fs.t -> t -> t
val build: ?domain:Domain.t -> ?pat_vars: string list -> Lexicons.t -> Ast.node -> (Id.name * t)
val build: ?domain:Domain.t -> Lexicons.t -> Ast.node -> (Id.name * t)
val add_edge: P_edge.t -> Pid.t -> t -> t option
......
src/grew_parser.mly
View file @ 188f89ad
......@@ -288,8 +288,6 @@ rule:
{ Ast.rule_id = fst id_loc;
pattern = Ast.complete_pattern { Ast.pat_pos = p; Ast.pat_negs = n };
commands = cmds;
param = None;
lex_par = None;
lexicon_info = lexicons;
rule_doc = begin match doc with Some d -> d | None -> [] end;
rule_loc = snd id_loc;
......
src/grew_rule.ml
View file @ 188f89ad
......@@ -268,9 +268,9 @@ module Rule = struct
("constraints", `List (List.map (const_to_json ?domain) basic.constraints));
]
let build_pos_basic ?domain lexicons ?pat_vars basic_ast =
let build_pos_basic ?domain lexicons basic_ast =
let (graph, pos_table) =
P_graph.build ?domain ?pat_vars lexicons basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
P_graph.build ?domain lexicons basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
(
{
graph = graph;
......@@ -367,9 +367,9 @@ module Rule = struct
(* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
let build_neg_basic ?domain ?pat_vars lexicons pos_table basic_ast =
let build_neg_basic ?domain lexicons pos_table basic_ast =
let (extension, neg_table) =
P_graph.build_extension ?domain ?pat_vars lexicons pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
P_graph.build_extension ?domain lexicons pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
let filters = Pid_map.fold (fun id node acc -> Filter (id, P_node.get_fs node) :: acc) extension.P_graph.old_map [] in
{
......@@ -394,7 +394,6 @@ module Rule = struct
name: string;
pattern: pattern;
commands: Command.t list;
param: Lex_par.t * string list; (* ([],[]) if None *)
lexicons: Lexicons.t;
loc: Loc.t;
}
......@@ -404,19 +403,13 @@ module Rule = struct
let get_loc t = t.loc
let to_json ?domain t =
let param_json = match t.param with
| ([],[]) -> []
| (lex_par, param_names) -> [
("pattern_param", `List (List.map (fun x -> `String x) (param_names)));
("lex_par", Lex_par.to_json lex_par);
] in
`Assoc
([
("rule_name", `String t.name);
("match", basic_to_json ?domain (fst t.pattern));
("without", `List (List.map (basic_to_json ?domain) (snd t.pattern)));
("commands", `List (List.map (Command.to_json ?domain) t.commands))
] @ param_json
]
)
(* ====================================================================== *)
......@@ -429,7 +422,7 @@ module Rule = struct
Pid_map.fold
(fun id node acc ->
(node, sprintf " N_%s { word=\"%s\"; subword=\"%s\"}"
(Pid.to_id id) (P_node.get_name node) (P_fs.to_dep (snd t.param) (P_node.get_fs node))
(Pid.to_id id) (P_node.get_name node) (P_fs.to_dep (P_node.get_fs node))
)
:: acc
) pos_basic.graph [] in
......@@ -479,7 +472,7 @@ module Rule = struct
Buffer.contents buff
(* ====================================================================== *)
let build_commands ?domain ?param lexicons pos pos_table ast_commands =
let build_commands ?domain lexicons pos pos_table ast_commands =
let known_node_ids = Array.to_list pos_table in
let known_edge_ids = get_edge_ids pos in
......@@ -489,7 +482,6 @@ module Rule = struct
let (command, (new_kni, new_kei)) =
Command.build
?domain
?param
lexicons
(kni,kei)
pos_table
......@@ -507,11 +499,6 @@ module Rule = struct
(* ====================================================================== *)
let build ?domain deprecated_dir rule_ast =
let dir = match rule_ast.Ast.rule_dir with
| Some d -> d
| None -> deprecated_dir in
let lexicons =
List.fold_left (fun acc (name,lex) ->
try
......@@ -520,35 +507,9 @@ module Rule = struct
with Not_found -> (name, build_lex rule_ast.Ast.rule_loc lex) :: acc
) [] rule_ast.Ast.lexicon_info in
let (param, pat_vars) =
match rule_ast.Ast.param with
| None -> ([],[])
| Some (files,vars) ->
let nb_var = List.length vars in
(* first: load lexical parameters given in the same file at the end of the rule definition *)
let local_param = match rule_ast.Ast.lex_par with
| None -> []
| Some lines -> Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_var lines in
(* second: load lexical parameters given in external files *)
let full_param = List.fold_left
(fun acc file ->
match acc with
| [] -> Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_var file
| lp -> Lex_par.append (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_var file) lp
) local_param files in
(full_param, vars) in
(match (param, pat_vars) with
| ([], _::_) -> Error.build ~loc:rule_ast.Ast.rule_loc "[Rule.build] Missing lexical parameters in rule \"%s\"" rule_ast.Ast.rule_id
| _ -> ()
);
let pattern = Ast.normalize_pattern rule_ast.Ast.pattern in
let (pos, pos_table) =
try build_pos_basic ?domain lexicons ~pat_vars pattern.Ast.pat_pos
try build_pos_basic ?domain lexicons pattern.Ast.pat_pos
with P_fs.Fail_unif ->
Error.build ~loc:rule_ast.Ast.rule_loc
"[Rule.build] in rule \"%s\": feature structures declared in the \"match\" clause are inconsistent"
......@@ -556,7 +517,7 @@ module Rule = struct
let (negs,_) =
List.fold_left
(fun (acc,pos) basic_ast ->
try ((build_neg_basic ?domain ~pat_vars lexicons pos_table basic_ast) :: acc, pos+1)
try ((build_neg_basic ?domain lexicons pos_table basic_ast) :: acc, pos+1)
with P_fs.Fail_unif ->
Log.fwarning "In rule \"%s\" [%s], the wihtout number %d cannot be satisfied, it is skipped"
rule_ast.Ast.rule_id (Loc.to_string rule_ast.Ast.rule_loc) pos;
......@@ -565,10 +526,9 @@ module Rule = struct
{
name = rule_ast.Ast.rule_id;
pattern = (pos, negs);
commands = build_commands ?domain ~param:pat_vars lexicons pos pos_table rule_ast.Ast.commands;
commands = build_commands ?domain lexicons pos pos_table rule_ast.Ast.commands;
loc = rule_ast.Ast.rule_loc;
lexicons;
param = (param, pat_vars);
}
let build_pattern ?domain ?(lexicons=[]) pattern_ast =
......@@ -587,7 +547,6 @@ 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) *)
m_param: Lex_par.t option;
l_param: Lexicons.t;
}
......@@ -611,7 +570,7 @@ module Rule = struct