Commit 28d60fa6 authored by bguillaum's avatar bguillaum

html doc and speed up compilation

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@7035 7838e531-6607-4d57-9587-6c381814729c
parent 41b36b1d
This diff is collapsed.
......@@ -43,9 +43,9 @@ module Ast = struct
type u_const =
| Start of Id.name * string list (* (source, labels) *)
| No_out of Id.name
| Cst_out of Id.name
| End of Id.name * string list (* (target, labels) *)
| No_in of Id.name
| Cst_in of Id.name
| Feature_eq of qfn * qfn
type const = u_const * Loc.t
......
......@@ -43,9 +43,9 @@ module Ast : sig
type u_const =
| Start of Id.name * string list (* (source, labels) *)
| No_out of Id.name
| Cst_out of Id.name
| End of Id.name * string list (* (target, labels) *)
| No_in of Id.name
| Cst_in of Id.name
| Feature_eq of qfn * qfn
type const = u_const * Loc.t
......@@ -76,12 +76,13 @@ module Ast : sig
| Update_feat of qfn * concat_item list
type command = u_command * Loc.t
type rule = {
rule_id:Id.name;
pos_pattern: pattern;
neg_patterns: pattern list;
commands: command list;
param: (string*string list) option;
param: (string*string list) option; (* (file, vars) *)
rule_doc:string list;
rule_loc: Loc.t;
}
......
......@@ -94,39 +94,6 @@ module P_graph = struct
) map_without_edges full_edge_list in
(map, table, [](* List.map (build_filter table) constraints *))
let to_dep t =
let buff = Buffer.create 32 in
bprintf buff "[GRAPH] { scale = 200; }\n";
bprintf buff "[WORDS] {\n";
Pid_map.iter
(fun id node ->
bprintf buff " N_%d { word=\"%s\"; subword=\"%s\"}\n"
id
(P_node.get_name node)
(P_fs.to_dep (P_node.get_fs node))
) t;
bprintf buff "}\n";
bprintf buff "[EDGES] {\n";
Pid_map.iter
(fun id_src node ->
Massoc.iter
(fun id_tar edge ->
bprintf buff " N_%d -> N_%d { label=\"%s\"}\n"
id_src id_tar
(P_edge.to_string edge)
)
(P_node.get_next node)
) t;
bprintf buff "}\n";
Buffer.contents buff
(* a type for extension of graph: a former graph exists:
......
......@@ -24,8 +24,6 @@ module P_graph: sig
old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
}
val to_dep: t -> string
val build:
?pat_vars: string list ->
?locals: Label.decl array ->
......
......@@ -320,10 +320,13 @@ module Grs = struct
let rule_iter fct grs =
List.iter
(fun modul ->
List.iter (fun rule -> fct modul.Modul.name rule) modul.Modul.rules
) grs.modules
let filter_iter fct grs =
List.iter
(fun rule ->
fct modul.Modul.name rule
) modul.Modul.rules
(fun modul ->
List.iter (fun filter -> fct modul.Modul.name filter) modul.Modul.filters
) grs.modules
end
......
......@@ -40,6 +40,7 @@ module Grs: sig
val build_rew_display: t -> string -> Instance.t -> Grew_types.rew_display
val rule_iter: (string -> Rule.t -> unit) -> t -> unit
val filter_iter: (string -> Rule.t -> unit) -> t -> unit
end
......
......@@ -59,9 +59,9 @@ module Html = struct
bprintf buff " ";
(match u_const with
| Ast.Start (id,labels) -> bprintf buff "%s -[%s]-> *" id (List_.to_string (fun x->x) "|" labels)
| Ast.No_out id -> bprintf buff "%s -> *" id
| Ast.Cst_out id -> bprintf buff "%s -> *" id
| Ast.End (id,labels) -> bprintf buff "* -[%s]-> %s" (List_.to_string (fun x->x) "|" labels) id
| Ast.No_in id -> bprintf buff "* -> %s" id
| Ast.Cst_in id -> bprintf buff "* -> %s" id
| Ast.Feature_eq (qfn_l, qfn_r) -> bprintf buff "%s = %s" (string_of_qfn qfn_l) (string_of_qfn qfn_r));
bprintf buff "\n"
......@@ -84,7 +84,15 @@ module Html = struct
let buff = Buffer.create 32 in
List.iter
(fun rule ->
bprintf buff "<font color=\"purple\">rule</font> %s <b>{</b>\n" rule.Ast.rule_id;
(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
bprintf buff "<font color=\"purple\">lex_rule</font> %s %s <b>{</b>\n" rule.Ast.rule_id param
);
(* the match part *)
buff_html_pos_pattern buff rule.Ast.pos_pattern;
......@@ -93,9 +101,12 @@ module Html = struct
List.iter (buff_html_neg_pattern buff) rule.Ast.neg_patterns;
(* the commands part *)
(match rule.Ast.commands with
| [] -> () (* filter *)
| list ->
bprintf buff " <font color=\"purple\">commands</font> <b>{</b>\n";
List.iter (buff_html_command buff) rule.Ast.commands;
bprintf buff " <b>}</b>\n";
List.iter (buff_html_command buff) list;
bprintf buff " <b>}</b>\n");
bprintf buff "<b>}</b>\n";
) rules;
......@@ -191,6 +202,22 @@ module Html = struct
w "<IMG src=\"%s\">" dep_pattern_file;
wnl "</pre>";
(match rule_.Ast.param with
| None -> ()
| Some (file, args) ->
let filename = Filename.concat module_.Ast.mod_dir file in
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>";
wnl " </body>";
wnl "</html>";
Buffer.contents buff
......
......@@ -77,6 +77,7 @@ module P_node = struct
name: Id.name;
fs: P_fs.t;
next: P_edge.t Massoc.t;
loc: Loc.t option;
}
let get_name t = t.name
......@@ -85,7 +86,7 @@ module P_node = struct
let unif_fs fs t = { t with fs = P_fs.unif fs t.fs }
let empty = { fs = P_fs.empty; next = Massoc.empty; name = "" }
let empty = { fs = P_fs.empty; next = Massoc.empty; name = ""; loc=None }
let build ?pat_vars (ast_node, loc) =
(ast_node.Ast.node_id,
......@@ -93,6 +94,7 @@ module P_node = struct
name = ast_node.Ast.node_id;
fs = P_fs.build ?pat_vars ast_node.Ast.fs;
next = Massoc.empty;
loc = Some loc;
} )
let add_edge p_edge pid_tar t =
......@@ -102,6 +104,7 @@ module P_node = struct
let match_ ?param p_node g_node = P_fs.match_ ?param p_node.fs (G_node.get_fs g_node)
let compare_pos t1 t2 = Pervasives.compare t1.loc t2.loc
end
(* ================================================================================ *)
......
......@@ -56,5 +56,6 @@ module P_node: sig
val match_: ?param: Lex_par.t -> t -> G_node.t -> Lex_par.t option
val compare_pos: t -> t -> int
end
(* ================================================================================ *)
......@@ -32,7 +32,6 @@ module Instance = struct
{ empty with graph = graph }
let of_conll ?loc lines =
(match loc with None -> "None" | Some (f,l) -> Printf.sprintf "(%s,%d)" f l);
{ empty with graph = G_graph.of_conll ?loc lines }
let rev_steps t =
......@@ -57,9 +56,6 @@ end (* module Instance *)
module Instance_set = Set.Make (Instance)
(* ================================================================================ *)
module Rule = struct
(* the [pid] type is used for pattern identifier *)
type pid = Pid.t
......@@ -71,16 +67,16 @@ module Rule = struct
let max_depth = ref 500
type const =
| No_out of pid * P_edge.t
| No_in of pid * P_edge.t
| Cst_out of pid * P_edge.t
| Cst_in of pid * P_edge.t
| Feature_eq of pid * string * pid * string
| Filter of pid * P_fs.t (* used when a without impose a fs on a node defined by the match pattern *)
let build_constraint ?locals table = function
| (Ast.Start (node_name, labels), loc) -> No_out (Id.build ~loc node_name table, P_edge.make ?locals labels)
| (Ast.No_out node_name, loc) -> No_out (Id.build ~loc node_name table, P_edge.all)
| (Ast.End (node_name, labels),loc) -> No_in (Id.build ~loc node_name table, P_edge.make ?locals labels)
| (Ast.No_in node_name, loc) -> No_in (Id.build ~loc node_name table, P_edge.all)
| (Ast.Start (node_name, labels), loc) -> Cst_out (Id.build ~loc node_name table, P_edge.make ?locals labels)
| (Ast.Cst_out node_name, loc) -> Cst_out (Id.build ~loc node_name table, P_edge.all)
| (Ast.End (node_name, labels),loc) -> Cst_in (Id.build ~loc node_name table, P_edge.make ?locals labels)
| (Ast.Cst_in node_name, loc) -> Cst_in (Id.build ~loc node_name table, P_edge.all)
| (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Feature_eq (Id.build ~loc node_name1 table, feat_name1, Id.build ~loc node_name2 table, feat_name2)
......@@ -108,10 +104,10 @@ module Rule = struct
let id_build loc string_id =
match Id.build_opt string_id pos_table with Some i -> i | None -> -1-(Id.build ~loc string_id neg_table) in
match const with
| (Ast.Start (node_name, labels),loc) -> No_out (id_build loc node_name, P_edge.make ?locals labels)
| (Ast.No_out node_name, loc) -> No_out (id_build loc node_name, P_edge.all)
| (Ast.End (node_name, labels),loc) -> No_in (id_build loc node_name, P_edge.make ?locals labels)
| (Ast.No_in node_name, loc) -> No_in (id_build loc node_name, P_edge.all)
| (Ast.Start (node_name, labels),loc) -> Cst_out (id_build loc node_name, P_edge.make ?locals labels)
| (Ast.Cst_out node_name, loc) -> Cst_out (id_build loc node_name, P_edge.all)
| (Ast.End (node_name, labels),loc) -> Cst_in (id_build loc node_name, P_edge.make ?locals labels)
| (Ast.Cst_in node_name, loc) -> Cst_in (id_build loc node_name, P_edge.all)
| (Ast.Feature_eq ((node_name1, feat_name1), (node_name2, feat_name2)), loc) ->
Feature_eq (id_build loc node_name1, feat_name1, id_build loc node_name2, feat_name2)
......@@ -147,7 +143,59 @@ module Rule = struct
let get_loc t = t.loc
let to_dep t = P_graph.to_dep t.pos.graph
let to_dep t =
let buff = Buffer.create 32 in
bprintf buff "[GRAPH] { scale = 200; }\n";
let nodes =
Pid_map.fold
(fun id node acc ->
(node, sprintf " N_%d { word=\"%s\"; subword=\"%s\"}" id (P_node.get_name node) (P_fs.to_dep (P_node.get_fs node)))
:: acc
) t.pos.graph [] in
(* noodes are sorted to appear in the same order in dep picture and in input file *)
let sorted_nodes = List.sort (fun (n1,_) (n2,_) -> P_node.compare_pos n1 n2) nodes in
bprintf buff "[WORDS] {\n";
List.iter
(fun (_, dep_line) -> bprintf buff "%s\n" dep_line
) sorted_nodes;
List_.iteri
(fun i cst ->
match cst with
| Cst_out _ | Cst_in _ -> bprintf buff " C_%d { word=\"*\"}\n" i
| _ -> ()
) t.pos.constraints;
bprintf buff "}\n";
bprintf buff "[EDGES] {\n";
Pid_map.iter
(fun id_src node ->
Massoc.iter
(fun id_tar edge ->
bprintf buff " N_%d -> N_%d { label=\"%s\"}\n"
id_src id_tar
(P_edge.to_string edge)
)
(P_node.get_next node)
) t.pos.graph;
List_.iteri
(fun i cst ->
match cst with
| Cst_out (pid, edge) ->
bprintf buff " N_%d -> C_%d {label = \"%s\"; style=dot; bottom; color=green;}\n"
pid i (P_edge.to_string edge)
| Cst_in (pid, edge) ->
bprintf buff " C_%d -> N_%d {label = \"%s\"; style=dot; bottom; color=green;}\n"
i pid (P_edge.to_string edge)
| _ -> ()
) t.pos.constraints;
bprintf buff "}\n";
Buffer.contents buff
let is_filter t = t.commands = []
......@@ -293,10 +341,10 @@ module Rule = struct
let fullfill graph matching = function
| No_out (pid,edge) ->
| Cst_out (pid,edge) ->
let gid = Pid_map.find pid matching.n_match in
G_graph.edge_out graph gid edge
| No_in (pid,edge) ->
| Cst_in (pid,edge) ->
let gid = Pid_map.find pid matching.n_match in
gid_map_exists (* should be Gid_map.exists with ocaml 3.12 *)
(fun _ node ->
......
......@@ -42,12 +42,14 @@ let load_grs ?doc_output_dir file =
| None -> ()
| Some dir ->
Html.proceed dir grs_ast;
Grs.rule_iter
(fun modul_name rule ->
let dep_code = Rule.to_dep rule in
let dep_svg_file = sprintf "%s/%s_%s-patt.png" dir modul_name (Rule.get_name rule) in
ignore (Dep2pict.fromDepStringToPng dep_code dep_svg_file)
) grs
(* draw pattern graphs for all rules and all filters *)
let fct module_ rule_ =
let dep_code = Rule.to_dep rule_ in
let dep_svg_file = sprintf "%s/%s_%s-patt.png" dir module_ (Rule.get_name rule_) in
ignore (Dep2pict.fromDepStringToPng dep_code dep_svg_file) in
Grs.rule_iter fct grs;
Grs.filter_iter fct grs
);
grs
with
......
......@@ -5,36 +5,36 @@ byte: parser_global.cmo gr_grs_parser.cmo lexer.cmo grew_parser.cmo
include ../../config/Makefile
parser_global.cmo: parser_global.ml
ocamlc -c $(BYTE_FLAGS) parser_global.ml
ocamlc.opt -c $(BYTE_FLAGS) parser_global.ml
parser_global.cmx: parser_global.ml
ocamlopt -c $(OPT_FLAGS) parser_global.ml
ocamlopt.opt -c $(OPT_FLAGS) parser_global.ml
gr_grs_parser.ml: gr_grs_parser.mly
menhir --infer --ocamlc "ocamlc -c -I .. grew_utils.cmo grew_ast.cmo parser_global.cmo" gr_grs_parser.mly
gr_grs_parser.cmx: gr_grs_parser.ml ../grew_utils.cmx ../grew_ast.cmx parser_global.cmo
ocamlopt -c $(OPT_FLAGS) -I .. grew_utils.cmx grew_ast.cmx gr_grs_parser.mli
ocamlopt -c $(OPT_FLAGS) -I .. grew_utils.cmx grew_ast.cmx gr_grs_parser.ml
ocamlopt.opt -c $(OPT_FLAGS) -I .. grew_utils.cmx grew_ast.cmx gr_grs_parser.mli
ocamlopt.opt -c $(OPT_FLAGS) -I .. grew_utils.cmx grew_ast.cmx gr_grs_parser.ml
gr_grs_parser.cmo: gr_grs_parser.ml ../grew_utils.cmo ../grew_ast.cmx parser_global.cmo
ocamlc -c $(BYTE_FLAGS) -I .. grew_utils.cmo grew_ast.cmo gr_grs_parser.mli
ocamlc -c $(BYTE_FLAGS) -I .. grew_utils.cmo grew_ast.cmo gr_grs_parser.ml
ocamlc.opt -c $(BYTE_FLAGS) -I .. grew_utils.cmo grew_ast.cmo gr_grs_parser.mli
ocamlc.opt -c $(BYTE_FLAGS) -I .. grew_utils.cmo grew_ast.cmo gr_grs_parser.ml
lexer.ml: lexer.mll
ocamllex lexer.mll
lexer.cmx: gr_grs_parser.cmx lexer.ml ../grew_ast.cmx
ocamlopt -c $(OPT_FLAGS) -I .. grew_ast.cmx lexer.ml
ocamlopt.opt -c $(OPT_FLAGS) -I .. grew_ast.cmx lexer.ml
lexer.cmo: gr_grs_parser.cmo lexer.ml ../grew_ast.cmo
ocamlc -c $(BYTE_FLAGS) -I .. grew_ast.cmo lexer.ml
ocamlc.opt -c $(BYTE_FLAGS) -I .. grew_ast.cmo lexer.ml
grew_parser.cmx: gr_grs_parser.cmx lexer.cmx grew_parser.ml ../grew_ast.cmx
ocamlopt -c $(OPT_FLAGS) -I .. grew_ast.cmx grew_parser.ml
ocamlopt.opt -c $(OPT_FLAGS) -I .. grew_ast.cmx grew_parser.ml
grew_parser.cmo: gr_grs_parser.cmo lexer.cmo grew_parser.ml ../grew_ast.cmo
ocamlc -c $(BYTE_FLAGS) -I .. grew_ast.cmo grew_parser.ml
ocamlc.opt -c $(BYTE_FLAGS) -I .. grew_ast.cmo grew_parser.ml
clean:
rm -rf *.cmi *.cmx *.cmo lexer.ml gr_grs_parser.ml *.o *.mli *.annot
......@@ -426,7 +426,7 @@ pat_const:
(* "A -> *" *)
| n1 = IDENT GOTO_NODE STAR
{ localize (Ast.No_out n1) }
{ localize (Ast.Cst_out n1) }
(* "* -[X|Y]-> A" *)
| STAR labels = delimited(LTR_EDGE_LEFT,separated_nonempty_list(PIPE,IDENT),LTR_EDGE_RIGHT) n2 = IDENT
......@@ -434,7 +434,7 @@ pat_const:
(* "* -> A" *)
| STAR GOTO_NODE n2 = IDENT
{ localize (Ast.No_in n2) }
{ localize (Ast.Cst_in n2) }
| qfn1 = QFN EQUAL qfn2 = QFN
{ localize (Ast.Feature_eq (qfn1, qfn2)) }
......
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