Commit b7499232 authored by Bruno Guillaume's avatar Bruno Guillaume

clean code

parent 678ebfcb
digraph grew {
node [shape=Mrecord];
rankdir = LR;
grew_base [label="grew_base|String_set\nString_map\nInt_set\nInt_map\nLoc\nError\nString_\nDot\nFile\nArray_\nList_\nMassoc_make()\nId\nTimeout\nGlobal"]
grew_base [label="grew_base|String_set\nString_map\nInt_set\nInt_map\nLoc\nError\nString_\nFile\nArray_\nList_\nMassoc_make()\nId\nTimeout\nGlobal"]
grew_types [label="grew_types|Pid\nPid_set\nPid_map\nGid\nGid_map\nMassoc_gid\nMassoc_pid\nMassoc_string\nLexicon\nLexicons\nConcat_item"]
grew_ast [label="grew_ast|Ast"]
grew_domain [label="grew_domain|Label_domain\nFeature_domain\nDomain"]
......@@ -10,7 +10,7 @@ digraph grew {
grew_edge [label="grew_edge|Label\nLabel_cst\nG_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_graph [label="grew_graph|P_deco\nP_graph\nG_deco\nG_graph\nDelta\nGraph_with_history\nGraph_with_history_set"]
grew_rule [label="grew_rule|Rule"]
grew_grs [label="grew_grs|Grs"]
......
......@@ -387,7 +387,7 @@ module Ast = struct
| T (_,_,l) -> List.flatten (List.map word_list l)
type strat =
| Ref of node_ident (* reference to a rule name or to another strategy *)
| Ref of node_ident (* reference to a rule name or to another strategy *)
| Pick of strat (* pick one normal form a the given strategy; return 0 if nf *)
| Alt of strat list (* a set of strategies to apply in parallel *)
| Seq of strat list (* a sequence of strategies to apply one after the other *)
......@@ -420,7 +420,7 @@ module Ast = struct
let strat_list grs =
let rec loop pref = function
[] -> []
| [] -> []
| Strategy (_,name,_) :: tail -> name :: (loop pref tail)
| Package (_,pack_name,decl_list) :: tail -> (loop (pref^"."^pack_name) decl_list) @ (loop pref tail)
| _ :: tail -> loop pref tail
......
......@@ -23,7 +23,6 @@ module Loc = struct
let empty = (None, None)
let file f = (Some f, None)
let file_line f l = (Some f, Some l)
let file_opt_line fo l = (fo, Some l)
let file_opt_line_opt fo lo = (fo, lo)
let set_line l (x,_) = (x, Some l)
......@@ -59,7 +58,6 @@ end (* module Error *)
(* ================================================================================ *)
module String_ = struct
let to_float string =
try float_of_string string
with _ ->
......@@ -79,15 +77,6 @@ module String_ = struct
end (* module String_ *)
(* ================================================================================ *)
module Dot = struct
let to_png_file dot output_file =
let temp_file_name,out_ch = Filename.open_temp_file ~mode:[Open_rdonly;Open_wronly;Open_text] "grewui_" ".dot" in
fprintf out_ch "%s" dot;
close_out out_ch;
ignore(Sys.command(sprintf "dot -Tpng -o %s %s " output_file temp_file_name))
end (* module Dot *)
(* ================================================================================ *)
module File = struct
let write data name =
......@@ -218,11 +207,6 @@ module List_ = struct
| _::t -> loop (i+1) t in
loop 0 l
let rec opt = function
| [] -> []
| None :: t -> opt t
| Some x :: t -> x :: (opt t)
let rec opt_map f = function
| [] -> []
| x::t ->
......
......@@ -21,7 +21,6 @@ module Loc: sig
val empty: t
val file_line: string -> int -> t
val file_opt_line: string option -> int -> t
val file_opt_line_opt: string option -> int option -> t
val file: string -> t
......@@ -52,31 +51,25 @@ module String_: sig
(* [to_float]: robust conversion of string to float whatever is the locale *)
val to_float: string -> float
(* [to_float]: robust conversion of float to string whatever is the locale *)
(* [of_float]: robust conversion of string to float (both . and , is accepted as separator) *)
val of_float: float -> string
(* [re_match regexp s] returns true iff the full string [s] matches with [regexp] *)
val re_match: Str.regexp -> string -> bool
(* [rm_first_char s] returns the string [s] without the first charater if s is not empty.
If s in empty, the empty string is returned *)
If [s] in empty, the empty string is returned *)
val rm_first_char: string -> string
(* [rm_peripheral_white s] returns the string [s] without any white space ot tab
(* [rm_peripheral_white s] returns the string [s] without any white space or tab
at the beginning or at the end of the string. *)
val rm_peripheral_white: string -> string
end
(* ================================================================================ *)
(* [Dot] function to manipulate the dot format *)
module Dot: sig
val to_png_file: string -> string -> unit
end
end (* module String_ *)
(* ================================================================================ *)
(* [File] functions to read/write file *)
module File: sig
(** [write data file_name] write [data] in file named [file_name] *)
(** [write data file_name] write [data] in [file_name] *)
val write: string -> string -> unit
(** [read file_name] read the content of [file_name] line by line.
......@@ -114,15 +107,14 @@ module Array_: sig
(* [dicho_find_assoc key array] returns the value associated with [key] in the assoc [array].
[Not found] is raised if [key] is not defined in [array].
Warning: the array MUST be sorted (with respect to the first component) and without duplicates. *)
val dicho_find_assoc: 'a -> ('a*'b) array -> int
end
val dicho_find_assoc: 'a -> ('a * 'b) array -> int
end (* module Array_ *)
(* ================================================================================ *)
(* [List_] contains additional functions on the caml [list] type. *)
module List_: sig
(** [rm elt list] removes the first occurence of [elt] in [list]. [Not_found] can be raised. *)
val rm: 'a -> 'a list -> 'a list
val opt: 'a option list -> 'a list
val set: int -> 'a -> 'a list -> 'a list
......@@ -141,7 +133,9 @@ module List_: sig
val opt_mapi: (int -> 'a -> 'b option) -> 'a list -> 'b list
val flat_map: ('a -> 'b list) -> 'a list -> 'b list
(* remove [elt] from [list]. raise Not_found if [elt] is not in [list] *)
(** [remove elt list] remove the first occurence od [elt] in [list].
raise Not_found if [elt] is not in [list] *)
val remove: 'a -> 'a list -> 'a list
val foldi_left: (int -> 'a -> 'b -> 'a) -> 'a -> 'b list -> 'a
......@@ -150,6 +144,7 @@ module List_: sig
val sort_disjoint: 'a list -> 'a list -> bool
val to_string: ('a -> string) -> string -> 'a list -> string
val rev_to_string: ('a -> string) -> string -> 'a list -> string
val sort_mem: 'a -> 'a list -> bool
......
......@@ -21,7 +21,7 @@ module Feature_value: sig
val build_disj: ?loc:Loc.t -> ?domain: Domain.t -> feature_name -> feature_atom list -> value list
val build_value: ?loc:Loc.t -> ?domain: Domain.t -> feature_name -> feature_atom -> value
end (* module Feature_domain *)
end (* module Feature_value *)
(* ================================================================================ *)
......
......@@ -1032,15 +1032,17 @@ module G_graph = struct
let cast ?domain graph = match (domain, graph.domain) with
| (None, _) -> graph
| (Some new_domain, Some dom) when dom == new_domain -> (* ====== NO CAST NEEDED ====== *) graph
| _ -> (* ====== CASTING NEEDED ====== *) of_conll ?domain (to_conll graph)
| (Some new_domain, Some dom) when dom == new_domain ->
(* ====== NO CAST NEEDED ====== *) graph
| _ ->
(* ====== CASTING NEEDED ====== *) of_conll ?domain (to_conll graph)
end (* module G_graph *)
(* ================================================================================ *)
(* The module [Delta] defines a type for recording the effect of a set of commands on a graph *)
(* It is used a key to detect egal graphs based on rewriting history *)
(* It is used as key to detect egal graphs based on rewriting history *)
module Delta = struct
type status = Add | Del
......@@ -1098,6 +1100,7 @@ module Delta = struct
{ t with feats = loop t.feats }
end (* module Delta *)
(* ================================================================================ *)
module Graph_with_history = struct
type t = {
seed: G_graph.t;
......@@ -1112,4 +1115,5 @@ module Graph_with_history = struct
let compare t1 t2 = Pervasives.compare (t1.delta,t1.added_gids) (t2.delta, t2.added_gids)
end (* module Graph_with_history*)
(* ================================================================================ *)
module Graph_with_history_set = Set.Make (Graph_with_history)
......@@ -202,6 +202,7 @@ module G_graph: sig
val cast: ?domain:Domain.t -> t -> t
end (* module G_graph *)
(* ================================================================================ *)
module Delta : sig
type t
......@@ -211,8 +212,9 @@ module Delta : sig
val add_edge: Gid.t -> Label.t -> Gid.t -> t -> t
val del_edge: Gid.t -> Label.t -> Gid.t -> t -> t
val set_feat: G_graph.t -> Gid.t -> feature_name -> value option -> t -> t
end
end (* module Delta *)
(* ================================================================================ *)
module Graph_with_history : sig
type t = {
seed: G_graph.t;
......@@ -224,6 +226,7 @@ module Graph_with_history : sig
val from_graph: G_graph.t -> t
val compare: t -> t -> int
end
end (* module Graph_with_history *)
(* ================================================================================ *)
module Graph_with_history_set : Set.S with type elt = Graph_with_history.t
......@@ -75,9 +75,9 @@ module Grs = struct
let rec build_decl ?domain = function
| Ast.Package (loc, name, decl_list) -> Package (name, List.map (build_decl ?domain) decl_list)
| Ast.Rule ast_rule -> Rule (Rule.build ?domain "TODO: remove this arg (old grs)" ast_rule)
| Ast.Rule ast_rule -> Rule (Rule.build ?domain ast_rule)
| Ast.Strategy (loc, name, ast_strat) -> Strategy (name, ast_strat)
| _ -> Error.bug "[build_decl] Inconsistent ast for new_grs"
| _ -> Error.bug "[build_decl] Inconsistent ast for grs"
let domain t = t.domain
......@@ -117,8 +117,8 @@ module Grs = struct
| Ast.Features _ -> None
| Ast.Labels _ -> None
| Ast.Conll_fields _ -> None
| Ast.Import _ -> Error.bug "[load] Import: inconsistent ast for new_grs"
| Ast.Include _ -> Error.bug "[load] Include: inconsistent ast for new_grs"
| Ast.Import _ -> Error.bug "[load] Import: inconsistent ast for grs"
| Ast.Include _ -> Error.bug "[load] Include: inconsistent ast for grs"
| x -> Some (build_decl ?domain x)
) ast in
......@@ -128,7 +128,7 @@ module Grs = struct
decls;
}
let load filename = from_ast filename (Loader.new_grs filename)
let load filename = from_ast filename (Loader.grs filename)
(* The type [pointed] is a zipper style data structure for resolving names x.y.z *)
type pointed =
......
......@@ -35,4 +35,4 @@ module Grs : sig
val gwh_simple_rewrite: t -> string -> G_graph.t -> G_graph.t list
val wrd_rewrite: t -> string -> G_graph.t -> Libgrew_types.rew_display
end
end (* module Grs *)
......@@ -22,6 +22,7 @@ let parse_handle fct_name fct lexbuf =
| Failure msg -> Error.parse ~loc:(Global.get_loc ()) "%s, Failure: %s" fct_name msg
| err -> Error.bug ~loc:(Global.get_loc ()) "%s, Unexpected error: %s" fct_name (Printexc.to_string err)
(* ================================================================================ *)
module Loader = struct
(* ------------------------------------------------------------------------------------------*)
let domain file =
......@@ -75,17 +76,17 @@ module Loader = struct
| Unix.S_LNK -> Filename.dirname (Unix.readlink file)
| _ -> Filename.dirname file
let loc_new_grs file =
let loc_grs file =
try
Global.new_file file;
let in_ch = open_in file in
let lexbuf = Lexing.from_channel in_ch in
let grs = parse_handle "loc_new_grs" (Grew_parser.new_grs Grew_lexer.global) lexbuf in
let grs = parse_handle "loc_grs" (Grew_parser.grs Grew_lexer.global) lexbuf in
close_in in_ch;
grs
with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.grs] %s" msg
let rec unfold_new_grs dir top new_ast_grs =
let rec unfold_grs dir top new_ast_grs =
List.fold_left
(fun acc decl -> match decl with
| Ast.Import filename ->
......@@ -93,28 +94,29 @@ module Loader = struct
let pack_name = match CCString.chop_suffix ~suf:".grs" filename with
| Some x -> x
| None -> Error.build "Imported file must have the \".grs\" file extension" in
let sub = loc_new_grs real_file in
let unfolded_sub = unfold_new_grs (real_dir real_file) false sub in
let sub = loc_grs real_file in
let unfolded_sub = unfold_grs (real_dir real_file) false sub in
Ast.Package (Loc.file filename, pack_name, unfolded_sub) :: acc
| Ast.Include filename ->
let real_file = Filename.concat dir filename in
let sub = loc_new_grs real_file in
let unfolded_sub = unfold_new_grs (real_dir real_file) top sub in
let sub = loc_grs real_file in
let unfolded_sub = unfold_grs (real_dir real_file) top sub in
unfolded_sub @ acc
| Ast.Features _ when not top -> Error.build "Non top features declaration"
| Ast.Labels _ when not top -> Error.build "Non top labels declaration"
| Ast.Package (loc, name, decls) ->
Ast.Package (loc, name, unfold_new_grs dir top decls) :: acc
Ast.Package (loc, name, unfold_grs dir top decls) :: acc
| Ast.Rule ast_rule ->
Ast.Rule {ast_rule with Ast.rule_dir = Some dir} :: acc
| x -> x :: acc
) [] new_ast_grs
let new_grs file =
let final_grs = unfold_new_grs (real_dir file) true (loc_new_grs file) in
let grs file =
let final_grs = unfold_grs (real_dir file) true (loc_grs file) in
check_grs final_grs;
final_grs
(* ================================================================================ *)
(* ------------------------------------------------------------------------------------------*)
let gr file =
try
......
......@@ -13,19 +13,20 @@ open Grew_base
open Grew_types
open Grew_ast
(* ================================================================================ *)
module Loader: sig
val domain: string -> Ast.domain
val new_grs: string -> Ast.grs
val grs: string -> Ast.grs
val gr: string -> Ast.gr
val pattern: string -> Ast.pattern
val phrase_structure_tree: string -> Ast.pst
end
end (* module Loader *)
(* ================================================================================ *)
module Parser : sig
val gr: string -> Ast.gr
......@@ -34,4 +35,4 @@ module Parser : sig
val pattern: string -> Ast.pattern
val strategy: string -> Ast.strat
end
end (* module Parser *)
......@@ -23,7 +23,6 @@ module G_node: sig
| Ordered of float
| Unordered of int
type t
val empty: t
......@@ -75,15 +74,13 @@ module G_node: sig
val fresh: ?prec:Gid.t -> ?succ:Gid.t -> float -> t
val fresh_unordered: unit -> t
val position_comp: t -> t -> int
(* val build_neighbour: t -> t
val build_new: t -> t *)
val rename: (Gid.t * Gid.t) list -> t -> t
end
(* ================================================================================ *)
end (* module G_node *)
(* ================================================================================ *)
module P_node: sig
......@@ -109,5 +106,4 @@ module P_node: sig
val match_: ?lexicons:Lexicons.t -> t -> G_node.t -> Lexicons.t
val compare_pos: t -> t -> int
end
(* ================================================================================ *)
end (* module P_node *)
......@@ -122,7 +122,7 @@ let localize t = (t,get_loc ())
%start <Grew_ast.Ast.pattern> pattern
%start <Grew_ast.Ast.domain> domain
%start <Grew_ast.Ast.grs> new_grs
%start <Grew_ast.Ast.grs> grs
%start <Grew_ast.Ast.strat> strat_alone
/* parsing of the string representation of the constituent representation of Sequoia */
......@@ -697,7 +697,7 @@ pst:
/*=============================================================================================*/
/*=============================================================================================*/
new_grs:
grs:
| decls = list(decl) EOF { decls }
decl:
......
......@@ -498,7 +498,7 @@ module Rule = struct
(* ====================================================================== *)
let build ?domain deprecated_dir rule_ast =
let build ?domain rule_ast =
let lexicons =
List.fold_left (fun acc (name,lex) ->
try
......@@ -545,11 +545,10 @@ module Rule = struct
(* ====================================================================== *)
type matching = {
n_match: Gid.t Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *)
e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident |--> (src,label,tar) *)
l_param: Lexicons.t;
}
n_match: Gid.t Pid_map.t; (* partial fct: pattern nodes |--> graph nodes *)
e_match: (string*(Gid.t*Label.t*Gid.t)) list; (* edge matching: edge ident |--> (src,label,tar) *)
l_param: Lexicons.t; (* *)
}
let to_python pattern graph m =
let node_name gid = G_node.get_name gid (G_graph.find gid graph) in
......@@ -560,7 +559,7 @@ module Rule = struct
let edges = List.map (fun (id, (src,lab,tar)) ->
(id, `String (sprintf "%s/%s/%s" (node_name src) (Label.to_string lab) (node_name tar)))
) m.e_match in
`Assoc ( nodes @ edges)
`Assoc (nodes @ edges)
let node_matching pattern graph { n_match } =
Pid_map.fold
......@@ -647,8 +646,8 @@ module Rule = struct
| true, false -> -1
| false, true -> 1
| _ -> 0) node_list in
{ sub = empty_matching ?lexicons ();
{
sub = empty_matching ?lexicons ();
unmatched_nodes = sorted_node_list;
unmatched_edges = [];
already_matched_gids = [];
......@@ -1122,16 +1121,6 @@ module Rule = struct
else None
with Not_found -> (* raised by List.find, no matching apply *) None
let rec wrd_apply ?domain rule (graph, big_step_opt) =
let (pos,negs) = rule.pattern in
(* get the list of partial matching for positive part of the pattern *)
......@@ -1175,19 +1164,6 @@ module Rule = struct
else None
with Not_found -> (* raised by List.find, no matching apply *) None
let find cnode ?loc gwh matching =
match cnode with
| Command.Pat pid ->
......
......@@ -44,9 +44,8 @@ module Rule : sig
(** [to_dep t] returns a string in the [dep] language describing the match basic of the rule *)
val to_dep: ?domain:Domain.t -> t -> string
(** [build domain ?local dir ast_rule] returns the Rule.t value corresponding to [ast_rule].
[dir] is used for localisation of lp files *)
val build: ?domain:Domain.t -> string -> Ast.rule -> t
(** [build ?domain ast_rule] returns the Rule.t value corresponding to [ast_rule] *)
val build: ?domain:Domain.t -> Ast.rule -> t
(** the type matching encodes the graph morphism from a pattern to a graph *)
......
......@@ -16,9 +16,10 @@ open Grew_base
type feature_name = string (* cat, num, ... *)
type feature_atom = string (* V, N, inf, ... *)
type feature_value = string (* V, 4, "free text", ... *)
type suffix = string
type value = String of string | Float of float
type value =
| String of string
| Float of float
let string_of_value = function
| String s -> Str.global_replace (Str.regexp "\"") "\\\""
......@@ -209,14 +210,13 @@ end (* module Lexicon *)
module Lexicons = struct
type t = (string * Lexicon.t) list
let check ~loc lexicon_name field_name t =
try
let lexicon = List.assoc lexicon_name t in
if not (List.mem field_name lexicon.Lexicon.header)
then Error.build ~loc "Undefined field name \"%s\" in lexicon %s" field_name lexicon_name
with Not_found -> Error.build ~loc "Undefined lexicon name \"%s\"" lexicon_name
end
let check ~loc lexicon_name field_name t =
try
let lexicon = List.assoc lexicon_name t in
if not (List.mem field_name lexicon.Lexicon.header)
then Error.build ~loc "Undefined field name \"%s\" in lexicon %s" field_name lexicon_name
with Not_found -> Error.build ~loc "Undefined lexicon name \"%s\"" lexicon_name
end (* module Lexicons *)
(* ================================================================================ *)
module Concat_item = struct
......
......@@ -14,7 +14,9 @@ type feature_name = string (* cat, num, ... *)
type feature_atom = string (* V, N, inf, ... *)
type feature_value = string (* V, 4, "free text", ... *)
type value = String of string | Float of float
type value =
| String of string
| Float of float
val string_of_value : value -> string
......
......@@ -10,10 +10,7 @@
open Grew_graph
type graph = G_graph.t
type deco = G_deco.t
type module_name = string
type step_name = string
type rule_app = {
rule_name: string;
......@@ -21,7 +18,6 @@ type rule_app = {
down: G_deco.t;
}
(* the type for big edges which correspond to a module *)
type big_step = {
first: rule_app;
small_step: (G_graph.t * rule_app) list;
......@@ -33,8 +29,8 @@ let swap bs = {bs with small_step = List.rev bs.small_step}
type rew_display =
| Empty (* pour les besoin du dev *)
| Leaf of G_graph.t
| Local_normal_form of G_graph.t * module_name * rew_display
| Node of G_graph.t * module_name * (big_step * rew_display) list
| Local_normal_form of G_graph.t * step_name * rew_display
| Node of G_graph.t * step_name * (big_step * rew_display) list
let rec rew_display_size = function
| Empty -> 0
......
......@@ -12,24 +12,17 @@
open Grew_graph
(**/**)
type graph = G_graph.t
type deco = G_deco.t
(**/**)
type step_name = string
type module_name = string
(** Rule app *)
type rule_app = {
rule_name: string;
up: deco;
down: deco;
up: G_deco.t;
down: G_deco.t;
}
(** the type for big edges which correspond the a module *)
type big_step = {
first: rule_app;
small_step: (graph * rule_app) list;
small_step: (G_graph.t * rule_app) list;
}
val swap : big_step -> big_step
......@@ -37,8 +30,8 @@ val swap : big_step -> big_step
(** the main type for display the result of a rewriting *)
type rew_display =
| Empty (* pour les besoin du dev *)
| Leaf of graph
| Local_normal_form of graph * module_name * rew_display
| Node of graph * module_name * (big_step * rew_display) list
| Leaf of G_graph.t
| Local_normal_form of G_graph.t * step_name * rew_display
| Node of G_graph.t * step_name * (big_step * rew_display) list
val rew_display_size: rew_display -> int
\ No newline at end of file
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