Commit 54d71609 authored by bguillaum's avatar bguillaum

(conservative) syntax extension: local lexical parameters, any number of lexical files

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@7201 7838e531-6607-4d57-9587-6c381814729c
parent f6b78841
......@@ -93,7 +93,8 @@ module Ast = struct
pos_pattern: pattern;
neg_patterns: pattern list;
commands: command list;
param: (string*string list) option;
param: (string list * string list) option;
lp: string list option;
rule_doc:string list;
rule_loc: Loc.t;
}
......
......@@ -82,7 +82,8 @@ module Ast : sig
pos_pattern: pattern;
neg_patterns: pattern list;
commands: command list;
param: (string*string list) option; (* (file, vars) *)
param: (string list * string list) option; (* (files, vars) *)
lp: string list option; (* lexical parameters in the file *)
rule_doc:string list;
rule_loc: Loc.t;
}
......
......@@ -84,13 +84,19 @@ module Html = struct
let buff = Buffer.create 32 in
List.iter
(fun rule ->
(* the first line: (lex_)rule / filter *)
(match (rule.Ast.commands, rule.Ast.param) with
| ([], None) ->
bprintf buff "<font color=\"purple\">filter</font> %s <b>{</b>\n" rule.Ast.rule_id
| (_,None) ->
bprintf buff "<font color=\"purple\">rule</font> %s <b>{</b>\n" rule.Ast.rule_id
| (_,Some (file, vars)) ->
let param = sprintf "(feature %s; file \"%s\")" (String.concat ", " vars) file in
| (_,Some (files, vars)) ->
let param =
match files with
| [] -> sprintf "(feature %s)" (String.concat ", " vars)
| l -> sprintf "(feature %s; %s)"
(String.concat ", " vars)
(String.concat ", " (List.map (fun f -> sprintf "file \"%s\"" f) l)) in
bprintf buff "<font color=\"purple\">lex_rule</font> %s %s <b>{</b>\n" rule.Ast.rule_id param
);
......@@ -202,22 +208,39 @@ module Html = struct
w "<IMG src=\"%s\">" dep_pattern_file;
wnl "</pre>";
let output_table args lines =
wnl " <table border=\"1\" cellspacing=\"0\" cellpadding=\"3\">";
wnl " <tr>%s</tr>" (List_.to_string (fun x -> sprintf "<th bgcolor=\"#cccccc\">%s</th>" x) "" args);
List.iter
(fun l -> wnl "<tr>%s</tr>"
(List_.to_string (fun x -> sprintf "<td>%s</td>" x) "" (Str.split (Str.regexp "#+") l))
) lines;
wnl " </table>" in
(match rule_.Ast.param with
| None -> ()
| Some (file, args) ->
let filename = Filename.concat module_.Ast.mod_dir file in
| Some (files, args) ->
wnl "<h6>Lexical parameters</h6>";
wnl "<b>File:</b> %s</br>" file;
let lines =
try File.read filename
with Sys_error msg -> wnl "<font color=\"red\">Error: %s</font>" msg; [] in
wnl " <table border=\"1\">";
wnl " <tr>%s</tr>" (List_.to_string (fun x -> sprintf "<th bgcolor=\"#cccccc\">%s</th>" x) "" args);
List.iter
(fun l -> wnl "<tr>%s</tr>"
(List_.to_string (fun x -> sprintf "<td>%s</td>" x) "" (Str.split (Str.regexp "#+") l))
) lines);
wnl " </table>";
(* output local lexical parameters (if any) *)
(match rule_.Ast.lp with
| None -> ()
| Some string ->
wnl "<b>Local parameters</b></br>";
output_table args (Str.split (Str.regexp "\n") string)
);
(* output external lexical parameters (if any) *)
List.iter
(fun file ->
let filename = Filename.concat module_.Ast.mod_dir file in
wnl "<b>File:</b> %s</br>" file;
let lines =
try File.read filename
with Sys_error msg -> wnl "<font color=\"red\">Error: %s</font>" msg; [] in
output_table args lines
) files
);
wnl " </body>";
wnl "</html>";
Buffer.contents buff
......
......@@ -230,11 +230,21 @@ module Rule = struct
let (param, pat_vars, cmd_vars) =
match rule_ast.Ast.param with
| None -> (None,[],[])
| Some (file,vars) ->
| 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 param = Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file in
let param = List.fold_left
(fun acc file ->
Lex_par.append
(Lex_par.load ~loc:rule_ast.Ast.rule_loc dir nb_pv nb_cv file)
acc
)
(match rule_ast.Ast.lp with
| None -> Lex_par.empty
| Some lines -> Lex_par.from_lines ~loc:rule_ast.Ast.rule_loc nb_pv nb_cv lines
)
files in
(Some param, pat_vars, cmd_vars) in
let (pos,pos_table) = build_pos_pattern ~pat_vars ~locals rule_ast.Ast.pos_pattern in
......
......@@ -554,39 +554,41 @@ module Lex_par = struct
type t = item list
let empty=[]
let append = List.append
let rm_peripheral_white s =
Str.global_replace (Str.regexp "\\( \\|\t\\)*$") ""
(Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "" s)
let parse_line ?loc nb_p nb_c line =
let line = rm_peripheral_white 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 -> (l,[])
| _ -> Error.bug ?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 -> (lp,lc)
| _ -> Error.bug ?loc
"Illegal lexical parameter line: \"%s\" doesn't contain %d args and %d values"
line nb_p nb_c)
| _ -> Error.bug ?loc "Illegal param line: '%s'" line
let from_lines ?loc nb_p nb_c lines = List.map (parse_line ?loc nb_p nb_c) lines
let load ?loc dir nb_p nb_c 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
let param =
(List.map
(fun line ->
let line = rm_peripheral_white 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 -> (l,[])
| _ -> Error.bug
"Illegal param line in file \"%s\", the line \"%s\" doesn't contain %d args"
full_file 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 -> (lp,lc)
| _ -> Error.bug
"Illegal param line in file \"%s\", the line \"%s\" doesn't contain %d args and %d values"
full_file line nb_p nb_c)
| _ -> Error.bug "Illegal param line in file '%s' line '%s'" full_file line
) lines
) in
param
List_.mapi (fun i line -> parse_line ~loc:(full_file,i) nb_p nb_c line) lines
with Sys_error _ -> Error.build ?loc "External lexical file '%s' not found" file
let sub x y = List.mem x (Str.split (Str.regexp "|") y)
......
......@@ -122,7 +122,8 @@ module List_: sig
val foldi_left: (int -> 'a -> 'b -> 'a) -> 'a -> 'b list -> 'a
end
(* module Massoc implements multi-association data: keys are int and the same key can be
(* ================================================================================ *)
(* module Massoc implements multi-association data: keys are (hardly coded as) int and the same key can be
associated with a set of values *)
module Massoc: sig
type 'a t
......@@ -215,6 +216,12 @@ end
module Lex_par: sig
type t
val empty:t
val append: t -> t -> t
(** [from_lines filename nb_pattern_var nb_command_var strings] *)
val from_lines: ?loc: Loc.t -> int -> 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
......
......@@ -73,6 +73,7 @@ let localize t = (t,get_loc ())
%token <string> STRING
%token <int> INT
%token <string list> COMMENT
%token <string list> LP
%token EOF /* end of file */
......@@ -290,17 +291,19 @@ rule:
neg_patterns = n;
commands = cmds;
param = None;
lp = 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
| doc = option(rule_doc) LEX_RULE id = rule_id param=option(param) LACC p = pos_item n = list(neg_item) cmds = commands RACC lp = option(lp)
{
{ Ast.rule_id = fst id;
pos_pattern = p;
neg_patterns = n;
commands = cmds;
param = param;
lp = lp;
rule_doc = begin match doc with Some d -> d | None -> [] end;
rule_loc = (!Parser_global.current_file,snd id);
}
......@@ -312,14 +315,21 @@ rule:
neg_patterns = n;
commands = [];
param = None;
lp = None;
rule_doc = begin match doc with Some d -> d | None -> [] end;
rule_loc = (!Parser_global.current_file,snd id);
}
}
lp:
| lp = LP {lp}
param:
| LPAREN FEATURE vars = separated_nonempty_list(COMA,var) SEMIC FILE file=STRING RPAREN { (file,vars) }
| LPAREN FEATURE vars = separated_nonempty_list(COMA,var) RPAREN { ([],vars) }
| LPAREN FEATURE vars = separated_nonempty_list(COMA,var) SEMIC files = separated_list(COMA, file) RPAREN { (files,vars) }
file:
| FILE f=STRING {f}
var:
| i = PAT {i}
| i = CMD {i}
......
{
open Printf
open Log
open Grew_ast
open Gr_grs_parser
exception Error of string
let tmp_string = ref ""
let escaped = ref false
let parse_qfn string_feat =
let parse_qfn string_feat =
match Str.split (Str.regexp "\\.") string_feat with
| [node; feat_name] -> (node, feat_name)
| _ -> Log.fcritical "[BUG] \"%s\" is not a feature" string_feat
let split_comment com =
let raw = Str.split (Str.regexp "\n") com in
List.filter (fun l -> not (Str.string_match (Str.regexp "[ \t]*$") l 0)) raw;;
List.filter (fun l -> not (Str.string_match (Str.regexp "[ \t]*$") l 0)) raw
let lp_buff = Buffer.create 32
}
let digit = ['0'-'9']
......@@ -37,32 +37,38 @@ and comment_multi_doc target = shortest
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;
incr Parser_global.current_line;
Lexing.new_line lexbuf;
done; assert false
with Not_found ->
COMMENT(split_comment comment)
COMMENT(split_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 }
| _ as c { escaped := false; tmp_string := !tmp_string^(sprintf "%c" c); string_lex target lexbuf }
and lp_lex target = parse
| '\n' { incr Parser_global.current_line; Lexing.new_line lexbuf; bprintf lp_buff "\n"; lp_lex target lexbuf }
| _ as c { bprintf lp_buff "%c" c; lp_lex target lexbuf }
| "#END" [' ' '\t']* '\n' { incr Parser_global.current_line; LP (Str.split (Str.regexp "\n") (Buffer.contents lp_buff)) }
and global = parse
| [' ' '\t'] { global lexbuf }
| "%--" { comment_multi_doc global lexbuf }
| "/*" { comment_multi global lexbuf }
| '%' { comment global lexbuf }
| "#BEGIN" [' ' '\t']* '\n' { incr Parser_global.current_line; Buffer.clear lp_buff; lp_lex global lexbuf}
| '\n' { incr Parser_global.current_line; Lexing.new_line lexbuf; global lexbuf}
......@@ -123,10 +129,8 @@ and global = parse
| "==>" { LONGARROW }
| '"' { tmp_string := ""; string_lex global lexbuf }
| eof { EOF }
| _ as c { raise (Error (Printf.sprintf "At line %d: unexpected character '%c'.\n" (lexbuf.Lexing.lex_start_p.Lexing.pos_lnum) c)) }
| _ as c { raise (Error (sprintf "At line %d: unexpected character '%c'" (lexbuf.Lexing.lex_start_p.Lexing.pos_lnum) c)) }
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