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

src/grew_ast.ml

@@ -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

src/grew_ast.mli

@@ -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;
     }

src/grew_graph.ml

@@ -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: 

src/grew_graph.mli

@@ -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 -> 

src/grew_grs.ml

@@ -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
+        List.iter (fun rule -> fct modul.Modul.name rule) modul.Modul.rules
+      ) grs.modules
+
+  let filter_iter fct grs =
+    List.iter
+      (fun modul ->
+        List.iter (fun filter -> fct modul.Modul.name filter) modul.Modul.filters
       ) grs.modules
 end  
 

src/grew_grs.mli

@@ -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
 
     

src/grew_html.ml

@@ -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 *)
-        bprintf buff "    <font color=\"purple\">commands</font> <b>{</b>\n";
-        List.iter (buff_html_command buff) rule.Ast.commands;
-        bprintf buff "    <b>}</b>\n"; 
+        (match rule.Ast.commands with
+          | [] -> ()  (* filter *)
+          | list ->
+            bprintf buff "    <font color=\"purple\">commands</font> <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

src/grew_node.ml

@@ -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
 (* ================================================================================ *)
 

src/grew_node.mli

@@ -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
 (* ================================================================================ *)

src/grew_rule.ml

@@ -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
@@ -70,17 +66,17 @@ module Rule = struct
   (* the rewriting depth is bounded to stop rewriting when the system is not terminating *) 
   let max_depth = ref 500
 
-  type const = 
-    | No_out of pid * P_edge.t 
-    | No_in of pid * P_edge.t
+  type const =
+    | 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 ->

src/libgrew.ml

@@ -39,15 +39,17 @@ let load_grs ?doc_output_dir file =
       let grs_ast = Grew_parser.grs_of_file file in
       let grs = Grs.build grs_ast in
       (match doc_output_dir with
-      | None -> ()
-      | Some dir -> 
+        | 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

src/parser/Makefile.in

@@ -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

src/parser/gr_grs_parser.mly

@@ -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)) }