Skip to content

GitLab

L
libcaml-grew
Commit 4d144edc authored by Bruno Guillaume's avatar Bruno Guillaume
Browse files
Options

all lexical parameters are “in”

parent 3cecd883
Hide whitespace changes
Inline Side-by-side
Showing with 51 additions and 123 deletions
src/grew_command.ml
View file @ 4d144edc
......@@ -32,8 +32,7 @@ module Command = struct
type item =
| Feat of (command_node * string)
| String of string
| Param_in of int
| Param_out of int
| Param of int
let item_to_json = function
| Feat (cn, feature_name) -> `Assoc [("copy_feat",
......@@ -43,8 +42,7 @@ module Command = struct
]
)]
| String s -> `Assoc [("string", `String s)]
| Param_in i -> `Assoc [("param_in", `Int i)]
| Param_out i -> `Assoc [("param_out", `Int i)]
| Param i -> `Assoc [("param", `Int i)]
(* the command in pattern *)
type p =
......@@ -266,16 +264,15 @@ module Command = struct
| Ast.Param_item var ->
match param with
| None -> Error.build ~loc "Unknown command variable '%s'" var
| Some (par,cmd) ->
match (List_.index var par, List_.index var cmd) with
| (_,Some index) -> Param_out index
| (Some index,_) -> Param_in index
| Some par ->
match List_.index var par with
| Some index -> Param index
| _ -> Error.build ~loc "Unknown command variable '%s'" var
) ast_items in
(* check for consistency *)
(match items with
| _ when Domain.is_open_feature ?domain feat_name -> ()
| [Param_out _] -> () (* TODO: check that lexical parameters are compatible with the feature domain *)
| [Param _] -> () (* TODO: check that lexical parameters are compatible with the feature domain *)
| [String s] -> Domain.check_feature ~loc ?domain feat_name s
| [Feat (_,fn)] -> ()
| _ -> Error.build ~loc "[Update_feat] Only open features can be modified with the concat operator '+' but \"%s\" is not declared as an open feature" feat_name);
......
src/grew_command.mli
View file @ 4d144edc
......@@ -23,8 +23,7 @@ module Command : sig
type item =
| Feat of (command_node * string)
| String of string
| Param_in of int
| Param_out of int
| Param of int
type p =
| DEL_NODE of command_node
......@@ -65,7 +64,7 @@ module Command : sig
val build:
?domain: Domain.t ->
?param: (string list * string list) ->
?param: string list ->
(Id.name list * string list) ->
Id.table ->
Ast.command ->
......
src/grew_fs.ml
View file @ 4d144edc
......@@ -142,7 +142,7 @@ module P_feature = struct
let to_string ?param_names t =
let param_string index = match param_names with
| None -> sprintf "$%d" index
| Some (l,_) -> sprintf "%s" (List.nth l index) in
| Some l -> sprintf "%s" (List.nth l index) in
match t with
| (feat_name, {cst=Absent ;in_param=[]}) -> sprintf "!%s" feat_name
......@@ -458,8 +458,8 @@ module P_fs = struct
| (None,_) -> Log.bug "[P_fs.match_] Parametrized constraint in a non-parametrized rule"; exit 2
| (Some param, [index]) ->
(match Lex_par.select index (string_of_value atom) param with
| None -> raise Fail
| Some new_param -> loop (Some new_param) (t_pat,t)
| [] -> raise Fail
| new_param -> loop (Some new_param) (t_pat,t)
)
| _ -> Error.bug "[P_fs.match_] several different parameters contraints for the same feature is not implemented" in
loop param (p_fs_wo_pos,g_fs)
......
src/grew_fs.mli
View file @ 4d144edc
......@@ -80,7 +80,7 @@ module P_fs: sig
val to_string: t -> string
val to_dep: ?filter: (string -> bool) -> (string list * string list) -> t -> string
val to_dep: ?filter: (string -> bool) -> string list -> t -> string
val to_dot: t -> string
......
src/grew_rule.ml
View file @ 4d144edc
......@@ -364,7 +364,7 @@ module Rule = struct
pattern: pattern;
commands: Command.t list;
param: Lex_par.t option;
param_names: (string list * string list);
param_names: string list;
loc: Loc.t;
}
......@@ -376,8 +376,7 @@ module Rule = struct
let param_json = match t.param with
| None -> []
| Some lex_par -> [
("pattern_param", `List (List.map (fun x -> `String x) (fst t.param_names)));
("command_param", `List (List.map (fun x -> `String x) (snd t.param_names)));
("pattern_param", `List (List.map (fun x -> `String x) (t.param_names)));
("lex_par", Lex_par.to_json lex_par);
] in
`Assoc
......@@ -466,19 +465,6 @@ module Rule = struct
command :: (loop (new_kni,new_kei) tail) in
loop (known_node_ids, known_edge_ids) ast_commands
(* ====================================================================== *)
let parse_vars loc vars =
let rec parse_cmd_vars = function
| [] -> []
| x::t when x.[0] = '@' -> x :: parse_cmd_vars t
| x::t -> Error.bug ~loc "Illegal feature definition '%s' in the lexical rule" x in
let rec parse_pat_vars = function
| [] -> ([],[])
| x::t when x.[0] = '@' -> ([],parse_cmd_vars (x::t))
| x::t when x.[0] = '$' -> let (pv,cv) = parse_pat_vars t in (x::pv, cv)
| x::t -> Error.bug ~loc "Illegal feature definition '%s' in the lexical rule" x in
parse_pat_vars vars
(* ====================================================================== *)
let build ?domain deprecated_dir rule_ast =
......@@ -486,28 +472,26 @@ module Rule = struct
| Some d -> d
| None -> deprecated_dir in
let (param, pat_vars, cmd_vars) =
let (param, pat_vars) =
match rule_ast.Ast.param with
| None -> (None,[],[])
| None -> (None,[])
| Some (files,vars) ->
let (pat_vars, cmd_vars) = parse_vars rule_ast.Ast.rule_loc vars in
let nb_pv = List.length pat_vars in
let nb_cv = List.length cmd_vars in
let nb_var = List.length vars in
(* first: load lexical parameters given in the same file at the end of the rule definition *)
let local_param = match rule_ast.Ast.lex_par with
| None -> None
| Some lines -> Some (Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_pv nb_cv lines) in
| Some lines -> Some (Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_var lines) in
(* second: load lexical parameters given in external files *)
let full_param = List.fold_left
(fun acc file ->
match acc with
| None -> Some (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file)
| Some lp -> Some (Lex_par.append (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file) lp)
| None -> Some (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_var file)
| Some lp -> Some (Lex_par.append (Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_var file) lp)
) local_param files in
(full_param, pat_vars, cmd_vars) in
(full_param, vars) in
(match (param, pat_vars) with
| (None, _::_) -> Error.build ~loc:rule_ast.Ast.rule_loc "[Rule.build] Missing lexical parameters in rule \"%s\"" rule_ast.Ast.rule_id
......@@ -533,10 +517,10 @@ module Rule = struct
{
name = rule_ast.Ast.rule_id;
pattern = (pos, negs);
commands = build_commands ?domain ~param:(pat_vars,cmd_vars) pos pos_table rule_ast.Ast.commands;
commands = build_commands ?domain ~param:pat_vars pos pos_table rule_ast.Ast.commands;
loc = rule_ast.Ast.rule_loc;
param = param;
param_names = (pat_vars,cmd_vars)
param_names = pat_vars;
}
let build_pattern ?domain pattern_ast =
......@@ -975,11 +959,7 @@ module Rule = struct
(function
| Command.Feat (cnode, feat_name) -> Concat_item.Feat (node_find cnode, feat_name)
| Command.String s -> Concat_item.String s
| Command.Param_out index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
| Some param -> Concat_item.String (Lex_par.get_command_value index param))
| Command.Param_in index ->
| Command.Param index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
| Some param -> Concat_item.String (Lex_par.get_param_value index param))
......@@ -1434,11 +1414,7 @@ module Rule = struct
(function
| Command.Feat (cnode, feat_name) -> Concat_item.Feat (node_find cnode, feat_name)
| Command.String s -> Concat_item.String s
| Command.Param_out index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
| Some param -> Concat_item.String (Lex_par.get_command_value index param))
| Command.Param_in index ->
| Command.Param index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
| Some param -> Concat_item.String (Lex_par.get_param_value index param))
......@@ -1680,14 +1656,10 @@ module Rule = struct
(function
| Command.Feat (cnode, feat_name) -> Concat_item.Feat (node_find cnode, feat_name)
| Command.String s -> Concat_item.String s
| Command.Param_out index ->
| Command.Param index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
| Some param -> Concat_item.String (Lex_par.get_command_value index param))
| Command.Param_in index ->
(match matching.m_param with
| None -> Error.bug "Cannot apply a UPDATE_FEAT command without parameter"
| Some param -> Concat_item.String (Lex_par.get_param_value index param))
) item_list in
let (new_graph, new_feature_value) = (* TODO: take value type into account in update_feat *)
......
src/grew_types.ml
View file @ 4d144edc
......@@ -95,11 +95,9 @@ module Massoc_pid = Massoc_make (Pid)
(* This module defines a type for lexical parameter (i.e. one line in a lexical file) *)
module Lex_par = struct
type item = string list * string list (* first list: pattern parameters $id , second list command parameters @id *)
type item = string list
let item_to_string = function
| (l,[]) -> String.concat "#" l
| (pat,com) -> (String.concat "#" pat) ^ "##" ^ (String.concat "#" com)
let item_to_string l = String.concat "#" l
type t = item list
......@@ -111,87 +109,49 @@ module Lex_par = struct
let signature = function
| [] -> Error.bug "[Lex_par.signature] empty data"
| (pp,cp)::_ -> (List.length pp,List.length cp)
| v -> List.length v
let dump t =
printf "[Lex_par.dump] --> size = %d\n" (List.length t);
List.iter (fun (pp,cp) ->
printf "%s##%s\n"
(String.concat "#" pp)
(String.concat "#" cp)
) t
List.iter (fun il -> printf "%s\n" (String.concat "#" il)) t
let parse_line ?loc nb_p nb_c line =
let parse_line ?loc nb_var line =
let line = String_.rm_peripheral_white line in
if line = "" || line.[0] = '%'
then None
else
let line = Str.global_replace (Str.regexp "\\\\%") "%" line in
match Str.split (Str.regexp "##") line with
| [args] when nb_c = 0 ->
(match Str.split (Str.regexp "#") args with
| l when List.length l = nb_p -> Some (l,[])
| _ -> Error.build ?loc
"Illegal lexical parameter line: \"%s\" doesn't contain %d args"
line nb_p)
| [args; values] ->
(match (Str.split (Str.regexp "#") args, Str.split (Str.regexp "#") values) with
| (lp,lc) when List.length lp = nb_p && List.length lc = nb_c -> Some (lp,lc)
| _ -> Error.build ?loc
"Illegal lexical parameter line: \"%s\" doesn't contain %d args and %d values"
line nb_p nb_c)
| _ -> Error.build ?loc "Illegal param line: '%s'" line
let from_lines ?loc nb_p nb_c lines =
match List_.opt_map (parse_line ?loc nb_p nb_c) lines with
match Str.split (Str.regexp "##\\|#") line with
| args when List.length args = nb_var -> Some args
| args -> Error.build ?loc "Wrong param number: '%d instead of %d'" (List.length args) nb_var
let from_lines ?loc nb_var lines =
match List_.opt_map (parse_line ?loc nb_var) lines with
| [] -> Error.build ?loc "Empty lexical parameter list"
| l -> l
let load ?loc dir nb_p nb_c file =
let load ?loc dir nb_var file =
try
let full_file =
if Filename.is_relative file
then Filename.concat dir file
else file in
let lines = File.read full_file in
match List_.opt_mapi (fun i line -> parse_line ~loc:(Loc.file_line full_file i) nb_p nb_c line) lines with
match List_.opt_mapi (fun i line -> parse_line ~loc:(Loc.file_line full_file i) nb_var line) lines with
| [] -> Error.build ?loc "Empty lexical parameter file '%s'" file
| l -> l
with Sys_error _ -> Error.build ?loc "External lexical file '%s' not found" file
let select index atom t =
match
List_.opt_map
(fun (p_par, c_par) ->
let par = List.nth p_par index in
if atom = par
then Some (p_par, c_par)
else None
) t
with
| [] -> None
| t -> Some t
let select index atom t = List.filter (fun par -> List.nth par index = atom) t
let get_param_value index = function
| [] -> Error.bug "[Lex_par.get_param_value] empty parameter"
| (params,_)::_ -> List.nth params index
| params::_ -> List.nth params index
let get_command_value index = function
| [(_,one)] -> List.nth one index
| [] -> Error.bug "[Lex_par.get_command_value] empty parameter"
| (_,[sing])::tail when index=0 ->
Printf.sprintf "%s/%s"
sing
(List_.to_string
(function
| (_,[s]) -> s
| _ -> Error.bug "[Lex_par.get_command_value] inconsistent param"
) "/" tail
)
| (left,_)::_ ->
Error.run "Lexical parameter are not functional, input parameter%s: %s"
(if (List.length left) > 1 then "s" else "")
(String.concat ", " left)
| [one] -> List.nth one index
| _ -> Error.run "Lexical parameter are not functional"
end (* module Lex_par *)
(* ================================================================================ *)
......
src/grew_types.mli
View file @ 4d144edc
......@@ -66,7 +66,7 @@ module Massoc_pid : S with type key = Pid.t
(* ================================================================================ *)
(** module for rules that are lexically parametrized *)
module Lex_par: sig
type t
type t = string list list
val to_json: t -> Yojson.Basic.json
......@@ -76,20 +76,20 @@ module Lex_par: sig
val size: t -> int
(** [signature t] returns (number of pattern parameters, number of lexical parameters) *)
val signature: t -> (int * int)
(** [signature t] returns number of parameters *)
val signature: t -> int
(** [from_lines filename nb_pattern_var nb_command_var strings] *)
val from_lines: ?loc: Loc.t -> int -> int -> string list -> t
(** [from_lines filename nb_var strings] *)
val from_lines: ?loc: Loc.t -> int -> string list -> t
(** [load ?loc local_dir_name nb_pattern_var nb_command_var file] *)
val load: ?loc: Loc.t -> string -> int -> int -> string -> t
(** [load ?loc local_dir_name nb_var file] *)
val load: ?loc: Loc.t -> string -> int -> string -> t
(** [select index atom t] returns the subset of [t] which contains only entries
which refers to [atom] at the [index]^th pattern_var.
[None] is returned if no such entry s founded.
*)
val select: int -> string -> t -> t option
val select: int -> string -> t -> t
(** [get_param_value index t] returns the [index]^th param_var. *)
val get_param_value: int -> t -> string
......
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