Commit 18fc3960 authored by bguillaum's avatar bguillaum

cosmetic

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8448 7838e531-6607-4d57-9587-6c381814729c
parent 090d109d
all:
dot -Tpdf arch.dot -o arch.pdf
clean:
rm -f arch.pdf
\ No newline at end of file
digraph grew {
node [shape=Mrecord];
grew_rule [label="{grew_rule|Instance(_set)\nRule}"]
grew_command [label="{grew_command|Command}"]
grew_grs [label="{grew_grs|Rewrite_history\nModul\nSequence\nGrs}"]
grew_graph [label="{grew_graph|P_deco\nP_graph\nG_deco\nConcat_item\nG_graph}"]
grew_ast [label="{grew_ast|Ast}"]
grew_fs [label="{grew_fs|Domain\nG_fs\nP_fs}"]
grew_node [label="{grew_node|G_node\nP_node}"]
grew_edge [label="{grew_edge|Label\nG_edge\nP_edge}"]
grew_html [label="{grew_html|Html_doc\nHtml_rh\nHtml_sentences\nGr_stat\nCorpus_stat}"]
rankdir = LR;
grew_base
grew_types [label="grew_types|Pid(_map\|_set)\nGid(_map)\nMassoc[_gid\|_pid]\nLabel\nDomain\nConll\nLex_par\nConcat_item"]
grew_ast [label="grew_ast|Ast"]
grew_fs [label="grew_fs|G_fs\nP_fs"]
grew_edge [label="grew_edge|G_edge\nP_edge"]
grew_node [label="grew_node|G_node\nP_node"]
grew_command [label="grew_command|Command"]
grew_graph [label="grew_graph|P_deco\nP_graph\nG_deco\nG_graph"]
grew_rule [label="grew_rule|Instance(_set)\nRule"]
grew_grs [label="grew_grs|Rewrite_history\nModul\nSequence\nGrs"]
grew_html [label="grew_html|Html_doc\nHtml_rh\nHtml_sentences\nHtml_annot\nGr_stat\nCorpus_stat"]
grew_ast -> grew_utils
grew_command -> grew_edge
grew_command -> grew_fs
grew_ast -> grew_types -> grew_base
grew_edge -> grew_ast
grew_fs -> grew_ast
grew_command -> grew_edge
grew_command -> grew_fs
grew_node -> grew_edge
grew_node -> grew_fs
grew_graph -> grew_node
grew_graph -> grew_command
libgrew_types -> grew_graph
grew_rule -> libgrew_types
grew_grs -> grew_rule
grew_html -> grew_grs
grew_node -> grew_edge
grew_node -> grew_fs
grew_rule -> grew_types
grew_types -> grew_graph
libgrew -> grew_html
libgrew -> grew_types [style=dotted]
libgrew -> libgrew_types [style=dotted]
}
\ No newline at end of file
......@@ -210,14 +210,14 @@ module Ast = struct
| Includ of (string * Loc.t)
type grs_with_include = {
domain_wi: Domain.domain;
domain_wi: Domain.t;
labels_wi: (string * string list) list; (* the list of global edge labels *)
modules_wi: module_or_include list;
sequences_wi: sequence list;
}
type grs = {
domain: Domain.domain;
domain: Domain.t;
labels: (string * string list) list;
modules: modul list;
sequences: sequence list;
......
......@@ -147,7 +147,7 @@ module Ast : sig
| Includ of (string * Loc.t)
type grs_with_include = {
domain_wi: Domain.domain;
domain_wi: Domain.t;
labels_wi: (string * string list) list; (* the list of global edge labels *)
modules_wi: module_or_include list;
sequences_wi: sequence list;
......@@ -155,7 +155,7 @@ module Ast : sig
(* a GRS: graph rewriting system *)
type grs = {
domain: Domain.domain;
domain: Domain.t;
labels: (string * string list) list;
modules: modul list;
sequences: sequence list;
......
......@@ -510,33 +510,6 @@ module Id = struct
with Not_found -> None
end (* module Id *)
(* ================================================================================ *)
module Html = struct
let css = String.concat "\n" [
"<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />";
"<link rel=\"stylesheet\" href=\"style.css\" type=\"text/css\">"
]
let enter out_ch ?title ?header base_name =
fprintf out_ch "<html>\n";
(match title with
| Some t -> fprintf out_ch "<head>\n%s\n<title>%s</title>\n</head>\n" css t
| None -> fprintf out_ch "<head>\n%s\n</head>\n" css
);
fprintf out_ch "<body>\n";
(match header with None -> () | Some s -> fprintf out_ch "%s\n" s);
(match title with
| Some t -> fprintf out_ch "<h1>%s</h1>\n" t
| None -> ()
)
let leave out_ch =
fprintf out_ch "</body>\n";
fprintf out_ch "</html>\n";
end (* module Html *)
(* ================================================================================ *)
(* copy from leopar *)
module Timeout = struct
......
......@@ -137,6 +137,7 @@ module List_: sig
val prev_next_iter: (?prev:'a -> ?next:'a -> 'a -> unit) -> 'a list -> unit
end
(* ================================================================================ *)
module type OrderedType =
sig
type t
......@@ -152,7 +153,7 @@ module type OrderedType =
end
(** Input signature of the functor {!Map.Make}. *)
(* ================================================================================ *)
module type S =
sig
type key
......@@ -197,9 +198,10 @@ module type S =
val rename: (key * key) list -> 'a t -> 'a t
end
(* ================================================================================ *)
module Massoc_make (Ord : OrderedType) : S with type key = Ord.t
(* ================================================================================ *)
module Error: sig
exception Build of (string * Loc.t option)
exception Run of (string * Loc.t option)
......@@ -210,6 +212,7 @@ module Error: sig
val bug: ?loc: Loc.t -> ('a, unit, string, 'b) format4 -> 'a
end
(* ================================================================================ *)
module Id: sig
type name = string
type t = int
......@@ -222,11 +225,7 @@ module Id: sig
val build_opt: name -> table -> t option
end
module Html: sig
val enter: out_channel -> ?title: string -> ?header: string -> string -> unit
val leave: out_channel -> unit
end
(* ================================================================================ *)
module Timeout: sig
exception Stop
......
......@@ -18,7 +18,7 @@ open Grew_ast
open Grew_edge
open Grew_fs
(* ==================================================================================================== *)
(* ================================================================================ *)
module Command = struct
type command_node = (* a command node is either: *)
| Pat of Pid.t (* a node identified in the pattern *)
......
......@@ -14,7 +14,7 @@ open Grew_types
open Grew_edge
(* ==================================================================================================== *)
(* ================================================================================ *)
module Command : sig
type command_node = (* a command node is either: *)
| Pat of Pid.t (* a node identified in the pattern *)
......
......@@ -105,4 +105,3 @@ module P_edge = struct
| list -> Binds (i, list))
| _ -> Fail
end (* module P_edge *)
......@@ -13,8 +13,6 @@ open Grew_types
open Grew_ast
(* ================================================================================ *)
(** The module [G_edge] defines the type of Graph label edges: atomic edges *)
module G_edge: sig
......@@ -30,7 +28,6 @@ module G_edge: sig
val to_dep: ?deco:bool -> t -> string
end (* module G_edge *)
(* ================================================================================ *)
(** The module [G_edge] defines the type of Graph label edges: atomic edges *)
module P_edge: sig
......
......@@ -15,7 +15,7 @@ open Grew_base
open Grew_types
open Grew_ast
(* ==================================================================================================== *)
(* ================================================================================ *)
module G_feature = struct
type t = string * value
......@@ -44,9 +44,9 @@ module G_feature = struct
match Str.split (Str.regexp ":C:") string_val with
| [] -> Error.bug "[G_feature.to_dot] feature value '%s'" string_val
| fv::_ -> bprintf buff "<TR><TD ALIGN=\"right\">%s</TD><TD>=</TD><TD ALIGN=\"left\">%s</TD></TR>\n" feat_name fv
end
end (* module G_feature *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module P_feature = struct
(* feature= (feature_name, disjunction of atomic values) *)
......@@ -94,9 +94,9 @@ module P_feature = struct
match List_.pos var l with
| Some index -> (name, Param index)
| None -> Error.build ~loc "[P_feature.build] Unknown pattern variable '%s'" var
end
end (* module P_feature *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module G_fs = struct
(* list are supposed to be striclty ordered wrt compare*)
type t = G_feature.t list
......@@ -257,7 +257,7 @@ module G_fs = struct
)
end (* module G_fs *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module P_fs = struct
(* list are supposed to be striclty ordered wrt compare*)
type t = P_feature.t list
......
......@@ -215,13 +215,6 @@ module G_deco = struct
) t.edges
end (* module G_deco *)
(* ================================================================================ *)
module Concat_item = struct
type t =
| Feat of (Gid.t * string)
| String of string
end (* module Concat_item *)
(* ================================================================================ *)
module G_graph = struct
type t = {
......
......@@ -17,7 +17,7 @@ open Grew_edge
open Grew_node
open Grew_command
(* ==================================================================================================== *)
(* ================================================================================ *)
module P_deco: sig
type t =
{ nodes: Pid.t list;
......@@ -27,7 +27,7 @@ module P_deco: sig
val empty:t
end (* module P_deco *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module G_deco: sig
type t =
{ nodes: (Gid.t * (string * string list)) list;
......@@ -37,10 +37,9 @@ module G_deco: sig
val empty:t
val dump: t -> unit
end (* module G_deco *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module P_graph: sig
type t = P_node.t Pid_map.t
......@@ -74,14 +73,7 @@ module P_graph: sig
(extension * Id.table)
end (* module P_graph *)
(* ==================================================================================================== *)
module Concat_item : sig
type t =
| Feat of (Gid.t * string)
| String of string
end (* module Concat_item *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module G_graph: sig
type t
......@@ -178,6 +170,4 @@ module G_graph: sig
(string * string) list *
(string * string) list list *
(int * string * int) list
end
end (* module G_graph *)
\ No newline at end of file
......@@ -21,7 +21,7 @@ open Grew_graph
open Grew_rule
open Grew_parser
(* ==================================================================================================== *)
(* ================================================================================ *)
module Rewrite_history = struct
type t = {
instance: Instance.t;
......@@ -132,7 +132,7 @@ module Rewrite_history = struct
in loop t
end (* module Rewrite_history *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module Modul = struct
type t = {
name: string;
......@@ -172,7 +172,7 @@ module Modul = struct
check modul; modul
end (* module Modul *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module Sequence = struct
type t = {
name: string;
......@@ -198,7 +198,7 @@ module Sequence = struct
check module_list sequence; sequence
end (* module Sequence *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module Grs = struct
type t = {
......
......@@ -13,7 +13,7 @@ open Grew_graph
open Grew_rule
open Grew_ast
(* ==================================================================================================== *)
(* ================================================================================ *)
module Rewrite_history: sig
type t = {
instance: Instance.t;
......@@ -54,9 +54,9 @@ module Rewrite_history: sig
val det_dep_string: t -> string option
val conll_dep_string: ?keep_empty_rh:bool -> t -> string option
end
end (* module Rewrite_history *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module Modul: sig
type t = {
name: string;
......@@ -67,9 +67,9 @@ module Modul: sig
confluent: bool;
loc: Loc.t;
}
end
end (* module Modul *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module Grs: sig
type t
......@@ -95,4 +95,4 @@ module Grs: sig
val filter_iter: (string -> Rule.t -> unit) -> t -> unit
val modules_of_sequence: t -> string -> Modul.t list
end
end (* module Grs *)
......@@ -38,7 +38,7 @@ let html_header ?css_file ?title ?(add_lines=[]) buff =
List.iter (fun line -> wnl " %s" line) add_lines;
wnl " </head>";
(* ====================================================================================================*)
(* ================================================================================*)
module Html_doc = struct
let string_of_concat_item = function
......@@ -377,7 +377,7 @@ module Html_doc = struct
(function
| Domain.Closed (feat_name,values) -> wnl "<b>%s</b> : %s<br/>" feat_name (String.concat " | " values)
| Domain.Open feat_name -> wnl " <b>%s</b> : *<br/>" feat_name
| Domain.Int feat_name -> wnl " <b>%s</b> : #<br/>" feat_name
| Domain.Num feat_name -> wnl " <b>%s</b> : #<br/>" feat_name
) ast.Ast.domain;
wnl " </code>";
......@@ -496,7 +496,7 @@ module Html_doc = struct
done
end (* module Html_doc *)
(* ==================================================================================================== *)
(* ================================================================================ *)
module Html_rh = struct
let build ?filter ?main_feat ?(dot=false) ?(init_graph=true) ?(out_gr=false) ?header ?graph_file prefix t =
......@@ -637,7 +637,7 @@ module Html_rh = struct
close_out out_ch
end (* module Html_rh *)
(* ====================================================================================================*)
(* ================================================================================*)
module Html_sentences = struct
let build ~title output_dir sentences =
let buff = Buffer.create 32 in
......@@ -674,9 +674,7 @@ module Html_sentences = struct
close_out out_ch
end (* module Html_sentences *)
(* ====================================================================================================*)
(* ================================================================================*)
module Gr_stat = struct
(** the type [gr] stores the stats for the rewriting of one gr file *)
......@@ -792,7 +790,7 @@ module Gr_stat = struct
with Sys_error msg -> Error (sprintf "Sys_error: %s" msg)
end (* module Gr_stat *)
(* ====================================================================================================*)
(* ================================================================================*)
module Corpus_stat = struct
(** the [t] type stores stats for a corpus of gr_files *)
(*
......@@ -1006,11 +1004,8 @@ module Corpus_stat = struct
let out_ch = open_out (Filename.concat output_dir "index.html") in
fprintf out_ch "%s" (Buffer.contents buff);
close_out out_ch
end (* module Stat *)
(* ==================================================================================================== *)
module Html_annot = struct
let script_lines static_dir = [
......@@ -1134,5 +1129,4 @@ module Html_annot = struct
fprintf out_ch "%s" (Buffer.contents buff);
close_out out_ch;
()
end (* module Html_annot *)
......@@ -12,16 +12,18 @@
open Grew_rule
open Grew_grs
(* ================================================================================ *)
module Html_doc : sig
(* dep is a flag which is true iff dep file are shown in doc (iff dep2pict is available) *)
val build: dep:bool -> corpus:bool -> string -> Grs.t -> unit
end
end (* module Html_doc *)
(* ================================================================================ *)
module Html_sentences : sig
val build: title:string -> string -> (bool * string * int * string) list -> unit
end
end (* module Html_sentences *)
(* ================================================================================ *)
module Html_rh: sig
val build:
......@@ -45,8 +47,9 @@ module Html_rh: sig
string ->
Instance.t option ->
unit
end
end (* module Html_rh *)
(* ================================================================================ *)
module Gr_stat: sig
type t
......@@ -55,8 +58,9 @@ module Gr_stat: sig
val save: string -> t -> unit
val load: string -> t
end
end (* module Gr_stat *)
(* ================================================================================ *)
module Corpus_stat: sig
type t
......@@ -70,8 +74,9 @@ module Corpus_stat: sig
input_dir:string ->
output_dir:string ->
t -> unit
end
end (* module Corpus_stat *)
(* ================================================================================ *)
module Html_annot: sig
val build: title:string -> string -> string -> (string * Rewrite_history.t) list -> unit
end
end (* module Html_annot *)
......@@ -89,8 +89,7 @@ module G_node = struct
let position_comp n1 n2 = Pervasives.compare n1.position n2.position
let rename mapping n = {n with next = Massoc_gid.rename mapping n.next}
end
(* ================================================================================ *)
end (* module G_node *)
(* ================================================================================ *)
module P_node = struct
......@@ -130,5 +129,4 @@ module P_node = struct
else raise P_fs.Fail
let compare_pos t1 t2 = Pervasives.compare t1.loc t2.loc
end
(* ================================================================================ *)
end (* module P_node *)
\ No newline at end of file
......@@ -21,7 +21,6 @@ open Grew_node
open Grew_command
open Grew_graph
(* ================================================================================ *)
module Instance = struct
type t = {
......@@ -69,7 +68,7 @@ module Instance = struct
let save_dot_png ?filter ?main_feat base t =
ignore (Dot.to_png_file (G_graph.to_dot ?main_feat t.graph) (base^".png"))
IFDEF DEP2PICT THEN
IFDEF DEP2PICT THEN
let save_dep_png ?filter ?main_feat base t =
let (_,_,highlight_position) =
Dep2pict.Dep2pict.fromDepStringToPng_with_pos
......@@ -82,10 +81,10 @@ IFDEF DEP2PICT THEN
(G_graph.to_dep ?filter ?main_feat t.graph) (base^".svg") in
highlight_position
ELSE
ELSE
let save_dep_png ?filter ?main_feat base t = None
let save_dep_svg ?filter ?main_feat base t = None
ENDIF
ENDIF
end (* module Instance *)
(* ================================================================================ *)
......@@ -392,7 +391,6 @@ module Rule = struct
}
exception Fail
(* ================================================================================ *)
type partial = {
sub: matching;
unmatched_nodes: Pid.t list;
......@@ -405,7 +403,7 @@ module Rule = struct
- all partial matching have the same domain
- the domain of the pattern P is the disjoint union of domain([sub]) and [unmatched_nodes]
*)
(* ---------------------------------------------------------------------- *)
let init param pattern =
let roots = P_graph.roots pattern.graph in
......@@ -426,16 +424,7 @@ module Rule = struct
check = pattern.constraints;
}
(* (\* Ocaml < 3.12 doesn't have exists function for maps! *\) *)
(* exception True *)
(* let gid_map_exists fct map = *)
(* try *)
(* Gid_map.iter (fun k v -> if fct k v then raise True) map; *)
(* false *)
(* with True -> true *)
(* (\* Ocaml < 3.12 doesn't have exists function for maps! *\) *)
(* ---------------------------------------------------------------------- *)
let fullfill graph matching cst =
let get_node pid = G_graph.find (Pid_map.find pid matching.n_match) graph in
let get_string_feat pid = function
......@@ -479,6 +468,7 @@ module Rule = struct
| (Ast.Ge, Some fv1, Some fv2) when fv1 >= fv2 -> true
| _ -> false
(* ---------------------------------------------------------------------- *)
(* returns all extension of the partial input matching *)
let rec extend_matching (positive,neg) (graph:G_graph.t) (partial:partial) =
match (partial.unmatched_edges, partial.unmatched_nodes) with
......@@ -533,6 +523,7 @@ module Rule = struct
(extend_matching_from (positive,neg) graph pid gid partial) @ acc
) graph []
(* ---------------------------------------------------------------------- *)
and extend_matching_from (positive,neg) (graph:G_graph.t) pid (gid : Gid.t) partial =
if List.mem gid partial.already_matched_gids
then [] (* the required association pid -> gid is not injective *)
......@@ -569,10 +560,12 @@ module Rule = struct
extend_matching (positive,neg) graph new_partial
with P_fs.Fail -> []
(* the exception below is added to handle unification failure in merge!! *)
(* ---------------------------------------------------------------------- *)
(* the exception below is added to handle unification failure in merge!! *)
exception Command_execution_fail
(** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
(* ---------------------------------------------------------------------- *)
(** [apply_command instance matching created_nodes command] returns [(new_instance, new_created_nodes)] *)
let apply_command (command,loc) instance matching (created_nodes, (activated_nodes:((Pid.t * string) * Gid.t) list)) =
let node_find cnode = find ~loc cnode (matching, (created_nodes, activated_nodes)) in
......@@ -735,9 +728,9 @@ module Rule = struct
(created_nodes, activated_nodes)
)
(** [apply_rule instance matching rule] returns a new instance after the application of the rule
[Command_execution_fail] is raised if some merge unification fails
*)
(* ---------------------------------------------------------------------- *)
(** [apply_rule instance matching rule] returns a new instance after the application of the rule
[Command_execution_fail] is raised if some merge unification fails *)
let apply_rule instance matching rule =
(* Timeout check *)
......@@ -770,8 +763,7 @@ module Rule = struct
| Some bs -> Some { bs with Libgrew_types.small_step = (instance.Instance.graph, rule_app) :: bs.Libgrew_types.small_step }
}
(*-----------------------------*)
(* ---------------------------------------------------------------------- *)
let update_partial pos_graph without (sub, already_matched_gids) =
let neg_graph = without.graph in
let unmatched_nodes =
......@@ -804,16 +796,17 @@ module Rule = struct
}
(* ---------------------------------------------------------------------- *)
let fulfill (pos_graph,neg_graph) graph new_partial_matching =
match extend_matching (pos_graph, neg_graph) graph new_partial_matching with
| [] -> true (* the without pattern in not found -> OK *)
| x -> false
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
let match_in_graph rule graph =
let pos_graph = rule.pos.graph in
......@@ -836,12 +829,13 @@ module Rule = struct
) matching_list in
List.map fst filtered_matching_list
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ================================================================================ *)
(* ---------------------------------------------------------------------- *)
(** [one_step instance rules] computes the list of one-step reduct with rules *)
let one_step instance rules =
List.fold_left
......@@ -855,7 +849,8 @@ module Rule = struct
) acc matching_list
) [] rules
(** [conf_one_step instance rules] computes one Some (one-step reduct) with rules, None if no rule apply *)
(* ---------------------------------------------------------------------- *)
(** [conf_one_step instance rules] computes one Some (one-step reduct) with rules, None if no rule apply *)
let rec conf_one_step (instance : Instance.t) = function
| [] -> None
| rule::rule_tail ->
......@@ -883,7 +878,8 @@ module Rule = struct
with Not_found -> (* try another rule *) conf_one_step instance rule_tail
(** filter nfs being equal *)
(* ---------------------------------------------------------------------- *)
(** filter nfs being equal *)
let rec filter_equal_nfs nfs =
Instance_set.fold
(fun nf acc ->
......@@ -892,11 +888,9 @@ module Rule = struct
else Instance_set.add nf acc
) nfs Instance_set.empty
(** normalize [t] according to the [rules]
* [t] is a raw graph
* Info about the commands applied on [t] are kept
*)
(* ---------------------------------------------------------------------- *)
(** normalize [t] according to the [rules]. [t] is a raw graph
Info about the commands applied on [t] are kept *)
(* type: Instance.t -> t list -> Instance_set.t *)
let normalize_instance modul_name instance rules =
let rec loop to_do_set nf_set =
......@@ -921,7 +915,7 @@ module Rule = struct
then Log.fwarning "In module \"%s\", %d nf are produced, only %d different ones" modul_name nfs_card reduced_nfs_card;
reduced_nfs
(* ---------------------------------------------------------------------- *)
(* [filter_instance instance filters] return a boolean:
- true iff the instance does NOT match any pattern in [filters] *)
let filter_instance filters instance =
......@@ -950,13 +944,13 @@ module Rule = struct
else loop filter_tail in
loop filters
(* ---------------------------------------------------------------------- *)
let rec conf_normalize instance rules =
match conf_one_step instance rules with
| Some new_instance -> conf_normalize new_instance rules
| None -> Instance.rev_steps instance
(* ---------------------------------------------------------------------- *)
let normalize modul_name ?(confluent=false) rules filters instance =
if confluent
then
......@@ -968,5 +962,4 @@ module Rule = struct
let output_set = normalize_instance modul_name instance rules in
let (good_set, bad_set) = Instance_set.partition (filter_instance filters) output_set in
(good_set, bad_set)
end (* module Rule *)