Commit 0d7a7dcb authored by Bruno Guillaume's avatar Bruno Guillaume

load & dump for new grs syntax

parent 9f5fbb31
......@@ -488,18 +488,15 @@ module New_ast = struct
| Rules of Ast.node_ident (* ≜ Alt (rules defined in the top level of the package with the given name *)
type decl =
| Features of Ast.feature_spec list
| Labels of (string * string list) list
| Package of (Ast.simple_ident * decl list)
| Rule of Ast.rule
| Strategy of (Ast.simple_ident * strat)
| Import of string
| Include of string
type top_decl =
| Features of Ast.feature_spec list
| Labels of (string * string list) list
| D of decl
type grs = top_decl list
type grs = decl list
end (* module New_ast *)
......
......@@ -259,16 +259,13 @@ module New_ast : sig
| Rules of Ast.node_ident (* ≜ Alt (rules defined in the top level of the package with the given name *)
type decl =
| Features of Ast.feature_spec list
| Labels of (string * string list) list
| Package of (Ast.simple_ident * decl list)
| Rule of Ast.rule
| Strategy of (Ast.simple_ident * strat)
| Import of string
| Include of string
type top_decl =
| Features of Ast.feature_spec list
| Labels of (string * string list) list
| D of decl
type grs = top_decl list
type grs = decl list
end (* module New_ast *)
......@@ -31,14 +31,25 @@ module Label_domain = struct
type t = string array * style array
let dump (label_array, _) =
Printf.printf "========= Label domain =========\n";
Array.iter (function label -> Printf.printf " - %s\n" label) label_array;
Printf.printf "==================================\n%!"
(** The [default] style value *)
let default = { text="UNSET"; bottom=false; color=None; bgcolor=None; line=Solid }
let merge t1 t2 = failwith "TODO"
(** [decl] is the type for a label declaration: the name and a list of display styles *)
type decl = string * string list
let merge l1 l2 =
List.fold_left
(fun acc (name, styles) ->
if List.mem_assoc name acc
then (Log.fwarning "duplicate label definition \"%s\"" name; acc)
else (name, styles) :: acc
) l1 l2
(** Computes the style of a label from its options and maybe its shape (like I:...). *)
let parse_option string_label options =
let init_style = match Str.bounded_split (Str.regexp ":") string_label 2 with
......@@ -100,13 +111,22 @@ end
module Feature_domain = struct
type t = Ast.feature_spec list
let dump t =
Printf.printf "========= Feature domain =========\n";
List.iter (function
| Ast.Closed (fn, values) -> Printf.printf " %s : %s\n" fn (String.concat ", " values)
| Ast.Open fn -> Printf.printf " %s is OPEN\n" fn
| Ast.Num fn -> Printf.printf " %s id NUMERICAL\n" fn
) t;
Printf.printf "==================================\n%!"
let get_name = function
| Ast.Closed (fn, _) -> fn
| Ast.Open fn -> fn
| Ast.Num fn -> fn
let is_defined feature_name feature_domain =
List.exists (function
| Ast.Closed (fn,_) when fn = feature_name -> true
| Ast.Open fn when fn = feature_name -> true
| Ast.Num fn when fn = feature_name -> true
| _ -> false
) feature_domain
List.exists (fun item -> get_name item = feature_name) feature_domain
let rec build = function
| [] -> [Ast.Num "position"]
......@@ -121,7 +141,22 @@ module Feature_domain = struct
let feature_names feature_domain =
List.map (function Ast.Closed (fn, _) | Ast.Open fn | Ast.Num fn -> fn) feature_domain
let merge t1 t2 = failwith "TODO"
let merge list1 list2 =
List.fold_left
(fun acc item ->
match List.filter (fun i -> get_name i = get_name item) acc with
| [] -> item :: acc
| [one] ->
let new_item = match (one, item) with
| (Ast.Open _, Ast.Open _) | (Ast.Num _, Ast.Num _) -> item
| (Ast.Open fn, Ast.Closed _) | (Ast.Closed _, Ast.Open fn) ->
Log.fwarning "Feature name \"%s\" is declared twice as open and close; it is consider as open" fn; Ast.Open fn
| (Ast.Closed (fn, l1), (Ast.Closed (_, l2))) -> Ast.Closed (fn , l1 @ l2)
| _ -> Error.build "Cannot merge numerical ans non numerical feature \"%s\"" (get_name item) in
new_item :: acc
| _ -> Error.bug "Duplicate in Feature_domain.merge"
acc)
list1 list2
let get feature_name feature_domain =
List.find (function
......@@ -178,6 +213,12 @@ module Domain = struct
| Label of Label_domain.t
| Feature of Feature_domain.t
let dump = function
| None -> Printf.printf "=================== No domain ===================\n";
| Some Both (ld,fd) -> Label_domain.dump ld; Feature_domain.dump fd
| Some Label ld -> Label_domain.dump ld
| Some Feature fd -> Feature_domain.dump fd
let build ld fd = Both (ld, fd)
let build_features_only fd = Feature fd
......
......@@ -26,9 +26,10 @@ module Label_domain : sig
(* [decl] is the type for a label declaration: the name and a list of display options *)
type decl = string * string list
val merge: decl list -> decl list -> decl list
val build: decl list -> t
val merge: t -> t -> t
end
(* ================================================================================ *)
......@@ -37,16 +38,19 @@ module Feature_domain: sig
val build: Ast.feature_spec list -> t
(** [sub domain fn1 fn2] returns [true] iff the domain of [fn1] is a subset if the domain of [fn2]. *)
val sub: t -> feature_name -> feature_name -> bool
val merge: t -> t -> t
val merge: Ast.feature_spec list -> Ast.feature_spec list -> Ast.feature_spec list
end (* module Feature_domain *)
(* ================================================================================ *)
module Domain : sig
type t
val dump: t option -> unit
val build: Label_domain.t -> Feature_domain.t -> t
val build_features_only: Feature_domain.t -> t
val build_labels_only: Label_domain.t -> t
......
......@@ -593,7 +593,7 @@ module New_grs = struct
type decl =
| Rule of Rule.t
| Strategy of New_ast.strat
| Strategy of string * New_ast.strat
| Package of string * decl list
type t = {
......@@ -603,26 +603,50 @@ module New_grs = struct
ast: New_ast.grs;
}
let rec dump_decl indent = function
| Rule r -> printf "%srule %s\n" (String.make indent ' ') (Rule.get_name r)
| Strategy (name, def) -> printf "%sstrat %s\n" (String.make indent ' ') name
| Package (name, decl_list) ->
printf "%spackage %s:\n" (String.make indent ' ') name;
List.iter (dump_decl (indent + 2)) decl_list
let dump t =
printf "================ New_grs ================\n";
Domain.dump t.domain;
printf "-----------------------\n";
List.iter (dump_decl 0) t.decls;
printf "================ New_grs ================\n%!";
()
let rec build_decl ?domain = function
| New_ast.Package (name, decl_list) -> Package (name, List.map build_decl decl_list)
| New_ast.Rule ast_rule -> Rule (Rule.build ?domain "TODO" ast_rule)
| New_ast.Strategy (name, ast_strat) -> Strategy (name, ast_strat)
| _ -> Error.bug "[build_decl] Inconsistent ast for new_grs"
let domain t = t.domain
let load filename =
let ast = Loader.new_grs filename in
let feature_domains = List_.opt_map
(fun x -> match x with
| New_ast.Features desc -> Some (Feature_domain.build desc)
| New_ast.Features desc -> Some desc
| _ -> None
) ast in
let feature_domain = match feature_domains with
| [] -> None
| h::t -> Some (List.fold_left Feature_domain.merge h t) in
| h::t -> Some (Feature_domain.build (List.fold_left Feature_domain.merge h t)) in
let label_domains = List_.opt_map
(fun x -> match x with
| New_ast.Labels desc -> Some (Label_domain.build desc)
| New_ast.Labels desc -> Some desc
| _ -> None
) ast in
let label_domain = match label_domains with
| [] -> None
| h::t -> Some (List.fold_left Label_domain.merge h t) in
| h::t -> Some (Label_domain.build (List.fold_left Label_domain.merge h t)) in
let domain = match (label_domain, feature_domain) with
| (None, None) -> None
......@@ -630,9 +654,18 @@ module New_grs = struct
| (None, Some fd) -> Some (Domain.build_features_only fd)
| (Some ld, Some fd) -> Some (Domain.build ld fd) in
let decls = List_.opt_map
(fun x -> match x with
| New_ast.Features _ -> None
| New_ast.Labels _ -> None
| New_ast.Import _ -> Error.bug "[load] Import: inconsistent ast for new_grs"
| New_ast.Include _ -> Error.bug "[load] Inlcude: inconsistent ast for new_grs"
| x -> Some (build_decl ?domain x)
) ast in
{ filename;
ast;
domain;
decls = [];
decls;
}
end
......@@ -117,4 +117,8 @@ module New_grs : sig
type t
val load: string -> t
val dump: t -> unit
val domain: t -> Domain.t option
end
\ No newline at end of file
......@@ -95,7 +95,7 @@ module Loader = struct
Ast.strategies = grs_wi.Ast.strategies_wi;
}
let new_grs file =
let rec loc_new_grs file =
try
Global.new_file file;
let in_ch = open_in file in
......@@ -105,6 +105,23 @@ module Loader = struct
grs
with Sys_error msg -> Error.parse ~loc:(Loc.file file) "[Grew_loader.Loader.grs] %s" msg
and unfold_new_grs top new_ast_grs = List.fold_left
(fun acc decl -> match decl with
| New_ast.Import filename ->
let sub = loc_new_grs filename in
let unfolded_sub = unfold_new_grs false sub in
New_ast.Package (filename, unfolded_sub) :: acc
| New_ast.Include filename ->
let sub = loc_new_grs filename in
let unfolded_sub = unfold_new_grs top sub in
unfolded_sub @ acc
| New_ast.Features _ when not top -> Error.bug "Non top features declaration"
| New_ast.Labels _ when not top -> Error.bug "Non top labels declaration"
| x -> x :: acc
) [] new_ast_grs
let new_grs file = unfold_new_grs true (loc_new_grs file)
(* ------------------------------------------------------------------------------------------*)
let gr file =
try
......
......@@ -751,18 +751,15 @@ pst:
/*=============================================================================================*/
new_grs:
| top_decls = list(top_decl) EOF { top_decls }
top_decl:
| f=features_group { New_ast.Features f }
| l=labels { New_ast.Labels l }
| d=decl { New_ast.D d }
| decls = list(decl) EOF { decls }
decl:
| r=rule { New_ast.Rule r }
| IMPORT f=STRING { New_ast.Import f }
| INCL f=STRING { New_ast.Include f }
| PACKAGE id_loc=simple_id_with_loc LACC l=list(decl) RACC { New_ast.Package (fst id_loc, l) }
| f=features_group { New_ast.Features f }
| l=labels { New_ast.Labels l }
| r=rule { New_ast.Rule r }
| IMPORT f=STRING { New_ast.Import f }
| INCL f=STRING { New_ast.Include f }
| PACKAGE id_loc=simple_id_with_loc LACC l=list(decl) RACC { New_ast.Package (fst id_loc, l) }
| STRAT id_loc=simple_id_with_loc LACC d = strat_desc RACC { New_ast.Strategy (fst id_loc, d) }
strat_desc:
......
......@@ -70,6 +70,12 @@ module Domain = struct
handle ~name:"Domain.feature_names"
(fun () -> Grew_domain.Domain.feature_names domain)
()
let dump domain =
handle ~name:"Domain.dump"
(fun () -> Grew_domain.Domain.dump domain)
()
end
(* ==================================================================================================== *)
......@@ -278,6 +284,18 @@ module New_grs = struct
(fun () ->
Grew_grs.New_grs.load file
) ()
let dump grs =
handle ~name:"New_grs.dump"
(fun () ->
Grew_grs.New_grs.dump grs
) ()
let domain grs =
handle ~name:"New_grs.domain"
(fun () ->
Grew_grs.New_grs.domain grs
) ()
end
(* ==================================================================================================== *)
......
......@@ -25,6 +25,7 @@ exception Bug of string
module Domain : sig
type t
val load: string -> t
val dump: t option -> unit
val feature_names: t -> string list
end
......@@ -134,6 +135,10 @@ module New_grs : sig
type t
val load: string -> t
val dump: t -> unit
val domain: t -> Domain.t option
end
(* ==================================================================================================== *)
......
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