module LexingExt = struct
open Lexing
let new_line lexbuf =
lexbuf.lex_curr_p <- {
lexbuf.lex_curr_p with
pos_bol = 0;
pos_lnum = lexbuf.lex_curr_p.pos_lnum + 1
}
end
module ListExt = struct
let inv_assoc l = List.map (fun (x, y) -> (y, x)) l
exception EmptyList
let last l = try List.hd (List.rev l) with _ -> raise EmptyList
let cut_last l =
let rec aux l = function
| [] -> raise EmptyList
| [ x ] -> (x, List.rev l)
| x :: xs -> aux (x :: l) xs
in
aux [] l
let multi_set_of_list l =
let h = Hashtbl.create 13 in
let incr_occ x =
let o = try Hashtbl.find h x with Not_found -> 0 in
Hashtbl.replace h x (o + 1)
in
List.iter incr_occ l;
Hashtbl.fold (fun k v accu -> (k, v) :: accu) h []
let hashtbl_of_assoc l =
let h = Hashtbl.create 13 in
List.iter (fun (k, v) -> Hashtbl.add h k v) l;
h
exception Conflict
let assoc_union l1 l2 =
let h1 = hashtbl_of_assoc l1 in
l1
@ List.filter
(fun (k, v1) ->
try
let v2 = Hashtbl.find h1 k in
if v1 <> v2 then raise Conflict;
false
with _ -> true) l2
let assoc_diff l1 l2 =
let h1 = hashtbl_of_assoc l1 in
let h2 = hashtbl_of_assoc l2 in
let diff h1 h2 f =
Hashtbl.fold
(fun k v1 accu ->
let v2 =
try Some (Hashtbl.find h2 k)
with Not_found -> None
in
if Some v1 <> v2 then
if f then
(k, (Some v1, v2)) :: accu
else
(k, (v2, Some v1)) :: accu
else
accu)
h1 []
in
let d1 = diff h1 h2 true in
let d2 = diff h2 h1 false in
try assoc_union d1 d2
with Conflict -> assert false
let transitive_forall2 p l =
let rec aux = function
| [] -> None
| [x] -> None
| x1 :: ((x2 :: _) as xs) ->
if not (p x1 x2) then Some (x1, x2) else aux xs
in
aux l
end
module ArgExt = struct
let extra_doc s = "", Arg.Unit ignore, s
end
module SysExt = struct
let safe_remove name =
try Sys.remove name with Sys_error _ -> ()
let rec alternative name =
if not (Sys.file_exists name) then
name
else
let dirname = Filename.dirname name in
let filename = Filename.basename name in
let r = Str.regexp "\\([0-9]+\\)-\\(.*\\)" in
let filename =
if Str.string_match r filename 0 then
let i = int_of_string (Str.matched_group 1 filename) in
Printf.sprintf "%02d-%s" (i + 1) (Str.matched_group 2 filename)
else
"01-" ^ filename
in
alternative (Filename.concat dirname filename)
end
let fresh_file prefix suffix =
let string_of_complement = function
| None -> ""
| Some i -> string_of_int i in
let next_complement = function
| None -> Some 0
| Some i -> Some (i+1) in
let rec aux complement =
let filename = prefix ^ (string_of_complement complement) ^ suffix in
if not (Sys.file_exists filename) then filename
else aux (next_complement complement) in
aux None
let exists_exts base exts =
let f res ext = res || (Sys.file_exists (base ^ ext)) in
List.fold_left f false exts
let fresh_base base exts =
let string_of_complement = function
| None -> ""
| Some i -> string_of_int i in
let next_complement = function
| None -> Some 0
| Some i -> Some (i+1) in
let rec aux complement =
let new_base = base ^ (string_of_complement complement) in
if not (exists_exts new_base exts) then new_base
else aux (next_complement complement) in
aux None
let rec repeat n f a =
if n = 0 then a
else repeat (n-1) f (f a)