Commit e459c7fc authored by Andrei Paskevich's avatar Andrei Paskevich

registered transformations are automatically named

parent 18b84207
...@@ -32,6 +32,8 @@ let debug = Debug.register_flag "transform" ...@@ -32,6 +32,8 @@ let debug = Debug.register_flag "transform"
type 'a trans = task -> 'a type 'a trans = task -> 'a
type 'a tlist = 'a list trans type 'a tlist = 'a list trans
let apply f x = f x
let identity x = x let identity x = x
let identity_l x = [x] let identity_l x = [x]
...@@ -42,18 +44,6 @@ let singleton f x = [f x] ...@@ -42,18 +44,6 @@ let singleton f x = [f x]
let compose f g x = g (f x) let compose f g x = g (f x)
let compose_l f g x = list_apply g (f x) let compose_l f g x = list_apply g (f x)
exception TransFailure of (string * exn)
let apply f x = f x
let apply_named s f x =
Debug.dprintf debug "Apply transformation %s@." s;
try apply f x with
| e when not (Debug.test_flag Debug.stack_trace) ->
raise (TransFailure (s,e))
let catch_named = apply_named
module Wtask = Hashweak.Make (struct module Wtask = Hashweak.Make (struct
type t = task_hd type t = task_hd
let tag t = t.task_tag let tag t = t.task_tag
...@@ -224,13 +214,11 @@ let on_tagged_pr t fn = ...@@ -224,13 +214,11 @@ let on_tagged_pr t fn =
(** debug *) (** debug *)
let print_meta f m task = let print_meta f m task =
if Debug.test_flag f then let print_tds fmt m =
(let fmt = Debug.get_debug_formatter () in Pp.print_iter1 Stdecl.iter Pp.newline Pretty.print_tdecl fmt
Pp.print_iter1 Stdecl.iter Pp.newline (find_meta_tds task m).tds_set
Pretty.print_tdecl in
fmt Debug.dprintf f "%a@." print_tds m;
(find_meta_tds task m).tds_set;
(Pp.add_flush Pp.newline) fmt ());
task task
(** register transformations *) (** register transformations *)
...@@ -244,25 +232,31 @@ end) ...@@ -244,25 +232,31 @@ end)
exception UnknownTrans of string exception UnknownTrans of string
exception KnownTrans of string exception KnownTrans of string
exception TransFailure of (string * exn)
let named s f (x : task) =
Debug.dprintf debug "Apply transformation %s@." s;
if Debug.test_flag Debug.stack_trace then f x
else try f x with e -> raise (TransFailure (s,e))
let transforms : (string, env -> task trans) Hashtbl.t = Hashtbl.create 17 let transforms : (string, env -> task trans) Hashtbl.t = Hashtbl.create 17
let transforms_l : (string, env -> task tlist) Hashtbl.t = Hashtbl.create 17 let transforms_l : (string, env -> task tlist) Hashtbl.t = Hashtbl.create 17
let register_transform s p = let register_transform s p =
if Hashtbl.mem transforms s then raise (KnownTrans s); if Hashtbl.mem transforms s then raise (KnownTrans s);
Hashtbl.replace transforms s (fun _ -> p) Hashtbl.replace transforms s (fun _ -> named s p)
let register_transform_l s p = let register_transform_l s p =
if Hashtbl.mem transforms_l s then raise (KnownTrans s); if Hashtbl.mem transforms_l s then raise (KnownTrans s);
Hashtbl.replace transforms_l s (fun _ -> p) Hashtbl.replace transforms_l s (fun _ -> named s p)
let register_env_transform s p = let register_env_transform s p =
if Hashtbl.mem transforms s then raise (KnownTrans s); if Hashtbl.mem transforms s then raise (KnownTrans s);
Hashtbl.replace transforms s (Wenv.memoize 3 p) Hashtbl.replace transforms s (Wenv.memoize 3 (fun e -> named s (p e)))
let register_env_transform_l s p = let register_env_transform_l s p =
if Hashtbl.mem transforms_l s then raise (KnownTrans s); if Hashtbl.mem transforms_l s then raise (KnownTrans s);
Hashtbl.replace transforms_l s (Wenv.memoize 3 p) Hashtbl.replace transforms_l s (Wenv.memoize 3 (fun e -> named s (p e)))
let lookup_transform s = let lookup_transform s =
try Hashtbl.find transforms s with Not_found -> raise (UnknownTrans s) try Hashtbl.find transforms s with Not_found -> raise (UnknownTrans s)
......
...@@ -39,9 +39,6 @@ val singleton : 'a trans -> 'a tlist ...@@ -39,9 +39,6 @@ val singleton : 'a trans -> 'a tlist
val compose : task trans -> 'a trans -> 'a trans val compose : task trans -> 'a trans -> 'a trans
val compose_l : task tlist -> 'a tlist -> 'a tlist val compose_l : task tlist -> 'a tlist -> 'a tlist
(* Should be only used with functions working in constant time *)
(* val conv_res : ('a -> 'b) -> 'a trans -> 'b trans *)
val fold : (task_hd -> 'a -> 'a ) -> 'a -> 'a trans val fold : (task_hd -> 'a -> 'a ) -> 'a -> 'a trans
val fold_l : (task_hd -> 'a -> 'a list) -> 'a -> 'a tlist val fold_l : (task_hd -> 'a -> 'a list) -> 'a -> 'a tlist
...@@ -81,12 +78,12 @@ val on_tagged_pr : meta -> (Spr.t -> 'a trans) -> 'a trans ...@@ -81,12 +78,12 @@ val on_tagged_pr : meta -> (Spr.t -> 'a trans) -> 'a trans
(** debug transformation *) (** debug transformation *)
val print_meta : Debug.flag -> meta -> task trans val print_meta : Debug.flag -> meta -> task trans
(** [print_meta f m] if [d] is set pretty_print on the debug (** [print_meta f m] is an identity transformation that
formatter. In all the case the transformation is indeed the prints every meta [m] in the task if flag [d] is set *)
identity *)
(** {2 Registration} *) (** {2 Registration} *)
exception TransFailure of (string * exn)
exception UnknownTrans of string exception UnknownTrans of string
exception KnownTrans of string exception KnownTrans of string
...@@ -102,9 +99,6 @@ val lookup_transform_l : string -> Env.env -> task tlist ...@@ -102,9 +99,6 @@ val lookup_transform_l : string -> Env.env -> task tlist
val list_transforms : unit -> string list val list_transforms : unit -> string list
val list_transforms_l : unit -> string list val list_transforms_l : unit -> string list
exception TransFailure of (string * exn) val named : string -> 'a trans -> 'a trans
(** give transformation a name without registering *)
val apply_named : string -> 'a trans -> (task -> 'a)
val catch_named : string -> 'a trans -> 'a trans
(** catch the error, and reraise with TransFailure *)
...@@ -246,9 +246,9 @@ let print_task ?old drv fmt task = ...@@ -246,9 +246,9 @@ let print_task ?old drv fmt task =
in in
let lookup_transform t = t, lookup_transform t drv.drv_env in let lookup_transform t = t, lookup_transform t drv.drv_env in
let transl = List.map lookup_transform drv.drv_transform in let transl = List.map lookup_transform drv.drv_transform in
let apply task (t, tr) = let apply task (_t, tr) =
(* Format.printf "@\n@\n[%f] %s@." (Sys.time ()) t; *) (* Format.printf "@\n@\n[%f] %s@." (Sys.time ()) t; *)
Trans.apply_named t tr task Trans.apply tr task
in in
(*Format.printf "@\n@\nTASK";*) (*Format.printf "@\n@\nTASK";*)
let task = update_task drv task in let task = update_task drv task in
......
...@@ -375,13 +375,13 @@ let do_task drv fname tname (th : Why.Theory.theory) (task : Task.task) = ...@@ -375,13 +375,13 @@ let do_task drv fname tname (th : Why.Theory.theory) (task : Task.task) =
let do_tasks env drv fname tname th task = let do_tasks env drv fname tname th task =
let lookup acc t = let lookup acc t =
(try t, Trans.singleton (Trans.lookup_transform t env) with (try Trans.singleton (Trans.lookup_transform t env) with
Trans.UnknownTrans _ -> t, Trans.lookup_transform_l t env) :: acc Trans.UnknownTrans _ -> Trans.lookup_transform_l t env) :: acc
in in
let trans = List.fold_left lookup [] !opt_trans in let trans = List.fold_left lookup [] !opt_trans in
let apply tasks (s, tr) = let apply tasks tr =
List.rev (List.fold_left (fun acc task -> List.rev (List.fold_left (fun acc task ->
List.rev_append (Trans.apply_named s tr task) acc) [] tasks) List.rev_append (Trans.apply tr task) acc) [] tasks)
in in
let tasks = List.fold_left apply [task] trans in let tasks = List.fold_left apply [task] trans in
List.iter (do_task drv fname tname th) tasks List.iter (do_task drv fname tname th) tasks
......
...@@ -53,7 +53,7 @@ let enco_gen opt env = ...@@ -53,7 +53,7 @@ let enco_gen opt env =
| Some [MAstr s] -> s | Some [MAstr s] -> s
| _ -> assert false in | _ -> assert false in
try try
Trans.catch_named s ((Hashtbl.find opt.table s) env) Trans.named s ((Hashtbl.find opt.table s) env)
with Not_found -> failwith with Not_found -> failwith
(Format.sprintf "encoding : %s wrong argument %s" opt.meta.meta_name s)) (Format.sprintf "encoding : %s wrong argument %s" opt.meta.meta_name s))
......
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