Commit 35d77e87 authored by bguillaum's avatar bguillaum

Cleaning of identifiers in lexer, parser, ...

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8101 7838e531-6607-4d57-9587-6c381814729c
parent ddde63b4
......@@ -4,49 +4,121 @@ open Log
open Grew_utils
module Ast = struct
let dot_split s = Str.split (Str.regexp "\\.") s
let get_single s = match dot_split s with
| [one] -> one
| _ -> Error.build "The identifier '%s' contains the '.' symbol" s
type feature_name = string (* cat, num, ... *)
type feature_atom = string (* V, N, inf, ... *)
type feature_value = string (* V, 4, "free text", ... *)
(* -------------------------------------------------------------------------------- *)
(* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
type complex_id =
| No_sharp of string
| Sharp of string * string
let complex_id_to_string = function
| No_sharp x -> x
| Sharp (x,y) -> x ^ "#" ^ y
(* -------------------------------------------------------------------------------- *)
(* simple_id: V *)
type simple_id = Id.name
let simple_id_of_ci ci = match ci with
| No_sharp s -> get_single s
| Sharp _ -> Error.build "The identifier '%s' must be basic (without '#' symbol)" (complex_id_to_string ci)
let is_simple = function
| No_sharp s when List.length (dot_split s) = 1 -> true
| _ -> false
(* -------------------------------------------------------------------------------- *)
(* label_id: p_obj.loc x.y.z *)
type label_id = string
let label_id_of_ci ci = match ci with
| No_sharp s -> s
| Sharp _ -> Error.build "The identifier '%s' must be a label (without '#' symbol)" (complex_id_to_string ci)
(* -------------------------------------------------------------------------------- *)
(* act_id: V, V#alpha *)
type act_id = Id.name * string option
let act_id_of_ci = function
| No_sharp s -> (get_single s, None)
| Sharp (s1,s2) -> (get_single s1, Some (get_single s2))
let act_id_to_string = function
| (base, None) -> base
| (base, Some ln) -> sprintf "%s#%s" base ln
(* -------------------------------------------------------------------------------- *)
(* simple_qfn: V.cat *)
type simple_qfn = Id.name * feature_name
let simple_qfn_of_ci ci = match ci with
| No_sharp s ->
(match dot_split s with
| [base;fn] -> (base, fn)
| _ -> Error.build "The identifier '%s' must be a qualified feature name (with one '.' symbol)" s
)
| Sharp _ -> Error.build "The identifier '%s' must be a qualified feature name (without '#' symbol)" (complex_id_to_string ci)
let simple_qfn_to_string (name, feat_name) = sprintf "%s.%s" name feat_name
(* -------------------------------------------------------------------------------- *)
(* act_qfn: V.cat, V#alpha.cat *)
type act_qfn = act_id * feature_name
let act_qfn_of_ci = function
| No_sharp s ->
(match dot_split s with
| [base;fn] -> ((base, None), fn)
| _ -> Error.build "The identifier '%s' must be a qualified feature name (with one '.' symbol)" s
)
| Sharp (base, s) ->
(match dot_split s with
| [ext;fn] -> ((get_single base, Some ext), fn)
| _ -> Error.build "The identifier '%s' must be a qualified feature name (with one '.' symbol)" s
)
type feature_spec =
| Closed of string * string list (* (the name, the set of atomic values) *)
| Open of string (* the name *)
| Int of string (* the name *)
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
| Int of feature_name (* position *)
type domain = feature_spec list
type feature_kind =
| Equality of string list
| Disequality of string list
| Param of string
| Equality of feature_value list
| Disequality of feature_value list
| Param of string (* $ident *)
type u_feature = {
name: string;
kind: feature_kind;
}
name: feature_name;
kind: feature_kind;
}
type feature = u_feature * Loc.t
type u_node = {
node_id: Id.name;
position: int option;
fs: feature list;
}
type node = u_node * Loc.t
type edge_label = string
type u_edge = {
edge_id: Id.name option;
src: Id.name;
edge_labels: string list;
edge_labels: edge_label list;
tar: Id.name;
negative: bool;
}
type edge = u_edge * Loc.t
(* the base node name and the eventual new_node extension *)
type c_ident = Id.name * string option
let c_ident_to_string (string_node, new_opt) =
match new_opt with
| None -> string_node
| Some a -> sprintf "%s#%s" string_node a
type ineq = Lt | Gt | Le | Ge
let string_of_ineq = function
......@@ -55,17 +127,14 @@ module Ast = struct
| Le -> "≤"
| Ge -> "≥"
type feature_name = string
type u_const =
| Start of c_ident * string list (* (source, labels) *)
| Cst_out of c_ident
| End of c_ident * string list (* (target, labels) *)
| Cst_in of c_ident
| Feature_eq of (c_ident * feature_name) * (c_ident * feature_name)
| Feature_diseq of (c_ident * feature_name) * (c_ident * feature_name)
| Feature_ineq of ineq * (c_ident * feature_name) * (c_ident * feature_name)
| Start of Id.name * edge_label list (* (source, labels) *)
| Cst_out of Id.name
| End of Id.name * edge_label list (* (target, labels) *)
| Cst_in of Id.name
| Feature_eq of simple_qfn * simple_qfn
| Feature_diseq of simple_qfn * simple_qfn
| Feature_ineq of ineq * simple_qfn * simple_qfn
type const = u_const * Loc.t
type pattern = {
......@@ -80,25 +149,24 @@ module Ast = struct
}
type concat_item =
| Qfn_item of (c_ident * feature_name)
| Qfn_item of complex_id (* Warning: either a simple string (without .) of a real qualified feature_name *)
| String_item of string
| Param_item of string
type u_command =
| Del_edge_expl of (c_ident * c_ident * string)
| Del_edge_expl of (act_id * act_id * edge_label)
| Del_edge_name of string
| Add_edge of (c_ident * c_ident * string)
| Shift_in of (c_ident*c_ident)
| Shift_out of (c_ident*c_ident)
| Shift_edge of (c_ident*c_ident)
| Merge_node of (c_ident*c_ident)
| New_neighbour of (c_ident * c_ident * string)
| Del_node of c_ident
| Activate of c_ident
| Del_feat of (c_ident * feature_name)
| Update_feat of (c_ident * feature_name) * concat_item list
| Add_edge of (act_id * act_id * edge_label)
| Shift_in of (act_id * act_id)
| Shift_out of (act_id * act_id)
| Shift_edge of (act_id * act_id)
| Merge_node of (act_id * act_id)
| New_neighbour of (Id.name * act_id * edge_label)
| Del_node of act_id
| Activate of act_id
| Del_feat of act_qfn
| Update_feat of act_qfn * concat_item list
type command = u_command * Loc.t
(* the [rule] type is used for 3 kids of module items:
......@@ -161,4 +229,4 @@ module Ast = struct
nodes: node list;
edges: edge list;
}
end (* module Ast *)
end (* module Ast *)
open Grew_utils
module Ast : sig
type feature_name = string (* cat, num, ... *)
type feature_atom = string (* V, N, inf, ... *)
type feature_value = string (* V, 4, "free text", ... *)
(* -------------------------------------------------------------------------------- *)
(* complex_id: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
type complex_id =
| No_sharp of string
| Sharp of string * string
val complex_id_to_string: complex_id -> string
(* simple_id: V *)
type simple_id = Id.name
val simple_id_of_ci: complex_id -> string
val is_simple: complex_id -> bool
(* label_id: V *)
type label_id = Id.name
val label_id_of_ci: complex_id -> string
(* act_id: V, V#alpha *)
type act_id = Id.name * string option
val act_id_of_ci: complex_id -> act_id
val act_id_to_string: act_id -> string
(* simple_qfn: V.cat *)
type simple_qfn = Id.name * feature_name
val simple_qfn_of_ci: complex_id -> simple_qfn
val simple_qfn_to_string: simple_qfn -> string
(* act_id: V.cat, V#alpha.cat *)
type act_qfn = act_id * feature_name
val act_qfn_of_ci: complex_id -> act_qfn
type feature_spec =
| Closed of string * string list (* (the name, the set of atomic values) *)
| Open of string (* the name *)
| Int of string (* the name *)
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
| Int of feature_name (* position *)
type domain = feature_spec list
type feature_kind =
| Equality of string list
| Disequality of string list
| Param of string
| Equality of feature_value list
| Disequality of feature_value list
| Param of string (* $ident *)
type u_feature = {
name: string;
kind: feature_kind;
}
name: feature_name;
kind: feature_kind;
}
type feature = u_feature * Loc.t
type u_node = {
......@@ -25,39 +59,31 @@ module Ast : sig
position: int option;
fs: feature list;
}
type node = u_node * Loc.t
type edge_label = string (* p_obj.agt:suj *)
type u_edge = {
edge_id: Id.name option;
src: Id.name;
edge_labels: string list;
edge_labels: edge_label list;
tar: Id.name;
negative: bool;
}
type edge = u_edge * Loc.t
(* the base node name and the eventual new_node extension *)
type c_ident = Id.name * string option
val c_ident_to_string: c_ident -> string
type ineq = Lt | Gt | Le | Ge
val string_of_ineq: ineq -> string
type feature_name = string
type u_const =
| Start of c_ident * string list (* (source, labels) *)
| Cst_out of c_ident
| End of c_ident * string list (* (target, labels) *)
| Cst_in of c_ident
| Feature_eq of (c_ident * feature_name) * (c_ident * feature_name)
| Feature_diseq of (c_ident * feature_name) * (c_ident * feature_name)
| Feature_ineq of ineq * (c_ident * feature_name) * (c_ident * feature_name)
| Start of Id.name * edge_label list (* (source, labels) *)
| Cst_out of Id.name
| End of Id.name * edge_label list (* (target, labels) *)
| Cst_in of Id.name
| Feature_eq of simple_qfn * simple_qfn
| Feature_diseq of simple_qfn * simple_qfn
| Feature_ineq of ineq * simple_qfn * simple_qfn
type const = u_const * Loc.t
type pattern = {
......@@ -67,25 +93,24 @@ module Ast : sig
}
type concat_item =
| Qfn_item of (c_ident * feature_name)
| Qfn_item of complex_id
| String_item of string
| Param_item of string
type u_command =
| Del_edge_expl of (c_ident * c_ident * string)
| Del_edge_expl of (act_id * act_id * edge_label)
| Del_edge_name of string
| Add_edge of (c_ident * c_ident * string)
| Shift_in of (c_ident*c_ident)
| Shift_out of (c_ident*c_ident)
| Shift_edge of (c_ident*c_ident)
| Merge_node of (c_ident*c_ident)
| New_neighbour of (c_ident * c_ident * string)
| Del_node of c_ident
| Activate of c_ident
| Del_feat of (c_ident * feature_name)
| Update_feat of (c_ident * feature_name) * concat_item list
| Add_edge of (act_id * act_id * edge_label)
| Shift_in of (act_id * act_id)
| Shift_out of (act_id * act_id)
| Shift_edge of (act_id * act_id)
| Merge_node of (act_id * act_id)
| New_neighbour of (Id.name * act_id * edge_label)
| Del_node of act_id
| Activate of act_id
| Del_feat of act_qfn
| Update_feat of act_qfn * concat_item list
type command = u_command * Loc.t
type rule = {
......
......@@ -8,30 +8,30 @@ open Grew_fs
(* ==================================================================================================== *)
module Command = struct
type cnode = (* a command node is either: *)
type command_node = (* a command node is either: *)
| Pat of Pid.t (* a node identified in the pattern *)
| New of string (* a node introduced by a new_neighbour *)
| Act of Pid.t * string (* a node introduced by a activate *)
type item =
| Feat of (cnode * string)
| Feat of (command_node * string)
| String of string
| Param_in of int
| Param_out of int
(* the command in pattern *)
type p =
| DEL_NODE of cnode
| DEL_EDGE_EXPL of (cnode * cnode * G_edge.t)
| DEL_NODE of command_node
| DEL_EDGE_EXPL of (command_node * command_node * G_edge.t)
| DEL_EDGE_NAME of string
| ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
| ADD_EDGE of (command_node * command_node * G_edge.t)
| DEL_FEAT of (command_node * string)
| UPDATE_FEAT of (command_node * string * item list)
| NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
| SHIFT_OUT of (cnode * cnode)
| MERGE_NODE of (cnode * cnode)
| SHIFT_EDGE of (command_node * command_node)
| SHIFT_IN of (command_node * command_node)
| SHIFT_OUT of (command_node * command_node)
| MERGE_NODE of (command_node * command_node)
type t = p * Loc.t (* remember command location to be able to localize a command failure *)
......@@ -49,71 +49,71 @@ module Command = struct
| H_SHIFT_OUT of (Gid.t * Gid.t)
| H_MERGE_NODE of (Gid.t * Gid.t)
let build ?param (kci, kei) table locals ast_command =
let build ?param (kai, kei) table locals ast_command =
let pid_of_c_ident = function
let pid_of_act_id = function
| (node_name, None) -> Pat (Pid.Pos (Id.build node_name table))
| (node_name, Some n) -> Act (Pid.Pos (Id.build node_name table), n) in
| (node_name, Some n) -> Act (Pid.Pos (Id.build node_name table), n) in
let check_c_ident loc c_ident kci =
if not (List.mem c_ident kci)
then Error.build ~loc "Unbound c_ident identifier \"%s\"" (Ast.c_ident_to_string c_ident) in
let check_act_id loc act_id kai =
if not (List.mem act_id kai)
then Error.build ~loc "Unbound node identifier \"%s\"" (Ast.act_id_to_string act_id) in
let check_edge loc edge_id kei =
if not (List.mem edge_id kei)
then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in
match ast_command with
| (Ast.Del_edge_expl (i, j, lab), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
| (Ast.Del_edge_expl (act_i, act_j, lab), loc) ->
check_act_id loc act_i kai;
check_act_id loc act_j kai;
let edge = G_edge.make ~loc ~locals lab in
((DEL_EDGE_EXPL (pid_of_c_ident i, pid_of_c_ident j, edge), loc), (kci, kei))
((DEL_EDGE_EXPL (pid_of_act_id act_i, pid_of_act_id act_j, edge), loc), (kai, kei))
| (Ast.Del_edge_name id, loc) ->
check_edge loc id kei;
(DEL_EDGE_NAME id, loc), (kci, List_.rm id kei)
(DEL_EDGE_NAME id, loc), (kai, List_.rm id kei)
| (Ast.Add_edge (i, j, lab), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
| (Ast.Add_edge (act_i, act_j, lab), loc) ->
check_act_id loc act_i kai;
check_act_id loc act_j kai;
let edge = G_edge.make ~loc ~locals lab in
((ADD_EDGE (pid_of_c_ident i, pid_of_c_ident j, edge), loc), (kci, kei))
| (Ast.Shift_edge (i, j), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
((SHIFT_EDGE (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei))
| (Ast.Shift_in (i, j), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
((SHIFT_IN (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei))
| (Ast.Shift_out (i, j), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
((SHIFT_OUT (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei))
| (Ast.Merge_node (i, j), loc) ->
check_c_ident loc i kci;
check_c_ident loc j kci;
((MERGE_NODE (pid_of_c_ident i, pid_of_c_ident j), loc), (List_.rm i kci, kei))
| (Ast.New_neighbour ((name_created, None), ancestor, label), loc) ->
check_c_ident loc ancestor kci;
if List.mem (name_created, None) kci
then Error.build ~loc "Node identifier \"%s\" is already used" name_created;
((ADD_EDGE (pid_of_act_id act_i, pid_of_act_id act_j, edge), loc), (kai, kei))
| (Ast.Shift_edge (act_i, act_j), loc) ->
check_act_id loc act_i kai;
check_act_id loc act_j kai;
((SHIFT_EDGE (pid_of_act_id act_i, pid_of_act_id act_j), loc), (kai, kei))
| (Ast.Shift_in (act_i, act_j), loc) ->
check_act_id loc act_i kai;
check_act_id loc act_j kai;
((SHIFT_IN (pid_of_act_id act_i, pid_of_act_id act_j), loc), (kai, kei))
| (Ast.Shift_out (act_i, act_j), loc) ->
check_act_id loc act_i kai;
check_act_id loc act_j kai;
((SHIFT_OUT (pid_of_act_id act_i, pid_of_act_id act_j), loc), (kai, kei))
| (Ast.Merge_node (act_i, act_j), loc) ->
check_act_id loc act_i kai;
check_act_id loc act_j kai;
((MERGE_NODE (pid_of_act_id act_i, pid_of_act_id act_j), loc), (List_.rm act_i kai, kei))
| (Ast.New_neighbour (new_id, ancestor, label), loc) ->
check_act_id loc ancestor kai;
if List.mem (new_id, None) kai
then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
let edge = G_edge.make ~loc ~locals label in
begin
try
(
(NEW_NEIGHBOUR
(name_created,
(new_id,
edge,
Pid.Pos (Id.build ~loc (fst ancestor) table)
), loc),
((name_created, None)::kci, kei)
((new_id, None)::kai, kei)
)
with Not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
......@@ -124,19 +124,23 @@ module Command = struct
| (Ast.Activate n, loc) -> failwith "Not implemented"
| (Ast.Del_node n, loc) ->
check_c_ident loc n kci;
((DEL_NODE (pid_of_c_ident n), loc), (List_.rm n kci, kei))
| (Ast.Del_node act_n, loc) ->
check_act_id loc act_n kai;
((DEL_NODE (pid_of_act_id act_n), loc), (List_.rm act_n kai, kei))
| (Ast.Del_feat (c_ident,feat_name), loc) ->
check_c_ident loc c_ident kci;
((DEL_FEAT (pid_of_c_ident c_ident, feat_name), loc), (kci, kei))
| (Ast.Del_feat (act_id, feat_name), loc) ->
check_act_id loc act_id kai;
((DEL_FEAT (pid_of_act_id act_id, feat_name), loc), (kai, kei))
| (Ast.Update_feat ((c_ident, feat_name), ast_items), loc) ->
check_c_ident loc c_ident kci;
| (Ast.Update_feat ((act_id, feat_name), ast_items), loc) ->
check_act_id loc act_id kai;
let items = List.map
(function
| Ast.Qfn_item (ci,fn) -> check_c_ident loc ci kci; Feat (pid_of_c_ident ci, fn)
(* special case of a basic identifier understood as a string *)
| Ast.Qfn_item ci when Ast.is_simple ci -> String (Ast.complex_id_to_string ci)
| Ast.Qfn_item ci ->
let (act_id,feature_name) = Ast.act_qfn_of_ci ci in
check_act_id loc act_id kai; Feat (pid_of_act_id act_id, feature_name)
| Ast.String_item s -> String s
| Ast.Param_item var ->
match param with
......@@ -147,6 +151,5 @@ module Command = struct
| (Some index,_) -> Param_in index
| _ -> Error.build "Unknown command variable '%s'" var
) ast_items in
((UPDATE_FEAT (pid_of_c_ident c_ident, feat_name, items), loc), (kci, kei))
| _ -> failwith "TODO remove with new neighbour"
((UPDATE_FEAT (pid_of_act_id act_id, feat_name, items), loc), (kai, kei))
end (* module Command *)
......@@ -4,29 +4,29 @@ open Grew_edge
(* ==================================================================================================== *)
module Command : sig
type cnode = (* a command node is either: *)
type command_node = (* a command node is either: *)
| Pat of Pid.t (* a node identified in the pattern *)
| New of string (* a node introduced by a new_neighbour *)
| Act of Pid.t * string (* a node introduced by a activate *)
type item =
| Feat of (cnode * string)
| Feat of (command_node * string)
| String of string
| Param_in of int
| Param_out of int
type p =
| DEL_NODE of cnode
| DEL_EDGE_EXPL of (cnode * cnode *G_edge.t)
| DEL_NODE of command_node
| DEL_EDGE_EXPL of (command_node * command_node *G_edge.t)
| DEL_EDGE_NAME of string
| ADD_EDGE of (cnode * cnode * G_edge.t)
| DEL_FEAT of (cnode * string)
| UPDATE_FEAT of (cnode * string * item list)
| ADD_EDGE of (command_node * command_node * G_edge.t)
| DEL_FEAT of (command_node * string)
| UPDATE_FEAT of (command_node * string * item list)
| NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
| SHIFT_EDGE of (cnode * cnode)
| SHIFT_IN of (cnode * cnode)
| SHIFT_OUT of (cnode * cnode)
| MERGE_NODE of (cnode * cnode)
| SHIFT_EDGE of (command_node * command_node)
| SHIFT_IN of (command_node * command_node)
| SHIFT_OUT of (command_node * command_node)
| MERGE_NODE of (command_node * command_node)
type t = (p * Loc.t)
......@@ -45,9 +45,9 @@ module Command : sig
val build:
?param: (string list * string list) ->
(Ast.c_ident list * string list) ->
(Ast.act_id list * string list) ->
Id.table ->
Label.decl array ->
Ast.command <