diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Common.ml | 4 | ||||
| -rw-r--r-- | src/Hook.ml | 57 | ||||
| -rw-r--r-- | src/TamasheqLib.ml | 19 | ||||
| -rw-r--r-- | src/TamasheqLib.mli | 28 |
4 files changed, 108 insertions, 0 deletions
diff --git a/src/Common.ml b/src/Common.ml index 6f7c5f4..8f8d8d6 100644 --- a/src/Common.ml +++ b/src/Common.ml @@ -198,3 +198,7 @@ let lift3 (type a) (type b) (type c) (type d) function | [x; y; z] -> Obj.repr @$ f (cast a x) (cast b y) (cast c z) | xs -> unsupported_arity 3 @$ List.length xs + +let string_of_string_option = function + | Some str -> str + | None -> "" diff --git a/src/Hook.ml b/src/Hook.ml new file mode 100644 index 0000000..25caaec --- /dev/null +++ b/src/Hook.ml @@ -0,0 +1,57 @@ +(* +Copyright (c) 2014, Grégoire Duchêne <gduchene@awhk.org> + +Permission to use, copy, modify, and/or distribute this software for +any purpose with or without fee is hereby granted, provided that the +above copyright notice and this permission notice appear in all +copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR +PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. +*) + +open Common +open Printf + +type env = Environment.t +and finalize_fun = env -> result +and hook = string * init_fun * finalize_fun +and init_fun = term list -> result +and result = [ `Abort of string option + | `Continue + | `Warn of string option ] +and term = Lambda.lambda + +let hooks : hook Queue.t = Queue.create () + +let abort hook_name hook_reason = + match hook_reason with + | Some reason -> eprintf "fatal error: hook %s: %s" hook_name reason + | None -> eprintf "fatal error: hook %s failed" hook_name + ; + + exit 1 + +let warn hook_name hook_reason = + match hook_reason with + | Some reason -> eprintf "warning: hook %s: %s" hook_name reason + | None -> eprintf "warning: hook %s failed" hook_name + +let handle_result hook_name = function + | `Abort why -> abort hook_name why + | `Continue -> () + | `Warn why -> warn hook_name why + +let init_hooks terms = + Queue.iter (fun (n, f, _) -> handle_result n @$ f terms) hooks + +let finalize_hooks env = + Queue.iter (fun (n, _, f) -> handle_result n @$ f env) hooks + +let register_hook hook = Queue.push hook hooks diff --git a/src/TamasheqLib.ml b/src/TamasheqLib.ml new file mode 100644 index 0000000..65d4903 --- /dev/null +++ b/src/TamasheqLib.ml @@ -0,0 +1,19 @@ +(* +Copyright (c) 2014, Grégoire Duchêne <gduchene@awhk.org> + +Permission to use, copy, modify, and/or distribute this software for +any purpose with or without fee is hereby granted, provided that the +above copyright notice and this permission notice appear in all +copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR +PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. +*) + +include Hook diff --git a/src/TamasheqLib.mli b/src/TamasheqLib.mli new file mode 100644 index 0000000..32f53c7 --- /dev/null +++ b/src/TamasheqLib.mli @@ -0,0 +1,28 @@ +(* +Copyright (c) 2014, Grégoire Duchêne <gduchene@awhk.org> + +Permission to use, copy, modify, and/or distribute this software for +any purpose with or without fee is hereby granted, provided that the +above copyright notice and this permission notice appear in all +copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL +DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR +PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. +*) + +type env +and finalize_fun = env -> result +and hook = string * init_fun * finalize_fun +and init_fun = term list -> result +and result = [ `Abort of string option + | `Continue + | `Warn of string option ] +and term = Lambda.lambda + +val register_hook : hook -> unit |