* http://cs.unibo.it/helm/.
*)
+(* $Id$ *)
(** 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 }
let left, right = find_left 0, find_right (s_len - 1) in
String.sub s left (right - left + 1)
+(** {2 Char processing} *)
+
+let is_alpha c =
+ let code = Char.code c in
+ (code >= 65 && code <= 90) || (code >= 97 && code <= 122)
+
+let is_digit c =
+ let code = Char.code c in
+ code >= 48 && code <= 57
+
+let is_blank c =
+ let code = Char.code c in
+ code = 9 || code = 10 || code = 13 || code = 32
+
+let is_alphanum c = is_alpha c || is_digit c
+
(** {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
| hd :: tl -> aux ([sep; hd] @ acc) tl
in
aux []
+
+let rec list_findopt f l =
+ let rec aux = function
+ | [] -> None
+ | x::tl ->
+ (match f x with
+ | None -> aux tl
+ | Some _ as rc -> rc)
+ in
+ aux l
(** {2 File predicates} *)
let oc = open_out filename in
output_string oc text;
close_out oc
+
+let blank_split s =
+ let len = String.length s in
+ let buf = Buffer.create 0 in
+ let rec aux acc i =
+ if i >= len
+ then begin
+ if Buffer.length buf > 0
+ then List.rev (Buffer.contents buf :: acc)
+ else List.rev acc
+ end else begin
+ if is_blank s.[i] then
+ if Buffer.length buf > 0 then begin
+ let s = Buffer.contents buf in
+ Buffer.clear buf;
+ aux (s :: acc) (i + 1)
+ end else
+ aux acc (i + 1)
+ else begin
+ Buffer.add_char buf s.[i];
+ aux acc (i + 1)
+ end
+ end
+ in
+ aux [] 0
+
+ (* Rules: * "~name" -> home dir of "name"
+ * "~" -> value of $HOME if defined, home dir of the current user otherwise *)
+let tilde_expand s =
+ let get_home login = (Unix.getpwnam login).Unix.pw_dir in
+ let expand_one s =
+ let len = String.length s in
+ if len > 0 && s.[0] = '~' then begin
+ let login_len = ref 1 in
+ while !login_len < len && is_alphanum (s.[!login_len]) do
+ incr login_len
+ done;
+ let login = String.sub s 1 (!login_len - 1) in
+ try
+ let home =
+ if login = "" then
+ try Sys.getenv "HOME" with Not_found -> get_home (Unix.getlogin ())
+ else
+ get_home login
+ in
+ home ^ String.sub s !login_len (len - !login_len)
+ with Not_found | Invalid_argument _ -> s
+ end else
+ s
+ in
+ String.concat " " (List.map expand_one (blank_split s))
let find ?(test = fun _ -> true) path =
let rec aux acc todo =
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 floc_of_loc (loc_begin, loc_end) =
+ let floc_begin =
+ { Lexing.pos_fname = ""; Lexing.pos_lnum = -1; Lexing.pos_bol = -1;
+ Lexing.pos_cnum = loc_begin }
+ in
+ let floc_end = { floc_begin with Lexing.pos_cnum = loc_end } in
+ (floc_begin, floc_end)
+
+let dummy_floc = floc_of_loc (-1, -1)
+
+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))