Commit d0632382 authored by bguillaum's avatar bguillaum

code cleaning

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/semagramme/libcaml-grew/trunk@8137 7838e531-6607-4d57-9587-6c381814729c
parent 8941ec42
......@@ -93,7 +93,7 @@ module Ast = struct
| _ -> Error.build "The identifier '%s' must be a qualified feature name (with one '.' symbol)" s
)
type feature_spec =
type feature_spec =
| Closed of feature_name * feature_atom list (* cat:V,N *)
| Open of feature_name (* phon, lemma, ... *)
| Int of feature_name (* position *)
......@@ -118,7 +118,7 @@ module Ast = struct
Error.build "[Domain] The feature named \"%s\" is defined several times" fn
| x :: tail -> x :: (normalize_domain tail)
type feature_kind =
type feature_kind =
| Equality of feature_value list
| Disequality of feature_value list
| Param of string (* $ident *)
......@@ -131,21 +131,21 @@ module Ast = struct
type feature = u_feature * Loc.t
type u_node = {
node_id: Id.name;
position: float option;
fs: feature list;
}
node_id: Id.name;
position: float option;
fs: feature list;
}
type node = u_node * Loc.t
type edge_label = string
type u_edge = {
edge_id: Id.name option;
src: Id.name;
edge_labels: edge_label list;
tar: Id.name;
negative: bool;
}
edge_id: Id.name option;
src: Id.name;
edge_labels: edge_label list;
tar: Id.name;
negative: bool;
}
type edge = u_edge * Loc.t
type ineq = Lt | Gt | Le | Ge
......@@ -167,22 +167,22 @@ module Ast = struct
type const = u_const * Loc.t
type pattern = {
pat_nodes: node list;
pat_edges: edge list;
pat_const: const list;
}
pat_nodes: node list;
pat_edges: edge list;
pat_const: const list;
}
type graph = {
nodes: (Id.name * node) list;
edge: edge list;
}
nodes: (Id.name * node) list;
edge: edge list;
}
type concat_item =
| Qfn_item of complex_id (* Warning: either a simple string (without .) of a real qualified feature_name *)
| String_item of string
| Param_item of string
type u_command =
type u_command =
| Del_edge_expl of (act_id * act_id * edge_label)
| Del_edge_name of string
| Add_edge of (act_id * act_id * edge_label)
......@@ -202,56 +202,54 @@ module Ast = struct
- rule { param=None; ... }
- lex_rule
- filter { param=None; commands=[]; ... }
*)
*)
type rule = {
rule_id:Id.name;
pos_pattern: pattern;
neg_patterns: pattern list;
commands: command list;
param: (string list * string list) option;
lp: string list option;
rule_doc:string list;
rule_loc: Loc.t;
}
rule_id:Id.name;
pos_pattern: pattern;
neg_patterns: pattern list;
commands: command list;
param: (string list * string list) option;
lp: string list option;
rule_doc:string list;
rule_loc: Loc.t;
}
type modul = {
module_id:Id.name;
local_labels: (string * string list) list;
new_node_names: string list;
rules: rule list;
confluent: bool;
module_doc:string list;
mod_loc:Loc.t;
mod_dir: string; (* the directory where the module is defined (for lp file localisation) *)
}
module_id:Id.name;
local_labels: (string * string list) list;
new_node_names: string list;
rules: rule list;
confluent: bool;
module_doc:string list;
mod_loc:Loc.t;
mod_dir: string; (* the directory where the module is defined (for lp file localisation) *)
}
type sequence = {
seq_name:string;
seq_mod:string list;
seq_doc:string list;
seq_loc:Loc.t;
}
(**
a GRS: graph rewriting system
*)
type module_or_include =
seq_name:string;
seq_mod:string list;
seq_doc:string list;
seq_loc:Loc.t;
}
(** a GRS: graph rewriting system *)
type module_or_include =
| Modul of modul
| Includ of (string * Loc.t)
type grs_with_include = {
domain_wi: domain;
labels_wi: (string * string list) list; (* the list of global edge labels *)
modules_wi: module_or_include list;
sequences_wi: sequence list;
}
domain_wi: domain;
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;
labels: (string * string list) list;
modules: modul list;
sequences: sequence list;
}
domain: domain;
labels: (string * string list) list;
modules: modul list;
sequences: sequence list;
}
type gr = {
meta: (string * string) list;
......
......@@ -17,7 +17,7 @@ open Grew_edge
open Grew_fs
(* ==================================================================================================== *)
module Command = struct
module Command = struct
type command_node = (* a command node is either: *)
| Pat of Pid.t (* a node identified in the pattern *)
| New of string (* a node introduced by a new_neighbour *)
......@@ -30,7 +30,7 @@ module Command = struct
| Param_out of int
(* the command in pattern *)
type p =
type p =
| DEL_NODE of command_node
| DEL_EDGE_EXPL of (command_node * command_node * G_edge.t)
| DEL_EDGE_NAME of string
......@@ -46,7 +46,7 @@ module Command = struct
type t = p * Loc.t (* remember command location to be able to localize a command failure *)
(* a item in the command history: command applied to a graph *)
type h =
type h =
| H_DEL_NODE of Gid.t
| H_DEL_EDGE_EXPL of (Gid.t * Gid.t *G_edge.t)
| H_DEL_EDGE_NAME of string
......@@ -72,8 +72,8 @@ module Command = struct
if not (List.mem act_id kai)
then Error.build ~loc "Unbound node identifier \"%s\"" (Ast.act_id_to_string act_id) in
let check_edge loc edge_id kei =
if not (List.mem edge_id kei)
let check_edge loc edge_id kei =
if not (List.mem edge_id kei)
then Error.build ~loc "Unbound edge identifier \"%s\"" edge_id in
match ast_command with
......@@ -82,7 +82,7 @@ module Command = struct
check_act_id loc act_j kai;
let edge = G_edge.make ~loc ~locals lab in
((DEL_EDGE_EXPL (pid_of_act_id loc act_i, pid_of_act_id loc act_j, edge), loc), (kai, kei))
| (Ast.Del_edge_name id, loc) ->
check_edge loc id kei;
(DEL_EDGE_NAME id, loc), (kai, List_.rm id kei)
......@@ -128,7 +128,7 @@ module Command = struct
), loc),
((new_id, None)::kai, kei)
)
with Not_found ->
with Not_found ->
Log.fcritical "[GRS] tries to build a command New_neighbour (%s) on node %s which is not in the pattern %s"
(G_edge.to_string edge)
(fst ancestor)
......@@ -136,11 +136,11 @@ module Command = struct
end
| (Ast.Activate n, loc) -> failwith "Not implemented"
| (Ast.Del_node act_n, loc) ->
check_act_id loc act_n kai;
((DEL_NODE (pid_of_act_id loc act_n), loc), (List_.rm act_n kai, kei))
| (Ast.Del_feat (act_id, feat_name), loc) ->
if feat_name = "position"
then Error.build ~loc "Illegal del_feat command: the 'position' feature cannot be deleted";
......
......@@ -86,7 +86,7 @@ module G_feature = struct
let to_string (feat_name, feat_val) = sprintf "%s=%s" feat_name (string_of_value feat_val)
let to_gr (feat_name, feat_val) = sprintf "%s=\"%s\"" feat_name (string_of_value feat_val)
let to_dot (feat_name, feat_val) =
let string_val = string_of_value feat_val in
match Str.split (Str.regexp ":C:") string_val with
......@@ -96,9 +96,9 @@ end
(* ==================================================================================================== *)
module P_feature = struct
(* feature= (feature_name, disjunction of atomic values) *)
(* feature= (feature_name, disjunction of atomic values) *)
type v =
type v =
| Equal of value list (* with Equal constr, the list MUST never be empty *)
| Different of value list
| Param of int
......@@ -110,23 +110,23 @@ module P_feature = struct
let compare feat1 feat2 = Pervasives.compare (get_name feat1) (get_name feat2)
let unif_value v1 v2 =
let unif_value v1 v2 =
match (v1, v2) with
| (Equal l1, Equal l2) ->
| (Equal l1, Equal l2) ->
(match List_.sort_inter l1 l2 with
| [] -> Error.build "Unification failure"
| [] -> Error.build "Unification failure"
| l -> Equal l)
| (Different l1, Different l2) -> Different (List_.sort_union l1 l2)
| _ -> Error.build "cannot unify heterogeneous pattern features"
let to_string ?param_names = function
| (feat_name, Equal atoms) -> sprintf "%s=%s" feat_name (List_.to_string string_of_value "|" atoms)
| (feat_name, Different []) -> sprintf "%s=*" feat_name
| (feat_name, Different atoms) -> sprintf "%s<>%s" feat_name (List_.to_string string_of_value "|" atoms)
| (feat_name, Absent) -> sprintf "!%s" feat_name
| (feat_name, Param index) ->
| (feat_name, Param index) ->
match param_names with
| None -> sprintf "%s=$%d" feat_name index
| None -> sprintf "%s=$%d" feat_name index
| Some (l,_) -> sprintf "%s=%s" feat_name (List.nth l index)
let build ?pat_vars = function
......@@ -138,7 +138,7 @@ module P_feature = struct
| ({Ast.kind=Ast.Param var; name=name}, loc) ->
match pat_vars with
| None -> Error.bug ~loc "[P_feature.build] param '%s' in an unparametrized rule" var
| Some l ->
| Some l ->
match List_.pos var l with
| Some index -> (name, Param index)
| None -> Error.build ~loc "[P_feature.build] Unknown pattern variable '%s'" var
......@@ -159,7 +159,7 @@ module G_fs = struct
| [] -> [(feature_name, new_value)]
| ((fn,_)::_) as t when feature_name < fn -> (feature_name, new_value)::t
| (fn,_)::t when feature_name = fn -> (feature_name, new_value)::t
| (fn,a)::t -> (fn,a) :: (loop t)
| (fn,a)::t -> (fn,a) :: (loop t)
in loop t
let del_feat = List_.sort_remove_assoc
......@@ -172,7 +172,7 @@ module G_fs = struct
| [(fn,value)] -> Some (fn,conll_string_of_value value)
| _ -> Error.build "[Fs.get_annot_info] More than one annot feature in the same feature structure"
let get_string_atom feat_name t =
let get_string_atom feat_name t =
match List_.sort_assoc feat_name t with
| None -> None
| Some v -> Some (conll_string_of_value v)
......@@ -201,13 +201,13 @@ module G_fs = struct
| s -> ("pos", Domain.build_one "pos" s) :: unsorted_without_pos in
List.sort G_feature.compare unsorted
exception Fail_unif
let unif fs1 fs2 =
exception Fail_unif
let unif fs1 fs2 =
let rec loop = function
| [], fs | fs, [] -> fs
| (f1::t1, f2::t2) when G_feature.compare f1 f2 < 0 -> f1 :: loop (t1, f2::t2)
| (f1::t1, f2::t2) when G_feature.compare f1 f2 > 0 -> f2 :: loop (f1::t1, t2)
(* all remaining case are fn1 = fn2 *)
| ((fn, a1)::t1, (_, a2)::t2) when a1=a2 -> (fn,a1) :: (loop (t1, t2))
| _ -> raise Fail_unif
......@@ -231,12 +231,12 @@ module G_fs = struct
| (None, _) -> List_.to_string G_feature.to_dot "\\n" t
| (Some atom, sub) ->
sprintf "{%s|%s}" (string_of_value atom) (List_.to_string G_feature.to_dot "\\n" sub)
let to_word ?main_feat t =
match get_main ?main_feat t with
| (None, _) -> "#"
| (Some atom, _) -> string_of_value atom
let to_dep ?position ?main_feat ?filter t =
let (main_opt, sub) = get_main ?main_feat t in
let last = match position with Some f when f > 0. -> [("position", Float f)] | _ -> [] in
......@@ -259,7 +259,7 @@ module G_fs = struct
reduced_t
)
end (* module G_fs *)
(* ==================================================================================================== *)
module P_fs = struct
(* list are supposed to be striclty ordered wrt compare*)
......@@ -281,7 +281,7 @@ module P_fs = struct
let build ?pat_vars ast_fs =
let unsorted = List.map (P_feature.build ?pat_vars) ast_fs in
List.sort P_feature.compare unsorted
List.sort P_feature.compare unsorted
let to_string t = List_.to_string P_feature.to_string "\\n" t
......@@ -328,11 +328,11 @@ module P_fs = struct
)
)
(* remaining cases: Equal and not list_mem | Diff and not list_mem -> fail*)
(* remaining cases: Equal and not list_mem | Diff and not list_mem -> fail*)
| _ -> raise Fail
in loop param (pattern_wo_pos,fs)
let filter fs_p fs_g =
let filter fs_p fs_g =
let rec loop = function
| [], fs -> true
......@@ -353,7 +353,7 @@ module P_fs = struct
in loop (fs_p, fs_g)
let unif fs1 fs2 =
let unif fs1 fs2 =
let rec loop = function
| [], fs -> fs
| fs, [] -> fs
......@@ -363,5 +363,5 @@ module P_fs = struct
(* all remaining case are fn1 = fn2 *)
| ((fn1,v1)::t1, (fn2,v2)::t2) (* when fn1 = fn2 *) -> (fn1,P_feature.unif_value v1 v2) :: (loop (t1,t2))
in loop (fs1, fs2)
in loop (fs1, fs2)
end
......@@ -41,8 +41,8 @@ module P_graph = struct
(* Not found can be raised when adding an edge from pos to neg *)
try Pid_map.find id_src map with Not_found -> P_node.empty in
match P_node.add_edge label id_tar node_src with
| None -> None
| Some new_node -> Some (Pid_map.add id_src new_node map)
| None -> None
| Some new_node -> Some (Pid_map.add id_src new_node map)
(* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
(* Build functions *)
......@@ -62,7 +62,7 @@ module P_graph = struct
let rec insert (ast_node, loc) = function
| [] -> [P_node.build ?pat_vars (ast_node, loc)]
| (node_id,fs)::tail when ast_node.Ast.node_id = node_id ->
(node_id, P_node.unif_fs (P_fs.build ?pat_vars ast_node.Ast.fs) fs) :: tail
(node_id, P_node.unif_fs (P_fs.build ?pat_vars ast_node.Ast.fs) fs) :: tail
| head :: tail -> head :: (insert (ast_node, loc) tail) in
let (named_nodes : (Id.name * P_node.t) list) =
......@@ -88,10 +88,10 @@ module P_graph = struct
let i2 = Id.build ~loc ast_edge.Ast.tar pos_table in
let edge = P_edge.build ~locals (ast_edge, loc) in
(match map_add_edge acc (Pid.Pos i1) edge (Pid.Pos i2) with
| Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
(P_edge.to_string edge)
(Loc.to_string loc)
| Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
(P_edge.to_string edge)
(Loc.to_string loc)
)
) map_without_edges full_edge_list in
(map, pos_table)
......@@ -101,9 +101,9 @@ module P_graph = struct
(* a type for extension of graph: a former graph exists:
in grew the former is a positive pattern and an extension is a "without" *)
type extension = {
ext_map: P_node.t Pid_map.t; (* node description for new nodes and for edge "Old -> New" *)
old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
}
ext_map: P_node.t Pid_map.t; (* node description for new nodes and for edge "Old -> New" *)
old_map: P_node.t Pid_map.t; (* a partial map for new constraints on old nodes "Old [...]" *)
}
(* -------------------------------------------------------------------------------- *)
let build_extension ?(locals=[||]) pos_table full_node_list full_edge_list =
......@@ -114,7 +114,7 @@ module P_graph = struct
List.partition
(function (id,_) when Array_.dicho_mem id pos_table -> true | _ -> false)
built_nodes in
let new_sorted_nodes = List.sort (fun (id1,_) (id2,_) -> Pervasives.compare id1 id2) new_nodes in
let (new_sorted_ids, new_node_list) = List.split new_sorted_nodes in
......@@ -150,8 +150,8 @@ module P_graph = struct
| None -> Pid.Neg (Id.build ~loc tar new_table) in
let edge = P_edge.build ~locals (ast_edge, loc) in
match map_add_edge acc i1 edge i2 with
| Some map -> map
| None -> Log.fbug "[GRS] [Graph.build_extension] add_edge cannot fail in pattern extension (1)"; exit 2
| Some map -> map
| None -> Log.fbug "[GRS] [Graph.build_extension] add_edge cannot fail in pattern extension (1)"; exit 2
) ext_map_without_edges full_edge_list in
({ext_map = ext_map_with_all_edges; old_map = old_map_without_edges}, new_table)
......@@ -217,14 +217,7 @@ module G_graph = struct
let equals t t' = Gid_map.equal (fun node1 node2 -> node1 = node2) t.map t'.map
(* Ocaml < 3.12 doesn't have exists function for maps! *)
exception True
let node_exists fct t =
try
Gid_map.iter (fun _ v -> if fct v then raise True) t.map;
false
with True -> true
(* Ocaml < 3.12 doesn't have exists function for maps! *)
let node_exists fct t = Gid_map.exists (fun _ node -> fct node) t.map
let fold_gid fct t init =
Gid_map.fold (fun gid _ acc -> fct gid acc) t.map init
......@@ -265,8 +258,8 @@ module G_graph = struct
(* Not found can be raised when adding an edge from pos to neg *)
try Gid_map.find id_src map with Not_found -> G_node.empty in
match G_node.add_edge label id_tar node_src with
| None -> None
| Some new_node -> Some (Gid_map.add id_src new_node map)
| None -> None
| Some new_node -> Some (Gid_map.add id_src new_node map)
let add_edge graph id_src label id_tar =
match map_add_edge graph.map id_src label id_tar with
......@@ -313,10 +306,10 @@ module G_graph = struct
let i2 = Id.build ~loc ast_edge.Ast.tar table in
let edge = G_edge.build ~locals (ast_edge, loc) in
(match map_add_edge acc (Gid.Old i1) edge (Gid.Old i2) with
| Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
(G_edge.to_string edge)
(Loc.to_string loc)
| Some g -> g
| None -> Error.build "[GRS] [Graph.build] try to build a graph with twice the same edge %s %s"
(G_edge.to_string edge)
(Loc.to_string loc)
)
) map_without_edges full_edge_list in
......@@ -407,7 +400,7 @@ module G_graph = struct
(* -------------------------------------------------------------------------------- *)
let rename mapping graph =
{graph with map =
{graph with map =
Gid_map.fold
(fun id node acc ->
let new_id = try List.assoc id mapping with Not_found -> id in
......@@ -422,14 +415,14 @@ module G_graph = struct
try Gid_map.find id_src graph.map
with Not_found ->
match edge_ident with
| None -> Log.fcritical "[RUN] Some edge refers to a dead node, please report"
| Some id -> Error.run ~loc "[Graph.del_edge] cannot find source node of edge \"%s\"" id in
| None -> Log.fcritical "[RUN] Some edge refers to a dead node, please report"
| Some id -> Error.run ~loc "[Graph.del_edge] cannot find source node of edge \"%s\"" id in
try {graph with map = Gid_map.add id_src (G_node.remove id_tar label node_src) graph.map}
with Not_found -> Error.run ~loc "[Graph.del_edge] cannot find edge '%s'" (G_edge.to_string label)
(* -------------------------------------------------------------------------------- *)
let del_node graph node_id =
{graph with map =
{graph with map =
Gid_map.fold
(fun id value acc ->
if id = node_id
......@@ -456,8 +449,8 @@ module G_graph = struct
let new_map = Gid_map.add index (G_node.build_neighbour node) graph.map in
match map_add_edge new_map node_id label index with
| Some g -> (index, {graph with map = g})
| None -> Log.bug "[Graph.add_neighbour] add_edge must not fail"; exit 1
| Some g -> (index, {graph with map = g})
| None -> Log.bug "[Graph.add_neighbour] add_edge must not fail"; exit 1
(* -------------------------------------------------------------------------------- *)
let shift_in loc graph src_gid tar_gid =
......@@ -538,15 +531,15 @@ module G_graph = struct
let tar_node = Gid_map.find tar_gid se_graph.map in
match G_fs.unif (G_node.get_fs src_node) (G_node.get_fs tar_node) with
| Some new_fs ->
Some {graph with map =
(Gid_map.add
tar_gid
(G_node.set_fs tar_node new_fs)
(Gid_map.remove src_gid se_graph.map)
)
}
| None -> None
| Some new_fs ->
Some {graph with map =
(Gid_map.add
tar_gid
(G_node.set_fs tar_node new_fs)
(Gid_map.remove src_gid se_graph.map)
)
}
| None -> None
(* -------------------------------------------------------------------------------- *)
let set_feat ?loc graph node_id feat_name new_value =
......@@ -565,11 +558,11 @@ module G_graph = struct
List.map
(function
| Concat_item.Feat (node_gid, feat_name) ->
let node = Gid_map.find node_gid graph.map in
(match G_fs.get_string_atom feat_name (G_node.get_fs node) with
let node = Gid_map.find node_gid graph.map in
(match G_fs.get_string_atom feat_name (G_node.get_fs node) with
| Some atom -> atom
| None -> Error.run ?loc "Cannot update_feat, some feature (named \"%s\") is not defined" feat_name
)
)
| Concat_item.String s -> s
) item_list in
let new_feature_value = List_.to_string (fun s->s) "" strings_to_concat in
......
......@@ -195,7 +195,7 @@ let det_dep_string rew_hist =
let conll_dep_string ?keep_empty_rh rew_hist =
handle ~name:"conll_dep_string" (fun () -> Rewrite_history.conll_dep_string ?keep_empty_rh rew_hist) ()
let write_html
let write_html
?(no_init=false)
?(out_gr=false)
?filter
......@@ -219,12 +219,12 @@ let write_html
)
) ()
let error_html
?(no_init=false)
?main_feat
let error_html
?(no_init=false)
?main_feat
?dot
~header
msg
msg
?init
output_base =
handle ~name:"error_html" (fun () ->
......
......@@ -13,39 +13,31 @@ open Grew_ast
module Grew_parser = struct
(* message and line number *)
(* message and location *)
exception Parse_error of (string * Loc.t option)
(* ------------------------------------------------------------------------------------------*)
(** general fucntion to handle parse errors *)
let parse_handle file fct lexbuf =
try fct lexbuf with
| Lexer.Error msg ->
let cp = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum in
raise (Parse_error ("Lexing error:"^msg, Some (file,cp)))
| Gr_grs_parser.Error ->
let cp = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum in
raise (Parse_error ("Syntax error:"^(Lexing.lexeme lexbuf), Some (file,cp)))
| Failure msg ->
let cp = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum in
raise (Parse_error ("Failure:"^msg, Some (file,cp)))
| Error.Build (msg,_) ->
let cp = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum in
raise (Parse_error ("Syntax error:"^msg, Some (file,cp)))
| err ->
let cp = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum in
raise (Parse_error ("Unexpected error:"^(Printexc.to_string err), Some (file,cp)))
(* ------------------------------------------------------------------------------------------*)
(**
[parse_string str] where [str] is a string following the grew syntax
@param str the string to parse
@return a syntactic tree of the parsed file
*)
let parse_string_to_grs str = parse_handle "" (Gr_grs_parser.grs Lexer.global) (Lexing.from_string str)
(* ------------------------------------------------------------------------------------------*)
let parse_file_to_grs_with_includes file =
(* ------------------------------------------------------------------------------------------*)
(** general fucntion to handle parse errors *)
let parse_handle file fct lexbuf =
try fct lexbuf with
| Lexer.Error msg ->
let cp = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum in
raise (Parse_error ("Lexing error:"^msg, Some (file,cp)))
| Gr_grs_parser.Error ->
let cp = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum in
raise (Parse_error ("Syntax error:"^(Lexing.lexeme lexbuf), Some (file,cp)))
| Failure msg ->
let cp = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum in
raise (Parse_error ("Failure:"^msg, Some (file,cp)))
| Error.Build (msg,_) ->
let cp = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum in
raise (Parse_error ("Syntax error:"^msg, Some (file,cp)))
| err ->
let cp = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum in
raise (Parse_error ("Unexpected error:"^(Printexc.to_string err), Some (file,cp)))
(* ------------------------------------------------------------------------------------------*)
let parse_file_to_grs_with_includes file =
try
Parser_global.init file;
let in_ch = open_in file in
......@@ -53,10 +45,9 @@ let parse_handle file fct lexbuf =
let grs = parse_handle file (Gr_grs_parser.grs_with_include Lexer.global) lexbuf in
close_in in_ch;
grs
with Sys_error msg->
raise (Parse_error (msg, None))
with Sys_error msg -> raise (Parse_error (msg, None))
(* ------------------------------------------------------------------------------------------*)
(* ------------------------------------------------------------------------------------------*)
let parse_file_to_module_list loc file =
try
Parser_global.init file;
......@@ -67,44 +58,35 @@ let parse_handle file fct lexbuf =
module_list
with Sys_error msg-> raise (Parse_error (msg, None))
(* ------------------------------------------------------------------------------------------*)
(* ------------------------------------------------------------------------------------------*)
(**
[parse_string file] where [file] is a file following the grew syntax
@param file the file to parse
@return a syntactic tree of the parsed file
*)
*)
let grs_of_file main_file =
let grs_with_includes = parse_file_to_grs_with_includes main_file in
let rec flatten_modules current_file = function
| [] -> []
| Ast.Modul m :: tail ->
{m with Ast.mod_dir = Filename.dirname current_file}
:: (flatten_modules current_file tail)
| Ast.Includ (inc_file,loc) :: tail ->
let sub_file =
if Filename.is_relative inc_file
then Filename.concat (Filename.dirname current_file) inc_file
else inc_file in
(flatten_modules sub_file (parse_file_to_module_list loc sub_file))
@ (flatten_modules current_file tail) in
| Ast.Modul m :: tail ->
{m with Ast.mod_dir = Filename.dirname current_file}
:: (flatten_modules current_file tail)
| Ast.Includ (inc_file,loc) :: tail ->
let sub_file =
if Filename.is_relative inc_file
then Filename.concat (Filename.dirname current_file) inc_file
else inc_file in
(flatten_modules sub_file (parse_file_to_module_list loc sub_file))