Commit 1a0f4cae authored by bguillaum's avatar bguillaum

handle < and << between nodes

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8959 7838e531-6607-4d57-9587-6c381814729c
parent 94d2f1b0
......@@ -63,12 +63,17 @@ module Ast = struct
| [Str.Text base; Str.Delim "."; Str.Text fn] -> (base, fn)
| _ -> Error.build "The identifier '%s' must be a feature identifier (with exactly one '.' symbol, like \"V.cat\" for instance)" s
let parse_ineq_ident s =
(* ---------------------------------------------------------------------- *)
(* 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
let parse_simple_or_feature_ident s =
check_special "feature ident" ["."] s;
match Str.full_split (Str.regexp "\\.") s with
| [Str.Text base; ] -> (base, "position")
| [Str.Text base; Str.Delim "."; Str.Text fn] -> (base, fn)
| _ -> Error.build "The identifier '%s' must be a feature identifier (with exactly one '.' symbol, like \"V.cat\" for instance)" s
| [Str.Text base; ] -> (base, None)
| [Str.Text base; Str.Delim "."; Str.Text fn] -> (base, Some fn)
| _ -> Error.build "The identifier '%s' must be a feature identifier (with at most one '.' symbol, like \"V\" or \"V.cat\" for instance)" s
(* ---------------------------------------------------------------------- *)
(* command_node_id: V, V#alpha *)
......@@ -156,6 +161,8 @@ module Ast = struct
| Feature_ineq of ineq * feature_ident * feature_ident
| Feature_ineq_cst of ineq * feature_ident * float
| Feature_re of feature_ident * string
| Prec of Id.name * Id.name
| Lprec of Id.name * Id.name
type const = u_const * Loc.t
type basic = {
......@@ -187,7 +194,8 @@ module Ast = struct
(fun acc (u_const, loc) -> match u_const with
| Feature_eq ((name1,_), (name2,_))
| Feature_diseq ((name1,_), (name2,_))
| Feature_ineq (_, (name1,_), (name2,_)) ->
| Feature_ineq (_, (name1,_), (name2,_))
| Prec (name1, name2) ->
acc
|> (add_implicit_node loc aux name1)
|> (add_implicit_node loc aux name2)
......
......@@ -14,7 +14,7 @@ open Grew_types
module Ast : sig
(* ---------------------------------------------------------------------- *)
(* simple_ident: V.cat *)
(* simple_ident: cat or V *)
type simple_ident = Id.name
val parse_simple_ident: string -> simple_ident
val is_simple_ident: string -> bool
......@@ -36,10 +36,15 @@ module Ast : sig
(* feature_ident: V.cat *)
type feature_ident = Id.name * feature_name
val parse_feature_ident: string -> feature_ident
val parse_ineq_ident: string -> feature_ident
val dump_feature_ident: feature_ident -> string
(* -------------------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)
(* 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
(* ---------------------------------------------------------------------- *)
(* command_node_ident: V, V#alpha, V.cat, V#alpha.cat, p_obj.loc *)
type command_node_ident =
| No_sharp of string
......@@ -99,6 +104,8 @@ module Ast : sig
| Feature_ineq of ineq * feature_ident * feature_ident
| Feature_ineq_cst of ineq * feature_ident * float
| Feature_re of feature_ident * string
| Prec of Id.name * Id.name
| Lprec of Id.name * Id.name
type const = u_const * Loc.t
......
......@@ -140,6 +140,10 @@ module Html_doc = struct
bprintf buff "%s %s %f" (Ast.dump_feature_ident feat_id_l) (Ast.string_of_ineq ineq) constant
| Ast.Feature_re (feat_id, regexp) ->
bprintf buff "%s == \"%s\"" (Ast.dump_feature_ident feat_id) regexp
| Ast.Prec (id1, id2) ->
bprintf buff "%s < %s" id1 id2
| Ast.Lprec (id1, id2) ->
bprintf buff "%s << %s" id1 id2
);
bprintf buff "\n"
......
......@@ -215,6 +215,8 @@ and standard target = parse
| "!" { BANG }
| "<>" { DISEQUAL }
| "<<" { LPREC }
| ">>" { LSUCC }
| "<" { LT }
| ">" { GT }
| "<=" | "≤" { LE }
......
......@@ -24,6 +24,10 @@ type graph_item =
| Graph_node of Ast.node
| Graph_edge of Ast.edge
type ineq_item =
| Ineq_sofi of Ast.simple_or_feature_ident
| Ineq_float of float
let get_loc () = Loc.file_line !Global.current_file !Global.current_line
let localize t = (t,get_loc ())
%}
......@@ -48,6 +52,8 @@ let localize t = (t,get_loc ())
%token GT /* > */
%token LE /* <= or */
%token GE /* >= or */
%token LPREC /* << */
%token LSUCC /* >> */
%token PIPE /* | */
......@@ -157,12 +163,6 @@ feature_ident :
feature_ident_with_loc :
| id=ID { localize (Ast.parse_feature_ident id) }
ineq_ident :
| id=ID { Ast.parse_ineq_ident id }
ineq_ident_with_loc :
| id=ID { localize (Ast.parse_ineq_ident id) }
command_feature_ident_with_loc :
| id=ID { localize (Ast.parse_command_feature_ident id) }
......@@ -171,6 +171,14 @@ feature_value:
| v=STRING { v }
| v=FLOAT { Printf.sprintf "%g" v }
ineq_value:
| v=ID { Ineq_sofi (Ast.parse_simple_or_feature_ident v) }
| v=FLOAT { Ineq_float v }
ineq_value_with_loc:
| v=ID { localize (Ineq_sofi (Ast.parse_simple_or_feature_ident v)) }
| v=FLOAT { localize (Ineq_float v) }
/*=============================================================================================*/
/* GREW GRAPH */
/*=============================================================================================*/
......@@ -479,42 +487,61 @@ pat_edge_or_const:
| feat_id_loc=feature_ident_with_loc REGEXP regexp=STRING
{ let (feat_id,loc)=feat_id_loc in Pat_const (Ast.Feature_re (feat_id, regexp), loc) }
(* "X.position < Y.position" *)
| feat_id1_loc=ineq_ident_with_loc LT feat_id2=ineq_ident
{ let (feat_id1,loc)=feat_id1_loc in Pat_const (Ast.Feature_ineq (Ast.Lt, feat_id1, feat_id2), loc) }
| id1_loc=ineq_value_with_loc LT id2=ineq_value
{ 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.Feature_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)
(* "12.34 < Y.feat" *)
| (Ineq_float num, Ineq_sofi (n1, Some 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.Prec (n1,n2), loc)
| (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"
}
(* "X.position > Y.position" *)
| feat_id1_loc=ineq_ident_with_loc GT feat_id2=ineq_ident
{ let (feat_id1,loc)=feat_id1_loc in Pat_const (Ast.Feature_ineq (Ast.Gt, feat_id1, feat_id2), loc) }
| id1_loc=ineq_value_with_loc GT id2=ineq_value
{ 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.Feature_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)
(* "12.34 > Y.feat" *)
| (Ineq_float num, Ineq_sofi (n1, Some 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.Prec (n2,n1), loc)
| (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"
}
(* "X.position <= Y.position" *)
| feat_id1_loc=ineq_ident_with_loc LE feat_id2=ineq_ident
| feat_id1_loc=feature_ident_with_loc LE feat_id2=feature_ident
{ let (feat_id1,loc)=feat_id1_loc in Pat_const (Ast.Feature_ineq (Ast.Le, feat_id1, feat_id2), loc) }
(* "X.position >= Y.position" *)
| feat_id1_loc=ineq_ident_with_loc GE feat_id2=ineq_ident
| feat_id1_loc=feature_ident_with_loc GE feat_id2=feature_ident
{ let (feat_id1,loc)=feat_id1_loc in Pat_const (Ast.Feature_ineq (Ast.Ge, feat_id1, feat_id2), loc) }
(* "X.feat >= 12.34" *)
| feat_id1_loc=ineq_ident_with_loc GE num=FLOAT
| num=FLOAT LE feat_id1_loc=ineq_ident_with_loc
| feat_id1_loc=feature_ident_with_loc GE num=FLOAT
| num=FLOAT LE feat_id1_loc=feature_ident_with_loc
{ let (feat_id1,loc)=feat_id1_loc in Pat_const (Ast.Feature_ineq_cst (Ast.Ge, feat_id1, num), loc) }
(* "X.feat > 12.34" *)
| feat_id1_loc=ineq_ident_with_loc GT num=FLOAT
| num=FLOAT LT feat_id1_loc=ineq_ident_with_loc
{ let (feat_id1,loc)=feat_id1_loc in Pat_const (Ast.Feature_ineq_cst (Ast.Gt, feat_id1, num), loc) }
(* "X.feat <= 12.34" *)
| feat_id1_loc=ineq_ident_with_loc LE num=FLOAT
| num=FLOAT GE feat_id1_loc=ineq_ident_with_loc
| feat_id1_loc=feature_ident_with_loc LE num=FLOAT
| num=FLOAT GE feat_id1_loc=feature_ident_with_loc
{ let (feat_id1,loc)=feat_id1_loc in Pat_const (Ast.Feature_ineq_cst (Ast.Le, feat_id1, num), loc) }
(* "X.feat < 12.34" *)
| feat_id1_loc=ineq_ident_with_loc LT num=FLOAT
| num=FLOAT GT feat_id1_loc=ineq_ident_with_loc
{ let (feat_id1,loc)=feat_id1_loc in Pat_const (Ast.Feature_ineq_cst (Ast.Lt, feat_id1, num), loc) }
(* "A << B" *)
| n1_loc=simple_id_with_loc LPREC n2=simple_id
{ let (n1,loc) = n1_loc in Pat_const (Ast.Lprec (n1,n2), loc) }
(* "A >> B" *)
| n1_loc=simple_id_with_loc LSUCC n2=simple_id
{ let (n1,loc) = n1_loc in Pat_const (Ast.Lprec (n2,n1), loc) }
/*=============================================================================================*/
/* COMMANDS DEFINITION */
......
......@@ -112,6 +112,9 @@ module Rule = struct
| Filter of Pid.t * P_fs.t (* used when a without impose a fs on a node defined by the match basic *)
| Prec of Pid.t * Pid.t
| Lprec of Pid.t * Pid.t
let build_pos_constraint domain ?locals pos_table const =
let pid_of_name loc node_name = Pid.Pos (Id.build ~loc node_name pos_table) in
match const with
......@@ -143,6 +146,12 @@ module Rule = struct
Domain.check_feature_name domain ~loc feat_name;
Feature_re (pid_of_name loc node_name, feat_name, regexp)
| (Ast.Prec (id1, id2), loc) ->
Prec (pid_of_name loc id1, pid_of_name loc id2)
| (Ast.Lprec (id1, id2), loc) ->
Lprec (pid_of_name loc id1, pid_of_name loc id2)
type basic = {
graph: P_graph.t;
constraints: const list;
......@@ -202,6 +211,12 @@ module Rule = struct
Domain.check_feature_name domain ~loc feat_name;
Feature_re (pid_of_name loc node_name, feat_name, regexp)
| (Ast.Prec (id1, id2), loc) ->
Prec (pid_of_name loc id1, pid_of_name loc id2)
| (Ast.Lprec (id1, id2), loc) ->
Lprec (pid_of_name loc id1, pid_of_name loc id2)
(* It may raise [P_fs.Fail_unif] in case of contradiction on constraints *)
let build_neg_basic domain ?pat_vars ?(locals=[||]) pos_table basic_ast =
let (extension, neg_table) =
......@@ -569,6 +584,14 @@ module Rule = struct
else raise Fail
else raise Fail
end
| Prec (pid1, pid2) ->
let gid1 = Pid_map.find pid1 matching.n_match in
let gid2 = Pid_map.find pid2 matching.n_match in
failwith "TODO"
| Lprec (pid1, pid2) ->
let gid1 = Pid_map.find pid1 matching.n_match in
let gid2 = Pid_map.find pid2 matching.n_match in
failwith "TODO"
(* ---------------------------------------------------------------------- *)
(* returns all extension of the partial input matching *)
......
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