(** PROFILING *)
+(* we should use a key in te registry, but we can't see the registry.. *)
let profiling_enabled = true
+let profiling_printings = ref (fun () -> true)
+let set_profiling_printings f = profiling_printings := f
+
type profiler = { profile : 'a 'b. ('a -> 'b) -> 'a -> 'b }
let profile ?(enable = true) =
- if profiling_enabled && enable then
+ if profiling_enabled && enable then
function s ->
let total = ref 0.0 in
let profile f x =
in
at_exit
(fun () ->
- print_endline
- ("!! TOTAL TIME SPENT IN " ^ s ^ ": " ^ string_of_float !total));
+ if !profiling_printings () then
+ prerr_endline
+ ("!! TOTAL TIME SPENT IN " ^ s ^ ": " ^ string_of_float !total));
{ profile = profile }
else
function _ -> { profile = fun f x -> f x }
(** {2 List processing} *)
-let rec list_uniq = function
+let rec list_uniq ?(eq=(=)) = function
| [] -> []
| h::[] -> [h]
- | h1::h2::tl when h1 = h2 -> list_uniq (h2 :: tl)
- | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq tl
+ | h1::h2::tl when eq h1 h2 -> list_uniq ~eq (h2 :: tl)
+ | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq ~eq tl
let rec filter_map f =
function
in
aux [] [path]
+let safe_remove fname = if Sys.file_exists fname then Sys.remove fname
+
+let is_dir_empty d =
+ let od = Unix.opendir d in
+ let rec aux () =
+ let name = Unix.readdir od in
+ if name <> "." && name <> ".." then false else aux () in
+ let res = try aux () with End_of_file -> true in
+ Unix.closedir od;
+ res
+
+let safe_rmdir d = try Unix.rmdir d with Unix.Unix_error _ -> ()
+
+let rec rmdir_descend d =
+ if is_dir_empty d then
+ begin
+ safe_rmdir d;
+ rmdir_descend (Filename.dirname d)
+ end
+
+
(** {2 Exception handling} *)
let finally at_end f arg =
at_end ();
res
+(** {2 Localized exceptions } *)
+
+exception Localized of Token.flocation * exn
+
+let loc_of_floc = function
+ | { Lexing.pos_cnum = loc_begin }, { Lexing.pos_cnum = loc_end } ->
+ (loc_begin, loc_end)
+
+let raise_localized_exception ~offset floc exn =
+ let (x, y) = loc_of_floc floc in
+ let x = offset + x in
+ let y = offset + y in
+ let flocb,floce = floc in
+ let floc =
+ { flocb with Lexing.pos_cnum = x }, { floce with Lexing.pos_cnum = y }
+ in
+ raise (Localized (floc, exn))