1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Sebastien Hinderer, projet Gallium, INRIA Paris *)
6 (* *)
7 (* Copyright 2016 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* Definition of actions, basic blocks for tests *)
17
18 type code = out_channel -> Environments.t -> Result.t * Environments.t
19
20 type t = {
21 name : string;
22 body : code;
23 mutable hook : code option
24 }
25
26 let name a = a.name
27
28 let action_name = Variables.make ("action_name", "Name of the current action")
29
30 let make n c = { name = n; body = c; hook = None }
31
32 let update action code = { action with body = code }
33
34 let compare a1 a2 = String.compare a1.name a2.name
35
36 let (actions : (string, t) Hashtbl.t) = Hashtbl.create 10
37
38 let register action =
39 Hashtbl.add actions action.name action
40
41 let get_registered_actions () =
42 let f _name action acc = action::acc in
43 let unsorted_actions = Hashtbl.fold f actions [] in
44 List.sort compare unsorted_actions
45
46 let lookup name =
47 try Some (Hashtbl.find actions name)
48 with Not_found -> None
49
50 let set_hook name hook =
51 let action = (Hashtbl.find actions name) in
52 action.hook <- Some hook
53
54 let clear_hook name =
55 let action = (Hashtbl.find actions name) in
56 action.hook <- None
57
58 let clear_all_hooks () =
59 let f _name action = action.hook <- None in
60 Hashtbl.iter f actions
61
62 let run log env action =
63 let code = match action.hook with
64 | None -> action.body
65 | Some code -> code in
66 let env = Environments.add action_name action.name env in
67 code log env
68
69 module ActionSet = Set.Make
70 (struct
71 type nonrec t = t
72 let compare = compare
73 end)
74
75 let _ = Variables.register_variable action_name
76