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 ...@@ -4,49 +4,121 @@ open Log
open Grew_utils open Grew_utils
module Ast = struct 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 = type feature_spec =
| Closed of string * string list (* (the name, the set of atomic values) *) | Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of string (* the name *) | Open of feature_name (* phon, lemma, ... *)
| Int of string (* the name *) | Int of feature_name (* position *)
type domain = feature_spec list type domain = feature_spec list
type feature_kind = type feature_kind =
| Equality of string list | Equality of feature_value list
| Disequality of string list | Disequality of feature_value list
| Param of string | Param of string (* $ident *)
type u_feature = { type u_feature = {
name: string; name: feature_name;
kind: feature_kind; kind: feature_kind;
} }
type feature = u_feature * Loc.t type feature = u_feature * Loc.t
type u_node = { type u_node = {
node_id: Id.name; node_id: Id.name;
position: int option; position: int option;
fs: feature list; fs: feature list;
} }
type node = u_node * Loc.t type node = u_node * Loc.t
type edge_label = string
type u_edge = { type u_edge = {
edge_id: Id.name option; edge_id: Id.name option;
src: Id.name; src: Id.name;
edge_labels: string list; edge_labels: edge_label list;
tar: Id.name; tar: Id.name;
negative: bool; negative: bool;
} }
type edge = u_edge * Loc.t 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 type ineq = Lt | Gt | Le | Ge
let string_of_ineq = function let string_of_ineq = function
...@@ -55,17 +127,14 @@ module Ast = struct ...@@ -55,17 +127,14 @@ module Ast = struct
| Le -> "≤" | Le -> "≤"
| Ge -> "≥" | Ge -> "≥"
type feature_name = string
type u_const = type u_const =
| Start of c_ident * string list (* (source, labels) *) | Start of Id.name * edge_label list (* (source, labels) *)
| Cst_out of c_ident | Cst_out of Id.name
| End of c_ident * string list (* (target, labels) *) | End of Id.name * edge_label list (* (target, labels) *)
| Cst_in of c_ident | Cst_in of Id.name
| Feature_eq of (c_ident * feature_name) * (c_ident * feature_name) | Feature_eq of simple_qfn * simple_qfn
| Feature_diseq of (c_ident * feature_name) * (c_ident * feature_name) | Feature_diseq of simple_qfn * simple_qfn
| Feature_ineq of ineq * (c_ident * feature_name) * (c_ident * feature_name) | Feature_ineq of ineq * simple_qfn * simple_qfn
type const = u_const * Loc.t type const = u_const * Loc.t
type pattern = { type pattern = {
...@@ -80,25 +149,24 @@ module Ast = struct ...@@ -80,25 +149,24 @@ module Ast = struct
} }
type concat_item = 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 | String_item of string
| Param_item of string | Param_item of string
type u_command = 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 | Del_edge_name of string
| Add_edge of (c_ident * c_ident * string) | Add_edge of (act_id * act_id * edge_label)
| Shift_in of (c_ident*c_ident) | Shift_in of (act_id * act_id)
| Shift_out of (c_ident*c_ident) | Shift_out of (act_id * act_id)
| Shift_edge of (c_ident*c_ident) | Shift_edge of (act_id * act_id)
| Merge_node of (c_ident*c_ident) | Merge_node of (act_id * act_id)
| New_neighbour of (c_ident * c_ident * string) | New_neighbour of (Id.name * act_id * edge_label)
| Del_node of c_ident | Del_node of act_id
| Activate of c_ident | Activate of act_id
| Del_feat of (c_ident * feature_name) | Del_feat of act_qfn
| Update_feat of (c_ident * feature_name) * concat_item list | Update_feat of act_qfn * concat_item list
type command = u_command * Loc.t type command = u_command * Loc.t
(* the [rule] type is used for 3 kids of module items: (* the [rule] type is used for 3 kids of module items:
...@@ -161,4 +229,4 @@ module Ast = struct ...@@ -161,4 +229,4 @@ module Ast = struct
nodes: node list; nodes: node list;
edges: edge list; edges: edge list;
} }
end (* module Ast *) end (* module Ast *)
open Grew_utils open Grew_utils
module Ast : sig 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 = type feature_spec =
| Closed of string * string list (* (the name, the set of atomic values) *) | Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of string (* the name *) | Open of feature_name (* phon, lemma, ... *)
| Int of string (* the name *) | Int of feature_name (* position *)
type domain = feature_spec list type domain = feature_spec list
type feature_kind = type feature_kind =
| Equality of string list | Equality of feature_value list
| Disequality of string list | Disequality of feature_value list
| Param of string | Param of string (* $ident *)
type u_feature = { type u_feature = {
name: string; name: feature_name;
kind: feature_kind; kind: feature_kind;
} }
type feature = u_feature * Loc.t type feature = u_feature * Loc.t
type u_node = { type u_node = {
...@@ -25,39 +59,31 @@ module Ast : sig ...@@ -25,39 +59,31 @@ module Ast : sig
position: int option; position: int option;
fs: feature list; fs: feature list;
} }
type node = u_node * Loc.t type node = u_node * Loc.t
type edge_label = string (* p_obj.agt:suj *)
type u_edge = { type u_edge = {
edge_id: Id.name option; edge_id: Id.name option;
src: Id.name; src: Id.name;
edge_labels: string list; edge_labels: edge_label list;
tar: Id.name; tar: Id.name;
negative: bool; negative: bool;
} }
type edge = u_edge * Loc.t 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 type ineq = Lt | Gt | Le | Ge
val string_of_ineq: ineq -> string val string_of_ineq: ineq -> string
type feature_name = string
type u_const = type u_const =
| Start of c_ident * string list (* (source, labels) *) | Start of Id.name * edge_label list (* (source, labels) *)
| Cst_out of c_ident | Cst_out of Id.name
| End of c_ident * string list (* (target, labels) *) | End of Id.name * edge_label list (* (target, labels) *)
| Cst_in of c_ident | Cst_in of Id.name
| Feature_eq of (c_ident * feature_name) * (c_ident * feature_name) | Feature_eq of simple_qfn * simple_qfn
| Feature_diseq of (c_ident * feature_name) * (c_ident * feature_name) | Feature_diseq of simple_qfn * simple_qfn
| Feature_ineq of ineq * (c_ident * feature_name) * (c_ident * feature_name) | Feature_ineq of ineq * simple_qfn * simple_qfn
type const = u_const * Loc.t type const = u_const * Loc.t
type pattern = { type pattern = {
...@@ -67,25 +93,24 @@ module Ast : sig ...@@ -67,25 +93,24 @@ module Ast : sig
} }
type concat_item = type concat_item =
| Qfn_item of (c_ident * feature_name) | Qfn_item of complex_id
| String_item of string | String_item of string
| Param_item of string | Param_item of string
type u_command = 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 | Del_edge_name of string
| Add_edge of (c_ident * c_ident * string) | Add_edge of (act_id * act_id * edge_label)
| Shift_in of (c_ident*c_ident) | Shift_in of (act_id * act_id)
| Shift_out of (c_ident*c_ident) | Shift_out of (act_id * act_id)
| Shift_edge of (c_ident*c_ident) | Shift_edge of (act_id * act_id)
| Merge_node of (c_ident*c_ident) | Merge_node of (act_id * act_id)
| New_neighbour of (c_ident * c_ident * string) | New_neighbour of (Id.name * act_id * edge_label)
| Del_node of c_ident | Del_node of act_id
| Activate of c_ident | Activate of act_id
| Del_feat of (c_ident * feature_name) | Del_feat of act_qfn
| Update_feat of (c_ident * feature_name) * concat_item list | Update_feat of act_qfn * concat_item list
type command = u_command * Loc.t type command = u_command * Loc.t
type rule = { type rule = {
......
...@@ -8,30 +8,30 @@ open Grew_fs ...@@ -8,30 +8,30 @@ open Grew_fs
(* ==================================================================================================== *) (* ==================================================================================================== *)
module Command = struct 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 *) | Pat of Pid.t (* a node identified in the pattern *)
| New of string (* a node introduced by a new_neighbour *) | New of string (* a node introduced by a new_neighbour *)
| Act of Pid.t * string (* a node introduced by a activate *) | Act of Pid.t * string (* a node introduced by a activate *)
type item = type item =
| Feat of (cnode * string) | Feat of (command_node * string)
| String of string | String of string
| Param_in of int | Param_in of int
| Param_out of int | Param_out of int
(* the command in pattern *) (* the command in pattern *)
type p = type p =
| DEL_NODE of cnode | DEL_NODE of command_node
| DEL_EDGE_EXPL of (cnode * cnode * G_edge.t) | DEL_EDGE_EXPL of (command_node * command_node * G_edge.t)
| DEL_EDGE_NAME of string | DEL_EDGE_NAME of string
| ADD_EDGE of (cnode * cnode * G_edge.t) | ADD_EDGE of (command_node * command_node * G_edge.t)
| DEL_FEAT of (cnode * string) | DEL_FEAT of (command_node * string)
| UPDATE_FEAT of (cnode * string * item list) | UPDATE_FEAT of (command_node * string * item list)
| NEW_NEIGHBOUR of (string * G_edge.t * Pid.t) | NEW_NEIGHBOUR of (string * G_edge.t * Pid.t)
| SHIFT_EDGE of (cnode * cnode) | SHIFT_EDGE of (command_node * command_node)
| SHIFT_IN of (cnode * cnode) | SHIFT_IN of (command_node * command_node)
| SHIFT_OUT of (cnode * cnode) | SHIFT_OUT of (command_node * command_node)
| MERGE_NODE of (cnode * cnode) | MERGE_NODE of (command_node * command_node)
type t = p * Loc.t (* remember command location to be able to localize a command failure *) type t = p * Loc.t (* remember command location to be able to localize a command failure *)
...@@ -49,71 +49,71 @@ module Command = struct ...@@ -49,71 +49,71 @@ module Command = struct
| H_SHIFT_OUT of (Gid.t * Gid.t) | H_SHIFT_OUT of (Gid.t * Gid.t)
| H_MERGE_NODE 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, 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 = let check_act_id loc act_id kai =
if not (List.mem c_ident kci) if not (List.mem act_id kai)
then Error.build ~loc "Unbound c_ident identifier \"%s\"" (Ast.c_ident_to_string c_ident) in then Error.build ~loc "Unbound node identifier \"%s\"" (Ast.act_id_to_string act_id) in
let check_edge loc edge_id kei = let check_edge loc edge_id kei =
if not (List.mem edge_id kei) if not (List.mem edge_id kei)
then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in
match ast_command with match ast_command with
| (Ast.Del_edge_expl (i, j, lab), loc) -> | (Ast.Del_edge_expl (act_i, act_j, lab), loc) ->
check_c_ident loc i kci; check_act_id loc act_i kai;
check_c_ident loc j kci; check_act_id loc act_j kai;
let edge = G_edge.make ~loc ~locals lab in 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) -> | (Ast.Del_edge_name id, loc) ->
check_edge loc id kei; 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) -> | (Ast.Add_edge (act_i, act_j, lab), loc) ->
check_c_ident loc i kci; check_act_id loc act_i kai;
check_c_ident loc j kci; check_act_id loc act_j kai;
let edge = G_edge.make ~loc ~locals lab in 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)) ((ADD_EDGE (pid_of_act_id act_i, pid_of_act_id act_j, edge), loc), (kai, kei))
| (Ast.Shift_edge (i, j), loc) -> | (Ast.Shift_edge (act_i, act_j), loc) ->
check_c_ident loc i kci; check_act_id loc act_i kai;
check_c_ident loc j kci; check_act_id loc act_j kai;
((SHIFT_EDGE (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei)) ((SHIFT_EDGE (pid_of_act_id act_i, pid_of_act_id act_j), loc), (kai, kei))
| (Ast.Shift_in (i, j), loc) -> | (Ast.Shift_in (act_i, act_j), loc) ->
check_c_ident loc i kci; check_act_id loc act_i kai;
check_c_ident loc j kci; check_act_id loc act_j kai;
((SHIFT_IN (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei)) ((SHIFT_IN (pid_of_act_id act_i, pid_of_act_id act_j), loc), (kai, kei))
| (Ast.Shift_out (i, j), loc) -> | (Ast.Shift_out (act_i, act_j), loc) ->
check_c_ident loc i kci; check_act_id loc act_i kai;
check_c_ident loc j kci; check_act_id loc act_j kai;
((SHIFT_OUT (pid_of_c_ident i, pid_of_c_ident j), loc), (kci, kei)) ((SHIFT_OUT (pid_of_act_id act_i, pid_of_act_id act_j), loc), (kai, kei))
| (Ast.Merge_node (i, j), loc) -> | (Ast.Merge_node (act_i, act_j), loc) ->
check_c_ident loc i kci; check_act_id loc act_i kai;
check_c_ident loc j kci; check_act_id loc act_j kai;
((MERGE_NODE (pid_of_c_ident i, pid_of_c_ident j), loc), (List_.rm i kci, kei)) ((MERGE_NODE (pid_of_act_id act_i, pid_of_act_id act_j), loc), (List_.rm act_i kai, kei))
| (Ast.New_neighbour ((name_created, None), ancestor, label), loc) -> | (Ast.New_neighbour (new_id, ancestor, label), loc) ->
check_c_ident loc ancestor kci; check_act_id loc ancestor kai;
if List.mem (name_created, None) kci if List.mem (new_id, None) kai
then Error.build ~loc "Node identifier \"%s\" is already used" name_created; then Error.build ~loc "Node identifier \"%s\" is already used" new_id;
let edge = G_edge.make ~loc ~locals label in let edge = G_edge.make ~loc ~locals label in
begin begin
try try
( (
(NEW_NEIGHBOUR (NEW_NEIGHBOUR
(name_created, (new_id,
edge, edge,
Pid.Pos (Id.build ~loc (fst ancestor) table) Pid.Pos (Id.build ~loc (fst ancestor) table)
), loc), ), loc),
((name_created, None)::kci, kei) ((new_id, None)::kai, kei)
) )
with Not_found -> with Not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s" 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 ...@@ -124,19 +124,23 @@ module Command = struct
| (Ast.Activate n, loc) -> failwith "Not implemented" | (Ast.Activate n, loc) -> failwith "Not implemented"
| (Ast.Del_node n, loc) -> | (Ast.Del_node