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 }
......
This diff is collapsed.
......@@ -104,7 +104,7 @@ module Rule : sig
val to_python: pattern -> G_graph.t -> matching -> json
val build_pattern: ?domain:Domain.t -> Ast.pattern -> pattern
val build_pattern: ?domain:Domain.t -> (string * Lexicon.t) list -> Ast.pattern -> pattern
(** [node_matching pattern graph matching] return a assoc list (pid_name, gid.position) *)
val node_matching: pattern -> G_graph.t -> matching -> (string * float) list
......
......@@ -89,6 +89,8 @@ module Massoc_gid = Massoc_make (Gid)
(* ================================================================================ *)
module Massoc_pid = Massoc_make (Pid)
(* ================================================================================ *)
module Massoc_string = Massoc_make (String)
(* ================================================================================ *)
......@@ -154,6 +156,75 @@ module Lex_par = struct
| _ -> Error.run "Lexical parameter are not functional"
end (* module Lex_par *)
(* ================================================================================ *)
module Lexicon = struct
module Line_set = Set.Make (struct type t=string list let compare = Pervasives.compare end)
type t = {
header: string list; (* ordered list of column headers *)
lines: Line_set.t;
}
let rec transpose = function
| [] -> []
| [] :: xss -> transpose xss
| (x::xs) :: xss -> (x :: List.map List.hd xss) :: transpose (xs :: List.map List.tl xss)
let build items =
let tr = transpose items in
let sorted_tr = List.sort (fun l1 l2 -> Pervasives.compare (List.hd l1) (List.hd l2)) tr in
match transpose sorted_tr with
| [] -> Error.bug "[Lexicon.build] inconsistent data"
| header :: lines_list -> { header; lines = List.fold_right Line_set.add lines_list Line_set.empty }
let load file =
let lines = File.read file in
let items = List.map (fun line -> Str.split (Str.regexp "\\t") line) lines in
build items
let reduce sub_list lexicon =
let sorted_sub_list = List.sort Pervasives.compare sub_list in
let reduce_line line =
let rec loop = function
| ([],_,_) -> []
| (hs::ts, hh::th, hl::tl) when hs=hh -> hl::(loop (ts,th,tl))
| (hs::ts, hh::th, hl::tl) when hs>hh -> loop (hs::ts, th, tl)
| (hs::ts, hh::th, hl::tl) (* when hs<hh *) -> Error.bug "[Lexicon.reduce] Field '%s' not in lexicon" hs
| (hs::ts, [], []) -> Error.bug "[Lexicon.reduce] Field '%s' not in lexicon" hs
| _ -> Error.bug "[Lexicon.reduce] Inconsistent length" in
loop (sorted_sub_list, lexicon.header, line) in
let new_lines = Line_set.map reduce_line lexicon.lines in
{ header = sorted_sub_list; lines = new_lines }
let union lex1 lex2 =
if lex1.header <> lex2.header then Error.build "[Lexcion.union] different header";
{ header = lex1.header; lines = Line_set.union lex1.lines lex2.lines }
let select head value lex =
match List_.index head lex.header with
| None -> Error.build "[Lexicon.select] cannot find %s in lexicon" head
| Some index ->
{ lex with lines = Line_set.filter (fun line -> List.nth line index = value) lex.lines}
let projection head lex =
match List_.index head lex.header with
| None -> Error.build "[Lexicon.projection] cannot find %s in lexicon" head
| Some index ->
Line_set.fold (fun line acc -> String_set.add (List.nth line index) acc) lex.lines String_set.empty
exception Not_functional_lexicon
let read head lex =
match String_set.elements (projection head lex) with
| [] -> None
| [one] -> Some one
| _ -> raise Not_functional_lexicon
let read_multi head lex =
match String_set.elements (projection head lex) with
| [] -> None
| l -> Some (String.concat "/" l)
end (* module Lexicon *)
(* ================================================================================ *)
module Concat_item = struct
type t =
......
......@@ -63,6 +63,9 @@ module Massoc_gid : S with type key = Gid.t
(* ================================================================================ *)
module Massoc_pid : S with type key = Pid.t
(* ================================================================================ *)
module Massoc_string : S with type key = string
(* ================================================================================ *)
(** module for rules that are lexically parametrized *)
module Lex_par: sig
......@@ -101,6 +104,47 @@ module Lex_par: sig
val get_command_value: int -> t -> string
end (* module Lex_par *)
(* ================================================================================ *)
module Lexicon : sig
type t
(** [build items] build a lexicon from a list.
The first list is interpreted as the column headers.
All other lines are lexicon items.
It is supposed that all sublist have the same length *)
val build: string list list -> t
(** [load file] build a lexicon from a file.
The file should contain same data than the ones in the build function
in separate lines, each line used tabulation as separator *)
val load: string -> t
(** [reduce headers lexicon] build a smaller lexicon restricted to a subset of columns (defined in [headers]) *)
val reduce: string list -> t -> t
(** [union lex1 lex2] returns the union of two lexicons
It supposed that the two lexicons define the same columns *)
val union: t -> t -> t
(** [select head value] returns the sublexicon with only items where the [head] column is equals to [value] *)
val select: string -> string -> t -> t
exception Not_functional_lexicon
(** [read head lexicon] returns
* None if [lexicon] is empty;
* Some value if all items have a [head] column equals to [value]
* raise [Not_functional_lexicon] if several values are defined
*)
val read: string -> t -> string option
(** [read_multi head lexicon] returns
* None if [lexicon] is empty;
* Some "v_1/…/v_k" where v_i are the values of the [head] column
*)
val read_multi: string -> t -> string option
end (* module Lexicon *)
(* ================================================================================ *)
module Concat_item : sig
type t =
......
......@@ -86,10 +86,10 @@ module Pattern = struct
type t = Grew_rule.Rule.pattern
let load ?domain file =
Libgrew.handle ~name:"Pattern.load" (fun () -> Grew_rule.Rule.build_pattern ?domain (Grew_loader.Loader.pattern file)) ()
Libgrew.handle ~name:"Pattern.load" (fun () -> Grew_rule.Rule.build_pattern ?domain [] (Grew_loader.Loader.pattern file)) ()
let parse ?domain desc =
Libgrew.handle ~name:"Pattern.load" (fun () -> Grew_rule.Rule.build_pattern ?domain (Grew_loader.Parser.pattern desc)) ()
Libgrew.handle ~name:"Pattern.load" (fun () -> Grew_rule.Rule.build_pattern ?domain [] (Grew_loader.Parser.pattern desc)) ()
let pid_name_list pattern =
Libgrew.handle ~name:"Pattern.pid_lits"
......
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