Commit 11c31ce4 authored by bguillaum's avatar bguillaum

parametrized rules

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@6757 7838e531-6607-4d57-9587-6c381814729c
parent d7f0eec1
......@@ -10,14 +10,16 @@ module Ast = struct
type domain = feature_spec list
type feature_kind = Equality | Disequality
type feature_kind =
| Equality of string list
| Disequality of string list
| Param of string
type u_feature = {
kind: feature_kind;
name: string;
values: string list;
}
kind: feature_kind;
}
type feature = u_feature * Loc.t
(* qualified feature name "A.lemma" *)
......@@ -76,8 +78,8 @@ module Ast = struct
| Del_node of Id.name
| Del_feat of qfn
| Update_feat of qfn * concat_item list
| Param_feat of qfn * string
type command = u_command * Loc.t
......@@ -86,6 +88,7 @@ module Ast = struct
pos_pattern: pattern;
neg_patterns: pattern list;
commands: command list;
param: (string*string list) option;
rule_doc:string;
rule_loc: Loc.t;
}
......@@ -159,7 +162,9 @@ module AST_HTML = struct
| Ast.New_neighbour (n1,n2,label) -> bprintf buff "add_node %s: <-[%s]- %s \n" n1 label n2
| Ast.Del_node n -> bprintf buff "del_node %s" n
| Ast.Update_feat (qfn,item_list) -> bprintf buff "%s = %s" (string_of_qfn qfn) (List_.to_string string_of_concat_item " + " item_list)
| Ast.Del_feat qfn -> bprintf buff "del_feat %s" (string_of_qfn qfn));
| Ast.Del_feat qfn -> bprintf buff "del_feat %s" (string_of_qfn qfn)
| Ast.Param_feat (qfn, var) -> bprintf buff "param_feat %s @ %s" (string_of_qfn qfn) var)
;
if li_html then bprintf buff "</li>\n" else bprintf buff ";\n"
let to_html_commands_pretty = function
......@@ -172,11 +177,12 @@ module AST_HTML = struct
Buffer.contents buff
let buff_html_feature buff (u_feature,_) =
bprintf buff "%s %s %s"
u_feature.Ast.name
(match u_feature.Ast.kind with Ast.Equality -> "=" | Ast.Disequality -> "<>")
(List_.to_string (fun x->x) ", " u_feature.Ast.values)
bprintf buff "%s" u_feature.Ast.name;
match u_feature.Ast.kind with
| Ast.Equality values -> bprintf buff " = %s" (List_.to_string (fun x->x) ", " values)
| Ast.Disequality values -> bprintf buff " <> %s" (List_.to_string (fun x->x) ", " values)
| Ast.Param index -> bprintf buff "@%s" index
let buff_html_node buff (u_node,_) =
bprintf buff " %s [" u_node.Ast.node_id;
List.iter (buff_html_feature buff) u_node.Ast.fs;
......
......@@ -7,12 +7,14 @@ module Ast : sig
type domain = feature_spec list
type feature_kind = Equality | Disequality
type feature_kind =
| Equality of string list
| Disequality of string list
| Param of string
type u_feature = {
kind: feature_kind;
name: string;
values: string list;
kind: feature_kind;
}
type feature = u_feature * Loc.t
......@@ -70,8 +72,8 @@ module Ast : sig
| Del_node of Id.name
| Del_feat of qfn
| Update_feat of qfn * concat_item list
| Param_feat of qfn * string
type command = u_command * Loc.t
type rule = {
......@@ -79,6 +81,7 @@ module Ast : sig
pos_pattern: pattern;
neg_patterns: pattern list;
commands: command list;
param: (string*string list) option;
rule_doc:string;
rule_loc: Loc.t;
}
......
......@@ -26,6 +26,7 @@ module Command = struct
| ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
| PARAM_FEAT of (cnode * string * int)
| NEW_NEIGHBOUR of (string * G_edge.t * pid)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
......@@ -48,7 +49,7 @@ module Command = struct
| H_SHIFT_OUT of (gid * gid)
| H_MERGE_NODE of (gid * gid)
let build ?domain (kni, kei) table locals ast_command =
let build ?cmd_vars ?domain (kni, kei) table locals ast_command =
let get_pid node_name =
match Id.build_opt node_name table with
| Some id -> Pid id
......@@ -124,5 +125,15 @@ module Command = struct
ast_items in
((UPDATE_FEAT (get_pid tar_node, tar_feat_name, items), loc), (kni, kei))
| (Ast.Param_feat ((node,feat_name), var), loc) ->
match cmd_vars with
| None -> Error.build "Unknown command variable '%s'" var
| Some l ->
match List_.pos var l with
| Some index -> ((PARAM_FEAT (get_pid node, feat_name, index), loc), (kni, kei))
| None -> Error.build "Unknown command variable '%s'" var
end
......@@ -21,6 +21,7 @@ module Command : sig
| ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
| PARAM_FEAT of (cnode * string * int)
| NEW_NEIGHBOUR of (string * G_edge.t * pid)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
......@@ -43,6 +44,7 @@ module Command : sig
| H_MERGE_NODE of (gid * gid)
val build:
?cmd_vars: string list ->
?domain:Ast.domain ->
(string list * string list) ->
Id.table ->
......
......@@ -9,8 +9,9 @@ module Feature = struct
type t =
| Equal of string * string list
| Different of string * string list
| Param of string * int
let get_name = function | Equal (n,_) -> n | Different (n,_) -> n
let get_name = function | Equal (n,_) -> n | Different (n,_) | Param (n,_) -> n
let get_atom = function | Equal (n,[one]) -> Some one | _ -> None
......@@ -30,25 +31,30 @@ module Feature = struct
)
| Some (_::t) -> check ~domain:t loc name values
let build ?domain = function
| ({Ast.kind=Ast.Equality;name=name;values=unsorted_values},loc) ->
let build ?pat_vars ?domain = function
| ({Ast.kind=Ast.Equality unsorted_values ;name=name},loc) ->
let values = List.sort Pervasives.compare unsorted_values in
check ?domain loc name values;
Equal (name, values)
| ({Ast.kind=Ast.Disequality;name=name;values=unsorted_values},loc) ->
| ({Ast.kind=Ast.Disequality unsorted_values;name=name},loc) ->
let values = List.sort Pervasives.compare unsorted_values in
check ?domain loc name values;
Different (name, values)
| ({Ast.kind=Ast.Param var; name=name},loc) ->
match pat_vars with
| None -> Error.build "Unknown pattern variable '%s'" var
| Some l ->
match List_.pos var l with
| Some index -> Param (name, index)
| None -> Error.build "Unknown pattern variable '%s'" var
end
module Feature_structure = struct
(* list are supposed to be striclty ordered wrt compare*)
type t = Feature.t list
let build ?domain ast_fs =
let unsorted = List.map (Feature.build ?domain) ast_fs in
let build ?pat_vars ?domain ast_fs =
let unsorted = List.map (Feature.build ?pat_vars ?domain) ast_fs in
List.sort Feature.compare unsorted
let of_conll line =
......@@ -70,6 +76,7 @@ module Feature_structure = struct
| Feature.Equal (n,l) :: t when n<name -> get name t
| Feature.Equal _ :: _ -> None
| Feature.Different _ :: _ -> Log.critical "[Feature_structure.get] this fs contains 'Different' constructor"
| Feature.Param _ :: _ -> Log.critical "[Feature_structure.get] this fs contains 'Param' constructor"
let get_atom name t =
match get name t with
......@@ -89,7 +96,8 @@ module Feature_structure = struct
| [] -> "EMPTY"
| h::t -> List.fold_right (fun atom acc -> atom^"|"^acc) t h
)
| Feature.Param (feat_name, index) ->
sprintf "@%d" index
let to_string t = List_.to_string string_of_feature "\\n" t
......@@ -152,7 +160,6 @@ module Feature_structure = struct
| Feature.Equal (fn,ats)::t -> Feature.Equal (fn,ats):: (del_feat feature_name t)
| _ -> Log.bug "[Feature_structure.set_feat]: Disequality not allowed in graph features"; exit 2
(* WARNING: different from prev implem: does not fail when pattern contains a feature_name or in instance *)
let compatible pattern fs =
let rec loop = function
| [], _ -> true
......@@ -180,13 +187,62 @@ module Feature_structure = struct
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn*) ->
(match fv_pat, fv with
| [],_ | _, [] -> loop (t_pat,t)
| [],_ | _, [] -> loop (t_pat,t) (* FIXME should be "false" *)
| l_pat,l -> (List_.sort_disjoint l_pat l) && loop (t_pat,t)
)
| _ -> Log.bug "[Feature_structure.set_feat]: Disequality not allowed in graph features"; exit 2
in loop (pattern,fs)
let compatible_param param pattern fs =
let rec loop acc_param = function
| [], _ -> acc_param
(* Three next cases: each feature_name present in pattern must be in instance: [] means unif failure *)
| _, [] -> []
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t) when fn_pat < fn -> []
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t) when fn_pat < fn -> []
(* Two next cases: a feature in graph, not in pattern *)
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
when fn_pat > fn ->
loop acc_param ((Feature.Equal (fn_pat, fv_pat))::t_pat, t)
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
when fn_pat > fn ->
loop acc_param ((Feature.Different (fn_pat, fv_pat))::t_pat, t)
| ((Feature.Param (fn_pat, i))::t_pat, (Feature.Equal (fn, fv))::t)
when fn_pat > fn ->
loop acc_param ((Feature.Param (fn_pat, i))::t_pat, t)
| ((Feature.Equal (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn *) ->
(match fv_pat, fv with
| [],_ -> (* pattern_value is ? *) loop acc_param (t_pat,t)
| l_pat,l when not (List_.sort_disjoint l_pat l) -> loop acc_param (t_pat,t)
| _ -> (* l_pat and l disjoint -> no sol *) []
)
| ((Feature.Different (fn_pat, fv_pat))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn*) ->
(match fv_pat, fv with
| [],_ -> []
| l_pat,l when List_.sort_disjoint l_pat l -> loop acc_param (t_pat,t)
| _ -> (* l_pat and l disjoint -> no disjoint *) []
)
| ((Feature.Param (fn_pat, i))::t_pat, (Feature.Equal (fn, fv))::t)
(* when fn_pat = fn*) ->
(match fv with
| [atom] ->
let reduce_param = List.filter (fun (x,_) -> List.nth x i = atom) acc_param in
loop reduce_param (t_pat,t)
| _ -> Log.critical "[compatible_param] Graph feature value not atomic"
)
| _ -> Log.bug "[Feature_structure.set_feat]: Disequality not allowed in graph features"; exit 2
in loop param (pattern,fs)
exception Fail_unif
exception Bug_unif of string
let unif fs1 fs2 =
......
......@@ -8,7 +8,7 @@ end
module Feature_structure: sig
type t
val build: ?domain:Ast.domain -> Ast.feature list -> t
val build: ?pat_vars: string list -> ?domain:Ast.domain -> Ast.feature list -> t
val of_conll: Conll.line -> t
......@@ -32,6 +32,7 @@ module Feature_structure: sig
val compatible: t -> t -> bool
val compatible_param: (string list * string list) list -> t -> t -> (string list * string list) list
(** [unif t1 t2] returns [Some t] if [t] is the unification of two graph feature structures
[None] is returned if the two feature structures cannot be unified
......
......@@ -41,7 +41,7 @@ module P_graph = struct
let fs = Feature_structure.build ?domain ast_node.Ast.fs in
(pid, fs)
let build ?domain ?(locals=[||]) full_node_list full_edge_list =
let build ?pat_vars ?domain ?(locals=[||]) full_node_list full_edge_list =
let (named_nodes, constraints) =
let rec loop already_bound = function
......@@ -50,7 +50,7 @@ module P_graph = struct
let (tail_nodes, tail_const) = loop (ast_node.Ast.node_id :: already_bound) tail in
if List.mem ast_node.Ast.node_id already_bound
then (tail_nodes, (ast_node, loc)::tail_const)
else (P_node.build ?domain (ast_node, loc) :: tail_nodes, tail_const) in
else (P_node.build ?pat_vars ?domain (ast_node, loc) :: tail_nodes, tail_const) in
loop [] full_node_list in
(* let named_nodes = List.map (Node.build ?domain) full_node_list in *)
......@@ -242,6 +242,7 @@ module G_graph = struct
let of_conll lines =
let nodes =
List.fold_left
(fun acc line -> Gid_map.add line.Conll.num (G_node.of_conll line) acc)
......@@ -253,7 +254,9 @@ module G_graph = struct
if line.Conll.gov=0
then acc
else
let gov_node = Gid_map.find line.Conll.gov acc in
let gov_node =
try Gid_map.find line.Conll.gov acc
with Not_found -> Log.fcritical "Ill-formed CONLL file: line number %d refers to the on existing gov %d" line.Conll.num line.Conll.gov in
match G_node.add_edge (G_edge.make line.Conll.dep_lab) line.Conll.num gov_node with
| None -> acc
| Some new_node -> Gid_map.add line.Conll.gov new_node acc
......@@ -412,8 +415,12 @@ module G_graph = struct
| None -> None
(* FIXME: check consistency wrt the domain *)
let set_feat graph node_id feat_name new_value =
let node = Gid_map.find node_id graph.map in
let new_fs = Feature_structure.set_feat feat_name [new_value] (G_node.get_fs node) in
{graph with map = Gid_map.add node_id (G_node.set_fs node new_fs) graph.map}
let update_feat graph tar_id tar_feat_name item_list =
let tar = Gid_map.find tar_id graph.map in
let strings_to_concat =
List.map
(function
......@@ -429,8 +436,13 @@ module G_graph = struct
| String s -> s
) item_list in
let new_feature_value = List_.to_string (fun s->s) "" strings_to_concat in
let new_fs = Feature_structure.set_feat tar_feat_name [new_feature_value] (G_node.get_fs tar) in
({graph with map = Gid_map.add tar_id (G_node.set_fs tar new_fs) graph.map}, new_feature_value)
(set_feat graph tar_id tar_feat_name new_feature_value, new_feature_value)
(* let tar = Gid_map.find tar_id graph.map in *)
(* let new_fs = Feature_structure.set_feat tar_feat_name [new_feature_value] (G_node.get_fs tar) in *)
(* ({graph with map = Gid_map.add tar_id (G_node.set_fs tar new_fs) graph.map}, new_feature_value) *)
(** [del_feat graph node_id feat_name] returns [graph] where the feat [feat_name] of [node_id] is deleted
If the feature is not present, [graph] is returned. *)
......
......@@ -25,6 +25,7 @@ module P_graph: sig
}
val build:
?pat_vars: string list ->
?domain: Ast.domain ->
?locals: Label.decl array ->
Ast.node list ->
......@@ -93,6 +94,8 @@ module G_graph: sig
It returns both the new graph and the new feature value produced as the second element *)
val update_feat : t -> int -> string -> concat_item list -> (t * string)
val set_feat: t -> int -> string -> string -> t
val del_feat : t -> int -> string -> t
(** [edge_out t id edge] returns true iff there is an out-edge from the node [id] with a label compatible with [edge] *)
......
......@@ -83,9 +83,9 @@ module P_node = struct
let empty = { fs = Feature_structure.empty; next = Massoc.empty }
let build ?domain (ast_node, loc) =
let build ?pat_vars ?domain (ast_node, loc) =
(ast_node.Ast.node_id,
{ fs = Feature_structure.build ?domain ast_node.Ast.fs;
{ fs = Feature_structure.build ?pat_vars ?domain ast_node.Ast.fs;
next = Massoc.empty;
} )
......@@ -97,6 +97,7 @@ module P_node = struct
(* Says that "pattern" t1 is a t2*)
let is_a p_node g_node = Feature_structure.compatible p_node.fs (G_node.get_fs g_node)
let is_a_param param p_node g_node = Feature_structure.compatible_param param p_node.fs (G_node.get_fs g_node)
end
(* ================================================================================ *)
......
......@@ -46,11 +46,12 @@ module P_node: sig
val get_fs: t -> Feature_structure.t
val get_next: t -> P_edge.t Massoc.t
val build: ?domain:Ast.domain -> Ast.node -> (Id.name * t)
val build: ?pat_vars: string list -> ?domain:Ast.domain -> Ast.node -> (Id.name * t)
val add_edge: P_edge.t -> int -> t -> t option
val is_a: t -> G_node.t -> bool
val is_a_param: (string list * string list) list -> t -> G_node.t -> (string list * string list) list
end
(* ================================================================================ *)
This diff is collapsed.
......@@ -87,7 +87,10 @@ module File = struct
let rev_lines = ref [] in
try
while true do
rev_lines := (input_line in_ch) :: !rev_lines
let line = input_line in_ch in
if (Str.string_match (Str.regexp "^$[ \t]*") line 0) || (line.[0] = '%')
then ()
else rev_lines := line :: !rev_lines
done; assert false
with End_of_file ->
close_in in_ch;
......@@ -135,6 +138,13 @@ module List_ = struct
| x::t when x=elt -> t
| x::t -> x::(rm elt t)
let pos x l =
let rec loop i = function
| [] -> None
| h::t when h=x -> Some i
| _::t -> loop (i+1) t in
loop 0 l
let rec opt = function
| [] -> []
| None :: t -> opt t
......
......@@ -40,6 +40,9 @@ module List_: sig
(** [rm elt list] removes the first occurence of [elt] in [list]. [Not_found] can be raised. *)
val rm: 'a -> 'a list -> 'a list
val opt: 'a option list -> 'a list
(** [pos elt list] return [Some index] if [index] is the smallest position in the [list] equals to [elt]. None is returned if [elt] is not in the [list] *)
val pos: 'a -> 'a list -> int option
val opt_map: ('a -> 'b option) -> 'a list -> 'b list
......
......@@ -42,7 +42,7 @@ let load_grs ?doc_output_dir file =
| Grew_parser.Parse_error msg -> raise (Parsing_err msg)
| Error.Build (msg,loc) -> raise (Build (msg,loc))
| Error.Bug (msg, loc) -> raise (Bug (msg,loc))
| exc -> raise (Bug (sprintf "UNCATCHED EXCEPTION: %s" (Printexc.to_string exc), None))
| exc -> raise (Bug (sprintf "[Libgrew.load_grs] UNCATCHED EXCEPTION: %s" (Printexc.to_string exc), None))
let get_sequence_names grs = Grs.sequence_names grs
......@@ -58,7 +58,7 @@ let load_gr file =
| Grew_parser.Parse_error msg -> raise (Parsing_err msg)
| Error.Build (msg,loc) -> raise (Build (msg,loc))
| Error.Bug (msg, loc) -> raise (Bug (msg,loc))
| exc -> raise (Bug (sprintf "UNCATCHED EXCEPTION: %s" (Printexc.to_string exc), None))
| exc -> raise (Bug (sprintf "[Libgrew.load_gr] UNCATCHED EXCEPTION: %s" (Printexc.to_string exc), None))
) else (
raise (File_dont_exists file)
......@@ -72,7 +72,7 @@ let load_conll file =
| Grew_parser.Parse_error msg -> raise (Parsing_err msg)
| Error.Build (msg,loc) -> raise (Build (msg,loc))
| Error.Bug (msg, loc) -> raise (Bug (msg,loc))
| exc -> raise (Bug (sprintf "UNCATCHED EXCEPTION: %s" (Printexc.to_string exc), None))
| exc -> raise (Bug (sprintf "[Libgrew.load_conll] UNCATCHED EXCEPTION: %s" (Printexc.to_string exc), None))
let load_graph file =
if Filename.check_suffix file ".gr"
......@@ -95,14 +95,14 @@ let rewrite ~gr ~grs ~seq =
with
| Error.Run (msg,loc) -> raise (Run (msg,loc))
| Error.Bug (msg, loc) -> raise (Bug (msg,loc))
| exc -> raise (Bug (sprintf "UNCATCHED EXCEPTION: %s" (Printexc.to_string exc), None))
| exc -> raise (Bug (sprintf "[Libgrew.rewrite] UNCATCHED EXCEPTION: %s" (Printexc.to_string exc), None))
let display ~gr ~grs ~seq =
try Grs.build_rew_display grs seq gr
with
| Error.Run (msg,loc) -> raise (Run (msg,loc))
| Error.Bug (msg, loc) -> raise (Bug (msg,loc))
| exc -> raise (Bug (sprintf "UNCATCHED EXCEPTION: %s" (Printexc.to_string exc), None))
| exc -> raise (Bug (sprintf "[Libgrew.display] UNCATCHED EXCEPTION: %s" (Printexc.to_string exc), None))
let write_stat filename rew_hist = Gr_stat.save filename (Gr_stat.from_rew_history rew_hist)
......
......@@ -41,6 +41,8 @@ let localize t = (t,get_loc ())
%token INCLUDE /* include */
%token FEATURES /* features */
%token FEATURE /* feature */
%token FILE /* file */
%token LABELS /* labels */
%token BAD_LABELS /* bad_labels */
%token MATCH /* match */
......@@ -49,6 +51,7 @@ let localize t = (t,get_loc ())
%token MODULE /* module */
%token CONFLUENT /* confluent */
%token RULE /* rule */
%token LEX_RULE /* lex_rule */
%token SEQUENCES /* sequences */
%token GRAPH /* graph */
......@@ -62,6 +65,9 @@ let localize t = (t,get_loc ())
%token ADD_NODE /* add_node */
%token DEL_FEAT /* del_feat */
%token <string> PAT /* $id */
%token <string> CMD /* @id */
%token <string> IDENT /* indentifier */
%token <Grew_ast.Ast.qfn> QFN /* ident.ident */
%token <string> STRING
......@@ -273,15 +279,34 @@ rules:
rule:
| doc = option(rule_doc) RULE id = rule_id LACC p = pos_item n = list(neg_item) cmds = commands RACC
{
{ Ast.rule_id = fst id;
{ Ast.rule_id = fst id;
pos_pattern = p;
neg_patterns = n;
commands = List_.opt cmds;
commands = List_.opt cmds;
param = None;
rule_doc = begin match doc with Some d -> d | None -> "" end;
rule_loc = (!Parser_global.current_file,snd id);
}
}
| doc = option(rule_doc) LEX_RULE id = rule_id param=option(param) LACC p = pos_item n = list(neg_item) cmds = commands RACC
{
{ Ast.rule_id = fst id;
pos_pattern = p;
neg_patterns = n;
commands = List_.opt cmds;
param = param;
rule_doc = begin match doc with Some d -> d | None -> "" end;
rule_loc = (!Parser_global.current_file,snd id);
}
}
param:
| LPAREN FEATURE vars = separated_nonempty_list(COMA,var) SEMIC FILE file=STRING RPAREN { (file,vars) }
var:
| i = PAT {i}
| i = CMD {i}
pos_item:
| MATCH i = pn_item { i }
......@@ -333,11 +358,13 @@ pat_node:
node_features:
| name = IDENT EQUAL STAR
{ localize {Ast.kind = Ast.Disequality; name=name; values=[]; } }
{ localize {Ast.kind = Ast.Disequality []; name=name; } }
| name = IDENT EQUAL values = separated_nonempty_list(PIPE,feature_value)
{ localize {Ast.kind = Ast.Equality; name=name; values=values; } }
{ localize {Ast.kind = Ast.Equality values; name=name; } }
| name = IDENT DISEQUAL values = separated_nonempty_list(PIPE,feature_value)
{ localize {Ast.kind = Ast.Disequality; name=name; values=values; } }
{ localize {Ast.kind = Ast.Disequality values; name=name; } }
| name = IDENT EQUAL p = PAT
{ localize {Ast.kind = Ast.Param p; name=name; } }
feature_value:
| v = IDENT { v }
......@@ -439,12 +466,14 @@ command:
{ localize (Ast.Shift_edge (n1,n2)) }
| MERGE n1 = IDENT LONGARROW n2 = IDENT
{ localize (Ast.Merge_node (n1,n2)) }
| DEL_NODE n = IDENT
| DEL_NODE n = IDENT
{ localize (Ast.Del_node n) }
| ADD_NODE n1 = IDENT DDOT label = delimited(RTL_EDGE_LEFT,IDENT,RTL_EDGE_RIGHT) n2 = IDENT
{ localize (Ast.New_neighbour (n1,n2,label)) }
| DEL_FEAT qfn = QFN
{ localize (Ast.Del_feat qfn) }
| qfn = QFN EQUAL p = CMD
{ localize (Ast.Param_feat (qfn, p)) }
| qfn = QFN EQUAL items = separated_nonempty_list (PLUS, concat_item)
{ localize (Ast.Update_feat (qfn, items)) }
......
......@@ -25,94 +25,98 @@ rule comment target = parse
and comment_multi_doc target = shortest
| (_* as comment)"--%" {
let start = ref 0 in
try while (Str.search_forward (Str.regexp "\n") comment !start != -1) do
start := Str.match_end ();
incr Parser_global.current_line;
Lexing.new_line lexbuf;
done; assert false
with Not_found ->
COMMENT(comment)
}
let start = ref 0 in
try while (Str.search_forward (Str.regexp "\n") comment !start != -1) do
start := Str.match_end ();
incr Parser_global.current_line;
Lexing.new_line lexbuf;
done; assert false
with Not_found ->
COMMENT(comment)
}
and comment_multi target = parse
| "*/" { target lexbuf }
| '\n' { incr Parser_global.current_line; Lexing.new_line lexbuf; comment_multi target lexbuf }
| _ { comment_multi target lexbuf }
and string_lex target = parse
| "\\" { escaped := true; tmp_string := !tmp_string^"\\"; string_lex target lexbuf }
| '\n' { incr Parser_global.current_line; Lexing.new_line lexbuf; tmp_string := !tmp_string^"\n"; string_lex target lexbuf }
| '\"' { if !escaped then (tmp_string := !tmp_string^"\""; escaped := false; string_lex target lexbuf) else ( STRING(!tmp_string) ) }
| _ as c { escaped := false; tmp_string := !tmp_string^(Printf.sprintf "%c" c); string_lex target lexbuf }
and global = parse
| [' ' '\t'] { global lexbuf }
| "%--" { comment_multi_doc global lexbuf }
| "/*" { comment_multi global lexbuf }
| '%' { comment global lexbuf }
| '\n' { incr Parser_global.current_line; Lexing.new_line lexbuf; global lexbuf}
| "include" { INCLUDE }
| "features" { FEATURES }
| "labels" { LABELS }
| "bad_labels" { BAD_LABELS }
| "match" { MATCH }
| "without" { WITHOUT }
| "commands" { COMMANDS }
| "add_edge" { ADD_EDGE }
| "del_edge" { DEL_EDGE }
| "shift_in" { SHIFT_IN }
| "shift_out" { SHIFT_OUT }
| "shift" { SHIFT }
| "merge" { MERGE }
| "del_node" { DEL_NODE }
| "add_node" { ADD_NODE }
| "del_feat" { DEL_FEAT }
| "module" { MODULE }
| "confluent" { CONFLUENT }
| "rule" { RULE }
| "%--" { comment_multi_doc global lexbuf }
| "/*" { comment_multi global lexbuf }
| '%' { comment global lexbuf }
| '\n' { incr Parser_global.current_line; Lexing.new_line lexbuf; global lexbuf}
| "include" { INCLUDE }
| "features" { FEATURES }
| "feature" { FEATURE }
| "file" { FILE }
| "labels" { LABELS }
| "bad_labels" { BAD_LABELS }
| "match" { MATCH }
| "without" { WITHOUT }
| "commands" { COMMANDS }
| "add_edge" { ADD_EDGE }
| "del_edge" { DEL_EDGE }
| "shift_in" { SHIFT_IN }
| "shift_out" { SHIFT_OUT }
| "shift" { SHIFT }
| "merge" { MERGE }
| "del_node" { DEL_NODE }
| "add_node" { ADD_NODE }
| "del_feat" { DEL_FEAT }
| "module" { MODULE }
| "confluent" { CONFLUENT }
| "rule" { RULE }
| "lex_rule" { LEX_RULE }
| "sequences" { SEQUENCES }
| "graph" { GRAPH }
| digit+ as number { INT (int_of_string number) }
| digit+ as number { INT (int_of_string number) }
| ident ['.'] ident as qfn { QFN (parse_qfn qfn) }