Commit c4836189 authored by Bruno Guillaume's avatar Bruno Guillaume

Error localisation

parent bb55e6d5
......@@ -606,13 +606,16 @@ end (* module Timeout *)
module Global = struct
let current_loc = ref Loc.empty
let label_flag = ref false
let current_dir = ref "."
let get_loc () = !current_loc
let loc_string () = Loc.to_string !current_loc
let get_line () = snd (get_loc ())
let get_dir () = !current_dir
let new_file filename =
current_dir := Filename.dirname filename;
current_loc := (Some filename, Some 1);
label_flag := false
......
......@@ -292,6 +292,7 @@ module Global: sig
val get_loc: unit -> Loc.t
val get_line: unit -> int option
val get_dir: unit -> string
val loc_string: unit -> string
val label_flag: bool ref
......
......@@ -172,7 +172,7 @@ module Command = struct
| H_SHIFT_OUT of (Gid.t * Gid.t)
let build ?domain ?param lexicon_names (kni, kei) table ast_command =
let build ?domain ?param lexicons (kni, kei) table ast_command =
(* kni stands for "known node idents", kei for "known edge idents" *)
let cn_of_node_id node_id =
......@@ -262,8 +262,12 @@ module Command = struct
(function
(* 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)
if List.mem_assoc node_id_or_lex lexicons
then
begin
Lexicons.check ~loc node_id_or_lex feature_name_or_lex_field lexicons;
Lexical_field (node_id_or_lex, feature_name_or_lex_field)
end
else
begin
check_node_id_msg loc ("Unbound identifier %s (neither a node nor a lexicon)") node_id_or_lex kni;
......
......@@ -66,7 +66,7 @@ module Command : sig
val build:
?domain: Domain.t ->
?param: string list ->
string list -> (* lexicon names *)
Lexicons.t ->
(Id.name list * string list) ->
Id.table ->
Ast.command ->
......
......@@ -162,7 +162,7 @@ module P_feature = struct
| _ -> Error.bug "[P_feature.to_string] multiple parameters are not handled"
let build ?domain ?pat_vars = function
let build ?domain ?pat_vars lexicons = function
| ({Ast.kind=Ast.Absent; name=name}, loc) ->
Domain.check_feature_name ~loc ?domain name;
(name, {cst=Absent;in_param=[];})
......@@ -170,8 +170,12 @@ module P_feature = struct
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_value.build_disj ~loc ?domain name unsorted_values in (name, {cst=Different values;in_param=[];})
| ({Ast.kind=Ast.Equal_lex (lex,fn); name=name}, loc) -> (name, {cst=Equal_lex (lex,fn); in_param=[];})
| ({Ast.kind=Ast.Disequal_lex (lex,fn); name=name}, loc) -> (name, {cst=Different_lex (lex,fn); in_param=[];})
| ({Ast.kind=Ast.Equal_lex (lex,fn); name=name}, loc) ->
Lexicons.check ~loc lex fn lexicons;
(name, {cst=Equal_lex (lex,fn); in_param=[];})
| ({Ast.kind=Ast.Disequal_lex (lex,fn); name=name}, loc) ->
Lexicons.check ~loc lex fn lexicons;
(name, {cst=Different_lex (lex,fn); in_param=[];})
| ({Ast.kind=Ast.Equal_param var; name=name}, loc) ->
begin
match pat_vars with
......@@ -414,8 +418,8 @@ module P_fs = struct
| _ -> Error.bug "Position can't be parametrized"
with Not_found -> true
let build ?domain ?pat_vars ast_fs =
let unsorted = List.map (P_feature.build ?domain ?pat_vars) ast_fs in
let build ?domain ?pat_vars lexicons ast_fs =
let unsorted = List.map (P_feature.build lexicons ?domain ?pat_vars) ast_fs in
List.sort P_feature.compare unsorted
let feat_list t = List.map P_feature.get_name t
......@@ -465,7 +469,7 @@ module P_fs = struct
let new_acc = (lex_name, new_lexicon) :: (List.remove_assoc lex_name acc) in
loop new_acc (t_pat, t)
with
| Not_found -> failwith "TODO"
| Not_found -> failwith "TODO<123>"
end
| (_::p_tail, _::g_tail) -> loop acc (p_tail,g_tail) in
loop lexicons (p_fs_wo_pos,g_fs)
......
......@@ -76,7 +76,7 @@ module P_fs: sig
val empty: t
val build: ?domain:Domain.t -> ?pat_vars: string list -> Ast.feature list -> t
val build: ?domain:Domain.t -> ?pat_vars: string list -> Lexicons.t -> Ast.feature list -> t
val to_string: t -> string
......
......@@ -62,21 +62,15 @@ module P_graph = struct
| Some new_node -> Some (Pid_map.add id_src new_node map)
(* -------------------------------------------------------------------------------- *)
let build_filter ?domain table (ast_node, loc) =
let pid = Id.build ~loc ast_node.Ast.node_id table in
let fs = P_fs.build ?domain ast_node.Ast.fs in
(pid, fs)
(* -------------------------------------------------------------------------------- *)
let build ?domain ?pat_vars (full_node_list : Ast.node list) full_edge_list =
let build ?domain ?pat_vars 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 (ast_node, loc)]
| [] -> [P_node.build ?domain ?pat_vars 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 ast_node.Ast.fs) fs) :: tail
try (node_id, P_node.unif_fs (P_fs.build ?domain ?pat_vars 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
......@@ -123,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 pos_table full_node_list full_edge_list =
let build_extension ?domain ?pat_vars lexicons pos_table full_node_list full_edge_list =
let built_nodes = List.map (P_node.build ?domain ?pat_vars) full_node_list in
let built_nodes = List.map (P_node.build ?domain ?pat_vars lexicons) full_node_list in
let (old_nodes, new_nodes) =
List.partition
......
......@@ -63,6 +63,7 @@ module P_graph: sig
val build:
?domain:Domain.t ->
?pat_vars: string list ->
Lexicons.t ->
Ast.node list ->
Ast.edge list ->
(t * Id.table)
......@@ -71,6 +72,7 @@ module P_graph: sig
val build_extension:
?domain:Domain.t ->
?pat_vars: string list ->
Lexicons.t ->
Id.table ->
Ast.node list ->
Ast.edge list ->
......
......@@ -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 (ast_node, loc) =
let build ?domain ?pat_vars lexicons (ast_node, loc) =
(ast_node.Ast.node_id,
{
name = ast_node.Ast.node_id;
fs = P_fs.build ?domain ?pat_vars ast_node.Ast.fs;
fs = P_fs.build ?domain ?pat_vars lexicons ast_node.Ast.fs;
next = Massoc_pid.empty;
loc = Some loc;
} )
......
......@@ -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 -> Ast.node -> (Id.name * t)
val build: ?domain:Domain.t -> ?pat_vars: string list -> Lexicons.t -> Ast.node -> (Id.name * t)
val add_edge: P_edge.t -> Pid.t -> t -> t option
......
......@@ -441,8 +441,8 @@ 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
......@@ -450,7 +450,7 @@ pat_item:
| 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)
Pat_const (Ast.Feature_eq_lex_or_fs (feat_id1, (s1, Ast.to_uname s2)), loc)
}
/* X.cat = "value" */
......@@ -470,7 +470,7 @@ pat_item:
| 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)
Pat_const (Ast.Feature_diff_lex_or_fs (feat_id1, (s1, Ast.to_uname s2)), loc)
}
/* X.cat <> "value" */
......@@ -712,7 +712,7 @@ concat_item:
{
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)
| Ast.Pointed (s1, s2) -> Ast.Qfn_or_lex_item (s1, Ast.to_uname s2)
}
| s=STRING { Ast.String_item s }
| f=FLOAT { Ast.String_item (Printf.sprintf "%g" f) }
......
......@@ -221,7 +221,7 @@ module Rule = struct
]
]
let build_pos_constraint ?domain ?lexicons pos_table const =
let build_pos_constraint ?domain lexicons 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) ->
......@@ -279,8 +279,22 @@ 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"
| (Ast.Feature_eq_lex_or_fs ((node_name, feat_name),(node_or_lex, fn_or_field)), loc) ->
begin
match Id.build_opt node_or_lex pos_table with
| None ->
Lexicons.check ~loc node_or_lex fn_or_field lexicons;
Feature_eq_lex (pid_of_name loc node_name, feat_name, (node_or_lex, fn_or_field))
| _ -> Features_eq (pid_of_name loc node_name, feat_name, pid_of_name loc node_or_lex, fn_or_field)
end
| (Ast.Feature_diff_lex_or_fs ((node_name, feat_name),(node_or_lex, fn_or_field)), loc) ->
begin
match Id.build_opt node_or_lex pos_table with
| None ->
Lexicons.check ~loc node_or_lex fn_or_field lexicons;
Feature_diff_lex (pid_of_name loc node_name, feat_name, (node_or_lex, fn_or_field))
| _ -> Features_diseq (pid_of_name loc node_name, feat_name, pid_of_name loc node_or_lex, fn_or_field)
end
type basic = {
......@@ -294,19 +308,19 @@ 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 ?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
P_graph.build ?domain ?pat_vars lexicons basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
(
{
graph = graph;
constraints = List.map (build_pos_constraint ?domain ?lexicons pos_table) basic_ast.Ast.pat_const
constraints = List.map (build_pos_constraint ?domain lexicons pos_table) basic_ast.Ast.pat_const
},
pos_table
)
(* the neg part *)
let build_neg_constraint ?domain pos_table neg_table const =
let build_neg_constraint ?domain lexicons pos_table neg_table const =
let pid_of_name loc node_name =
match Id.build_opt node_name pos_table with
| Some i -> Pid.Pos i
......@@ -375,19 +389,32 @@ 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"
| (Ast.Feature_eq_lex_or_fs ((node_name, feat_name),(node_or_lex, fn_or_field)), loc) ->
begin
match (Id.build_opt node_or_lex pos_table, Id.build_opt node_or_lex neg_table) with
| (None, None) ->
Lexicons.check ~loc node_or_lex fn_or_field lexicons;
Feature_eq_lex (pid_of_name loc node_name, feat_name, (node_or_lex, fn_or_field))
| _ -> Features_eq (pid_of_name loc node_name, feat_name, pid_of_name loc node_or_lex, fn_or_field)
end
| (Ast.Feature_diff_lex_or_fs ((node_name, feat_name),(node_or_lex, fn_or_field)), loc) ->
begin
match (Id.build_opt node_or_lex pos_table, Id.build_opt node_or_lex neg_table) with
| (None, None) -> Feature_diff_lex (pid_of_name loc node_name, feat_name, (node_or_lex, fn_or_field))
| _ -> Features_diseq (pid_of_name loc node_name, feat_name, pid_of_name loc node_or_lex, fn_or_field)
end
(* 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 build_neg_basic ?domain ?pat_vars lexicons pos_table basic_ast =
let (extension, neg_table) =
P_graph.build_extension ?domain ?pat_vars pos_table basic_ast.Ast.pat_nodes basic_ast.Ast.pat_edges in
P_graph.build_extension ?domain ?pat_vars 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
{
graph = extension.P_graph.ext_map;
constraints = filters @ List.map (build_neg_constraint ?domain pos_table neg_table) basic_ast.Ast.pat_const ;
constraints = filters @ List.map (build_neg_constraint ?domain lexicons pos_table neg_table) basic_ast.Ast.pat_const ;
}
let get_edge_ids basic =
......@@ -492,7 +519,7 @@ module Rule = struct
Buffer.contents buff
(* ====================================================================== *)
let build_commands ?domain ?param lexicon_names pos pos_table ast_commands =
let build_commands ?domain ?param 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
......@@ -503,7 +530,7 @@ module Rule = struct
Command.build
?domain
?param
lexicon_names
lexicons
(kni,kei)
pos_table
ast_command in
......@@ -511,7 +538,10 @@ module Rule = struct
loop (known_node_ids, known_edge_ids) ast_commands
let build_lex loc = function
| Ast.File filename -> Lexicon.load filename
| Ast.File filename ->
if Filename.is_relative filename
then Lexicon.load (Filename.concat (Global.get_dir ()) filename)
else Lexicon.load filename
| Ast.Final (line_list) -> Lexicon.build loc line_list
......@@ -522,15 +552,13 @@ module Rule = struct
| Some d -> d
| None -> deprecated_dir in
let lexicons = List.fold_left (fun acc (name,lex) ->
let lexicons =
List.fold_left (fun acc (name,lex) ->
try
let prev = List.assoc name acc in
(name, (Lexicon.union prev (build_lex rule_ast.Ast.rule_loc lex))) :: (List.remove_assoc name acc)
with
Not_found -> (name, build_lex rule_ast.Ast.rule_loc lex) :: acc
) [] rule_ast.Ast.lexicon_info in
let lexicon_names = List.map fst lexicons in
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
......@@ -560,7 +588,7 @@ module Rule = struct
let pattern = Ast.normalize_pattern rule_ast.Ast.pattern in
let (pos, pos_table) =
try build_pos_basic ?domain ~lexicons:lexicons ~pat_vars pattern.Ast.pat_pos
try build_pos_basic ?domain lexicons ~pat_vars 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"
......@@ -568,7 +596,7 @@ module Rule = struct
let (negs,_) =
List.fold_left
(fun (acc,pos) basic_ast ->
try ((build_neg_basic ?domain ~pat_vars pos_table basic_ast) :: acc, pos+1)
try ((build_neg_basic ?domain ~pat_vars 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;
......@@ -577,21 +605,21 @@ module Rule = struct
{
name = rule_ast.Ast.rule_id;
pattern = (pos, negs);
commands = build_commands ?domain ~param:pat_vars lexicon_names pos pos_table rule_ast.Ast.commands;
commands = build_commands ?domain ~param:pat_vars 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 =
let build_pattern ?domain ?(lexicons=[]) pattern_ast =
let n_pattern = Ast.normalize_pattern pattern_ast in
let (pos, pos_table) =
try build_pos_basic ?domain ?lexicons n_pattern.Ast.pat_pos
try build_pos_basic ?domain lexicons n_pattern.Ast.pat_pos
with P_fs.Fail_unif -> Error.build "feature structures declared in the \"match\" clause are inconsistent " in
let negs =
List_.try_map
P_fs.Fail_unif (* Skip the without parts that are incompatible with the match part *)
(fun basic_ast -> build_neg_basic ?domain pos_table basic_ast)
(fun basic_ast -> build_neg_basic ?domain lexicons pos_table basic_ast)
n_pattern.Ast.pat_negs in
(pos, negs)
......
......@@ -163,6 +163,7 @@ module Lexicon = struct
type t = {
header: string list; (* ordered list of column headers *)
lines: Line_set.t;
loc: Loc.t;
}
let rec transpose = function
......@@ -199,7 +200,7 @@ module Lexicon = struct
let sorted_tr = List.sort (fun l1 l2 -> strict_compare (List.hd l1) (List.hd l2)) tr in
match transpose sorted_tr with
| [] -> Error.bug ~loc "[Lexicon.build] inconsistent data"
| header :: lines_list -> { header; lines = List.fold_right Line_set.add lines_list Line_set.empty }
| header :: lines_list -> { header; lines = List.fold_right Line_set.add lines_list Line_set.empty; loc }
with Equal v ->
let loc = Loc.set_line linenum_h loc in
Error.build ~loc "[Lexicon.build] the field name \"%s\" is used twice" v
......@@ -221,15 +222,16 @@ module Lexicon = struct
| _ -> 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 }
{ lexicon with 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 }
if lex1.header <> lex2.header then Error.build "[Lexicon.union] different header";
{ lex1 with lines = Line_set.union lex1.lines lex2.lines }
(* NOTE: the loc field of a union may be not accurate *)
let select head value lex =
match List_.index head lex.header with
| None -> Error.build "[Lexicon.select] cannot find %s in lexicon" head
| None -> Error.build ~loc:lex.loc "[Lexicon.select] cannot find %s in lexicon" head
| Some index ->
let new_set = Line_set.filter (fun line -> List.nth line index = value) lex.lines in
if Line_set.is_empty new_set
......@@ -238,7 +240,7 @@ module Lexicon = struct
let unselect head value lex =
match List_.index head lex.header with
| None -> Error.build "[Lexicon.unselect] cannot find %s in lexicon" head
| None -> Error.build ~loc:lex.loc "[Lexicon.unselect] cannot find the fiels \"%s\" in lexicon" head
| Some index ->
let new_set = Line_set.filter (fun line -> List.nth line index <> value) lex.lines in
if Line_set.is_empty new_set
......@@ -247,7 +249,7 @@ module Lexicon = struct
let projection head lex =
match List_.index head lex.header with
| None -> Error.build "[Lexicon.projection] cannot find %s in lexicon" head
| None -> Error.build ~loc:lex.loc "[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
......@@ -268,6 +270,14 @@ end (* module Lexicon *)
(* ================================================================================ *)
module Lexicons = struct
type t = (string * Lexicon.t) list
let check ~loc lexicon_name field_name t =
try
let lexicon = List.assoc lexicon_name t in
if not (List.mem field_name lexicon.Lexicon.header)
then Error.build ~loc "Undefined field name \"%s\" in lexicon %s" field_name lexicon_name
with Not_found -> Error.build ~loc "Undefined lexicon name \"%s\"" lexicon_name
end
(* ================================================================================ *)
......
......@@ -148,6 +148,9 @@ end (* module Lexicon *)
(* ================================================================================ *)
module Lexicons : sig
type t = (string * Lexicon.t) list
val check: loc:Loc.t -> string -> string -> t -> unit
end
(* ================================================================================ *)
......
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