Commit 68887367 authored by Bruno Guillaume's avatar Bruno Guillaume

TMP: new syntax for lexicon declaration in rules

parent 0cd4cd9d
# 0.48.0 (2018/06/19)
* remove `conll_fields` mechanism (names of conll fields 2, 4 and 5 are fomr, upos, xpos)
* remove `conll_fields` mechanism (names of conll fields 2, 4 and 5 are `form`, `upos`, `xpos`)
## 0.47.2 (2018/05/04)
* Deal with increasing Grs
......
......@@ -76,16 +76,20 @@ module Ast = struct
| _ -> Error.build "The identifier '%s' must be a feature identifier (with exactly one '.' symbol, like \"V.cat\" for instance)" s
(* ---------------------------------------------------------------------- *)
(* simple_or_feature_ident: union of simple_ident and feature_ident *)
(* simple_or_pointed: union of simple_ident, feature_ident and lex field *)
(* Note: used for parsing of "X < Y" and "X.feat < Y.feat" without conflicts *)
type simple_or_feature_ident = Id.name * feature_name option
type pointed = string * string
let dump_pointed (s1,s2) = sprintf "%s.%s" s1 s2
type simple_or_pointed =
| Simple of Id.name
| Pointed of pointed
let parse_simple_or_feature_ident s =
let parse_simple_or_pointed s =
check_special "feature ident" ["."] s;
match Str.full_split (Str.regexp "\\.") s with
| [Str.Text base; ] -> (base, None)
| [Str.Text base; Str.Delim "."; Str.Text fn] -> (base, Some (to_uname fn))
| _ -> Error.build "The identifier '%s' must be a feature identifier (with at most one '.' symbol, like \"V\" or \"V.cat\" for instance)" s
match Str.split (Str.regexp "\\.") s with
| [base] -> Simple base
| [s1; s2] -> Pointed (s1, s2)
| _ -> Error.build "The identifier '%s' must be a feature identifier or a lexical reference (with at most one '.' symbol, like \"V\", \"V.cat\" or \"lex.cat\" for instance)" s
(* ---------------------------------------------------------------------- *)
......@@ -159,9 +163,15 @@ module Ast = struct
| Feature_eq_float of feature_ident * float
| Feature_diff_float of feature_ident * float
(* ambiguous case, context needed to make difference "N.cat = M.cat" VS "N.cat = lex.cat" *)
| Feature_eq_lex_or_fs of feature_ident * (string * string)
| Feature_diff_lex_or_fs of feature_ident * (string * string)
(* *)
| Feature_eq_regexp of feature_ident * string
| Feature_eq_cst of feature_ident * string
| Feature_eq_lex of feature_ident * (string * string)
| Feature_diff_cst of feature_ident * string
| Feature_diff_lex of feature_ident * (string * string)
| Immediate_prec of Id.name * Id.name
| Large_prec of Id.name * Id.name
......@@ -229,14 +239,14 @@ module Ast = struct
{ pat_pos = new_pat_pos; pat_negs = new_pat_negs;}
type concat_item =
| Qfn_item of feature_ident
| Qfn_or_lex_item of pointed
| String_item of string
| Param_item of string
let string_of_concat_item = function
| Qfn_item id -> sprintf "%s" (dump_feature_ident id)
| Qfn_or_lex_item pointed -> sprintf "%s.%s" (fst pointed) (snd pointed)
| String_item s -> sprintf "\"%s\"" s
| Param_item var -> sprintf "%s" var
| Param_item var -> var
type u_command =
| Del_edge_expl of (Id.name * Id.name * edge_label)
......@@ -305,17 +315,24 @@ module Ast = struct
| Del_feat (act_id, feat_name) ->
sprintf "del_feat %s.%s" act_id feat_name
type lexicon =
| File of string
| Final of string list
type lexicon_info = lexicon Massoc_string.t
(* the [rule] type is used for 3 kinds of module items:
- rule { param=None; ... }
- lex_rule
*)
type rule = {
rule_id:Id.name;
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 *)
rule_doc:string list;
lexicon_info: lexicon_info;
rule_doc: string list;
rule_loc: Loc.t;
rule_dir: string option; (* the real folder where the file is defined *)
}
......
......@@ -49,8 +49,12 @@ module Ast : sig
(* ---------------------------------------------------------------------- *)
(* simple_or_feature_ident: union of simple_ident and feature_ident *)
(* Note: used for parsing of "X < Y" and "X.feat < Y.feat" without conflicts *)
type simple_or_feature_ident = Id.name * feature_name option
val parse_simple_or_feature_ident: string -> simple_or_feature_ident
type pointed = string * string
type simple_or_pointed =
| Simple of Id.name
| Pointed of pointed
val parse_simple_or_pointed: string -> simple_or_pointed
(* ---------------------------------------------------------------------- *)
type feature_kind =
......@@ -105,11 +109,16 @@ module Ast : sig
| Feature_ineq_cst of ineq * feature_ident * float
| Feature_eq_float of feature_ident * float
| Feature_diff_float of feature_ident * float
(* ambiguous case, context needed to make difference "N.cat = M.cat" VS "N.cat = lex.cat" *)
| Feature_eq_lex_or_fs of feature_ident * (string * string)
| Feature_diff_lex_or_fs of feature_ident * (string * string)
(* *)
| Feature_eq_regexp of feature_ident * string
| Feature_eq_cst of feature_ident * string
| Feature_eq_lex of feature_ident * (string * string)
| Feature_diff_cst of feature_ident * string
| Feature_diff_lex of feature_ident * (string * string)
(* *)
| Immediate_prec of Id.name * Id.name
| Large_prec of Id.name * Id.name
type const = u_const * Loc.t
......@@ -132,7 +141,7 @@ module Ast : sig
val complete_pattern : pattern -> pattern
type concat_item =
| Qfn_item of feature_ident
| Qfn_or_lex_item of (string * string)
| String_item of string
| Param_item of string
......@@ -158,12 +167,19 @@ module Ast : sig
val string_of_u_command: u_command -> string
type command = u_command * Loc.t
type lexicon =
| File of string
| Final of string list
type lexicon_info = lexicon Massoc_string.t
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;
rule_dir: string option; (* the real folder where the file is defined *)
......
......@@ -426,6 +426,8 @@ module type S = sig
val fold: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
val fold_on_list: ('b -> key -> 'a list -> 'b) -> 'b -> 'a t -> 'b
(* raise Not_found if no (key,elt) *)
val remove: key -> 'a -> 'a t -> 'a t
val remove_opt: key -> 'a -> 'a t -> 'a t option
......@@ -490,6 +492,8 @@ module Massoc_make (Ord: OrderedType) = struct
acc list)
t init
let fold_on_list fct init t = M.fold (fun key list acc -> fct acc key list) t init
(* Not found raised in the value is not defined *)
let remove key value t =
match M.find key t with
......
......@@ -209,6 +209,8 @@ module type S =
val fold: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b
val fold_on_list: ('b -> key -> 'a list -> 'b) -> 'b -> 'a t -> 'b
(* raise Not_found if no (key,elt) *)
val remove: key -> 'a -> 'a t -> 'a t
val remove_opt: key -> 'a -> 'a t -> 'a t option
......
......@@ -32,6 +32,7 @@ module Command = struct
type item =
| Feat of (command_node * string)
| String of string
| Lexical_field of (string * string)
| Param of int
let item_to_json = function
......@@ -42,6 +43,7 @@ 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 *)
......@@ -170,7 +172,7 @@ module Command = struct
| H_SHIFT_OUT of (Gid.t * Gid.t)
let build ?domain ?param (kni, kei) table ast_command =
let build ?domain ?param lexicon_names (kni, kei) table ast_command =
(* kni stands for "known node idents", kei for "known edge idents" *)
let cn_of_node_id node_id =
......@@ -178,9 +180,11 @@ module Command = struct
| Some x -> Pat (Pid.Pos x)
| None -> New node_id in
let check_node_id loc node_id kni =
let check_node_id_msg loc msg node_id kni =
if not (List.mem node_id kni)
then Error.build ~loc "Unbound node identifier \"%s\"" node_id in
then Error.build ~loc "%s \"%s\"" msg node_id in
let check_node_id loc node_id kni = check_node_id_msg loc "Unbound node identifier" node_id kni in
(* check that the edge_id is defined in the pattern *)
let check_edge loc edge_id kei =
......@@ -256,10 +260,16 @@ module Command = struct
check_node_id loc node_id kni;
let items = List.map
(function
| Ast.Qfn_item (node_id,feature_name) ->
check_node_id loc node_id kni;
Domain.check_feature_name ~loc ?domain feature_name;
Feat (cn_of_node_id node_id, feature_name)
(* TODO update code for new lexicon *)
| Ast.Qfn_or_lex_item (node_id_or_lex,feature_name_or_lex_field) ->
if List.mem node_id_or_lex lexicon_names
then Lexical_field (node_id_or_lex, feature_name_or_lex_field)
else
begin
check_node_id_msg loc ("Unbound identifier %s (neither a node nor a lexicon)") node_id_or_lex kni;
Domain.check_feature_name ~loc ?domain feature_name_or_lex_field;
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
......
......@@ -23,6 +23,7 @@ module Command : sig
type item =
| Feat of (command_node * string)
| String of string
| Lexical_field of (string * string)
| Param of int
type p =
......@@ -65,6 +66,7 @@ module Command : sig
val build:
?domain: Domain.t ->
?param: string list ->
string list -> (* lexicon names *)
(Id.name list * string list) ->
Id.table ->
Ast.command ->
......
......@@ -100,7 +100,13 @@ and string_lex re target = parse
and lp_lex target = parse
| '\n' { Global.new_line (); Lexing.new_line lexbuf; bprintf buff "\n"; lp_lex target lexbuf }
| _ as c { bprintf buff "%c" c; lp_lex target lexbuf }
| "#END" [' ' '\t']* '\n' { Global.new_line (); LEX_PAR (Str.split (Str.regexp "\n") (Buffer.contents buff)) }
| "#END" [' ' '\t']* '\n' { Global.new_line ();
Printf.printf "********%s********\n%!" (Buffer.contents buff);
LEX_PAR (
"TODO",
Str.split (Str.regexp "\n") (Buffer.contents buff)
)
}
(* The lexer must be different when label_ident are parsed. The [global] lexer calls either
[label_parser] or [standard] depending on the flag [Global.label_flag].
......@@ -146,7 +152,8 @@ and standard target = parse
| "/*" { comment_multi global lexbuf }
| '%' { comment global lexbuf }
| "#BEGIN" [' ' '\t']* '\n' { Global.new_line (); Buffer.clear buff; lp_lex global lexbuf}
| "#BEGIN" [' ' '\t']* (label_ident as li) [' ' '\t']* '\n'
{ Printf.printf "%s\n%!" li; Global.new_line (); Buffer.clear buff; lp_lex global lexbuf}
| '\n' { Global.new_line (); Lexing.new_line lexbuf; global lexbuf}
......
......@@ -25,7 +25,7 @@ type graph_item =
| Graph_edge of Ast.edge
type ineq_item =
| Ineq_sofi of Ast.simple_or_feature_ident
| Ineq_sofi of Ast.simple_or_pointed
| Ineq_float of float
let get_loc () = Global.get_loc ()
......@@ -115,11 +115,11 @@ let localize t = (t,get_loc ())
/* %token <Grew_ast.Ast.complex_id> COMPLEX_ID*/
%token <string> STRING
%token <string> REGEXP
%token <float> FLOAT
%token <string list> COMMENT
%token <string list> LEX_PAR
%token <string> STRING
%token <string> REGEXP
%token <float> FLOAT
%token <string list> COMMENT
%token <string * string list> LEX_PAR
%token EOF /* end of file */
......@@ -182,11 +182,11 @@ feature_value:
| v=FLOAT { Printf.sprintf "%g" v }
ineq_value:
| v=ID { Ineq_sofi (Ast.parse_simple_or_feature_ident v) }
| v=ID { Ineq_sofi (Ast.parse_simple_or_pointed v) }
| v=FLOAT { Ineq_float v }
ineq_value_with_loc:
| v=ID { localize (Ineq_sofi (Ast.parse_simple_or_feature_ident v)) }
| v=ID { localize (Ineq_sofi (Ast.parse_simple_or_pointed v)) }
| v=FLOAT { localize (Ineq_float v) }
/*=============================================================================================*/
......@@ -332,13 +332,14 @@ rules:
| r = list(rule) { r }
rule:
| doc=option(COMMENT) RULE id_loc=simple_id_with_loc LACC p=pos_item n=list(neg_item) cmds=commands RACC
| doc=option(COMMENT) RULE id_loc=simple_id_with_loc LACC p=pos_item n=list(neg_item) cmds=commands RACC lex_par=list(lex_par)
{
{ 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 = Massoc_string.empty; (* TODOLEX *)
rule_doc = begin match doc with Some d -> d | None -> [] end;
rule_loc = snd id_loc;
rule_dir = None;
......@@ -351,6 +352,7 @@ rule:
commands = cmds;
param = Some param;
lex_par = lex_par;
lexicon_info = Massoc_string.empty; (* TODOLEX *)
rule_doc = begin match doc with Some d -> d | None -> [] end;
rule_loc = snd id_loc;
rule_dir = None;
......@@ -358,7 +360,7 @@ rule:
}
lex_par:
| lex_par = LEX_PAR { lex_par }
| lex_par = LEX_PAR { snd (lex_par) }
param:
| LPAREN FEATURE vars=separated_nonempty_list(COMA,var) RPAREN { ([],vars) }
......@@ -450,14 +452,17 @@ pat_item:
| STAR labels=delimited(LTR_EDGE_LEFT_NEG,separated_nonempty_list(PIPE,pattern_label_ident),LTR_EDGE_RIGHT) n2_loc=simple_id_with_loc
{ let (n2,loc) = n2_loc in Pat_const (Ast.Cst_in (n2,Ast.Neg_list labels), loc) }
/* X.cat = lex.value */
/* X.cat = Y.cat */
/* X.cat = value */
/* X.cat = lex.value */
| feat_id1_loc=feature_ident_with_loc EQUAL rhs=ID
{ let (feat_id1,loc)=feat_id1_loc in
match Ast.parse_simple_or_feature_ident rhs with
| (node_id, Some feat_name) -> Pat_const (Ast.Features_eq (feat_id1, (node_id,feat_name)), loc)
| (value, None) -> Pat_const (Ast.Feature_eq_cst (feat_id1, value), loc)
}
{ let (feat_id1,loc)=feat_id1_loc in
match Ast.parse_simple_or_pointed rhs with
| Ast.Simple value ->
Pat_const (Ast.Feature_eq_cst (feat_id1, value), loc)
| Ast.Pointed (s1, s2) ->
Pat_const (Ast.Feature_eq_lex_or_fs (feat_id1, (s1,s2)), loc)
}
/* X.cat = "value" */
| feat_id1_loc=feature_ident_with_loc EQUAL rhs=STRING
......@@ -469,12 +474,15 @@ pat_item:
/* X.cat <> Y.cat */
/* X.cat <> value */
/* X.cat <> lex.value */
| feat_id1_loc=feature_ident_with_loc DISEQUAL rhs=ID
{ let (feat_id1,loc)=feat_id1_loc in
match Ast.parse_simple_or_feature_ident rhs with
| (node_id, Some feat_name) -> Pat_const (Ast.Features_diseq (feat_id1, (node_id,feat_name)), loc)
| (value, None) -> Pat_const (Ast.Feature_diff_cst (feat_id1, value), loc)
}
{ let (feat_id1,loc)=feat_id1_loc in
match Ast.parse_simple_or_pointed rhs with
| Ast.Simple value ->
Pat_const (Ast.Feature_diff_cst (feat_id1, value), loc)
| Ast.Pointed (s1, s2) ->
Pat_const (Ast.Feature_diff_lex_or_fs (feat_id1, (s1,s2)), loc)
}
/* X.cat <> "value" */
| feat_id1_loc=feature_ident_with_loc DISEQUAL rhs=STRING
......@@ -493,13 +501,24 @@ pat_item:
{ let (id1,loc)=id1_loc in
match (id1, id2) with
(* X.feat < Y.feat *)
| (Ineq_sofi (n1, Some f1), Ineq_sofi (n2, Some f2)) -> Pat_const (Ast.Features_ineq (Ast.Lt, (n1,f1), (n2,f2)), loc)
| (Ineq_sofi (Ast.Pointed (n1, f1)), Ineq_sofi (Ast.Pointed (n2, f2))) ->
Pat_const (Ast.Features_ineq (Ast.Lt, (n1,f1), (n2,f2)), loc)
(* X.feat < 12.34 *)
| (Ineq_sofi (n1, Some f1), Ineq_float num) -> Pat_const (Ast.Feature_ineq_cst (Ast.Lt, (n1,f1), num), loc)
| (Ineq_sofi (Ast.Pointed (n1, f1)), Ineq_float num) ->
Pat_const (Ast.Feature_ineq_cst (Ast.Lt, (n1,f1), num), loc)
(* 12.34 < Y.feat *)
| (Ineq_float num, Ineq_sofi (n1, Some f1)) -> Pat_const (Ast.Feature_ineq_cst (Ast.Gt, (n1,f1), num), loc)
| (Ineq_float num, Ineq_sofi (Ast.Pointed (n1, f1))) ->
Pat_const (Ast.Feature_ineq_cst (Ast.Gt, (n1,f1), num), loc)
(* X < Y *)
| (Ineq_sofi (n1, None), Ineq_sofi (n2, None)) -> Pat_const (Ast.Immediate_prec (n1,n2), loc)
| (Ineq_sofi (Ast.Simple n1), Ineq_sofi (Ast.Simple n2)) ->
Pat_const (Ast.Immediate_prec (n1,n2), loc)
(* TODO : axe lex_field *)
(* __ERRORS__ *)
| (Ineq_float _, Ineq_float _) -> Error.build "the '<' symbol can be used with 2 constants"
| _ -> Error.build "the '<' symbol can be used with 2 nodes or with 2 features but not in a mix inequality"
}
......@@ -508,13 +527,26 @@ pat_item:
{ let (id1,loc)=id1_loc in
match (id1, id2) with
(* X.feat > Y.feat *)
| (Ineq_sofi (n1, Some f1), Ineq_sofi (n2, Some f2)) -> Pat_const (Ast.Features_ineq (Ast.Gt, (n1,f1), (n2,f2)), loc)
| (Ineq_sofi (Ast.Pointed (n1, f1)), Ineq_sofi (Ast.Pointed (n2, f2))) ->
Pat_const (Ast.Features_ineq (Ast.Gt, (n1,f1), (n2,f2)), loc)
(* X.feat > 12.34 *)
| (Ineq_sofi (n1, Some f1), Ineq_float num) -> Pat_const (Ast.Feature_ineq_cst (Ast.Gt, (n1,f1), num), loc)
| (Ineq_sofi (Ast.Pointed (n1, f1)), Ineq_float num) ->
Pat_const (Ast.Feature_ineq_cst (Ast.Gt, (n1,f1), num), loc)
(* 12.34 > Y.feat *)
| (Ineq_float num, Ineq_sofi (n1, Some f1)) -> Pat_const (Ast.Feature_ineq_cst (Ast.Lt, (n1,f1), num), loc)
| (Ineq_float num, Ineq_sofi (Ast.Pointed (n1, f1))) ->
Pat_const (Ast.Feature_ineq_cst (Ast.Lt, (n1,f1), num), loc)
(* X > Y *)
| (Ineq_sofi (n1, None), Ineq_sofi (n2, None)) -> Pat_const (Ast.Immediate_prec (n2,n1), loc)
| (Ineq_sofi (Ast.Simple n1), Ineq_sofi (Ast.Simple n2)) ->
Pat_const (Ast.Immediate_prec (n2,n1), loc)
(* TODO : axe lex_field *)
(* __ERRORS__ *)
| (Ineq_float _, Ineq_float _) -> Error.build "the '>' symbol can be used with 2 constants"
| (Ineq_float _, Ineq_float _) -> Error.build "the '>' symbol can be used with 2 constants"
| _ -> Error.build "the '>' symbol can be used with 2 nodes or with 2 features but not in a mix inequality"
}
......@@ -670,7 +702,12 @@ command:
{ let (com_fead_id,loc) = com_fead_id_loc in (Ast.Update_feat (com_fead_id, items), loc) }
concat_item:
| gi=ID { if Ast.is_simple_ident gi then Ast.String_item gi else Ast.Qfn_item (Ast.parse_feature_ident gi) }
| gi=ID
{
match Ast.parse_simple_or_pointed gi with
| Ast.Simple value -> Ast.String_item value
| Ast.Pointed (s1, s2) -> Ast.Qfn_or_lex_item (s1, s2)
}
| s=STRING { Ast.String_item s }
| f=FLOAT { Ast.String_item (Printf.sprintf "%g" f) }
| p=AROBAS_ID { Ast.Param_item p }
......
......@@ -83,6 +83,9 @@ module Rule = struct
| Feature_eq_cst of Pid.t * string * string
| Feature_diff_cst of Pid.t * string * string
(* *)
| Feature_eq_lex of Pid.t * string * (string * string)
| Feature_diff_lex of Pid.t * string * (string * string)
(* *)
| Feature_eq_float of Pid.t * string * float
| Feature_diff_float of Pid.t * string * float
(* *)
......@@ -133,6 +136,26 @@ module Rule = struct
("value", `String value);
]
]
| Feature_eq_lex (pid,fn,(lex,field)) ->
`Assoc ["feature_eq_lex",
`Assoc [
("id", `String (Pid.to_string pid));
("feature_name_", `String fn);
("lexicon", `String lex);
("field", `String field);
]
]
| Feature_diff_lex (pid,fn,(lex,field)) ->
`Assoc ["feature_diff_lex",
`Assoc [
("id", `String (Pid.to_string pid));
("feature_name_", `String fn);
("lexicon", `String lex);
("field", `String field);
]
]
| Feature_eq_float (pid,fn,value) ->
`Assoc ["feature_eq_float",
`Assoc [
......@@ -198,7 +221,7 @@ module Rule = struct
]
]
let build_pos_constraint ?domain pos_table const =
let build_pos_constraint ?domain (lexicons : (string * Lexicon.t) list) pos_table const =
let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
match const with
| (Ast.Cst_out (id,label_cst), loc) ->
......@@ -236,6 +259,13 @@ module Rule = struct
Domain.check_feature_name ?domain ~loc feat_name;
Feature_diff_cst (pid_of_name loc node_name, feat_name, string)
| (Ast.Feature_eq_lex ((node_name, feat_name), lf), loc) ->
Domain.check_feature_name ?domain ~loc feat_name;
Feature_eq_lex (pid_of_name loc node_name, feat_name, lf)
| (Ast.Feature_diff_lex ((node_name, feat_name), lf), loc) ->
Domain.check_feature_name ?domain ~loc feat_name;
Feature_diff_lex (pid_of_name loc node_name, feat_name, lf)
| (Ast.Feature_eq_float ((node_name, feat_name), float), loc) ->
Domain.check_feature_name ?domain ~loc feat_name;
Feature_eq_float (pid_of_name loc node_name, feat_name, float)
......@@ -249,6 +279,10 @@ module Rule = struct
| (Ast.Large_prec (id1, id2), loc) ->
Large_prec (pid_of_name loc id1, pid_of_name loc id2)
| (Ast.Feature_eq_lex_or_fs (s1,s2), loc) -> failwith "TODO"
| (Ast.Feature_diff_lex_or_fs (s1,s2), loc) -> failwith "TODO"
type basic = {
graph: P_graph.t;
constraints: const list;
......@@ -260,13 +294,13 @@ module Rule = struct
("constraints", `List (List.map (const_to_json ?domain) basic.constraints));
]
let build_pos_basic ?domain ?pat_vars basic_ast =
let build_pos_basic ?domain lexicons ?pat_vars basic_ast =
let (graph, pos_table) =
P_graph.build ?domain ?pat_vars basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
(
{
graph = graph;
constraints = List.map (build_pos_constraint ?domain pos_table) basic_ast.Ast.pat_const
constraints = List.map (build_pos_constraint ?domain lexicons pos_table) basic_ast.Ast.pat_const
},
pos_table
)
......@@ -321,6 +355,13 @@ module Rule = struct
Domain.check_feature_name ?domain ~loc feat_name;
Feature_diff_cst (pid_of_name loc node_name, feat_name, string)
| (Ast.Feature_eq_lex ((node_name, feat_name), lf), loc) ->
Domain.check_feature_name ?domain ~loc feat_name;
Feature_eq_lex (pid_of_name loc node_name, feat_name, lf)
| (Ast.Feature_diff_lex ((node_name, feat_name), lf), loc) ->
Domain.check_feature_name ?domain ~loc feat_name;
Feature_diff_lex (pid_of_name loc node_name, feat_name, lf)
| (Ast.Feature_eq_float ((node_name, feat_name), float), loc) ->
Domain.check_feature_name ?domain ~loc feat_name;
Feature_eq_float (pid_of_name loc node_name, feat_name, float)
......@@ -328,13 +369,16 @@ module Rule = struct
Domain.check_feature_name ?domain ~loc feat_name;
Feature_diff_float (pid_of_name loc node_name, feat_name, float)
| (Ast.Immediate_prec (id1, id2), loc) ->
Immediate_prec (pid_of_name loc id1, pid_of_name loc id2)
| (Ast.Large_prec (id1, id2), loc) ->
Large_prec (pid_of_name loc id1, pid_of_name loc id2)
| (Ast.Feature_eq_lex_or_fs (s1,s2), loc) -> failwith "TODO"
| (Ast.Feature_diff_lex_or_fs (s1,s2), loc) -> failwith "TODO"
(* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
let build_neg_basic ?domain ?pat_vars pos_table basic_ast =
let (extension, neg_table) =
......@@ -364,6 +408,7 @@ module Rule = struct
pattern: pattern;
commands: Command.t list;
param: Lex_par.t * string list; (* ([],[]) if None *)
lexicons: (string * Lexicon.t) list;
loc: Loc.t;
}
......@@ -447,7 +492,7 @@ module Rule = struct
Buffer.contents buff
(* ====================================================================== *)
let build_commands ?domain ?param pos pos_table ast_commands =
let build_commands ?domain ?param lexicon_names pos pos_table ast_commands =
let known_node_ids = Array.to_list pos_table in
let known_edge_ids = get_edge_ids pos in
......@@ -458,12 +503,18 @@ module Rule = struct
Command.build
?domain
?param
lexicon_names
(kni,kei)
pos_table
ast_command in
command :: (loop (new_kni,new_kei) tail) in
loop (known_node_ids, known_edge_ids) ast_commands
let build_lex = function
| Ast.File filename -> Lexicon.load filename
| Ast.Final line_list -> Lexicon.build (List.map (fun s -> Str.split (Str.regexp "\\t") s) line_list)
(* ====================================================================== *)