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)