Release coccinelle-0.1.8

[bpt/coccinelle.git] / commons / common.ml

(* Yoann Padioleau
 *
 * Copyright (C) 1998-2009 Yoann Padioleau
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * version 2.1 as published by the Free Software Foundation, with the
 * special exception on linking described in file license.txt.
 * 
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the file
 * license.txt for more details.
 *)

(*****************************************************************************)
(* Notes *)
(*****************************************************************************)



(* ---------------------------------------------------------------------- *)
(* Maybe could split common.ml and use include tricks as in ofullcommon.ml or
 * Jane Street core lib. But then harder to bundle simple scripts like my
 * make_full_linux_kernel.ml because would then need to pass all the files
 * either to ocamlc or either to some #load. Also as the code of many
 * functions depends on other functions from this common, it would
 * be tedious to add those dependencies. Here simpler (have just the
 * pb of the Prelude, but it's a small problem).
 * 
 * pixel means code from Pascal Rigaux
 * julia means code from Julia Lawall
 *)
(* ---------------------------------------------------------------------- *)

(*****************************************************************************)
(* We use *)
(*****************************************************************************)
(* 
 * modules:
 *   - Pervasives, of course
 *   - List
 *   - Str
 *   - Hashtbl
 *   - Format 
 *   - Buffer
 *   - Unix and Sys
 *   - Arg
 * 
 * functions: 
 *   - =, <=, max min, abs, ... 
 *   - List.rev, List.mem, List.partition,
 *   - List.fold*, List.concat, ... 
 *   - Str.global_replace
 *   - Filename.is_relative
 *   - String.uppercase, String.lowercase
 * 
 * 
 * The Format library allows to hide passing an indent_level variable.
 * You use as usual the print_string function except that there is
 * this automatic indent_level variable handled for you (and maybe
 * more services). src: julia in coccinelle unparse_cocci.
 * 
 * Extra packages 
 *  - ocamlbdb
 *  - ocamlgtk, and gtksourceview
 *  - ocamlgl
 *  - ocamlpython
 *  - ocamlagrep
 *  - ocamlfuse
 *  - ocamlmpi
 *  - ocamlcalendar
 * 
 *  - pcre
 *  - sdl
 * 
 * Many functions in this file were inspired by Haskell or Lisp librairies.
 *)

(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)

(* The following functions should be in their respective sections but
 * because some functions in some sections use functions in other
 * sections, and because I don't want to take care of the order of
 * those sections, of those dependencies, I put the functions causing
 * dependency problem here. C is better than caml on this with the
 * ability to declare prototype, enabling some form of forward
 * reference. *)

let (+>) o f = f o
let (++) = (@)

exception Timeout
exception UnixExit of int 

let rec (do_n: int -> (unit -> unit) -> unit) = fun i f ->
  if i = 0 then () else (f(); do_n (i-1) f)
let rec (foldn: ('a -> int -> 'a) -> 'a -> int -> 'a) = fun f acc i ->
  if i = 0 then acc else foldn f (f acc i) (i-1)

let sum_int   = List.fold_left (+) 0

(* could really call it 'for' :) *)
let fold_left_with_index f acc =
  let rec fold_lwi_aux acc n = function
    | [] -> acc
    | x::xs -> fold_lwi_aux (f acc x n) (n+1) xs 
  in fold_lwi_aux acc 0


let rec drop n xs = 
  match (n,xs) with
  | (0,_) -> xs
  | (_,[]) -> failwith "drop: not enough"
  | (n,x::xs) -> drop (n-1) xs

let rec enum_orig x n = if x = n then [n] else x::enum_orig (x+1)  n

let enum x n = 
  if not(x <= n)
  then failwith (Printf.sprintf "bad values in enum, expect %d <= %d" x n);
  let rec enum_aux acc x n = 
    if x = n then n::acc else enum_aux (x::acc) (x+1) n 
  in
  List.rev (enum_aux [] x n)

let rec take n xs = 
  match (n,xs) with
  | (0,_) -> []
  | (_,[]) -> failwith "take: not enough"
  | (n,x::xs) -> x::take (n-1) xs


let last_n n l = List.rev (take n (List.rev l))
let last l = List.hd (last_n 1 l)


let (list_of_string: string -> char list) = function
    "" -> []
  | s -> (enum 0 ((String.length s) - 1) +> List.map (String.get s))

let (lines: string -> string list) = fun s -> 
  let rec lines_aux = function
    | [] -> []
    | [x] -> if x = "" then [] else [x] 
    | x::xs -> 
        x::lines_aux xs 
  in
  Str.split_delim (Str.regexp "\n") s +> lines_aux


let push2 v l =
  l := v :: !l

let null xs = match xs with [] -> true | _ -> false




let debugger = ref false  

let unwind_protect f cleanup =
  if !debugger then f() else 
    try f ()
    with e -> begin cleanup e; raise e end

let finalize f cleanup = 
  if !debugger then f() else 
  try 
    let res = f () in
    cleanup ();
    res
  with e -> 
    cleanup ();
    raise e

let command2 s = ignore(Sys.command s)


let (matched: int -> string -> string) = fun i s -> 
  Str.matched_group i s

let matched1 = fun s -> matched 1 s
let matched2 = fun s -> (matched 1 s, matched 2 s)
let matched3 = fun s -> (matched 1 s, matched 2 s, matched 3 s)
let matched4 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s)
let matched5 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s)
let matched6 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s)
let matched7 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s, matched 7 s)

let (with_open_stringbuf: (((string -> unit) * Buffer.t) -> unit) -> string) =
 fun f ->
  let buf = Buffer.create 1000 in
  let pr s = Buffer.add_string buf (s ^ "\n") in
  f (pr, buf);
  Buffer.contents buf


let foldl1 p = function x::xs -> List.fold_left p x xs | _ -> failwith "foldl1"

(*****************************************************************************)
(* Debugging/logging *)
(*****************************************************************************)

(* I used this in coccinelle where the huge logging of stuff ask for 
 * a more organized solution that use more visual indentation hints.
 * 
 * todo? could maybe use log4j instead ? or use Format module more 
 * consistently ?
 *)

let _tab_level_print = ref 0
let _tab_indent = 5


let _prefix_pr = ref ""

let indent_do f = 
  _tab_level_print := !_tab_level_print + _tab_indent;
  finalize f 
   (fun () -> _tab_level_print := !_tab_level_print - _tab_indent;)


let pr s = 
  print_string !_prefix_pr;
  do_n !_tab_level_print (fun () -> print_string " ");
  print_string s;
  print_string "\n"; 
  flush stdout

let pr_no_nl s = 
  print_string !_prefix_pr;
  do_n !_tab_level_print (fun () -> print_string " ");
  print_string s;
  flush stdout






let _chan_pr2 = ref (None: out_channel option)

let out_chan_pr2 ?(newline=true) s = 
  match !_chan_pr2 with
  | None -> ()
  | Some chan -> 
      output_string chan (s ^ (if newline then "\n" else "")); 
      flush chan


let pr2 s = 
  prerr_string !_prefix_pr;
  do_n !_tab_level_print (fun () -> prerr_string " ");
  prerr_string s;
  prerr_string "\n"; 
  flush stderr;
  out_chan_pr2 s;
  ()

let pr2_no_nl s = 
  prerr_string !_prefix_pr;
  do_n !_tab_level_print (fun () -> prerr_string " ");
  prerr_string s;
  flush stderr;
  out_chan_pr2 ~newline:false s;
  ()


let pr_xxxxxxxxxxxxxxxxx () = 
  pr "-----------------------------------------------------------------------"

let pr2_xxxxxxxxxxxxxxxxx () = 
  pr2 "-----------------------------------------------------------------------"


let reset_pr_indent () =
  _tab_level_print := 0

(* old: 
 * let pr s = (print_string s; print_string "\n"; flush stdout)
 * let pr2 s = (prerr_string s; prerr_string "\n"; flush stderr) 
 *)

(* ---------------------------------------------------------------------- *)

(* I can not use the _xxx ref tech that I use for common_extra.ml here because 
 * ocaml don't like the polymorphism of Dumper mixed with refs.
 * 
 * let (_dump_func : ('a -> string) ref) = ref 
 * (fun x -> failwith "no dump yet, have you included common_extra.cmo?")
 * let (dump : 'a -> string) = fun x ->
 * !_dump_func x
 * 
 * So I have included directly dumper.ml in common.ml. It's more practical
 * when want to give script that use my common.ml, I just have to give
 * this file.
 *)

(* start of dumper.ml *)

(* Dump an OCaml value into a printable string.
 * By Richard W.M. Jones (rich@annexia.org).
 * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp 
 *)
open Printf
open Obj

let rec dump r =
  if is_int r then
    string_of_int (magic r : int)
  else (                                (* Block. *)
    let rec get_fields acc = function
      | 0 -> acc
      | n -> let n = n-1 in get_fields (field r n :: acc) n
    in
    let rec is_list r =
      if is_int r then (
        if (magic r : int) = 0 then true (* [] *)
        else false
      ) else (
        let s = size r and t = tag r in
        if t = 0 && s = 2 then is_list (field r 1) (* h :: t *)
        else false
      )
    in
    let rec get_list r =
      if is_int r then []
      else let h = field r 0 and t = get_list (field r 1) in h :: t
    in
    let opaque name =
      (* XXX In future, print the address of value 'r'.  Not possible in
       * pure OCaml at the moment.
       *)
      "<" ^ name ^ ">"
    in

    let s = size r and t = tag r in

    (* From the tag, determine the type of block. *)
    if is_list r then ( (* List. *)
      let fields = get_list r in
      "[" ^ String.concat "; " (List.map dump fields) ^ "]"
    )
    else if t = 0 then (                (* Tuple, array, record. *)
      let fields = get_fields [] s in
      "(" ^ String.concat ", " (List.map dump fields) ^ ")"
    )

      (* Note that [lazy_tag .. forward_tag] are < no_scan_tag.  Not
       * clear if very large constructed values could have the same
       * tag. XXX *)
    else if t = lazy_tag then opaque "lazy"
    else if t = closure_tag then opaque "closure"
    else if t = object_tag then (       (* Object. *)
      let fields = get_fields [] s in
      let clasz, id, slots =
        match fields with h::h'::t -> h, h', t | _ -> assert false in
      (* No information on decoding the class (first field).  So just print
       * out the ID and the slots.
       *)
      "Object #" ^ dump id ^
      " (" ^ String.concat ", " (List.map dump slots) ^ ")"
    )
    else if t = infix_tag then opaque "infix"
    else if t = forward_tag then opaque "forward"

    else if t < no_scan_tag then (      (* Constructed value. *)
      let fields = get_fields [] s in
      "Tag" ^ string_of_int t ^
      " (" ^ String.concat ", " (List.map dump fields) ^ ")"
    )
    else if t = string_tag then (
      "\"" ^ String.escaped (magic r : string) ^ "\""
    )
    else if t = double_tag then (
      string_of_float (magic r : float)
    )
    else if t = abstract_tag then opaque "abstract"
    else if t = custom_tag then opaque "custom"
    else if t = final_tag then opaque "final"
    else failwith ("dump: impossible tag (" ^ string_of_int t ^ ")")
  )

let dump v = dump (repr v)

(* end of dumper.ml *)

(*
let (dump : 'a -> string) = fun x ->
  Dumper.dump x
*)


(* ---------------------------------------------------------------------- *)
let pr2_gen x = pr2 (dump x)



(* ---------------------------------------------------------------------- *)


let _already_printed = Hashtbl.create 101
let disable_pr2_once = ref false 

let xxx_once f s = 
  if !disable_pr2_once then pr2 s
  else 
    if not (Hashtbl.mem _already_printed s)
    then begin
      Hashtbl.add _already_printed s true;
      f ("(ONCE) " ^ s);
    end

let pr2_once s = xxx_once pr2 s

(* ---------------------------------------------------------------------- *)
let mk_pr2_wrappers aref = 
  let fpr2 s = 
    if !aref
    then pr2 s
    else 
      (* just to the log file *)
      out_chan_pr2 s
  in
  let fpr2_once s = 
    if !aref
    then pr2_once s
    else 
      xxx_once out_chan_pr2 s
  in
  fpr2, fpr2_once


(* ---------------------------------------------------------------------- *)
(* could also be in File section *)

let redirect_stdout_stderr file f = 
  begin
    let chan = open_out file in
    let descr = Unix.descr_of_out_channel chan in

    let saveout = Unix.dup Unix.stdout in
    let saveerr = Unix.dup Unix.stderr in
    Unix.dup2 descr Unix.stdout;
    Unix.dup2 descr Unix.stderr;
    flush stdout; flush stderr;
    f();
    flush stdout; flush stderr;
    Unix.dup2 saveout Unix.stdout;
    Unix.dup2 saveerr Unix.stderr;
    close_out chan;
  end

let redirect_stdin file f = 
  begin
    let chan = open_in file in
    let descr = Unix.descr_of_in_channel chan in

    let savein = Unix.dup Unix.stdin in
    Unix.dup2 descr Unix.stdin;
    f();
    Unix.dup2 savein Unix.stdin;
    close_in chan;
  end

let redirect_stdin_opt optfile f = 
  match optfile with
  | None -> f()
  | Some infile -> redirect_stdin infile f


(* cf end 
let with_pr2_to_string f = 
*)
  

(* ---------------------------------------------------------------------- *)

include Printf

(* cf common.mli, fprintf, printf, eprintf, sprintf.
 * also what is this ?
 *  val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a
 *  val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
 *)

(* ex of printf: 
 *  printf "%02d" i
 * for padding
 *)

let spf = sprintf

(* ---------------------------------------------------------------------- *)

let _chan = ref stderr
let start_log_file () = 
  let filename = (spf "/tmp/debugml%d:%d" (Unix.getuid()) (Unix.getpid())) in
  pr2 (spf "now using %s for logging" filename);
  _chan := open_out filename
   

let dolog s = output_string !_chan (s ^ "\n"); flush !_chan

let verbose_level = ref 1
let log s =  if !verbose_level >= 1 then dolog s
let log2 s = if !verbose_level >= 2 then dolog s
let log3 s = if !verbose_level >= 3 then dolog s
let log4 s = if !verbose_level >= 4 then dolog s

let if_log f = if !verbose_level >= 1 then f()
let if_log2 f = if !verbose_level >= 2 then f()
let if_log3 f = if !verbose_level >= 3 then f()
let if_log4 f = if !verbose_level >= 4 then f()

(* ---------------------------------------------------------------------- *)

let pause () = (pr2 "pause: type return"; ignore(read_line ()))

(* src: from getopt from frish *)
let bip ()  = Printf.printf "\007"; flush stdout
let wait () = Unix.sleep 1 

(* was used by fix_caml *)
let _trace_var = ref 0
let add_var() = incr _trace_var
let dec_var() = decr _trace_var
let get_var() = !_trace_var

let (print_n: int -> string -> unit) = fun i s -> 
  do_n i (fun () -> print_string s)
let (printerr_n: int -> string -> unit) = fun i s -> 
  do_n i (fun () -> prerr_string s)

let _debug = ref true
let debugon  () = _debug := true
let debugoff () = _debug := false
let debug f = if !_debug then f () else ()



(* now in prelude:
 * let debugger = ref false  
 *)


(*****************************************************************************)
(* Profiling *)
(*****************************************************************************)

let get_mem() =
  command2("grep VmData /proc/" ^ string_of_int (Unix.getpid()) ^ "/status")

let memory_stat () =
  let stat = Gc.stat() in
  let conv_mo x = x * 4 / 1000000 in
  Printf.sprintf "maximal = %d Mo\n" (conv_mo stat.Gc.top_heap_words) ^
  Printf.sprintf "current = %d Mo\n" (conv_mo stat.Gc.heap_words) ^
  Printf.sprintf "lives   = %d Mo\n" (conv_mo stat.Gc.live_words)
  (* Printf.printf "fragments = %d Mo\n" (conv_mo stat.Gc.fragments); *)

let timenow () = 
  "sys:" ^ (string_of_float (Sys.time ())) ^ " seconds" ^
  ":real:" ^ 
    (let tm = Unix.time () +> Unix.gmtime in
     tm.Unix.tm_min +> string_of_int ^ " min:" ^ 
     tm.Unix.tm_sec +> string_of_int ^ ".00 seconds")

let _count1 = ref 0  
let _count2 = ref 0  
let _count3 = ref 0  
let _count4 = ref 0  
let _count5 = ref 0  

let count1 () = incr _count1
let count2 () = incr _count2
let count3 () = incr _count3
let count4 () = incr _count4
let count5 () = incr _count5

let profile_diagnostic_basic () = 
  Printf.sprintf 
    "count1 = %d\ncount2 = %d\ncount3 = %d\ncount4 = %d\ncount5 = %d\n" 
    !_count1 !_count2 !_count3 !_count4 !_count5



let time_func f = 
  (*   let _ = Timing () in *)
  let x = f () in
  (*   let _ = Timing () in *)
  x

(* ---------------------------------------------------------------------- *)

type prof = PALL | PNONE | PSOME of string list
let profile = ref PNONE
let show_trace_profile = ref false

let check_profile category =
  match !profile with
    PALL -> true
  | PNONE -> false
  | PSOME l -> List.mem category l

let _profile_table = ref (Hashtbl.create 100)

let adjust_profile_entry category difftime =
  let (xtime, xcount) = 
    (try Hashtbl.find !_profile_table category
    with Not_found -> 
      let xtime = ref 0.0 in
      let xcount = ref 0 in
      Hashtbl.add !_profile_table category (xtime, xcount);
      (xtime, xcount)
    ) in
  xtime := !xtime +. difftime;
  xcount := !xcount + 1;
  ()

let profile_start category = failwith "todo"
let profile_end category = failwith "todo"


(* subtil: don't forget to give all argumens to f, otherwise partial app
 * and will profile nothing.
 * 
 * todo: try also detect when complexity augment each time, so can
 * detect the situation for a function gets worse and worse ? 
 *)  
let profile_code category f = 
  if not (check_profile category)
  then f() 
  else begin
  if !show_trace_profile then pr2 (spf "p: %s" category);
  let t = Unix.gettimeofday () in
  let res, prefix = 
    try Some (f ()), ""
    with Timeout -> None, "*"
  in
  let category = prefix ^ category in (* add a '*' to indicate timeout func *)
  let t' = Unix.gettimeofday () in

  adjust_profile_entry category (t' -. t);
  (match res with
  | Some res -> res
  | None -> raise Timeout
  );
  end


let _is_in_exclusif = ref (None: string option) 

let profile_code_exclusif category f = 
  if not (check_profile category)
  then f() 
  else begin

  match !_is_in_exclusif with
  | Some s -> 
      failwith (spf "profile_code_exclusif: %s but already in %s " category s);
  | None -> 
      _is_in_exclusif := (Some category);
      finalize 
        (fun () -> 
          profile_code category f
        ) 
        (fun () -> 
          _is_in_exclusif := None
        )

  end

let profile_code_inside_exclusif_ok category f = 
  failwith "Todo"


(* todo: also put  % ? also add % to see if coherent numbers *)
let profile_diagnostic () = 
  if !profile = PNONE then "" else
  let xs = 
    Hashtbl.fold (fun k v acc -> (k,v)::acc) !_profile_table [] 
      +> List.sort (fun (k1, (t1,n1)) (k2, (t2,n2)) -> compare t2 t1)
    in
    with_open_stringbuf (fun (pr,_) -> 
      pr "---------------------";
      pr "profiling result";
      pr "---------------------";
      xs +> List.iter (fun (k, (t,n)) -> 
        pr (sprintf "%-40s : %10.3f sec %10d count" k !t !n)
      )
    )



let report_if_take_time timethreshold s f = 
  let t = Unix.gettimeofday () in
  let res = f () in
  let t' = Unix.gettimeofday () in
  if (t' -. t  > float_of_int timethreshold) 
  then pr2 (sprintf "NOTE: this code takes more than: %ds %s" timethreshold s);
  res

let profile_code2 category f = 
  profile_code category (fun () -> 
    if !profile = PALL
    then pr2 ("starting: " ^ category);
    let t = Unix.gettimeofday () in
    let res = f () in
    let t' = Unix.gettimeofday () in
    if !profile = PALL
    then pr2 (spf "ending: %s, %fs" category (t' -. t));
    res
  )
    

(*****************************************************************************)
(* Test *)
(*****************************************************************************)
let example b = assert b

let _ex1 = example (enum 1 4 = [1;2;3;4])

let assert_equal a b = 
  if not (a = b) 
  then failwith ("assert_equal: those 2 values are not equal:\n\t" ^ 
                 (dump a) ^ "\n\t" ^ (dump b) ^ "\n")

let (example2: string -> bool -> unit) = fun s b -> 
  try assert b with x -> failwith s

(*-------------------------------------------------------------------*)
let _list_bool = ref []

let (example3: string -> bool -> unit) = fun s b -> 
 _list_bool := (s,b)::(!_list_bool)

(* could introduce a fun () otherwise the calculus is made at compile time
 * and this can be long. This would require to redefine test_all.
 *   let (example3: string -> (unit -> bool) -> unit) = fun s func -> 
 *   _list_bool := (s,func):: (!_list_bool)
 * 
 * I would like to do as a func that take 2 terms, and make an = over it
 * avoid to add this ugly fun (), but pb of type, cant do that :(
 *)


let (test_all: unit -> unit) = fun () -> 
  List.iter (fun (s, b) -> 
    Printf.printf "%s: %s\n" s (if b then "passed" else "failed")
  ) !_list_bool

let (test: string -> unit) = fun s -> 
  Printf.printf "%s: %s\n" s 
    (if (List.assoc s (!_list_bool)) then "passed" else "failed")

let _ex = example3 "++" ([1;2]++[3;4;5] = [1;2;3;4;5])

(*-------------------------------------------------------------------*)
(* Regression testing *)
(*-------------------------------------------------------------------*)

(* cf end of file. It uses too many other common functions so I 
 * have put the code at the end of this file.
 *)



(* todo? take code from julien signoles in calendar-2.0.2/tests *)
(*

(* Generic functions used in the tests. *)

val reset : unit -> unit
val nb_ok : unit -> int
val nb_bug : unit -> int
val test : bool -> string -> unit
val test_exn : 'a Lazy.t -> string -> unit


let ok_ref = ref 0
let ok () = incr ok_ref
let nb_ok () = !ok_ref

let bug_ref = ref 0
let bug () = incr bug_ref
let nb_bug () = !bug_ref

let reset () =
  ok_ref := 0;
  bug_ref := 0

let test x s = 
  if x then ok () else begin Printf.printf "%s\n" s; bug () end;;

let test_exn x s =
  try
    ignore (Lazy.force x);
    Printf.printf "%s\n" s;
    bug ()
  with _ ->
    ok ();;
*)


(*****************************************************************************)
(* Quickcheck like (sfl) *)
(*****************************************************************************)

(* Better than quickcheck, cos cant do a test_all_prop in haskell cos
 * prop were functions, whereas here we have not prop_Unix x = ... but
 * laws "unit" ... 
 *
 * How to do without overloading ? objet ? can pass a generator as a
 * parameter, mais lourd, prefer automatic inferring of the
 * generator? But at the same time quickcheck does not do better cos
 * we must explictly type the property. So between a 
 *    prop_unit:: [Int] -> [Int] -> bool ... 
 *    prop_unit x = reverse [x] == [x] 
 * and 
 *    let _ = laws "unit" (fun x -> reverse [x] = [x]) (listg intg) 
 * there is no real differences.  
 *
 * Yes I define typeg generator but quickcheck too, he must define
 * class instance. I emulate the context Gen a => Gen [a] by making
 * listg take as a param a type generator. Moreover I have not the pb of
 * monad. I can do random independently, so my code is more simple 
 * I think than the haskell code of quickcheck.
 * 
 * update: apparently Jane Street have copied some of my code for their
 * Ounit_util.ml and quichcheck.ml in their Core library :)
 *)

(*---------------------------------------------------------------------------*)
(* generators *)
(*---------------------------------------------------------------------------*)
type 'a gen = unit -> 'a

let (ig: int gen) = fun () ->
  Random.int 10
let (lg: ('a gen) -> ('a list) gen) = fun gen () -> 
  foldn (fun acc i -> (gen ())::acc) [] (Random.int 10)
let (pg: ('a gen) -> ('b gen) -> ('a * 'b) gen) = fun gen1 gen2 () -> 
  (gen1 (), gen2 ())
let polyg = ig
let (ng: (string gen)) = fun () -> 
  "a" ^ (string_of_int (ig ()))

let (oneofl: ('a list) -> 'a gen) = fun xs () -> 
  List.nth xs (Random.int (List.length xs)) 
(* let oneofl l = oneof (List.map always l) *)

let (oneof: (('a gen) list) -> 'a gen) = fun xs -> 
  List.nth xs (Random.int (List.length xs)) 

let (always: 'a -> 'a gen) = fun e () -> e

let (frequency: ((int * ('a gen)) list) -> 'a gen) = fun xs -> 
  let sums = sum_int (List.map fst xs) in
  let i = Random.int sums in
  let rec freq_aux acc = function 
    | (x,g)::xs -> if i < acc+x then g else freq_aux (acc+x) xs 
    | _ -> failwith "frequency" 
  in
  freq_aux 0 xs
let frequencyl l = frequency (List.map (fun (i,e) -> (i,always e)) l)

(* 
let b = oneof [always true; always false] ()
let b = frequency [3, always true; 2, always false] ()
*)

(* cant do this:
 *    let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneofl [[]; lg gen ()]
 * nor
 *    let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneof [always []; lg gen]
 * 
 * because caml is not as lazy as haskell :( fix the pb by introducing a size
 * limit. take the bounds/size as parameter. morover this is needed for
 * more complex type.
 * 
 * how make a bintreeg ?? we need recursion
 * 
 * let rec (bintreeg: ('a gen) -> ('a bintree) gen) = fun gen () -> 
 * let rec aux n = 
 * if n = 0 then (Leaf (gen ()))
 * else frequencyl [1, Leaf (gen ()); 4, Branch ((aux (n / 2)), aux (n / 2))]
 * ()
 * in aux 20
 * 
 *)


(*---------------------------------------------------------------------------*)
(* property *)
(*---------------------------------------------------------------------------*)

(* todo: a test_all_laws, better syntax (done already a little with ig in
 * place of intg. En cas d'erreur, print the arg that not respect 
 * 
 * todo: with monitoring, as in haskell, laws = laws2, no need for 2 func,
 * but hard i found
 * 
 * todo classify, collect, forall 
 *)


(* return None when good, and Just the_problematic_case when bad *)
let (laws: string -> ('a -> bool) -> ('a gen) -> 'a option) = fun s func gen ->
  let res = foldn (fun acc i -> let n = gen() in (n, func n)::acc) [] 1000 in
  let res = List.filter (fun (x,b) -> not b) res in
  if res = [] then None else Some (fst (List.hd res))

let rec (statistic_number: ('a list) -> (int * 'a) list) = function
  | []    -> []
  | x::xs -> let (splitg, splitd) = List.partition (fun y -> y = x) xs in
    (1+(List.length splitg), x)::(statistic_number splitd)

(* in pourcentage *)
let (statistic: ('a list) -> (int * 'a) list) = fun xs ->
  let stat_num = statistic_number xs in
  let totals = sum_int (List.map fst stat_num) in
  List.map (fun (i, v) -> ((i * 100) / totals), v) stat_num 
  
let (laws2: 
        string -> ('a -> (bool * 'b)) -> ('a gen) -> 
        ('a option * ((int * 'b) list ))) = 
  fun s func gen ->
  let res = foldn (fun acc i -> let n = gen() in (n, func n)::acc) [] 1000 in
  let stat = statistic (List.map (fun (x,(b,v)) -> v) res) in
  let res = List.filter (fun (x,(b,v)) -> not b) res in
  if res = [] then (None, stat) else (Some (fst (List.hd res)), stat)


(*
let b = laws "unit" (fun x       -> reverse [x]          = [x]                   )ig
let b = laws "app " (fun (xs,ys) -> reverse (xs++ys)     = reverse ys++reverse xs)(pg (lg ig)(lg ig))
let b = laws "rev " (fun xs      -> reverse (reverse xs) = xs                    )(lg ig)
let b = laws "appb" (fun (xs,ys) -> reverse (xs++ys)     = reverse xs++reverse ys)(pg (lg ig)(lg ig))
let b = laws "max"  (fun (x,y)   -> x <= y ==> (max x y  = y)                       )(pg ig ig)

let b = laws2 "max"  (fun (x,y)   -> ((x <= y ==> (max x y  = y)), x <= y))(pg ig ig) 
*)


(* todo, do with coarbitrary ?? idea is that given a 'a, generate a 'b
 * depending of 'a and gen 'b, that is modify gen 'b, what is important is
 * that each time given the same 'a, we must get the same 'b !!!
 *)

(*
let (fg: ('a gen) -> ('b gen) -> ('a -> 'b) gen) = fun gen1 gen2 () ->
let b = laws "funs" (fun (f,g,h) -> x <= y ==> (max x y  = y)       )(pg ig ig)
 *)

(*
let one_of xs = List.nth xs (Random.int (List.length xs)) 
let take_one xs =
  if empty xs then failwith "Take_one: empty list"
  else 
    let i = Random.int (List.length xs) in
    List.nth xs i, filter_index (fun j _ -> i <> j) xs
*)    

(*****************************************************************************)
(* Persistence *)
(*****************************************************************************)

let get_value filename = 
  let chan = open_in filename in
  let x = input_value chan in (* <=> Marshal.from_channel  *)
  (close_in chan; x)

let write_value valu filename = 
  let chan = open_out filename in
  (output_value chan valu;  (* <=> Marshal.to_channel *)
   (* Marshal.to_channel chan valu [Marshal.Closures]; *)
   close_out chan) 

let write_back func filename = 
  write_value (func (get_value filename)) filename


let read_value f = get_value f


let marshal__to_string2 v flags = 
  Marshal.to_string v flags
let marshal__to_string a b = 
  profile_code "Marshalling" (fun () -> marshal__to_string2 a b)

let marshal__from_string2 v flags = 
  Marshal.from_string v flags
let marshal__from_string a b = 
  profile_code "Marshalling" (fun () -> marshal__from_string2 a b)



(*****************************************************************************)
(* Counter *)
(*****************************************************************************)
let _counter = ref 0
let counter () = (_counter := !_counter +1; !_counter)

let _counter2 = ref 0
let counter2 () = (_counter2 := !_counter2 +1; !_counter2)

let _counter3 = ref 0
let counter3 () = (_counter3 := !_counter3 +1; !_counter3)

type timestamp = int

(*****************************************************************************)
(* String_of *)
(*****************************************************************************)
(* To work with the macro system autogenerated string_of and print_ function
   (kind of deriving a la haskell) *)

(* int, bool, char, float, ref ?, string *) 

let string_of_string s = "\"" ^ s "\""

let string_of_list f xs = 
  "[" ^ (xs +> List.map f +> String.concat ";" ) ^ "]"

let string_of_unit () = "()"

let string_of_array f xs =
  "[|" ^ (xs +> Array.to_list +> List.map f +> String.concat ";") ^ "|]"

let string_of_option f = function
  | None   -> "None "
  | Some x -> "Some " ^ (f x)




let print_bool x = print_string (if x then  "True" else "False")

let print_option pr = function
  | None   -> print_string "None"
  | Some x -> print_string "Some ("; pr x; print_string ")"

let print_list pr xs = 
  begin
    print_string "["; 
    List.iter (fun x -> pr x; print_string ",") xs; 
    print_string "]";
  end

(* specialised 
let (string_of_list: char list -> string) = 
  List.fold_left (fun acc x -> acc^(Char.escaped x)) ""
*)


let rec print_between between fn = function
  | [] -> ()
  | [x] -> fn x
  | x::xs -> fn x; between(); print_between between fn xs




let adjust_pp_with_indent f = 
  Format.open_box !_tab_level_print; 
  (*Format.force_newline();*)
  f(); 
  Format.close_box ();
  Format.print_newline()

let adjust_pp_with_indent_and_header s f = 
  Format.open_box (!_tab_level_print + String.length s); 
  do_n !_tab_level_print (fun () -> Format.print_string " ");
  Format.print_string s;
  f();
  Format.close_box ();
  Format.print_newline()



let pp_do_in_box f      = Format.open_box 1; f(); Format.close_box ()
let pp_do_in_zero_box f = Format.open_box 0; f(); Format.close_box ()

let pp_f_in_box f      = 
  Format.open_box 1; 
  let res = f() in 
  Format.close_box ();
  res

let pp s = Format.print_string s

let mk_str_func_of_assoc_conv xs = 
  let swap (x,y) = (y,x) in

  (fun s -> 
    let xs' = List.map swap xs in
    List.assoc s xs'
  ),
  (fun a -> 
    List.assoc a xs
  )



(* julia: convert something printed using format to print into a string *)
(* now at bottom of file
let format_to_string f =
 ...
*)



(*****************************************************************************)
(* Macro *)
(*****************************************************************************)

(* put your macro in macro.ml4, and you can test it interactivly as in lisp *)
let macro_expand s = 
  let c = open_out "/tmp/ttttt.ml" in
  begin
    output_string c s; close_out c;
    command2 ("ocamlc -c -pp 'camlp4o pa_extend.cmo q_MLast.cmo -impl' " ^
             "-I +camlp4 -impl macro.ml4");
    command2 "camlp4o ./macro.cmo pr_o.cmo /tmp/ttttt.ml";
    command2 "rm -f /tmp/ttttt.ml";
  end

(*
let t = macro_expand "{ x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x>2 and y<3}"
let x = { x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x > 2 and y < 3}
let t = macro_expand "{1 .. 10}"
let x = {1 .. 10} +> List.map (fun i -> i)
let t = macro_expand "[1;2] to append to [2;4]"
let t = macro_expand "{x = 2; x = 3}"

let t = macro_expand "type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree)"
*)

  

(*****************************************************************************)
(* Composition/Control *)
(*****************************************************************************)

(* I like the obj.func object notation. In OCaml cant use '.' so I use +>
 * 
 * update: it seems that F# agrees with me :) but they use |>
 *)

(* now in prelude:
 * let (+>) o f = f o
 *)
let (+!>) refo f = refo := f !refo 
(* alternatives: 
 *  let ((@): 'a -> ('a -> 'b) -> 'b) = fun a b -> b a
 *  let o f g x = f (g x) 
 *)

let ($)     f g x = g (f x)
let compose f g x = f (g x)
(* dont work :( let ( ° ) f g x = f(g(x)) *)

(* trick to have something similar to the   1 `max` 4   haskell infix notation.
   by Keisuke Nakano on the caml mailing list.
>    let ( /* ) x y = y x
>    and ( */ ) x y = x y
or 
  let ( <| ) x y = y x
  and ( |> ) x y = x y

> Then we can make an infix operator <| f |> for a binary function f.
*)

let flip f = fun a b -> f b a

let curry f x y = f (x,y)
let uncurry f (a,b) = f a b

let id = fun x -> x

let do_nothing () = ()

let rec applyn n f o = if n = 0 then o else applyn (n-1) f (f o)

let forever f = 
  while true do
    f();
  done


class ['a] shared_variable_hook (x:'a) = 
  object(self)
    val mutable data = x
    val mutable registered = []
    method set x = 
      begin
        data <- x;
        pr "refresh registered";
        registered +> List.iter (fun f -> f());
      end
    method get = data
    method modify f = self#set (f self#get)
    method register f = 
      registered <- f :: registered 
  end    

(* src: from aop project. was called ptFix *)
let rec fixpoint trans elem =
  let image = trans elem in
  if (image = elem) 
  then elem (* point fixe *)
  else fixpoint trans image

(* le point fixe  pour les objets. was called ptFixForObjetct *)
let rec fixpoint_for_object trans elem =
  let image = trans elem in
  if (image#equal elem) then elem (* point fixe *)
  else fixpoint_for_object trans image

let (add_hook: ('a -> ('a -> 'b) -> 'b) ref  -> ('a -> ('a -> 'b) -> 'b) -> unit) = 
 fun var f ->
  let oldvar = !var in 
  var := fun arg k -> f arg (fun x -> oldvar x k)

let (add_hook_action: ('a -> unit) ->   ('a -> unit) list ref -> unit) = 
 fun f hooks -> 
  push2 f hooks

let (run_hooks_action: 'a -> ('a -> unit) list ref -> unit) = 
 fun obj hooks -> 
  !hooks +> List.iter (fun f -> try f obj with _ -> ())


type 'a mylazy = (unit -> 'a)

(* a la emacs *)
let save_excursion reference f = 
  let old = !reference in
  let res = f() in
  reference := old;
  res

let save_excursion_and_disable reference f = 
  save_excursion reference (fun () -> 
    reference := false;
    f ()
  )

let save_excursion_and_enable reference f = 
  save_excursion reference (fun () -> 
    reference := true;
    f ()
  )


let memoized h k f = 
  try Hashtbl.find h k 
  with Not_found -> 
    let v = f () in
    begin
      Hashtbl.add h k v;
      v
    end

let cache_in_ref myref f = 
  match !myref with
  | Some e -> e
  | None -> 
      let e = f () in
      myref := Some e;
      e

let once f = 
  let already = ref false in
  (fun x -> 
    if not !already
    then begin already := true; f x end
  )

(* cache_file, cf below *)

let before_leaving f x = 
  f x;
  x

(* finalize, cf prelude *)


(* cheat *)
let rec y f = fun x -> f (y f) x

(*****************************************************************************)
(* Concurrency *)
(*****************************************************************************)

(* from http://en.wikipedia.org/wiki/File_locking
 * 
 * "When using file locks, care must be taken to ensure that operations
 * are atomic. When creating the lock, the process must verify that it
 * does not exist and then create it, but without allowing another
 * process the opportunity to create it in the meantime. Various
 * schemes are used to implement this, such as taking advantage of
 * system calls designed for this purpose (but such system calls are
 * not usually available to shell scripts) or by creating the lock file
 * under a temporary name and then attempting to move it into place."
 * 
 * => can't use 'if(not (file_exist xxx)) then create_file xxx' because
 * file_exist/create_file are not in atomic section (classic problem).
 * 
 * from man open:
 * 
 * "O_EXCL When used with O_CREAT, if the file already exists it
 * is an error and the open() will fail. In this context, a
 * symbolic link exists, regardless of where it points to.
 * O_EXCL is broken on NFS file systems; programs which
 * rely on it for performing locking tasks will contain a
 * race condition. The solution for performing atomic file
 * locking using a lockfile is to create a unique file on
 * the same file system (e.g., incorporating host- name and
 * pid), use link(2) to make a link to the lockfile. If
 * link(2) returns 0, the lock is successful. Otherwise,
 * use stat(2) on the unique file to check if its link
 * count has increased to 2, in which case the lock is also
 * successful."

 *)

exception FileAlreadyLocked 

(* Racy if lock file on NFS!!! But still racy with recent Linux ? *)
let acquire_file_lock filename = 
  pr2 ("Locking file: " ^ filename);
  try 
    let _fd = Unix.openfile filename [Unix.O_CREAT;Unix.O_EXCL] 0o777 in
    ()
  with Unix.Unix_error (e, fm, argm) -> 
    pr2 (spf "exn Unix_error: %s %s %s\n" (Unix.error_message e) fm argm);
    raise FileAlreadyLocked


let release_file_lock filename =
  pr2 ("Releasing file: " ^ filename);
  Unix.unlink filename;
  ()



(*****************************************************************************)
(* Error managment *)
(*****************************************************************************)

exception Todo
exception Impossible
exception Here
exception ReturnExn

exception Multi_found (* to be consistent with Not_found *)

exception WrongFormat of string

(* old: let _TODO () = failwith "TODO",  now via fix_caml with raise Todo *)

let internal_error s = failwith ("internal error: "^s)
let error_cant_have x = internal_error ("cant have this case" ^(dump x))
let myassert cond = if cond then () else failwith "assert error"



(* before warning I was forced to do stuff like this:
 *  
 * let (fixed_int_to_posmap: fixed_int -> posmap) = fun fixed -> 
 * let v = ((fix_to_i fixed) / (power 2 16)) in
 * let _ = Printf.printf "coord xy = %d\n" v in
 * v
 * 
 * The need for printf make me force to name stuff :( 
 * How avoid ? use 'it' special keyword ?
 * In fact dont have to name it, use +> (fun v -> ...)  so when want 
 * erase debug just have to erase one line.
 *)
let warning s v = (pr2 ("Warning: " ^ s ^ "; value = " ^ (dump v)); v)




let exn_to_s exn = 
  Printexc.to_string exn

(* alias *)
let string_of_exn exn = exn_to_s exn


(* want or of merd, but cant cos cant put die ... in b (strict call) *)
let (|||) a b = try a with _ -> b

(* emacs/lisp inspiration, (vouillon does that too in unison I think) *)

(* now in Prelude:
 * let unwind_protect f cleanup = ...
 * let finalize f cleanup =  ...
 *)

type error = Error of string

(* sometimes to get help from ocaml compiler to tell me places where
 * I should update, we sometimes need to change some type from pair
 * to triple, hence this kind of fake type.
 *)
type evotype = unit
let evoval = ()

(*****************************************************************************)
(* Environment *)
(*****************************************************************************)

let check_stack = ref true
let check_stack_size limit = 
  if !check_stack then begin
    pr2 "checking stack size (do ulimit -s 50000 if problem)";
    let rec aux i = 
      if i = limit
      then 0
      else 1 + aux (i + 1)
    in
    assert(aux 0 = limit);
    ()
  end

let test_check_stack_size limit = 
  (* bytecode: 100000000 *)
  (* native:   10000000 *)
  check_stack_size (int_of_string limit)


(* only relevant in bytecode, in native the stacklimit is the os stacklimit
 * (adjustable by ulimit -s) 
 *)
let _init_gc_stack = 
  Gc.set {(Gc.get ()) with Gc.stack_limit = 100 * 1024 * 1024}




(* if process a big set of files then dont want get overflow in the middle
 * so for this we are ready to spend some extra time at the beginning that
 * could save far more later.
 *)
let check_stack_nbfiles nbfiles = 
  if nbfiles > 200
  then check_stack_size 10000000

(*****************************************************************************)
(* Arguments/options and command line (cocci and acomment) *)
(*****************************************************************************)

(* 
 * Why define wrappers ? Arg not good enough ? Well the Arg.Rest is not that
 * good and I need a way sometimes to get a list of argument.
 * 
 * I could define maybe a new Arg.spec such as
 * | String_list of (string list -> unit), but the action may require 
 * some flags to be set, so better to process this after all flags have
 * been set by parse_options. So have to split. Otherwise it would impose
 * an order of the options such as 
 * -verbose_parsing -parse_c file1 file2. and I really like to use bash
 * history and add just at the end of my command a -profile for instance.
 * 
 * 
 * Why want a -action arg1 arg2 arg3 ? (which in turn requires this
 * convulated scheme ...) Why not use Arg.String action such as 
 * "-parse_c", Arg.String (fun file -> ...) ? 
 * I want something that looks like ocaml function but at the UNIX 
 * command line level. So natural to have this scheme instead of 
 * -taxo_file arg2 -sample_file arg3 -parse_c arg1.
 * 
 * 
 * Why not use the toplevel ? 
 * - because to debug, ocamldebug is far superior to the toplevel
 *   (can go back, can go directly to a specific point, etc).
 *   I want a kind of testing at cmdline level. 
 * - Also I don't have file completion when in the ocaml toplevel. 
 *   I have to type "/path/to/xxx" without help.
 * 
 * 
 * Why having variable flags ? Why use 'if !verbose_parsing then ...' ? 
 * why not use strings and do stuff like the following
 * 'if (get_config "verbose_parsing") then ...'
 * Because I want to make the interface for flags easier for the code
 * that use it. The programmer should not be bothered wether this
 * flag is set via args cmd line or a config file, so I want to make it 
 * as simple as possible, just use a global plain caml ref variable.
 * 
 * Same spirit a little for the action. Instead of having function such as
 * test_parsing_c, I could do it only via string. But I still prefer
 * to have plain caml test functions. Also it makes it easier to call
 * those functions from a toplevel for people who prefer the toplevel.
 * 
 * 
 * So have flag_spec and action_spec. And in flag have debug_xxx flags, 
 * verbose_xxx flags and other flags.
 * 
 * I would like to not have to separate the -xxx actions spec from the
 * corresponding actions, but those actions may need more than one argument
 * and so have to wait for parse_options, which in turn need the options
 * spec, so circle. 
 * 
 * Also I dont want to mix code with data structures, so it's better that the
 * options variable contain just a few stuff and have no side effects except
 * setting global variables.
 * 
 * Why not have a global variable such as Common.actions that
 * other modules modify ? No, I prefer to do less stuff behind programmer's
 * back so better to let the user merge the different options at call
 * site, but at least make it easier by providing shortcut for set of options.
 * 
 * 
 * 
 * 
 * todo? isn't unison or scott-mcpeak-lib-in-cil handles that kind of
 * stuff better ? That is the need to localize command line argument
 * while still being able to gathering them. Same for logging.
 * Similiar to the type prof = PALL | PNONE | PSOME of string list.
 * Same spirit of fine grain config in log4j ?
 * 
 * todo? how mercurial/cvs/git manage command line options ? because they
 * all have a kind of DSL around arguments with some common options,
 * specific options, conventions, etc.
 * 
 * 
 * todo? generate the corresponding noxxx options ? 
 * todo? generate list of options and show their value ?
 * 
 * todo? make it possible to set this value via a config file ? 
 * 
 * 
 *)

type arg_spec_full = Arg.key * Arg.spec * Arg.doc
type cmdline_options = arg_spec_full list

(* the format is a list of triples:
 *  (title of section * (optional) explanation of sections * options)
 *)
type options_with_title = string * string * arg_spec_full list
type cmdline_sections = options_with_title list


(* ---------------------------------------------------------------------- *)

(* now I use argv as I like at the call sites to show that 
 * this function internally use argv.
 *)
let parse_options options usage_msg argv =
  let args = ref [] in
  (try
    Arg.parse_argv argv options (fun file -> args := file::!args) usage_msg;
    args := List.rev !args;
    !args
  with
  | Arg.Bad msg -> eprintf "%s" msg; exit 2
  | Arg.Help msg -> printf "%s" msg; exit 0
  )




let usage usage_msg options  = 
  Arg.usage (Arg.align options) usage_msg


(* for coccinelle *)

(* If you don't want the -help and --help that are appended by Arg.align *)
let arg_align2 xs =
  Arg.align xs +> List.rev +> drop 2 +> List.rev


let short_usage usage_msg  ~short_opt = 
  usage usage_msg short_opt

let long_usage  usage_msg  ~short_opt ~long_opt  = 
  pr usage_msg;
  pr "";
  let all_options_with_title = 
    (("main options", "", short_opt)::long_opt) in
  all_options_with_title +> List.iter 
    (fun (title, explanations, xs) -> 
      pr title;
      pr_xxxxxxxxxxxxxxxxx();
      if explanations <> "" 
      then begin pr explanations; pr "" end;
      arg_align2 xs +> List.iter (fun (key,action,s) -> 
        pr ("  " ^ key ^ s)
      );
      pr "";
    );
  ()


(* copy paste of Arg.parse. Don't want the default -help msg *)
let arg_parse2 l msg short_usage_fun =
  let args = ref [] in
  let f = (fun file -> args := file::!args) in
  let l = Arg.align l in
  (try begin 
    Arg.parse_argv Sys.argv l f msg;
    args := List.rev !args;
    !args
   end
  with
  | Arg.Bad msg -> (* eprintf "%s" msg; exit 2; *)
      let xs = lines msg in
      (* take only head, it's where the error msg is *)
      pr2 (List.hd xs);
      short_usage_fun();
      raise (UnixExit (2))
  | Arg.Help msg -> (* printf "%s" msg; exit 0; *)
      raise Impossible  (* -help is specified in speclist *)
  )


(* ---------------------------------------------------------------------- *)
(* kind of unit testing framework, or toplevel like functionnality 
 * at shell command line. I realize than in fact It follows a current trend
 * to have a main cmdline program where can then select different actions, 
 * as in cvs/hg/git where do  hg <action> <arguments>, and the shell even
 * use a curried syntax :)
 * 
 * 
 * Not-perfect-but-basic-feels-right: an action
 * spec looks like this:
 * 
 *    let actions () = [
 *      "-parse_taxo", "   <file>", 
 *      Common.mk_action_1_arg test_parse_taxo;
 *      ...
 *     ]
 * 
 * Not-perfect-but-basic-feels-right because for such functionality we
 * need a way to transform a string into a caml function and pass arguments
 * and the preceding design does exactly that, even if then the
 * functions that use this design are not so convenient to use (there
 * are 2 places where we need to pass those data, in the options and in the
 * main dispatcher). 
 * 
 * Also it's not too much intrusive. Still have an
 * action ref variable in the main.ml and can still use the previous 
 * simpler way to do where the match args with in main.ml do the
 * dispatch.
 * 
 * Use like this at option place: 
 *   (Common.options_of_actions actionref (Test_parsing_c.actions())) ++
 * Use like this at dispatch action place: 
 *   | xs when List.mem !action (Common.action_list all_actions) -> 
 *        Common.do_action !action xs all_actions
 * 
 *)

type flag_spec   = Arg.key * Arg.spec * Arg.doc
type action_spec = Arg.key * Arg.doc * action_func 
   and action_func = (string list -> unit)

type cmdline_actions = action_spec list
exception WrongNumberOfArguments

let options_of_actions action_ref actions = 
  actions +> List.map (fun (key, doc, _func) -> 
    (key, (Arg.Unit (fun () -> action_ref := key)), doc)
  )
    
let (action_list: cmdline_actions -> Arg.key list) = fun xs -> 
  List.map (fun (a,b,c) -> a) xs 

let (do_action: Arg.key -> string list (* args *) -> cmdline_actions -> unit) =
  fun key args xs -> 
    let assoc = xs +> List.map (fun (a,b,c) -> (a,c)) in
    let action_func = List.assoc key assoc in
    action_func args


(* todo? if have a function with default argument ? would like a 
 *  mk_action_0_or_1_arg ? 
 *)

let mk_action_0_arg f = 
  (function 
  | [] -> f ()
  | _ -> raise WrongNumberOfArguments
  )

let mk_action_1_arg f = 
  (function 
  | [file] -> f file
  | _ -> raise WrongNumberOfArguments
  )

let mk_action_2_arg f = 
  (function 
  | [file1;file2] -> f file1 file2
  | _ -> raise WrongNumberOfArguments
  )

let mk_action_3_arg f = 
  (function 
  | [file1;file2;file3] -> f file1 file2 file3
  | _ -> raise WrongNumberOfArguments
  )

let mk_action_n_arg f = f


(*****************************************************************************)
(* Equality *)
(*****************************************************************************)

(* Using the generic (=) is tempting, but it backfires, so better avoid it *)

(* To infer all the code that use an equal, and that should be
 * transformed, is not that easy, because (=) is used by many
 * functions, such as List.find, List.mem, and so on. So the strategy
 * is to turn what you were previously using into a function, because
 * (=) return an exception when applied to a function. Then you simply
 * use ocamldebug to infer where the code has to be transformed.
 *)

(* src: caml mailing list ? *)
let (=|=) : int    -> int    -> bool = (=)
let (=<=) : char   -> char   -> bool = (=)
let (=$=) : string -> string -> bool = (=)
let (=:=) : bool   -> bool   -> bool = (=)

(* the evil generic (=). I define another symbol to more easily detect
 * it, cos the '=' sign is syntaxically overloaded in caml. It is also
 * used to define function. 
 *)
let (=*=) = (=)

(* if really want to forbid to use '='
let (=) = (=|=)
*)
let (=) () () = false








(*###########################################################################*)
(* And now basic types *)
(*###########################################################################*)



(*****************************************************************************)
(* Bool *)
(*****************************************************************************)
let (==>) b1 b2 = if b1 then b2 else true (* could use too => *)

(* superseded by another <=> below
let (<=>) a b = if a =*= b then 0 else if a < b then -1 else 1
*)

let xor a b = not (a =*= b)


(*****************************************************************************)
(* Char *)
(*****************************************************************************)

let string_of_char c = String.make 1 c

let is_single  = String.contains ",;()[]{}_`"
let is_symbol  = String.contains "!@#$%&*+./<=>?\\^|:-~"
let is_space   = String.contains "\n\t "
let cbetween min max c = 
  (int_of_char c) <= (int_of_char max) && 
  (int_of_char c) >= (int_of_char min)
let is_upper = cbetween 'A' 'Z'
let is_lower = cbetween 'a' 'z'
let is_alpha c = is_upper c || is_lower c
let is_digit = cbetween '0' '9'

let string_of_chars cs = cs +> List.map (String.make 1) +> String.concat ""



(*****************************************************************************)
(* Num *)
(*****************************************************************************)

(* since 3.08, div by 0 raise Div_by_rezo, and not anymore a hardware trap :)*)
let (/!) x y = if y =|= 0 then (log "common.ml: div by 0"; 0) else x / y

(* now in prelude 
 * let rec (do_n: int -> (unit -> unit) -> unit) = fun i f ->
 * if i = 0 then () else (f(); do_n (i-1) f)
 *)

(* now in prelude
 * let rec (foldn: ('a -> int -> 'a) -> 'a -> int -> 'a) = fun f acc i ->
 * if i = 0 then acc else foldn f (f acc i) (i-1)
 *)

let sum_float = List.fold_left (+.) 0.0
let sum_int   = List.fold_left (+) 0

let pi  = 3.14159265358979323846
let pi2 = pi /. 2.0
let pi4 = pi /. 4.0

(* 180 = pi *)
let (deg_to_rad: float -> float) = fun deg ->
  (deg *. pi) /. 180.0

let clampf = function
  | n when n < 0.0 -> 0.0
  | n when n > 1.0 -> 1.0
  | n -> n

let square x = x *. x

let rec power x n = if n =|= 0 then 1 else x * power x (n-1)

let between i min max = i > min && i < max

let (between_strict: int -> int -> int -> bool) = fun a b c -> 
  a < b && b < c


let bitrange x p = let v = power 2 p in between x (-v) v

(* descendant *)
let (prime1: int -> int option)  = fun x -> 
  let rec prime1_aux n = 
    if n =|= 1 then None
    else 
      if (x / n) * n =|= x then Some n else prime1_aux (n-1)
  in if x =|= 1 then None else if x < 0 then failwith "negative" else prime1_aux (x-1)

(* montant, better *)
let (prime: int -> int option)  = fun x -> 
  let rec prime_aux n = 
    if n =|= x then None
    else 
      if (x / n) * n =|= x then Some n else prime_aux (n+1)
  in if x =|= 1 then None else if x < 0 then failwith "negative" else prime_aux 2

let sum xs = List.fold_left (+) 0 xs
let product = List.fold_left ( * ) 1


let decompose x = 
  let rec decompose x = 
  if x =|= 1 then []
  else 
    (match prime x with
    | None -> [x]
    | Some n -> n::decompose (x / n)
    ) 
  in assert (product (decompose x) =|= x); decompose x

let mysquare x = x * x
let sqr a = a *. a


type compare = Equal | Inf | Sup
let (<=>) a b = if a =*= b then Equal else if a < b then Inf else Sup
let (<==>) a b = if a =*= b then 0 else if a < b then -1 else 1

type uint = int


let int_of_stringchar s = 
  fold_left_with_index (fun acc e i -> acc + (Char.code e*(power 8 i))) 0 (List.rev (list_of_string s))

let int_of_base s base = 
  fold_left_with_index (fun acc e i -> 
    let j = Char.code e - Char.code '0' in
    if j >= base then failwith "not in good base"
    else acc + (j*(power base i))
                       )
    0  (List.rev (list_of_string s))

let int_of_stringbits s = int_of_base s 2
let _ = example (int_of_stringbits "1011" =|= 1*8 + 1*2 + 1*1)

let int_of_octal s = int_of_base s 8
let _ = example (int_of_octal "017" =|= 15)

(* let int_of_hex s = int_of_base s 16, NONONONO cos 'A' - '0' does not give 10 !! *)

let int_of_all s = 
  if String.length s >= 2 && (String.get s 0 =<= '0') && is_digit (String.get s 1)
  then int_of_octal s else int_of_string s


let (+=) ref v = ref := !ref + v
let (-=) ref v = ref := !ref - v

let pourcent x total = 
  (x * 100) / total
let pourcent_float x total = 
  ((float_of_int x) *. 100.0) /. (float_of_int total)

let pourcent_float_of_floats x total = 
  (x *. 100.0) /. total


let pourcent_good_bad good bad = 
  (good * 100) / (good + bad)

let pourcent_good_bad_float good bad = 
  (float_of_int good *. 100.0) /. (float_of_int good +. float_of_int bad)

type 'a max_with_elem = int ref * 'a ref
let update_max_with_elem (aref, aelem) ~is_better (newv, newelem) = 
  if is_better newv aref 
  then begin
    aref := newv;
    aelem := newelem;
  end

(*****************************************************************************)
(* Numeric/overloading *)
(*****************************************************************************)

type 'a numdict = 
    NumDict of (('a-> 'a -> 'a) * 
                ('a-> 'a -> 'a) * 
                ('a-> 'a -> 'a) * 
                ('a -> 'a));;

let add (NumDict(a, m, d, n)) = a;;
let mul (NumDict(a, m, d, n)) = m;;
let div (NumDict(a, m, d, n)) = d;;
let neg (NumDict(a, m, d, n)) = n;;

let numd_int   = NumDict(( + ),( * ),( / ),( ~- ));;
let numd_float = NumDict(( +. ),( *. ), ( /. ),( ~-. ));;
let testd dict n = 
  let ( * ) x y = mul dict x y in 
  let ( / ) x y = div dict x y in 
  let ( + ) x y = add dict x y in 
  (* Now you can define all sorts of things in terms of *, /, + *) 
  let f num = (num * num) / (num + num) in 
  f n;;



module ArithFloatInfix = struct 
    let (+..) = (+)
    let (-..) = (-)
    let (/..) = (/)
    let ( *.. ) = ( * )


    let (+) = (+.)
    let (-) = (-.)
    let (/) = (/.)
    let ( * ) = ( *. )

    let (+=) ref v = ref := !ref + v
    let (-=) ref v = ref := !ref - v

end



(*****************************************************************************)
(* Tuples *)
(*****************************************************************************)

type 'a pair = 'a * 'a
type 'a triple = 'a * 'a * 'a

let fst3 (x,_,_) = x
let snd3 (_,y,_) = y
let thd3 (_,_,z) = z

let sndthd (a,b,c) = (b,c)

let map_fst f (x, y) = f x, y
let map_snd f (x, y) = x, f y

let pair  f (x,y) = (f x, f y)

(* for my ocamlbeautify script *)
let snd = snd
let fst = fst

let double a = a,a
let swap (x,y) = (y,x)


let tuple_of_list1 = function [a] -> a | _ -> failwith "tuple_of_list1"
let tuple_of_list2 = function [a;b] -> a,b | _ -> failwith "tuple_of_list2"
let tuple_of_list3 = function [a;b;c] -> a,b,c | _ -> failwith "tuple_of_list3"
let tuple_of_list4 = function [a;b;c;d] -> a,b,c,d | _ -> failwith "tuple_of_list4"
let tuple_of_list5 = function [a;b;c;d;e] -> a,b,c,d,e | _ -> failwith "tuple_of_list5"
let tuple_of_list6 = function [a;b;c;d;e;f] -> a,b,c,d,e,f | _ -> failwith "tuple_of_list6"


(*****************************************************************************)
(* Maybe *)
(*****************************************************************************)

(* type 'a maybe  = Just of 'a | None *)

type ('a,'b) either = Left of 'a | Right of 'b
  (* with sexp *)
type ('a, 'b, 'c) either3 = Left3 of 'a | Middle3 of 'b | Right3 of 'c
  (* with sexp *)

let just = function
  | (Some x) -> x
  | _ -> failwith "just: pb"

let some = just


let fmap f = function
  | None -> None
  | Some x -> Some (f x)
let map_option = fmap

let do_option f = function
  | None -> ()
  | Some x -> f x

let optionise f = 
  try Some (f ()) with Not_found -> None



(* pixel *)
let some_or = function
  | None -> id
  | Some e -> fun _ -> e


let partition_either f l =
  let rec part_either left right = function
  | [] -> (List.rev left, List.rev right)
  | x :: l -> 
      (match f x with
      | Left  e -> part_either (e :: left) right l
      | Right e -> part_either left (e :: right) l) in
  part_either [] [] l


(* pixel *)
let rec filter_some = function
  | [] -> []
  | None :: l -> filter_some l
  | Some e :: l -> e :: filter_some l

let map_filter f xs = xs +> List.map f +> filter_some

let rec find_some p = function
  | [] -> raise Not_found
  | x :: l -> 
      match p x with
      | Some v -> v
      | None -> find_some p l

(* same
let map_find f xs = 
  xs +> List.map f +> List.find (function Some x -> true | None -> false)
    +> (function Some x -> x | None -> raise Impossible)
*)


let list_to_single_or_exn xs =
  match xs with
  | [] -> raise Not_found
  | x::y::zs -> raise Multi_found
  | [x] -> x

(*****************************************************************************)
(* TriBool *)
(*****************************************************************************)

type bool3 = True3 | False3 | TrueFalsePb3 of string



(*****************************************************************************)
(* Regexp, can also use PCRE *)
(*****************************************************************************)

(* Note: OCaml Str regexps are different from Perl regexp:
 *  - The OCaml regexp must match the entire way. 
 *    So  "testBee" =~ "Bee" is wrong  
 *    but "testBee" =~ ".*Bee" is right
 *    Can have the perl behavior if use  Str.search_forward instead of 
 *    Str.string_match.
 *  - Must add some additional \ in front of some special char. So use 
 *    \\( \\|  and also \\b
 *  - It does not always handle newlines very well.
 *  - \\b does consider _ but not numbers in indentifiers.
 * 
 * Note: PCRE regexps are then different from Str regexps ...
 *  - just use '(' ')' for grouping, not '\\)'
 *  - still need \\b for word boundary, but this time it works ...
 *    so can match some word that have some digits in them.
 * 
 *)

(* put before String section because String section use some =~ *)

(* let gsubst = global_replace *)


let (==~) s re = Str.string_match re s 0 

let _memo_compiled_regexp = Hashtbl.create 101
let candidate_match_func s re = 
  (* old: Str.string_match (Str.regexp re) s 0 *)
  let compile_re = 
    memoized _memo_compiled_regexp re (fun () -> Str.regexp re) 
  in
  Str.string_match compile_re s 0

let match_func s re = 
  profile_code "Common.=~" (fun () -> candidate_match_func s re)

let (=~) s re = 
  match_func s re





let string_match_substring re s = 
  try let _i = Str.search_forward re s 0 in true 
  with Not_found -> false

let _ = 
  example(string_match_substring (Str.regexp "foo") "a foo b")
let _ = 
  example(string_match_substring (Str.regexp "\\bfoo\\b") "a foo b")
let _ = 
  example(string_match_substring (Str.regexp "\\bfoo\\b") "a\n\nfoo b")
let _ = 
  example(string_match_substring (Str.regexp "\\bfoo_bar\\b") "a\n\nfoo_bar b")
(* does not work :( 
let _ = 
  example(string_match_substring (Str.regexp "\\bfoo_bar2\\b") "a\n\nfoo_bar2 b")
*)



let (regexp_match: string -> string -> string) = fun s re -> 
  assert(s =~ re);
  Str.matched_group 1 s

(* beurk, side effect code, but hey, it is convenient *)
(* now in prelude
 * let (matched: int -> string -> string) = fun i s -> 
 *    Str.matched_group i s
 * 
 * let matched1 = fun s -> matched 1 s
 * let matched2 = fun s -> (matched 1 s, matched 2 s)
 * let matched3 = fun s -> (matched 1 s, matched 2 s, matched 3 s)
 * let matched4 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s)
 * let matched5 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s)
 * let matched6 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s)
 *)



let split sep s = Str.split (Str.regexp sep) s
let _ = example (split "/" "" =*= [])
let join  sep xs = String.concat sep xs
let _ = example (join "/" ["toto"; "titi"; "tata"] =$= "toto/titi/tata")
(*
let rec join str = function
  | [] -> ""
  | [x] -> x
  | x::xs -> x ^ str ^ (join str xs)
*)


let (split_list_regexp: string -> string list -> (string * string list) list) =
 fun re xs ->
  let rec split_lr_aux (heading, accu) = function
    | [] -> [(heading, List.rev accu)]
    | x::xs -> 
        if x =~ re 
        then (heading, List.rev accu)::split_lr_aux (x, []) xs
        else split_lr_aux (heading, x::accu) xs
  in
  split_lr_aux ("__noheading__", []) xs 
  +> (fun xs -> if (List.hd xs) =*= ("__noheading__",[]) then List.tl xs else xs)



let regexp_alpha =  Str.regexp
  "^[a-zA-Z_][A-Za-z_0-9]*$"


let all_match re s = 
  let regexp = Str.regexp re in
  let res = ref [] in
  let _ = Str.global_substitute regexp (fun _s -> 
    let substr = Str.matched_string s in
    assert(substr ==~ regexp); (* @Effect: also use it's side effect *)
    let paren_matched = matched1 substr in
    push2 paren_matched res;
    "" (* @Dummy *)
  ) s in
  List.rev !res

let _ = example (all_match "\\(@[A-Za-z]+\\)" "ca va @Et toi @Comment" 
                  =*= ["@Et";"@Comment"])


let global_replace_regexp re f_on_substr s = 
  let regexp = Str.regexp re in
  Str.global_substitute regexp (fun _wholestr -> 

    let substr = Str.matched_string s in
    f_on_substr substr
  ) s


let regexp_word_str = 
  "\\([a-zA-Z_][A-Za-z_0-9]*\\)"
let regexp_word = Str.regexp regexp_word_str

let regular_words s = 
  all_match regexp_word_str s

let contain_regular_word s = 
  let xs = regular_words s in
  List.length xs >= 1



(*****************************************************************************)
(* Strings *)
(*****************************************************************************)

let slength = String.length
let concat = String.concat

(* ruby *)
let i_to_s = string_of_int
let s_to_i = int_of_string


(* strings take space in memory. Better when can share the space used by
   similar strings *)
let _shareds = Hashtbl.create 100
let (shared_string: string -> string) = fun s -> 
  try Hashtbl.find _shareds s 
  with Not_found -> (Hashtbl.add _shareds s s; s)

let chop = function
  | "" -> ""
  | s -> String.sub s 0 (String.length s - 1)


let chop_dirsymbol = function
  | s when s =~ "\\(.*\\)/$" -> matched1 s
  | s -> s


let (<!!>) s (i,j) = 
  String.sub s i (if j < 0 then String.length s - i + j + 1 else j - i)
(* let _ = example  ( "tototati"<!!>(3,-2) = "otat" ) *)

let (<!>) s i = String.get s i 

(* pixel *)
let rec split_on_char c s =
  try
    let sp = String.index s c in
    String.sub s 0 sp :: 
    split_on_char c (String.sub s (sp+1) (String.length s - sp - 1))
  with Not_found -> [s]


let lowercase = String.lowercase

let quote s = "\"" ^ s ^ "\""  

(* easier to have this to be passed as hof, because ocaml dont have
 * haskell "section" operators
 *)
let null_string s = 
  s =$= "" 

let is_blank_string s = 
  s =~ "^\\([ \t]\\)*$"

(* src: lablgtk2/examples/entrycompletion.ml *)
let is_string_prefix s1 s2 =
  (String.length s1 <= String.length s2) && 
  (String.sub s2 0 (String.length s1) =$= s1)

let plural i s = 
  if i =|= 1
  then Printf.sprintf "%d %s" i s 
  else Printf.sprintf "%d %ss" i s

let showCodeHex xs = List.iter (fun i -> printf "%02x" i) xs

let take_string n s =
  String.sub s 0 (n-1)

let take_string_safe n s = 
  if n > String.length s
  then s
  else take_string n s



(* used by LFS *)
let size_mo_ko i = 
  let ko = (i / 1024) mod 1024 in
  let mo = (i / 1024) / 1024 in
  (if mo > 0 
  then sprintf "%dMo%dKo" mo ko
  else sprintf "%dKo" ko
  )

let size_ko i = 
  let ko = i / 1024 in
  sprintf "%dKo" ko



 


(* done in summer 2007 for julia 
 * Reference: P216 of gusfeld book
 * For two strings S1 and S2, D(i,j) is defined to be the edit distance of S1[1..i] to S2[1..j]
 * So edit distance of S1 (of length n) and S2 (of length m) is D(n,m)
 * 
 * Dynamic programming technique
 * base: 
 * D(i,0) = i  for all i (cos to go from S1[1..i] to 0 characteres of S2 you have to delete all characters from S1[1..i]
 * D(0,j) = j  for all j (cos j characters must be inserted)
 * recurrence:
 * D(i,j) = min([D(i-1, j)+1, D(i, j - 1 + 1), D(i-1, j-1) + t(i,j)])
 * where t(i,j) is equal to 1 if S1(i) != S2(j) and  0 if equal
 * intuition = there is 4 possible action =  deletion, insertion, substitution, or match
 * so Lemma =
 * 
 * D(i,j) must be one of the three
 *  D(i, j-1) + 1
 *  D(i-1, j)+1 
 *  D(i-1, j-1) + 
 *  t(i,j) 
 * 
 * 
 *)
let matrix_distance s1 s2 = 
  let n = (String.length s1) in
  let m = (String.length s2) in 
  let mat = Array.make_matrix (n+1) (m+1) 0 in
  let t i j = 
    if String.get s1 (i-1) =<= String.get s2 (j-1)
    then 0
    else 1 
  in
  let min3 a b c = min (min a b) c in

  begin
    for i = 0 to n do
      mat.(i).(0) <- i
    done;
    for j = 0 to m do
      mat.(0).(j) <- j;
    done;
    for i = 1 to n do
      for j = 1 to m do
        mat.(i).(j) <- 
          min3 (mat.(i).(j-1) + 1) (mat.(i-1).(j) + 1) (mat.(i-1).(j-1) + t i j)
      done
    done;
    mat
  end
let edit_distance s1 s2 = 
  (matrix_distance s1 s2).(String.length s1).(String.length s2)


let test = edit_distance "vintner" "writers"
let _ = assert (edit_distance "winter" "winter" =|= 0)
let _ = assert (edit_distance "vintner" "writers" =|= 5)


(*****************************************************************************)
(* Filenames *)
(*****************************************************************************)

let dirname = Filename.dirname
let basename = Filename.basename

type filename = string (* TODO could check that exist :) type sux *)
  (* with sexp *)
type dirname = string (* TODO could check that exist :) type sux *)
  (* with sexp *)

module BasicType = struct
  type filename = string
end


let (filesuffix: filename -> string) = fun s -> 
  (try regexp_match s ".+\\.\\([a-zA-Z0-9_]+\\)$" with _ ->  "NOEXT")
let (fileprefix: filename -> string) = fun s -> 
  (try regexp_match s "\\(.+\\)\\.\\([a-zA-Z0-9_]+\\)?$" with _ ->  s)

let _ = example (filesuffix "toto.c" =$= "c")
let _ = example (fileprefix "toto.c" =$= "toto")

(*
assert (s = fileprefix s ^ filesuffix s)

let withoutExtension s = global_replace (regexp "\\..*$") "" s
let () = example "without"
    (withoutExtension "toto.s.toto" = "toto")
*)

let adjust_ext_if_needed filename ext = 
  if String.get ext 0 <> '.' 
  then failwith "I need an extension such as .c not just c";

  if not (filename =~ (".*\\" ^ ext))
  then filename ^ ext
  else filename



let db_of_filename file = 
  dirname file, basename file

let filename_of_db (basedir, file) = 
  Filename.concat basedir file



let dbe_of_filename file = 
  (* raise Invalid_argument if no ext, so safe to use later the unsafe
   * fileprefix and filesuffix functions.
   *)
  ignore(Filename.chop_extension file); 
  Filename.dirname file, 
  Filename.basename file +> fileprefix, 
  Filename.basename file +> filesuffix

let filename_of_dbe (dir, base, ext) = 
  Filename.concat dir (base ^ "." ^ ext)


let dbe_of_filename_safe file = 
  try Left (dbe_of_filename file)
  with Invalid_argument _ -> 
    Right (Filename.dirname file, Filename.basename file)


let dbe_of_filename_nodot file = 
  let (d,b,e) = dbe_of_filename file in
  let d = if d =$= "." then "" else d in
  d,b,e





let replace_ext file oldext newext = 
  let (d,b,e) = dbe_of_filename file in
  assert(e =$= oldext);
  filename_of_dbe (d,b,newext)


let normalize_path file = 
  let (dir, filename) = Filename.dirname file, Filename.basename file in
  let xs = split "/" dir in
  let rec aux acc = function
    | [] -> List.rev acc
    | x::xs -> 
        (match x with
        | "." -> aux acc xs
        | ".." -> aux (List.tl acc) xs
        | x -> aux (x::acc) xs
        )
  in
  let xs' = aux [] xs in
  Filename.concat (join "/" xs') filename



(*
let relative_to_absolute s = 
  if Filename.is_relative s
  then 
    begin
      let old = Sys.getcwd () in
      Sys.chdir s;
      let current = Sys.getcwd () in
      Sys.chdir old;
      s
    end
  else s
*)

let relative_to_absolute s = 
  if Filename.is_relative s
  then Sys.getcwd () ^ "/" ^ s
  else s

let is_relative s = Filename.is_relative s
let is_absolute s = not (is_relative s)


(* @Pre: prj_path must not contain regexp symbol *)
let filename_without_leading_path prj_path s = 
  let prj_path = chop_dirsymbol prj_path in
  if s =~ ("^" ^ prj_path ^ "/\\(.*\\)$")
  then matched1 s
  else 
    failwith 
      (spf "cant find filename_without_project_path: %s  %s" prj_path s)


(*****************************************************************************)
(* i18n *)
(*****************************************************************************)
type langage = 
  | English
  | Francais
  | Deutsch

(* gettext ? *)


(*****************************************************************************)
(* Dates *)
(*****************************************************************************)

(* maybe I should use ocamlcalendar, but I don't like all those functors ... *)

type month = 
  | Jan  | Feb  | Mar  | Apr  | May  | Jun
  | Jul  | Aug  | Sep  | Oct  | Nov  | Dec
type year = Year of int
type day = Day of int
type wday = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday

type date_dmy = DMY of day * month * year

type hour = Hour of int
type minute = Min of int
type second = Sec of int

type time_hms = HMS of hour * minute * second

type full_date = date_dmy * time_hms


(* intervalle *)
type days = Days of int

type time_dmy = TimeDMY of day * month * year


type float_time = float



let check_date_dmy (DMY (day, month, year)) = 
  raise Todo

let check_time_dmy (TimeDMY (day, month, year)) = 
  raise Todo

let check_time_hms (HMS (x,y,a)) =
  raise Todo



(* ---------------------------------------------------------------------- *)

(* older code *)
let int_to_month i = 
  assert (i <= 12 && i >= 1);
  match i with

  | 1 -> "Jan"
  | 2 -> "Feb"
  | 3 -> "Mar"
  | 4 -> "Apr"
  | 5 -> "May"
  | 6 -> "Jun"
  | 7 -> "Jul"
  | 8 -> "Aug"
  | 9 -> "Sep"
  | 10 -> "Oct"
  | 11 -> "Nov"
  | 12 -> "Dec"
(*
  | 1 -> "January"
  | 2 -> "February"
  | 3 -> "March"
  | 4 -> "April"
  | 5 -> "May"
  | 6 -> "June"
  | 7 -> "July"
  | 8 -> "August"
  | 9 -> "September"
  | 10 -> "October"
  | 11 -> "November"
  | 12 -> "December"
*)
  | _ -> raise Impossible


let month_info = [
  1  , Jan, "Jan", "January", 31;
  2  , Feb, "Feb", "February", 28;
  3  , Mar, "Mar", "March", 31;
  4  , Apr, "Apr", "April", 30;
  5  , May, "May", "May", 31;
  6  , Jun, "Jun", "June", 30;
  7  , Jul, "Jul", "July", 31;
  8  , Aug, "Aug", "August", 31;
  9  , Sep, "Sep", "September", 30;
  10 , Oct, "Oct", "October", 31;
  11 , Nov, "Nov", "November", 30;
  12 , Dec, "Dec", "December", 31;
]

let week_day_info = [
  0 , Sunday    , "Sun" , "Dim" , "Sunday";
  1 , Monday    , "Mon" , "Lun" , "Monday";
  2 , Tuesday   , "Tue" , "Mar" , "Tuesday";
  3 , Wednesday , "Wed" , "Mer" , "Wednesday";
  4 , Thursday  , "Thu" ,"Jeu"  ,"Thursday";
  5 , Friday    , "Fri" , "Ven" , "Friday";
  6 , Saturday  , "Sat" ,"Sam"  , "Saturday";
]

let i_to_month_h = 
  month_info +> List.map (fun (i,month,monthstr,mlong,days) -> i, month)
let s_to_month_h = 
  month_info +> List.map (fun (i,month,monthstr,mlong,days) -> monthstr, month)
let slong_to_month_h = 
  month_info +> List.map (fun (i,month,monthstr,mlong,days) -> mlong, month)
let month_to_s_h = 
  month_info +> List.map (fun (i,month,monthstr,mlong,days) -> month, monthstr)
let month_to_i_h = 
  month_info +> List.map (fun (i,month,monthstr,mlong,days) -> month, i)

let i_to_wday_h = 
  week_day_info +> List.map (fun (i,day,dayen,dayfr,daylong) -> i, day)
let wday_to_en_h =
  week_day_info +> List.map (fun (i,day,dayen,dayfr,daylong) -> day, dayen)
let wday_to_fr_h =
  week_day_info +> List.map (fun (i,day,dayen,dayfr,daylong) -> day, dayfr)

let month_of_string s = 
  List.assoc s s_to_month_h

let month_of_string_long s = 
  List.assoc s slong_to_month_h

let string_of_month s = 
  List.assoc s month_to_s_h

let month_of_int i = 
  List.assoc i i_to_month_h

let int_of_month m = 
  List.assoc m month_to_i_h


let wday_of_int i = 
  List.assoc i i_to_wday_h

let string_en_of_wday wday = 
  List.assoc wday wday_to_en_h
let string_fr_of_wday wday = 
  List.assoc wday wday_to_fr_h

(* ---------------------------------------------------------------------- *)

let wday_str_of_int ~langage i = 
  let wday = wday_of_int i in
  match langage with
  | English -> string_en_of_wday wday
  | Francais -> string_fr_of_wday wday
  | Deutsch -> raise Todo
  


let string_of_date_dmy (DMY (Day n, month, Year y)) = 
  (spf "%02d-%s-%d" n (string_of_month month) y)


let string_of_unix_time ?(langage=English) tm = 
  let y = tm.Unix.tm_year + 1900 in
  let mon = string_of_month (month_of_int (tm.Unix.tm_mon + 1)) in
  let d = tm.Unix.tm_mday in
  let h = tm.Unix.tm_hour in
  let min = tm.Unix.tm_min in
  let s = tm.Unix.tm_sec in

  let wday = wday_str_of_int ~langage tm.Unix.tm_wday in
  
  spf "%02d/%03s/%04d (%s) %02d:%02d:%02d" d mon y wday h min s

(* ex: 21/Jul/2008 (Lun) 21:25:12 *)
let unix_time_of_string s = 
  if s =~ 
    ("\\([0-9][0-9]\\)/\\(...\\)/\\([0-9][0-9][0-9][0-9]\\) " ^
     "\\(.*\\) \\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)")
  then
    let (sday, smonth, syear, _sday, shour, smin, ssec) = matched7 s in

    let y = s_to_i syear - 1900 in
    let mon = 
      smonth +> month_of_string +> int_of_month +> (fun i -> i -1)
    in

    let tm = Unix.localtime (Unix.time ()) in
    { tm with 
      Unix.tm_year = y;
      Unix.tm_mon = mon;
      Unix.tm_mday = s_to_i sday;
      Unix.tm_hour = s_to_i shour;
      Unix.tm_min = s_to_i smin;
      Unix.tm_sec = s_to_i ssec;
    }
  else failwith ("unix_time_of_string: " ^ s)



let short_string_of_unix_time ?(langage=English) tm = 
  let y = tm.Unix.tm_year + 1900 in
  let mon = string_of_month (month_of_int (tm.Unix.tm_mon + 1)) in
  let d = tm.Unix.tm_mday in
  let _h = tm.Unix.tm_hour in
  let _min = tm.Unix.tm_min in
  let _s = tm.Unix.tm_sec in

  let wday = wday_str_of_int ~langage tm.Unix.tm_wday in
  
  spf "%02d/%03s/%04d (%s)" d mon y wday


let string_of_unix_time_lfs time = 
  spf "%02d--%s--%d" 
    time.Unix.tm_mday 
    (int_to_month (time.Unix.tm_mon + 1)) 
    (time.Unix.tm_year + 1900)


(* ---------------------------------------------------------------------- *)
let string_of_floattime ?langage i = 
  let tm = Unix.localtime i in
  string_of_unix_time ?langage tm

let short_string_of_floattime ?langage i = 
  let tm = Unix.localtime i in
  short_string_of_unix_time ?langage tm

let floattime_of_string s = 
  let tm = unix_time_of_string s in
  let (sec,_tm) = Unix.mktime tm in
  sec


(* ---------------------------------------------------------------------- *)
let days_in_week_of_day day = 
  let tm = Unix.localtime day in 
  
  let wday = tm.Unix.tm_wday in
  let wday = if wday =|= 0 then 6 else wday -1 in

  let mday = tm.Unix.tm_mday in

  let start_d = mday - wday in
  let end_d = mday + (6 - wday) in

  enum start_d end_d +> List.map (fun mday -> 
    Unix.mktime {tm with Unix.tm_mday = mday} +> fst
  )

let first_day_in_week_of_day day = 
  List.hd (days_in_week_of_day day)

let last_day_in_week_of_day day = 
  last (days_in_week_of_day day)


(* ---------------------------------------------------------------------- *)

(* (modified) copy paste from ocamlcalendar/src/date.ml *)
let days_month = 
  [| 0;    31; 59; 90; 120; 151; 181; 212; 243; 273; 304; 334(*; 365*) |]


let rough_days_since_jesus (DMY (Day nday, month, Year year)) = 
  let n = 
    nday + 
      (days_month.(int_of_month month -1)) +
      year * 365
  in
  Days n



let is_more_recent d1 d2 = 
  let (Days n1) = rough_days_since_jesus d1 in
  let (Days n2) = rough_days_since_jesus d2 in
  (n1 > n2) 


let max_dmy d1 d2 = 
  if is_more_recent d1 d2 
  then d1
  else d2

let min_dmy d1 d2 = 
  if is_more_recent d1 d2 
  then d2
  else d1


let maximum_dmy ds = 
  foldl1 max_dmy ds

let minimum_dmy ds = 
  foldl1 min_dmy ds
  


let rough_days_between_dates d1 d2 = 
  let (Days n1) = rough_days_since_jesus d1 in
  let (Days n2) = rough_days_since_jesus d2 in
  Days (n2 - n1)

let _ = example 
  (rough_days_between_dates 
      (DMY (Day 7, Jan, Year 1977))
      (DMY (Day 13, Jan, Year 1977)) =*= Days 6)

(* because of rough days, it is a bit buggy, here it should return 1 *)
(*
let _ = assert_equal
  (rough_days_between_dates 
      (DMY (Day 29, Feb, Year 1977))
      (DMY (Day 1, Mar , Year 1977))) 
  (Days 1)
*)


(* from julia, in gitsort.ml *)

(*
let antimonths =
  [(1,31);(2,28);(3,31);(4,30);(5,31); (6,6);(7,7);(8,31);(9,30);(10,31);
    (11,30);(12,31);(0,31)]

let normalize (year,month,day,hour,minute,second) =
  if hour < 0
  then
    let (day,hour) = (day - 1,hour + 24) in
    if day = 0
    then
      let month = month - 1 in
      let day = List.assoc month antimonths in
      let day =
        if month = 2 && year / 4 * 4 = year && not (year / 100 * 100 = year)
        then 29
        else day in
      if month = 0
      then (year-1,12,day,hour,minute,second)
      else (year,month,day,hour,minute,second)
    else (year,month,day,hour,minute,second)
  else (year,month,day,hour,minute,second)

*)


let mk_date_dmy day month year = 
  let date = DMY (Day day, month_of_int month, Year year) in
  (* check_date_dmy date *)
  date


(* ---------------------------------------------------------------------- *)
(* conversion to unix.tm *)

let dmy_to_unixtime (DMY (Day n, month, Year year)) = 
  let tm = { 
    Unix.tm_sec = 0;      (** Seconds 0..60 *)
    tm_min = 0;           (** Minutes 0..59 *)
    tm_hour = 12;           (** Hours 0..23 *)
    tm_mday = n;              (** Day of month 1..31 *)
    tm_mon = (int_of_month month -1);               (** Month of year 0..11 *)
    tm_year = year - 1900;              (** Year - 1900 *)
    tm_wday = 0;              (** Day of week (Sunday is 0) *)
    tm_yday = 0;              (** Day of year 0..365 *)
    tm_isdst = false;            (** Daylight time savings in effect *)
  } in
  Unix.mktime tm

let unixtime_to_dmy tm = 
  let n = tm.Unix.tm_mday  in
  let month = month_of_int (tm.Unix.tm_mon + 1) in
  let year = tm.Unix.tm_year + 1900 in
 
  DMY (Day n, month, Year year)


let unixtime_to_floattime tm = 
  Unix.mktime tm +> fst

let floattime_to_unixtime sec = 
  Unix.localtime sec


let sec_to_days sec = 
  let minfactor = 60 in
  let hourfactor = 60 * 60 in
  let dayfactor = 60 * 60 * 24 in

  let days  =  sec / dayfactor in
  let hours = (sec mod dayfactor) / hourfactor in
  let mins  = (sec mod hourfactor) / minfactor in
  let sec = (sec mod 60) in
  (* old:   Printf.sprintf "%d days, %d hours, %d minutes" days hours mins *)
  (if days > 0  then plural days "day" ^ " "    else "") ^ 
  (if hours > 0 then plural hours "hour" ^ " " else "") ^
  (if mins > 0  then plural mins "min"   ^ " " else "") ^
  (spf "%dsec" sec)

let sec_to_hours sec = 
  let minfactor = 60 in
  let hourfactor = 60 * 60 in

  let hours = sec / hourfactor in
  let mins  = (sec mod hourfactor) / minfactor in
  let sec = (sec mod 60) in
  (* old:   Printf.sprintf "%d days, %d hours, %d minutes" days hours mins *)
  (if hours > 0 then plural hours "hour" ^ " " else "") ^
  (if mins > 0  then plural mins "min"   ^ " " else "") ^
  (spf "%dsec" sec)
  


let test_date_1 () =
  let date = DMY (Day 17, Sep, Year 1991) in
  let float, tm = dmy_to_unixtime date in
  pr2 (spf "date: %.0f" float);
  ()


(* src: ferre in logfun/.../date.ml *)

let day_secs : float = 86400.

let today     : unit -> float = fun () ->  (Unix.time () )
let yesterday : unit -> float = fun () ->  (Unix.time () -. day_secs)
let tomorrow  : unit -> float = fun () ->  (Unix.time () +. day_secs)

let lastweek  : unit -> float = fun () ->  (Unix.time () -. (7.0 *. day_secs))
let lastmonth  : unit -> float = fun () ->  (Unix.time () -. (30.0 *. day_secs))


let week_before  : float_time -> float_time = fun d ->  
  (d -. (7.0 *. day_secs))
let month_before  : float_time -> float_time = fun d ->  
  (d -. (30.0 *. day_secs))

let week_after  : float_time -> float_time = fun d ->  
  (d +. (7.0 *. day_secs))



(*****************************************************************************)
(* Lines/words/strings *)
(*****************************************************************************)

(* now in prelude:
 * let (list_of_string: string -> char list) = fun s -> 
 * (enum 0 ((String.length s) - 1) +> List.map (String.get s))
 *)

let _ = example (list_of_string "abcd" =*= ['a';'b';'c';'d'])

(*
let rec (list_of_stream: ('a Stream.t) -> 'a list) = 
parser
  | [< 'c ; stream >]  -> c :: list_of_stream stream
  | [<>]               -> []

let (list_of_string: string -> char list) = 
  Stream.of_string $ list_of_stream
*)

(* now in prelude: 
 * let (lines: string -> string list) = fun s -> ...
 *)

let (lines_with_nl: string -> string list) = fun s -> 
  let rec lines_aux = function
    | [] -> []
    | [x] -> if x =$= "" then [] else [x ^ "\n"] (* old: [x] *)
    | x::xs -> 
        let e = x ^ "\n" in
        e::lines_aux xs 
  in
  (time_func (fun () -> Str.split_delim (Str.regexp "\n") s)) +> lines_aux

(* in fact better make it return always complete lines, simplify *)
(*  Str.split, but lines "\n1\n2\n" dont return the \n and forget the first \n => split_delim better than split *)
(* +> List.map (fun s -> s ^ "\n") but add an \n even at the end => lines_aux *)
(* old: slow
  let chars = list_of_string s in
  chars +> List.fold_left (fun (acc, lines) char -> 
    let newacc = acc ^ (String.make 1 char) in
    if char = '\n' 
    then ("", newacc::lines)
    else (newacc, lines)
    ) ("", []) 
       +> (fun (s, lines) -> List.rev (s::lines))
*)

(*  CHECK: unlines (lines x) = x *)
let (unlines: string list -> string) = fun s -> 
  (String.concat "\n" s) ^ "\n"
let (words: string -> string list)   = fun s -> 
  Str.split (Str.regexp "[ \t()\";]+") s
let (unwords: string list -> string) = fun s -> 
  String.concat "" s

let (split_space: string -> string list)   = fun s -> 
  Str.split (Str.regexp "[ \t\n]+") s


(* todo opti ? *)
let nblines s = 
  lines s +> List.length
let _ = example (nblines "" =|= 0)
let _ = example (nblines "toto" =|= 1)
let _ = example (nblines "toto\n" =|= 1)
let _ = example (nblines "toto\ntata" =|= 2)
let _ = example (nblines "toto\ntata\n" =|= 2)

(*****************************************************************************)
(* Process/Files *)
(*****************************************************************************)
let cat_orig file = 
  let chan = open_in file in
  let rec cat_orig_aux ()  = 
    try 
      (* cant do input_line chan::aux() cos ocaml eval from right to left ! *)
      let l = input_line chan in
      l :: cat_orig_aux ()
    with End_of_file -> [] in
  cat_orig_aux()

(* tail recursive efficient version *)
let cat file = 
  let chan = open_in file in
  let rec cat_aux acc ()  = 
      (* cant do input_line chan::aux() cos ocaml eval from right to left ! *)
    let (b, l) = try (true, input_line chan) with End_of_file -> (false, "") in
    if b 
    then cat_aux (l::acc) ()
    else acc 
  in
  cat_aux [] () +> List.rev +> (fun x -> close_in chan; x)

let cat_array file = 
  (""::cat file) +> Array.of_list 


let interpolate str = 
  begin
    command2 ("printf \"%s\\n\" " ^ str ^ ">/tmp/caml");
    cat "/tmp/caml"
  end

(* could do a print_string but printf dont like print_string *)
let echo s = printf "%s" s; flush stdout; s 

let usleep s = for i = 1 to s do () done

let sleep_little () =
  (*old:  *) 
  Unix.sleep 1
  (*ignore(Sys.command ("usleep " ^ !_sleep_time))*)


(* now in prelude:
 * let command2 s = ignore(Sys.command s)
 *)

let do_in_fork f = 
  let pid = Unix.fork () in
  if pid =|= 0
  then 
    begin 
      (* Unix.setsid(); *)
      Sys.set_signal Sys.sigint (Sys.Signal_handle   (fun _ -> 
        pr2 "being killed";
        Unix.kill 0 Sys.sigkill;
        ));
      f(); 
      exit 0;
    end
  else pid


let process_output_to_list2 = fun command -> 
  let chan = Unix.open_process_in command in
  let res = ref ([] : string list) in
  let rec process_otl_aux () =  
    let e = input_line chan in
    res := e::!res;
    process_otl_aux() in
  try process_otl_aux ()
  with End_of_file ->
    let stat = Unix.close_process_in chan in (List.rev !res,stat)
let cmd_to_list command =
  let (l,_) = process_output_to_list2 command in l
let process_output_to_list = cmd_to_list
let cmd_to_list_and_status = process_output_to_list2

(* now in prelude:
 * let command2 s = ignore(Sys.command s)
 *) 


let _batch_mode = ref false 
let command2_y_or_no cmd = 
  if !_batch_mode then begin command2 cmd; true end
  else begin

    pr2 (cmd ^ " [y/n] ?");
    match read_line () with
    | "y" | "yes" | "Y" -> command2 cmd; true
    | "n" | "no"  | "N" -> false
    | _ -> failwith "answer by yes or no"
  end

let command2_y_or_no_exit_if_no cmd = 
  let res = command2_y_or_no cmd in
  if res
  then ()
  else raise (UnixExit (1))

  


let mkdir ?(mode=0o770) file = 
  Unix.mkdir file mode

let read_file_orig file = cat file +> unlines
let read_file file =
  let ic = open_in file  in
  let size = in_channel_length ic in
  let buf = String.create size in
  really_input ic buf 0 size;
  close_in ic;
  buf


let write_file ~file s = 
  let chan = open_out file in
  (output_string chan s; close_out chan)

let filesize file = 
  (Unix.stat file).Unix.st_size

let filemtime file = 
  (Unix.stat file).Unix.st_mtime

(* opti? use wc -l ? *)
let nblines_file file = 
  cat file +> List.length

let lfile_exists filename = 
  try 
    (match (Unix.lstat filename).Unix.st_kind with
    | (Unix.S_REG | Unix.S_LNK) -> true
    | _ -> false
    )
  with Unix.Unix_error (Unix.ENOENT, _, _) -> false

let is_directory file = 
  (Unix.stat file).Unix.st_kind =*= Unix.S_DIR
    
      
(* src: from chailloux et al book *)
let capsule_unix f args = 
  try (f args) 
  with Unix.Unix_error (e, fm, argm) -> 
    log (Printf.sprintf "exn Unix_error: %s %s %s\n" (Unix.error_message e) fm argm)


let (readdir_to_kind_list: string -> Unix.file_kind -> string list) = 
 fun path kind -> 
  Sys.readdir path 
  +> Array.to_list 
  +> List.filter (fun s -> 
    try 
      let stat = Unix.lstat (path ^ "/" ^  s) in
      stat.Unix.st_kind =*= kind
    with e -> 
      pr2 ("EXN pb stating file: " ^ s);
      false
    )

let (readdir_to_dir_list: string -> string list) = fun path -> 
  readdir_to_kind_list path Unix.S_DIR

let (readdir_to_file_list: string -> string list) = fun path -> 
  readdir_to_kind_list path Unix.S_REG

let (readdir_to_link_list: string -> string list) = fun path -> 
  readdir_to_kind_list path Unix.S_LNK


let (readdir_to_dir_size_list: string -> (string * int) list) = fun path -> 
  Sys.readdir path 
  +> Array.to_list 
  +> map_filter (fun s -> 
    let stat = Unix.lstat (path ^ "/" ^  s) in
    if stat.Unix.st_kind =*= Unix.S_DIR 
    then Some (s, stat.Unix.st_size) 
    else None
    )

(* could be in control section too *)

(* Why a use_cache argument ? because sometimes want disable it but dont
 * want put the cache_computation funcall in comment, so just easier to
 * pass this extra option.
 *)
let cache_computation2 ?(verbose=false) ?(use_cache=true) file ext_cache f = 
  if not use_cache 
  then f ()
  else begin
    if not (Sys.file_exists file) 
    then failwith ("can't find: "  ^ file);
    let file_cache = (file ^ ext_cache) in
    if Sys.file_exists file_cache && 
      filemtime file_cache >= filemtime file
    then begin
      if verbose then pr2 ("using cache: " ^ file_cache);
      get_value file_cache
    end
    else begin
      let res = f () in
      write_value res file_cache;
      res
    end
  end
let cache_computation ?verbose ?use_cache a b c = 
  profile_code "Common.cache_computation" (fun () -> 
    cache_computation2 ?verbose ?use_cache a b c)
  

let cache_computation_robust2 
 file ext_cache 
 (need_no_changed_files, need_no_changed_variables) ext_depend
 f = 
  if not (Sys.file_exists file) 
  then failwith ("can't find: "  ^ file);

  let file_cache = (file ^ ext_cache) in
  let dependencies_cache = (file ^ ext_depend) in

  let dependencies = 
    (* could do md5sum too *)
    ((file::need_no_changed_files) +> List.map (fun f -> f, filemtime f), 
    need_no_changed_variables) 
  in

  if Sys.file_exists dependencies_cache && 
     get_value dependencies_cache =*= dependencies
  then get_value file_cache
  else begin 
    pr2 ("cache computation recompute " ^ file);
    let res = f () in
    write_value dependencies dependencies_cache;
    write_value res file_cache;
    res
  end

let cache_computation_robust a b c d e =
  profile_code "Common.cache_computation_robust" (fun () -> 
    cache_computation_robust2 a b c d e)




(* dont forget that cmd_to_list call bash and so pattern may contain
 * '*' symbols that will be expanded, so can do  glob "*.c"
 *)
let glob pattern =
  cmd_to_list ("ls -1 " ^ pattern)


(* update: have added the -type f, so normally need less the sanity_check_xxx
 * function below *)
let files_of_dir_or_files ext xs = 
  xs +> List.map (fun x -> 
    if is_directory x
    then cmd_to_list ("find " ^ x  ^" -noleaf -type f -name \"*." ^ext^"\"")
    else [x]
  ) +> List.concat


let files_of_dir_or_files_no_vcs ext xs = 
  xs +> List.map (fun x -> 
    if is_directory x
    then 
      cmd_to_list 
        ("find " ^ x  ^" -noleaf -type f -name \"*." ^ext^"\"" ^
            "| grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/ |grep -v /_darcs/"
        )
    else [x]
  ) +> List.concat


let files_of_dir_or_files_no_vcs_post_filter regex xs = 
  xs +> List.map (fun x -> 
    if is_directory x
    then 
      cmd_to_list 
        ("find " ^ x  ^
         " -noleaf -type f | grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/ |grep -v /_darcs/"
        )
        +> List.filter (fun s -> s =~ regex)
    else [x]
  ) +> List.concat


let sanity_check_files_and_adjust ext files =
  let files = files +> List.filter (fun file -> 
    if not (file =~ (".*\\."^ext))
    then begin 
      pr2 ("warning: seems not a ."^ext^" file");
      false
    end
    else 
      if is_directory file
      then begin
        pr2 (spf "warning: %s is a directory" file);
        false
      end 
    else true
  ) in
  files
        


  
(* taken from mlfuse, the predecessor of ocamlfuse *)
type rwx = [`R|`W|`X] list
let file_perm_of : u:rwx -> g:rwx -> o:rwx -> Unix.file_perm = 
 fun ~u ~g ~o ->
  let to_oct l = 
    List.fold_left (fun acc p -> acc lor ((function `R -> 4 | `W -> 2 | `X -> 1) p)) 0 l in
  let perm = 
    ((to_oct u) lsl 6) lor
    ((to_oct g) lsl 3) lor
    (to_oct o)
  in
  perm


(* pixel *)
let has_env var = 
  try 
    let _ = Sys.getenv var in true
  with Not_found -> false

(* emacs/lisp inspiration (eric cooper and yaron minsky use that too) *)
let (with_open_outfile: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) = 
 fun file f ->
  let chan = open_out file in
  let pr s = output_string chan s in
  unwind_protect (fun () -> 
    let res = f (pr, chan) in
    close_out chan;
    res)
    (fun e -> close_out chan)

let (with_open_infile: filename -> ((in_channel) -> 'a) -> 'a) = fun file f ->
  let chan = open_in file in
  unwind_protect (fun () -> 
    let res = f chan in
    close_in chan;
    res)
    (fun e -> close_in chan)


let (with_open_outfile_append: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) = 
 fun file f ->
  let chan = open_out_gen [Open_creat;Open_append] 0o666 file in
  let pr s = output_string chan s in
  unwind_protect (fun () -> 
    let res = f (pr, chan) in
    close_out chan;
    res)
    (fun e -> close_out chan)


(* now in prelude:
 * exception Timeout
 *)

(* it seems that the toplevel block such signals, even with this explicit
 *  command :( 
 *  let _ = Unix.sigprocmask Unix.SIG_UNBLOCK [Sys.sigalrm]
 *)

(* could be in Control section *)

(* subtil: have to make sure that timeout is not intercepted before here, so 
 * avoid exn handle such as try (...) with _ -> cos timeout will not bubble up
 * enough. In such case, add a case before such as  
 * with Timeout -> raise Timeout | _ -> ... 
 * 
 * question: can we have a signal and so exn when in a exn handler ? 
 *)
let timeout_function timeoutval = fun f -> 
  try 
    begin
      Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout ));
      ignore(Unix.alarm timeoutval);
      let x = f() in
      ignore(Unix.alarm 0);
      x
    end
  with Timeout -> 
    begin 
      log "timeout (we abort)";
      raise Timeout;
    end
  | e -> 
     (* subtil: important to disable the alarm before relaunching the exn,
      * otherwise the alarm is still running.
      * 
      * robust?: and if alarm launched after the log (...) ? 
      * Maybe signals are disabled when process an exception handler ?
      *)
      begin 
        ignore(Unix.alarm 0);
        (* log ("exn while in transaction (we abort too, even if ...) = " ^
           Printexc.to_string e); 
        *)
        log "exn while in timeout_function";
        raise e
      end

let timeout_function_opt timeoutvalopt f =
  match timeoutvalopt with
  | None -> f()
  | Some x -> timeout_function x f
  


(* creation of tmp files, a la gcc *)

let _temp_files_created = ref [] 

(* ex: new_temp_file "cocci" ".c" will give "/tmp/cocci-3252-434465.c" *)
let new_temp_file prefix suffix = 
  let processid = i_to_s (Unix.getpid ()) in
  let tmp_file = Filename.temp_file (prefix ^ "-" ^ processid ^ "-") suffix in
  push2 tmp_file _temp_files_created;
  tmp_file


let save_tmp_files = ref false
let erase_temp_files () = 
  if not !save_tmp_files then begin
    !_temp_files_created +> List.iter (fun s -> 
      (* pr2 ("erasing: " ^ s); *)
      command2 ("rm -f " ^ s)
    );
    _temp_files_created := []
  end

(* now in prelude: exception UnixExit of int *)
let exn_to_real_unixexit f = 
  try f() 
  with UnixExit x -> exit x




let uncat xs file = 
  with_open_outfile file (fun (pr,_chan) -> 
    xs +> List.iter (fun s -> pr s; pr "\n");

  )






(*****************************************************************************)
(* List *)
(*****************************************************************************)

(* pixel *)
let uncons l = (List.hd l, List.tl l)

(* pixel *)
let safe_tl l = try List.tl l with _ -> []

let push l v =
  l := v :: !l

let rec zip xs ys = 
  match (xs,ys) with
  | ([],[]) -> []
  | ([],_) -> failwith "zip: not same length"
  | (_,[]) -> failwith "zip: not same length"
  | (x::xs,y::ys) -> (x,y)::zip xs ys

let rec zip_safe xs ys = 
  match (xs,ys) with
  | ([],_) -> []
  | (_,[]) -> []
  | (x::xs,y::ys) -> (x,y)::zip_safe xs ys

let rec unzip zs = 
  List.fold_right (fun e (xs, ys)    -> 
    (fst e::xs), (snd e::ys)) zs ([],[])


let map_withkeep f xs = 
  xs +> List.map (fun x -> f x, x)

(* now in prelude
 * let rec take n xs = 
 * match (n,xs) with
 * | (0,_) -> []
 * | (_,[]) -> failwith "take: not enough"
 * | (n,x::xs) -> x::take (n-1) xs
 *)

let rec take_safe n xs =
  match (n,xs) with
  | (0,_) -> []
  | (_,[]) -> []
  | (n,x::xs) -> x::take_safe (n-1) xs

let rec take_until p = function
  | [] -> []
  | x::xs -> if p x then [] else x::(take_until p xs)

let take_while p = take_until (p $ not)


(* now in prelude: let rec drop n xs = ... *)
let _ = example (drop 3 [1;2;3;4] =*= [4])

let rec drop_while p = function
  | [] -> []
  | x::xs -> if p x then drop_while p xs else x::xs     


let rec drop_until p xs = 
  drop_while (fun x -> not (p x)) xs
let _ = example (drop_until (fun x -> x =|= 3) [1;2;3;4;5] =*= [3;4;5])


let span p xs = (take_while p xs, drop_while p xs)


let rec (span: ('a -> bool) -> 'a list -> 'a list * 'a list) = 
 fun p -> function
  | []    -> ([], [])
  | x::xs -> 
      if p x then 
        let (l1, l2) = span p xs in
        (x::l1, l2)
      else ([], x::xs)
let _ = example ((span (fun x -> x <= 3) [1;2;3;4;1;2] =*= ([1;2;3],[4;1;2])))

let rec groupBy eq l =
  match l with
  | [] -> []
  | x::xs -> 
      let (xs1,xs2) = List.partition (fun x' -> eq x x') xs in
      (x::xs1)::(groupBy eq xs2)

let rec group_by_mapped_key fkey l =
  match l with
  | [] -> []
  | x::xs -> 
      let k = fkey x in 
      let (xs1,xs2) = List.partition (fun x' -> let k2 = fkey x' in k=*=k2) xs 
      in
      (k, (x::xs1))::(group_by_mapped_key fkey xs2)




let (exclude_but_keep_attached: ('a -> bool) -> 'a list -> ('a * 'a list) list)=
 fun f xs -> 
   let rec aux_filter acc = function
   | [] -> [] (* drop what was accumulated because nothing to attach to *)
   | x::xs -> 
       if f x 
       then aux_filter (x::acc) xs
       else (x, List.rev acc)::aux_filter [] xs
   in
   aux_filter [] xs
let _ = example
  (exclude_but_keep_attached (fun x -> x =|= 3) [3;3;1;3;2;3;3;3] =*=
      [(1,[3;3]);(2,[3])])

let (group_by_post: ('a -> bool) -> 'a list -> ('a list * 'a) list * 'a list)=
 fun f xs -> 
   let rec aux_filter grouped_acc acc = function
   | [] -> 
       List.rev grouped_acc, List.rev acc
   | x::xs -> 
       if f x 
       then 
         aux_filter ((List.rev acc,x)::grouped_acc) [] xs
       else 
         aux_filter grouped_acc (x::acc) xs
   in
   aux_filter [] [] xs

let _ = example
  (group_by_post (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*= 
      ([([1;1],3);([2],3);[4;5],3], [6;6;6]))

let (group_by_pre: ('a -> bool) -> 'a list -> 'a list * ('a * 'a list) list)=
  fun f xs -> 
    let xs' = List.rev xs in
    let (ys, unclassified) = group_by_post f xs' in
    List.rev unclassified,
    ys +> List.rev +> List.map (fun (xs, x) -> x, List.rev xs )

let _ = example
  (group_by_pre (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*= 
      ([1;1], [(3,[2]); (3,[4;5]); (3,[6;6;6])]))
                                           

let rec (split_when: ('a -> bool) -> 'a list -> 'a list * 'a * 'a list) = 
 fun p -> function
  | []    -> raise Not_found
  | x::xs -> 
      if p x then 
        [], x, xs 
      else 
        let (l1, a, l2) = split_when p xs in
        (x::l1, a, l2)
let _ = example (split_when (fun x -> x =|= 3) 
                    [1;2;3;4;1;2] =*= ([1;2],3,[4;1;2]))


(* not so easy to come up with ... used in aComment for split_paragraph *)
let rec split_gen_when_aux f acc xs = 
  match xs with
  | [] -> 
      if null acc
      then []
      else [List.rev acc]
  | (x::xs) -> 
      (match f (x::xs) with
      | None -> 
          split_gen_when_aux f (x::acc) xs 
      | Some (rest) -> 
          let before = List.rev acc in
          if null before
          then split_gen_when_aux f [] rest
          else before::split_gen_when_aux f [] rest
      )
(* could avoid introduce extra aux function by using ?(acc = []) *)
let split_gen_when f xs = 
  split_gen_when_aux f [] xs



(* generate exception (Failure "tl") if there is no element satisfying p *)
let rec (skip_until: ('a list -> bool) -> 'a list -> 'a list) = fun p xs ->
  if p xs then xs else skip_until p (List.tl xs)
let _ = example 
  (skip_until (function 1::2::xs -> true | _ -> false) 
      [1;3;4;1;2;4;5] =*= [1;2;4;5])

let rec skipfirst e = function
  | [] -> []
  | e'::l when e =*= e' -> skipfirst e l
  | l -> l


(* now in prelude:
 * let rec enum x n = ...
 *)


let index_list xs = 
  if null xs then [] (* enum 0 (-1) generate an exception *)
  else zip xs (enum 0 ((List.length xs) -1))

let index_list_and_total xs = 
  let total = List.length xs in
  if null xs then [] (* enum 0 (-1) generate an exception *)
  else zip xs (enum 0 ((List.length xs) -1)) 
    +> List.map (fun (a,b) -> (a,b,total))

let index_list_1 xs = 
  xs +> index_list +> List.map (fun (x,i) -> x, i+1)

let or_list  = List.fold_left (||) false
let and_list = List.fold_left (&&) true

let avg_list xs = 
  let sum = sum_int xs in
  (float_of_int sum) /. (float_of_int (List.length xs))

let snoc x xs = xs @ [x]
let cons x xs = x::xs

let head_middle_tail xs = 
  match xs with
  | x::y::xs -> 
      let head = x in
      let reversed = List.rev (y::xs) in
      let tail = List.hd reversed in
      let middle = List.rev (List.tl reversed) in
      head, middle, tail
  | _ -> failwith "head_middle_tail, too small list"

let _ = assert_equal (head_middle_tail [1;2;3]) (1, [2], 3)
let _ = assert_equal (head_middle_tail [1;3]) (1, [], 3)

(* now in prelude 
 * let (++) = (@) 
 *)

(* let (++) = (@), could do that, but if load many times the common, then pb *)
(* let (++) l1 l2 = List.fold_right (fun x acc -> x::acc) l1 l2 *)

let remove x xs = 
  let newxs = List.filter (fun y -> y <> x) xs in
  assert (List.length newxs =|= List.length xs - 1);
  newxs


let exclude p xs = 
  List.filter (fun x -> not (p x)) xs

(* now in prelude 
*)

let fold_k f lastk acc xs = 
  let rec fold_k_aux acc = function
    | [] -> lastk acc
    | x::xs -> 
        f acc x (fun acc -> fold_k_aux acc xs)
  in
  fold_k_aux acc xs


let rec list_init = function
  | []       -> raise Not_found
  | [x]      -> []
  | x::y::xs -> x::(list_init (y::xs))

let rec list_last = function
  | [] -> raise Not_found
  | [x] -> x
  | x::y::xs -> list_last (y::xs)

(* pixel *)
(* now in prelude
 *   let last_n n l = List.rev (take n (List.rev l))
 *   let last l = List.hd (last_n 1 l)
 *)

let rec join_gen a = function
  | [] -> []
  | [x] -> [x]
  | x::xs -> x::a::(join_gen a xs)


(* todo: foldl, foldr (a more consistent foldr) *)

(* start pixel *)
let iter_index f l =
  let rec iter_ n = function
    | [] -> ()
    | e::l -> f e n ; iter_ (n+1) l
  in iter_ 0 l

let map_index f l =
  let rec map_ n = function
    | [] -> []
    | e::l -> f e n :: map_ (n+1) l
  in map_ 0 l


(* pixel *)
let filter_index f l =
  let rec filt i = function
    | [] -> []
    | e::l -> if f i e then e :: filt (i+1) l else filt (i+1) l
  in
  filt 0 l

(* pixel *)
let do_withenv doit f env l =
  let r_env = ref env in
  let l' = doit (fun e -> 
    let e', env' = f !r_env e in
    r_env := env' ; e'
  ) l in
  l', !r_env

(* now in prelude: 
 * let fold_left_with_index f acc = ...
 *)
  
let map_withenv      f env e = do_withenv List.map f env e

let rec collect_accu f accu = function
  | [] -> accu
  | e::l -> collect_accu f (List.rev_append (f e) accu) l

let collect f l = List.rev (collect_accu f [] l)

(* cf also List.partition *)

let rec fpartition p l =
  let rec part yes no = function
  | [] -> (List.rev yes, List.rev no)
  | x :: l -> 
      (match p x with
      | None -> part yes (x :: no) l
      | Some v -> part (v :: yes) no l) in
  part [] [] l

(* end pixel *)

let rec removelast = function
  | [] -> failwith "removelast"
  | [_] -> []
  | e::l -> e :: removelast l

let remove x = List.filter (fun y -> y != x)
let empty list = null list


let rec inits = function
  | [] -> [[]]
  | e::l -> [] :: List.map (fun l -> e::l) (inits l)

let rec tails = function
  | [] -> [[]]
  | (_::xs) as xxs -> xxs :: tails xs


let reverse = List.rev
let rev = List.rev

let nth = List.nth
let fold_left = List.fold_left
let rev_map = List.rev_map

(* pixel *)
let rec fold_right1 f = function
  | [] -> failwith "fold_right1"
  | [e] -> e
  | e::l -> f e (fold_right1 f l)

let maximum l = foldl1 max l
let minimum l = foldl1 min l

(* do a map tail recursive, and result is reversed, it is a tail recursive map => efficient *)
let map_eff_rev = fun f l ->
  let rec map_eff_aux acc = 
    function 
      | []    -> acc
      | x::xs -> map_eff_aux ((f x)::acc) xs
  in
  map_eff_aux [] l

let acc_map f l =
  let rec loop acc = function
    [] -> List.rev acc
  | x::xs -> loop ((f x)::acc) xs in
  loop [] l


let rec (generate: int -> 'a -> 'a list) = fun i el ->
  if i =|= 0 then []
  else el::(generate (i-1) el)

let rec uniq = function
  | [] -> []
  | e::l -> if List.mem e l then uniq l else e :: uniq l

let has_no_duplicate xs = 
  List.length xs =|= List.length (uniq xs)
let is_set_as_list = has_no_duplicate


let rec get_duplicates xs = 
  match xs with
  | [] -> []
  | x::xs -> 
      if List.mem x xs
      then x::get_duplicates xs (* todo? could x from xs to avoid double dups?*)
      else get_duplicates xs

let rec all_assoc e = function
  | [] -> []
  | (e',v) :: l when e=*=e' -> v :: all_assoc e l
  | _ :: l -> all_assoc e l

let prepare_want_all_assoc l =
  List.map (fun n -> n, uniq (all_assoc n l)) (uniq (List.map fst l))

let rotate list = List.tl list ++ [(List.hd list)]

let or_list  = List.fold_left (||) false
let and_list = List.fold_left (&&) true

let rec (return_when: ('a -> 'b option) -> 'a list -> 'b) = fun p -> function
  | [] -> raise Not_found
  | x::xs -> (match p x with None -> return_when p xs | Some b -> b)

let rec splitAt n xs = 
  if n =|= 0 then ([],xs)
  else 
    (match xs with
    | []      -> ([],[])
    | (x::xs) -> let (a,b) = splitAt (n-1) xs in (x::a, b)
    )

let pack n xs = 
  let rec pack_aux l i = function
    | [] -> failwith "not on a boundary"
    | [x] -> if i =|= n then [l++[x]] else failwith "not on a boundary"
    | x::xs -> 
        if i =|= n 
        then (l++[x])::(pack_aux [] 1 xs) 
        else pack_aux (l++[x]) (i+1) xs 
  in
  pack_aux [] 1 xs

let min_with f = function
  | [] -> raise Not_found
  | e :: l ->
      let rec min_with_ min_val min_elt = function
        | [] -> min_elt
        | e::l -> 
            let val_ = f e in
            if val_ < min_val 
            then min_with_ val_ e l
            else min_with_ min_val min_elt l
      in min_with_ (f e) e l

let two_mins_with f = function
  | e1 :: e2 :: l ->
      let rec min_with_ min_val min_elt min_val2 min_elt2 = function
        | [] -> min_elt, min_elt2
        | e::l -> 
            let val_ = f e in
            if val_ < min_val2 
            then
              if val_ < min_val
              then min_with_ val_ e min_val min_elt l
              else min_with_ min_val min_elt val_ e l
            else min_with_ min_val min_elt min_val2 min_elt2 l
      in 
      let v1 = f e1 in
      let v2 = f e2 in
      if v1 < v2 then min_with_ v1 e1 v2 e2 l else min_with_ v2 e2 v1 e1 l 
  | _ -> raise Not_found

let grep_with_previous f = function
  | [] -> []
  | e::l ->
      let rec grep_with_previous_ previous = function
        | [] -> []
        | e::l -> if f previous e then e :: grep_with_previous_ e l else grep_with_previous_ previous l
      in e :: grep_with_previous_ e l

let iter_with_previous f = function
  | [] -> ()
  | e::l ->
      let rec iter_with_previous_ previous = function
        | [] -> ()
        | e::l -> f previous e ; iter_with_previous_ e l
      in iter_with_previous_ e l


let iter_with_before_after f xs = 
  let rec aux before_rev after = 
    match after with
    | [] -> ()
    | x::xs ->
        f   before_rev x xs;
        aux (x::before_rev) xs
  in
  aux [] xs



(* kind of cartesian product of x*x  *)
let rec (get_pair: ('a list) -> (('a * 'a) list)) = function
  | [] -> []
  | x::xs -> (List.map (fun y -> (x,y)) xs) ++ (get_pair xs)


(* retourne le rang dans une liste d'un element *)
let rang elem liste =
  let rec rang_rec elem accu = function
    | []   -> raise Not_found
    | a::l -> if a =*= elem then accu
    else rang_rec elem (accu+1) l in
  rang_rec elem 1 liste

(* retourne vrai si une liste contient des doubles *)
let rec doublon = function
  | []   -> false
  | a::l -> if List.mem a l then true
  else doublon l

let rec (insert_in: 'a -> 'a list -> 'a list list) = fun x -> function
  | []    -> [[x]]
  | y::ys -> (x::y::ys)  :: (List.map (fun xs -> y::xs) (insert_in x ys))
(* insert_in 3 [1;2] = [[3; 1; 2]; [1; 3; 2]; [1; 2; 3]] *)

let rec (permutation: 'a list -> 'a list list) = function
  | [] -> []
  | [x] -> [[x]]
  | x::xs -> List.flatten (List.map (insert_in x) (permutation xs))
(* permutation [1;2;3] = 
 * [[1; 2; 3]; [2; 1; 3]; [2; 3; 1]; [1; 3; 2]; [3; 1; 2]; [3; 2; 1]]
 *)


let rec remove_elem_pos pos xs =
  match (pos, xs) with
  | _, [] -> failwith "remove_elem_pos"
  | 0, x::xs -> xs
  | n, x::xs -> x::(remove_elem_pos (n-1) xs)

let rec insert_elem_pos (e, pos) xs =
  match (pos, xs) with 
  | 0, xs -> e::xs 
  | n, x::xs -> x::(insert_elem_pos (e, (n-1)) xs)
  | n, [] -> failwith "insert_elem_pos"

let rec uncons_permut xs = 
  let indexed = index_list xs in
  indexed +> List.map (fun (x, pos) -> (x, pos),  remove_elem_pos pos xs)
let _ = 
  example 
    (uncons_permut ['a';'b';'c'] =*= 
     [('a', 0),  ['b';'c'];
      ('b', 1),  ['a';'c'];
      ('c', 2),  ['a';'b']
     ])

let rec uncons_permut_lazy xs = 
  let indexed = index_list xs in
  indexed +> List.map (fun (x, pos) -> 
    (x, pos),  
    lazy (remove_elem_pos pos xs)
  )
        
    
    

(* pixel *)
let rec map_flatten f l =
  let rec map_flatten_aux accu = function    
    | [] -> accu
    | e :: l -> map_flatten_aux (List.rev (f e) ++ accu) l
  in List.rev (map_flatten_aux [] l)


let rec repeat e n = 
    let rec repeat_aux acc = function
      | 0 -> acc
      | n when n < 0 -> failwith "repeat"
      | n -> repeat_aux (e::acc) (n-1) in
    repeat_aux [] n

let rec map2 f = function 
  | [] -> []
  | x::xs -> let r = f x in r::map2 f xs

let rec map3 f l = 
  let rec map3_aux acc = function
    | [] -> acc 
    | x::xs -> map3_aux (f x::acc) xs in
  map3_aux [] l

(*
let tails2 xs = map rev (inits (rev xs))
let res = tails2 [1;2;3;4]
let res = tails [1;2;3;4]
let id x = x 
*)

let pack_sorted same xs = 
    let rec pack_s_aux acc xs = 
      match (acc,xs) with
      | ((cur,rest),[]) -> cur::rest
      | ((cur,rest), y::ys) -> 
          if same (List.hd cur) y then pack_s_aux (y::cur, rest) ys
          else pack_s_aux ([y], cur::rest) ys
    in pack_s_aux ([List.hd xs],[]) (List.tl xs) +> List.rev
let test = pack_sorted (=*=) [1;1;1;2;2;3;4]


let rec keep_best f = 
  let rec partition e = function
    | [] -> e, []
    | e' :: l ->
        match f(e,e') with
        | None -> let (e'', l') = partition e l in e'', e' :: l'
        | Some e'' -> partition e'' l
  in function
  | [] -> []
  | e::l -> 
      let (e', l') = partition e l in
      e' :: keep_best f l'

let rec sorted_keep_best f = function
  | [] -> []
  | [a] -> [a]
  | a :: b :: l -> 
      match f a b with
      | None -> a :: sorted_keep_best f (b :: l)
      | Some e -> sorted_keep_best f (e :: l)



let (cartesian_product: 'a list -> 'b list -> ('a * 'b) list) = fun xs ys -> 
  xs +> List.map (fun x ->  ys +> List.map (fun y -> (x,y)))
     +> List.flatten

let _ = assert_equal 
    (cartesian_product [1;2] ["3";"4";"5"]) 
    [1,"3";1,"4";1,"5";  2,"3";2,"4";2,"5"]

let sort_prof a b = 
  profile_code "Common.sort_by_xxx" (fun () -> List.sort a b)

let sort_by_val_highfirst xs = 
  sort_prof (fun (k1,v1) (k2,v2) -> compare v2 v1) xs
let sort_by_val_lowfirst xs = 
  sort_prof (fun (k1,v1) (k2,v2) -> compare v1 v2) xs

let sort_by_key_highfirst xs = 
  sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs
let sort_by_key_lowfirst xs = 
  sort_prof (fun (k1,v1) (k2,v2) -> compare k1 k2) xs

let _ = example (sort_by_key_lowfirst [4, (); 7,()] =*= [4,(); 7,()])
let _ = example (sort_by_key_highfirst [4,(); 7,()] =*= [7,(); 4,()])


let sortgen_by_key_highfirst xs = 
  sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs
let sortgen_by_key_lowfirst xs = 
  sort_prof (fun (k1,v1) (k2,v2) -> compare k1 k2) xs

(*----------------------------------*)

(* sur surEnsemble [p1;p2] [[p1;p2;p3] [p1;p2] ....] -> [[p1;p2;p3] ...      *)
(* mais pas p2;p3                                                            *)
(* (aop) *)
let surEnsemble  liste_el liste_liste_el = 
  List.filter
    (function liste_elbis ->
      List.for_all (function el -> List.mem el liste_elbis) liste_el
    ) liste_liste_el;;



(*----------------------------------*)
(* combinaison/product/.... (aop) *)
(* 123 -> 123 12 13 23 1 2 3 *)
let rec realCombinaison = function
  | []  -> []
  | [a] -> [[a]]
  | a::l  -> 
      let res  = realCombinaison l in
      let res2 = List.map (function x -> a::x) res in
      res2 ++ res ++ [[a]]

(* genere toutes les combinaisons possible de paire      *)
(* par exemple combinaison [1;2;4] -> [1, 2; 1, 4; 2, 4] *)
let rec combinaison = function
  | [] -> []
  | [a] -> []
  | [a;b] -> [(a, b)]
  | a::b::l -> (List.map (function elem -> (a, elem)) (b::l)) ++
     (combinaison (b::l))

(*----------------------------------*)

(* list of list(aop) *)
(* insere elem dans la liste de liste (si elem est deja present dans une de  *)
(* ces listes, on ne fait rien                                               *)
let rec insere elem = function
  | []   -> [[elem]]
  | a::l -> 
      if (List.mem elem a) then a::l
      else a::(insere elem l)

let rec insereListeContenant lis el = function
  | []   -> [el::lis]
  | a::l -> 
      if List.mem el a then 
        (List.append lis a)::l
      else a::(insereListeContenant lis el l)

(* fusionne les listes contenant et1 et et2  dans la liste de liste*)
let rec fusionneListeContenant (et1, et2) = function
  | []   -> [[et1; et2]]
  | a::l -> 
      (* si les deux sont deja dedans alors rien faire *)
      if List.mem et1 a then
        if List.mem et2 a then a::l
        else 
          insereListeContenant a et2 l
      else if List.mem et2 a then
        insereListeContenant a et1 l
      else a::(fusionneListeContenant (et1, et2) l)

(*****************************************************************************)
(* Arrays *)
(*****************************************************************************)

(* do bound checking ? *)
let array_find_index f a =
  let rec array_find_index_ i =
    if f i then i else array_find_index_ (i+1)
  in
  try array_find_index_ 0 with _ -> raise Not_found

let array_find_index_via_elem f a =
  let rec array_find_index_ i =
    if f a.(i) then i else array_find_index_ (i+1)
  in
  try array_find_index_ 0 with _ -> raise Not_found



type idx = Idx of int 
let next_idx (Idx i) = (Idx (i+1))
let int_of_idx (Idx i) = i

let array_find_index_typed f a =
  let rec array_find_index_ i =
    if f i then i else array_find_index_ (next_idx i)
  in
  try array_find_index_ (Idx 0) with _ -> raise Not_found



(*****************************************************************************)
(* Matrix *)
(*****************************************************************************)

type 'a matrix = 'a array array

let map_matrix f mat = 
  mat +> Array.map (fun arr -> arr +> Array.map f)

let (make_matrix_init: 
        nrow:int -> ncolumn:int -> (int -> int -> 'a) -> 'a matrix) = 
 fun ~nrow ~ncolumn f ->
  Array.init nrow (fun i -> 
    Array.init ncolumn (fun j -> 
      f i j
    )
  )

let iter_matrix f m = 
  Array.iteri (fun i e -> 
    Array.iteri (fun j x -> 
      f i j x
    ) e
  ) m

let nb_rows_matrix m = 
  Array.length m

let nb_columns_matrix m =
  assert(Array.length m > 0);
  Array.length m.(0)
  
(* check all nested arrays have the same size *)
let invariant_matrix m =
  raise Todo

let (rows_of_matrix: 'a matrix -> 'a list list) = fun m -> 
  Array.to_list m +> List.map Array.to_list
  
let (columns_of_matrix: 'a matrix -> 'a list list) = fun m -> 
  let nbcols = nb_columns_matrix m in
  let nbrows = nb_rows_matrix m in
  (enum 0 (nbcols -1)) +> List.map (fun j -> 
    (enum 0 (nbrows -1)) +> List.map (fun i -> 
      m.(i).(j)
    ))


let all_elems_matrix_by_row m = 
  rows_of_matrix m +> List.flatten 


let ex_matrix1 = 
  [|
    [|0;1;2|];
    [|3;4;5|];
    [|6;7;8|];
  |]
let ex_rows1 = 
  [
    [0;1;2];
    [3;4;5];
    [6;7;8];
  ]
let ex_columns1 = 
  [
    [0;3;6];
    [1;4;7];
    [2;5;8];
  ]
let _ = example (rows_of_matrix ex_matrix1 =*= ex_rows1)
let _ = example (columns_of_matrix ex_matrix1 =*= ex_columns1)


(*****************************************************************************)
(* Fast array *)
(*****************************************************************************)
(*
module B_Array = Bigarray.Array2
*)

(*
open B_Array
open Bigarray
*)


(* for the string_of auto generation of camlp4 
val b_array_string_of_t : 'a -> 'b -> string
val bigarray_string_of_int16_unsigned_elt : 'a -> string
val bigarray_string_of_c_layout : 'a -> string
let b_array_string_of_t f a = "<>"
let bigarray_string_of_int16_unsigned_elt a = "<>"
let bigarray_string_of_c_layout a = "<>"

*)


(*****************************************************************************)
(* Set. Have a look too at set*.mli  *)
(*****************************************************************************)
type 'a set = 'a list
  (* with sexp *)

let (empty_set: 'a set) = []
let (insert_set: 'a -> 'a set -> 'a set) = fun x xs -> 
  if List.mem x xs 
  then (* let _ = print_string "warning insert: already exist" in *) 
    xs 
  else x::xs

let is_set xs = 
  has_no_duplicate xs

let (single_set: 'a -> 'a set) = fun x -> insert_set x empty_set
let (set: 'a list -> 'a set) = fun xs -> 
  xs +> List.fold_left (flip insert_set) empty_set 

let (exists_set: ('a -> bool) -> 'a set -> bool) = List.exists
let (forall_set: ('a -> bool) -> 'a set -> bool) = List.for_all
let (filter_set: ('a -> bool) -> 'a set -> 'a set) = List.filter
let (fold_set: ('a -> 'b -> 'a) -> 'a -> 'b set -> 'a) = List.fold_left
let (map_set: ('a -> 'b) -> 'a set -> 'b set) = List.map
let (member_set: 'a -> 'a set -> bool) = List.mem

let find_set = List.find
let sort_set = List.sort
let iter_set = List.iter

let (top_set: 'a set -> 'a) = List.hd

let (inter_set: 'a set -> 'a set -> 'a set) = fun s1 s2 -> 
  s1 +> fold_set (fun acc x -> if member_set x s2 then insert_set x acc else acc) empty_set
let (union_set: 'a set -> 'a set -> 'a set) = fun s1 s2 -> 
  s2 +> fold_set (fun acc x -> if member_set x s1 then acc else insert_set x acc) s1
let (minus_set: 'a set -> 'a set -> 'a set) = fun s1 s2 -> 
  s1 +> filter_set  (fun x -> not (member_set x s2))


let union_all l = List.fold_left union_set [] l

let big_union_set f xs = xs +> map_set f +> fold_set union_set empty_set

let (card_set: 'a set -> int) = List.length

let (include_set: 'a set -> 'a set -> bool) = fun s1 s2 -> 
  (s1 +> forall_set (fun p -> member_set p s2))

let equal_set s1 s2 = include_set s1 s2 && include_set s2 s1

let (include_set_strict: 'a set -> 'a set -> bool) = fun s1 s2 -> 
  (card_set s1 < card_set s2) && (include_set s1 s2)

let ($*$) = inter_set
let ($+$) = union_set
let ($-$) = minus_set
let ($?$) a b = profile_code "$?$" (fun () -> member_set a b)
let ($<$) = include_set_strict
let ($<=$) = include_set
let ($=$) = equal_set

(* as $+$ but do not check for memberness, allow to have set of func *)
let ($@$) = fun a b -> a @ b 

let rec nub = function
    [] -> []
  | x::xs -> if List.mem x xs then nub xs else x::(nub xs)

(*****************************************************************************)
(* Set as normal list *)
(*****************************************************************************)
(*
let (union: 'a list -> 'a list -> 'a list) = fun l1 l2 -> 
  List.fold_left (fun acc x -> if List.mem x l1 then acc else x::acc) l1 l2

let insert_normal x xs = union xs [x]

(* retourne lis1 - lis2 *)
let minus l1 l2 = List.filter    (fun x -> not (List.mem x l2)) l1

let inter l1 l2 = List.fold_left (fun acc x -> if List.mem x l2 then x::acc else acc) [] l1

let union_list =  List.fold_left union []

let uniq lis = 
  List.fold_left (function acc -> function el -> union [el] acc) [] lis

(* pixel *)
let rec non_uniq = function
  | [] -> []
  | e::l -> if mem e l then e :: non_uniq l else non_uniq l

let rec inclu lis1 lis2 =
  List.for_all (function el -> List.mem el lis2) lis1

let equivalent lis1 lis2 = 
  (inclu lis1 lis2) && (inclu lis2 lis1)

*)


(*****************************************************************************)
(* Set as sorted list *)
(*****************************************************************************)
(* liste trie, cos we need to do intersection, and insertion (it is a set
   cos when introduce has, if we create a new has => must do a recurse_rep
   and another categ can have to this has => must do an union
 *)
(*
let rec insert x = function
  | [] -> [x]
  | y::ys -> 
      if x = y then y::ys
      else (if x < y then x::y::ys else y::(insert x ys))

(* same, suppose sorted list *)
let rec intersect x y =
  match(x,y) with
  | [], y -> []
  | x,  [] -> []
  | x::xs, y::ys -> 
      if x = y then x::(intersect xs ys)
      else 
        (if x < y then intersect xs (y::ys)
        else intersect (x::xs) ys
        )
(* intersect [1;3;7] [2;3;4;7;8];;   *)
*)

(*****************************************************************************)
(* Assoc *)
(*****************************************************************************)
type ('a,'b) assoc  = ('a * 'b) list
  (* with sexp *)


let (assoc_to_function: ('a, 'b) assoc -> ('a -> 'b)) = fun xs ->
  xs +> List.fold_left (fun acc (k, v) -> 
    (fun k' -> 
      if k =*= k' then v else acc k'
    )) (fun k -> failwith "no key in this assoc")
(* simpler: 
let (assoc_to_function: ('a, 'b) assoc -> ('a -> 'b)) = fun xs ->
  fun k -> List.assoc k xs
*)

let (empty_assoc: ('a, 'b) assoc) = []
let fold_assoc = List.fold_left
let insert_assoc = fun x xs -> x::xs
let map_assoc = List.map
let filter_assoc = List.filter

let assoc = List.assoc
let keys xs = List.map fst xs

let lookup = assoc

(* assert unique key ?*)
let del_assoc key xs = xs +> List.filter (fun (k,v) -> k <> key)
let replace_assoc (key, v) xs = insert_assoc (key, v) (del_assoc key xs)

let apply_assoc key f xs = 
  let old = assoc key xs in
  replace_assoc (key, f old) xs

let big_union_assoc f xs = xs +> map_assoc f +> fold_assoc union_set empty_set

(* todo: pb normally can suppr fun l -> .... l but if do that, then strange type _a
 => assoc_map is strange too => equal dont work
*)
let (assoc_reverse: (('a * 'b) list) -> (('b * 'a) list)) = fun l -> 
  List.map (fun(x,y) -> (y,x)) l

let (assoc_map: (('a * 'b) list) -> (('a * 'b) list) -> (('a * 'a) list)) = 
 fun l1 l2 ->
  let (l1bis, l2bis) = (assoc_reverse l1, assoc_reverse l2) in
  List.map (fun (x,y) -> (y, List.assoc x l2bis )) l1bis

let rec (lookup_list: 'a -> ('a , 'b) assoc list -> 'b) = fun el -> function
  | [] -> raise Not_found
  | (xs::xxs) -> try List.assoc el xs with Not_found -> lookup_list el xxs

let (lookup_list2: 'a -> ('a , 'b) assoc list -> ('b * int)) = fun el xxs -> 
  let rec lookup_l_aux i = function
  | [] -> raise Not_found
  | (xs::xxs) -> 
      try let res = List.assoc el xs in (res,i) 
      with Not_found -> lookup_l_aux (i+1) xxs
  in lookup_l_aux 0 xxs

let _ = example 
  (lookup_list2 "c" [["a",1;"b",2];["a",1;"b",3];["a",1;"c",7]] =*= (7,2))


let assoc_option  k l = 
  optionise (fun () -> List.assoc k l)

let assoc_with_err_msg k l =
  try List.assoc k l 
  with Not_found -> 
    pr2 (spf "pb assoc_with_err_msg: %s" (dump k));
    raise Not_found

(*****************************************************************************)
(* Assoc int -> xxx with binary tree.  Have a look too at Mapb.mli *)
(*****************************************************************************)

(* ex: type robot_list = robot_info IntMap.t *)
module IntMap = Map.Make
    (struct
      type t = int
      let compare = compare 
    end)
let intmap_to_list m = IntMap.fold (fun id v acc -> (id, v) :: acc) m []
let intmap_string_of_t f a = "<Not Yet>"

module IntIntMap = Map.Make
    (struct
      type t = int * int
      let compare = compare 
end)

let intintmap_to_list m = IntIntMap.fold (fun id v acc -> (id, v) :: acc) m []
let intintmap_string_of_t f a = "<Not Yet>"


(*****************************************************************************)
(* Hash *)
(*****************************************************************************)

(* il parait que better  when choose a prime *)
let hcreate () = Hashtbl.create 401 
let hadd (k,v) h = Hashtbl.add h k v
let hmem k h = Hashtbl.mem h k
let hfind k h = Hashtbl.find h k
let hreplace (k,v) h = Hashtbl.replace h k v
let hiter = Hashtbl.iter
let hfold = Hashtbl.fold
let hremove k h = Hashtbl.remove h k


let hash_to_list h = 
  Hashtbl.fold (fun k v acc -> (k,v)::acc) h [] 
  +> List.sort compare 

let hash_to_list_unsorted h = 
  Hashtbl.fold (fun k v acc -> (k,v)::acc) h [] 

let hash_of_list xs = 
  let h = Hashtbl.create 101 in
  begin
    xs +> List.iter (fun (k, v) -> Hashtbl.add h k v);
    h
  end

let _  =
  let h = Hashtbl.create 101 in
  Hashtbl.add h "toto" 1; 
  Hashtbl.add h "toto" 1;
  assert(hash_to_list h =*= ["toto",1; "toto",1])
 

let hfind_default key value_if_not_found h = 
  try Hashtbl.find h key
  with Not_found -> 
    (Hashtbl.add h key (value_if_not_found ()); Hashtbl.find h key)

(* not as easy as Perl  $h->{key}++; but still possible *)
let hupdate_default key op value_if_not_found h = 
  let old = hfind_default key value_if_not_found h in
  Hashtbl.replace h key (op old)
  

let hfind_option key h =
  optionise (fun () -> Hashtbl.find h key)


(* see below: let hkeys h = ... *)


(*****************************************************************************)
(* Hash sets *)
(*****************************************************************************)

type 'a hashset = ('a, bool) Hashtbl.t 
  (* with sexp *)


let hash_hashset_add k e h = 
  match optionise (fun () -> Hashtbl.find h k) with
  | Some hset -> Hashtbl.replace hset e true
  | None -> 
      let hset = Hashtbl.create 11 in
      begin
        Hashtbl.add h k hset;
        Hashtbl.replace hset e true;
      end

let hashset_to_set baseset h = 
 h +> hash_to_list +> List.map fst +> (fun xs -> baseset#fromlist xs) 

let hashset_to_list h = hash_to_list h +> List.map fst

let hashset_of_list xs = 
  xs +> List.map (fun x -> x, true) +> hash_of_list



let hkeys h = 
  let hkey = Hashtbl.create 101 in
  h +> Hashtbl.iter (fun k v -> Hashtbl.replace hkey k true);
  hashset_to_list hkey



let group_assoc_bykey_eff2 xs = 
  let h = Hashtbl.create 101 in 
  xs +> List.iter (fun (k, v) -> Hashtbl.add h k v);
  let keys = hkeys h in
  keys +> List.map (fun k -> k, Hashtbl.find_all h k)

let group_assoc_bykey_eff xs = 
  profile_code2 "Common.group_assoc_bykey_eff" (fun () -> 
    group_assoc_bykey_eff2 xs)
  

let test_group_assoc () = 
  let xs = enum 0 10000 +> List.map (fun i -> i_to_s i, i) in
  let xs = ("0", 2)::xs in
(*    let _ys = xs +> Common.groupBy (fun (a,resa) (b,resb) -> a =$= b)  *)
  let ys = xs +> group_assoc_bykey_eff 
  in
  pr2_gen ys


let uniq_eff xs = 
  let h = Hashtbl.create 101 in
  xs +> List.iter (fun k -> 
    Hashtbl.add h k true
  );
  hkeys h



let diff_two_say_set_eff xs1 xs2 = 
  let h1 = hashset_of_list xs1 in
  let h2 = hashset_of_list xs2 in
  
  let hcommon = Hashtbl.create 101 in
  let honly_in_h1 = Hashtbl.create 101 in
  let honly_in_h2 = Hashtbl.create 101 in
  
  h1 +> Hashtbl.iter (fun k _ -> 
    if Hashtbl.mem h2 k
    then Hashtbl.replace hcommon k true
    else Hashtbl.add honly_in_h1 k true
  );
  h2 +> Hashtbl.iter (fun k _ -> 
    if Hashtbl.mem h1 k
    then Hashtbl.replace hcommon k true
    else Hashtbl.add honly_in_h2 k true
  );
  hashset_to_list hcommon,
  hashset_to_list honly_in_h1,
  hashset_to_list honly_in_h2

  
(*****************************************************************************)
(* Stack *)
(*****************************************************************************)
type 'a stack = 'a list
  (* with sexp *)

let (empty_stack: 'a stack) = []
let (push: 'a -> 'a stack -> 'a stack) = fun x xs -> x::xs
let (top: 'a stack -> 'a) = List.hd
let (pop: 'a stack -> 'a stack) = List.tl

let top_option = function
  | [] -> None
  | x::xs -> Some x


  

(* now in prelude:
 * let push2 v l = l := v :: !l
 *)

let pop2 l = 
  let v = List.hd !l in
  begin
    l := List.tl !l;
    v
  end


(*****************************************************************************)
(* Undoable Stack *)
(*****************************************************************************)

(* Okasaki use such structure also for having efficient data structure
 * supporting fast append.
 *)

type 'a undo_stack = 'a list * 'a list (* redo *)

let (empty_undo_stack: 'a undo_stack) = 
  [], []

(* push erase the possible redo *)
let (push_undo: 'a -> 'a undo_stack -> 'a undo_stack) = fun x (undo,redo) -> 
  x::undo, [] 

let (top_undo: 'a undo_stack -> 'a) = fun (undo, redo) -> 
  List.hd undo 

let (pop_undo: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) -> 
  match undo with
  | [] ->  failwith "empty undo stack"
  | x::xs -> 
      xs, x::redo

let (undo_pop: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) -> 
  match redo with
  | [] -> failwith "empty redo, nothing to redo"
  | x::xs -> 
      x::undo, xs

let redo_undo x = undo_pop x 


let top_undo_option = fun (undo, redo) -> 
  match undo with
  | [] -> None
  | x::xs -> Some x

(*****************************************************************************)
(* Binary tree *)
(*****************************************************************************)
type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree)


(*****************************************************************************)
(* N-ary tree *)
(*****************************************************************************)

(* no empty tree, must have one root at list *)
type 'a tree = Tree of 'a * ('a tree) list

let rec (tree_iter: ('a -> unit) -> 'a tree -> unit) = fun f tree ->
  match tree with 
  | Tree (node, xs) -> 
      f node;
      xs +> List.iter (tree_iter f)


(*****************************************************************************)
(* N-ary tree with updatable childrens *)
(*****************************************************************************)

(* no empty tree, must have one root at list *)

type 'a treeref = 
  | NodeRef of 'a * 'a treeref list ref 

let treeref_children_ref tree = 
  match tree with
  | NodeRef (n, x) -> x



let rec (treeref_node_iter: 
(*   (('a * ('a, 'b) treeref list ref) -> unit) -> 
   ('a, 'b) treeref -> unit
*) 'a) 
 = 
 fun f tree -> 
  match tree with
(*  | LeafRef _ -> ()*)
  | NodeRef (n, xs) -> 
      f (n, xs);
      !xs +> List.iter (treeref_node_iter f)


let find_treeref f tree = 
  let res = ref [] in

  tree +> treeref_node_iter (fun (n, xs) -> 
    if f (n,xs)
    then push2 (n, xs) res;
  );
  match !res with
  | [n,xs] -> NodeRef (n, xs)
  | [] -> raise Not_found
  | x::y::zs -> raise Multi_found

let rec (treeref_node_iter_with_parents: 
 (*  (('a * ('a, 'b) treeref list ref) -> ('a list) -> unit) -> 
   ('a, 'b) treeref -> unit) 
 *) 'a)
 = 
 fun f tree -> 
  let rec aux acc tree = 
    match tree with
(*    | LeafRef _ -> ()*)
    | NodeRef (n, xs) -> 
        f (n, xs) acc ;
        !xs +> List.iter (aux (n::acc))
  in
  aux [] tree


(* ---------------------------------------------------------------------- *)
(* Leaf can seem redundant, but sometimes want to directly see if 
 * a children is a leaf without looking if the list is empty.
 *)
type ('a, 'b) treeref2 = 
  | NodeRef2 of 'a * ('a, 'b) treeref2 list ref 
  | LeafRef2 of 'b


let treeref2_children_ref tree = 
  match tree with
  | LeafRef2 _ -> failwith "treeref_tail: leaf"
  | NodeRef2 (n, x) -> x



let rec (treeref_node_iter2: 
   (('a * ('a, 'b) treeref2 list ref) -> unit) -> 
   ('a, 'b) treeref2 -> unit) = 
 fun f tree -> 
  match tree with
  | LeafRef2 _ -> ()
  | NodeRef2 (n, xs) -> 
      f (n, xs);
      !xs +> List.iter (treeref_node_iter2 f)


let find_treeref2 f tree = 
  let res = ref [] in

  tree +> treeref_node_iter2 (fun (n, xs) -> 
    if f (n,xs)
    then push2 (n, xs) res;
  );
  match !res with
  | [n,xs] -> NodeRef2 (n, xs)
  | [] -> raise Not_found
  | x::y::zs -> raise Multi_found




let rec (treeref_node_iter_with_parents2: 
  (('a * ('a, 'b) treeref2 list ref) -> ('a list) -> unit) -> 
   ('a, 'b) treeref2 -> unit) = 
 fun f tree -> 
  let rec aux acc tree = 
    match tree with
    | LeafRef2 _ -> ()
    | NodeRef2 (n, xs) -> 
        f (n, xs) acc ;
        !xs +> List.iter (aux (n::acc))
  in
  aux [] tree













let find_treeref_with_parents_some f tree = 
  let res = ref [] in

  tree +> treeref_node_iter_with_parents (fun (n, xs) parents -> 
    match f (n,xs) parents with
    | Some v -> push2 v res;
    | None -> ()
  );
  match !res with
  | [v] -> v
  | [] -> raise Not_found
  | x::y::zs -> raise Multi_found

let find_multi_treeref_with_parents_some f tree = 
  let res = ref [] in

  tree +> treeref_node_iter_with_parents (fun (n, xs) parents -> 
    match f (n,xs) parents with
    | Some v -> push2 v res;
    | None -> ()
  );
  match !res with
  | [v] -> !res
  | [] -> raise Not_found
  | x::y::zs -> !res 


(*****************************************************************************)
(* Graph. Have a look too at Ograph_*.mli  *)
(*****************************************************************************)
(* todo: generalise to put in common (need 'edge (and 'c ?), 
 * and take in param a display func, cos caml sux, no overloading of show :( 
 * Simple impelemntation. Can do also matrix, or adjacent list, or pointer(ref)
 * todo: do some check (dont exist already, ...)
 *)

type 'node graph = ('node set) * (('node * 'node) set)

let (add_node: 'a -> 'a graph -> 'a graph) = fun node (nodes, arcs) -> 
  (node::nodes, arcs)

let (del_node: 'a -> 'a graph -> 'a graph) = fun node (nodes, arcs) -> 
  (nodes $-$ set [node], arcs) 
(* could do more job:   
  let _ = assert (successors node (nodes, arcs) = empty) in
   +> List.filter (fun (src, dst) -> dst != node))
*)
let (add_arc: ('a * 'a) -> 'a graph -> 'a graph) = fun arc (nodes, arcs) -> 
  (nodes, set [arc] $+$ arcs)

let (del_arc: ('a * 'a) -> 'a graph -> 'a graph) = fun arc (nodes, arcs) -> 
  (nodes, arcs +> List.filter (fun a -> not (arc =*= a)))

let (successors: 'a -> 'a graph -> 'a set) = fun x (nodes, arcs) -> 
  arcs +> List.filter (fun (src, dst) -> src =*= x) +> List.map snd

let (predecessors: 'a -> 'a graph -> 'a set) = fun x (nodes, arcs) -> 
  arcs +> List.filter (fun (src, dst) -> dst =*= x) +> List.map fst

let (nodes: 'a graph -> 'a set) = fun (nodes, arcs) -> nodes

(* pre: no cycle *)
let rec (fold_upward: ('b -> 'a -> 'b) -> 'a set -> 'b -> 'a graph  -> 'b) = 
 fun f xs acc graph -> 
  match xs with
  | [] -> acc
  | x::xs -> (f acc x) 
        +> (fun newacc -> fold_upward f (graph +> predecessors x) newacc graph)
        +> (fun newacc -> fold_upward f xs newacc graph) 
   (* TODO avoid already visited *)

let empty_graph = ([], [])



(*
let (add_arcs_toward: int -> (int list) -> 'a graph -> 'a graph) = fun i xs -> 
  function
    (nodes, arcs) -> (nodes, (List.map (fun j -> (j,i) ) xs)++arcs)
let (del_arcs_toward: int -> (int list) -> 'a graph -> 'a graph)= fun i xs g ->
    List.fold_left (fun acc el -> del_arc (el, i) acc) g xs
let (add_arcs_from: int -> (int list) -> 'a graph -> 'a graph) = fun i xs -> 
 function
    (nodes, arcs) -> (nodes, (List.map (fun j -> (i,j) ) xs)++arcs)


let (del_node: (int * 'node) -> 'node graph -> 'node graph) = fun node -> 
 function (nodes, arcs) -> 
  let newnodes = List.filter (fun a -> not (node = a)) nodes in
    if newnodes = nodes then (raise Not_found) else (newnodes, arcs)
let (replace_node: int -> 'node -> 'node graph -> 'node graph) = fun i n -> 
 function (nodes, arcs) -> 
  let newnodes = List.filter (fun (j,_) -> not (i = j)) nodes in
    ((i,n)::newnodes, arcs)
let (get_node: int -> 'node graph -> 'node) = fun i -> function
    (nodes, arcs) -> List.assoc i nodes

let (get_free: 'a graph -> int) = function
    (nodes, arcs) -> (maximum (List.map fst nodes))+1
(* require no cycle !! 
  TODO if cycle check that we have already visited a node *)
let rec (succ_all: int -> 'a graph -> (int list)) = fun i -> function
    (nodes, arcs) as g -> 
      let direct = succ i g in
      union direct (union_list (List.map (fun i -> succ_all i g) direct))
let rec (pred_all: int -> 'a graph -> (int list)) = fun i -> function
    (nodes, arcs) as g -> 
      let direct = pred i g in
      union direct (union_list (List.map (fun i -> pred_all i g) direct))
(* require that the nodes are different !! *)
let rec (equal: 'a graph -> 'a graph -> bool) = fun g1 g2 ->
  let ((nodes1, arcs1),(nodes2, arcs2)) = (g1,g2) in
  try 
   (* do 2 things, check same length and to assoc *)
    let conv = assoc_map nodes1 nodes2 in 
    List.for_all (fun (i1,i2) -> 
       List.mem (List.assoc i1 conv, List.assoc i2 conv) arcs2)
     arcs1 
      && (List.length arcs1 = List.length arcs2)
    (* could think that only forall is needed, but need check same lenth too*)
  with _ -> false

let (display: 'a graph -> ('a -> unit) -> unit) = fun g display_func -> 
  let rec aux depth i = 
    print_n depth " ";
    print_int i; print_string "->"; display_func (get_node i g); 
    print_string "\n";
    List.iter (aux (depth+2)) (succ i g)
  in aux 0 1

let (display_dot: 'a graph -> ('a -> string) -> unit)= fun (nodes,arcs) func ->
  let file = open_out "test.dot" in
  output_string file "digraph misc {\n" ;
  List.iter (fun (n, node) -> 
    output_int file n; output_string file " [label=\"";
    output_string file (func node); output_string file " \"];\n"; ) nodes;
  List.iter (fun (i1,i2) ->  output_int file i1 ; output_string file " -> " ; 
    output_int file i2 ; output_string file " ;\n"; ) arcs;
  output_string file "}\n" ;
  close_out file;
  let status = Unix.system "viewdot test.dot" in
  ()
(* todo: faire = graphe (int can change !!! => cant make simply =)
   reassign number first !!
 *)

(* todo: mettre diff(modulo = !!) en rouge *)
let (display_dot2: 'a graph -> 'a graph -> ('a -> string) -> unit) = 
  fun (nodes1, arcs1) (nodes2, arcs2) func ->
  let file = open_out "test.dot" in
  output_string file "digraph misc {\n" ;
  output_string file "rotate = 90;\n";
  List.iter (fun (n, node) ->
    output_string file "100"; output_int file n; 
    output_string file " [label=\"";
    output_string file (func node); output_string file " \"];\n"; ) nodes1;
  List.iter (fun (n, node) ->
    output_string file "200"; output_int file n; 
    output_string file " [label=\"";
    output_string file (func node); output_string file " \"];\n"; ) nodes2;
  List.iter (fun (i1,i2) -> 
    output_string file "100"; output_int file i1 ; output_string file " -> " ; 
    output_string file "100"; output_int file i2 ; output_string file " ;\n"; 
    ) 
   arcs1;
  List.iter (fun (i1,i2) -> 
    output_string file "200"; output_int file i1 ; output_string file " -> " ;
    output_string file "200"; output_int file i2 ; output_string file " ;\n"; )
   arcs2;
(*  output_string file "500 -> 1001; 500 -> 2001}\n" ; *)
  output_string file "}\n" ;
  close_out file;
  let status = Unix.system "viewdot test.dot" in
  ()


*)
(*****************************************************************************)
(* Generic op *)
(*****************************************************************************)
(* overloading *)

let map = List.map (* note: really really slow, use rev_map if possible *)
let filter = List.filter
let fold = List.fold_left
let member = List.mem
let iter = List.iter
let find = List.find
let exists = List.exists
let forall = List.for_all
let big_union f xs = xs +> map f +> fold union_set empty_set
(* let empty = [] *)
let empty_list = []
let sort = List.sort
let length = List.length
(* in prelude now: let null xs = match xs with [] -> true | _ -> false *)
let head = List.hd
let tail = List.tl
let is_singleton = fun xs -> List.length xs =|= 1

(*****************************************************************************)
(* Geometry (raytracer) *)
(*****************************************************************************)

type vector = (float * float * float)
type point = vector
type color = vector (* color(0-1) *)

(* todo: factorise *)
let (dotproduct: vector * vector -> float) = 
  fun ((x1,y1,z1),(x2,y2,z2)) -> (x1*.x2 +. y1*.y2 +. z1*.z2)
let (vector_length: vector -> float) = 
  fun (x,y,z) -> sqrt (square x +. square y +. square z)
let (minus_point: point * point -> vector) = 
  fun ((x1,y1,z1),(x2,y2,z2)) -> ((x1 -. x2),(y1 -. y2),(z1 -. z2))
let (distance: point * point -> float) = 
  fun (x1, x2) -> vector_length (minus_point (x2,x1))
let (normalise: vector -> vector) = 
  fun (x,y,z) -> 
    let len = vector_length (x,y,z) in (x /. len, y /. len, z /. len)
let (mult_coeff: vector -> float -> vector) = 
  fun (x,y,z) c -> (x *. c, y *. c, z *. c)
let (add_vector: vector -> vector -> vector) = 
  fun v1 v2 -> let ((x1,y1,z1),(x2,y2,z2)) = (v1,v2) in
  (x1+.x2, y1+.y2, z1+.z2)
let (mult_vector: vector -> vector -> vector) = 
  fun v1 v2 -> let ((x1,y1,z1),(x2,y2,z2)) = (v1,v2) in
  (x1*.x2, y1*.y2, z1*.z2)
let sum_vector = List.fold_left add_vector (0.0,0.0,0.0)

(*****************************************************************************)
(* Pics (raytracer) *)
(*****************************************************************************)

type pixel = (int * int * int) (* RGB *)

(* required pixel list in row major order, line after line *)
let (write_ppm: int -> int -> (pixel list) -> string -> unit) = fun
  width height xs filename ->
    let chan = open_out filename in
    begin
     output_string chan "P6\n";
     output_string chan ((string_of_int width)  ^ "\n");
     output_string chan ((string_of_int height) ^ "\n");
     output_string chan "255\n";
     List.iter (fun (r,g,b) -> 
       List.iter (fun byt -> output_byte chan byt) [r;g;b]
               ) xs;
     close_out chan
    end
    
let test_ppm1 () = write_ppm 100 100 
    ((generate (50*100) (1,45,100)) ++ (generate (50*100) (1,1,100)))
    "img.ppm"

(*****************************************************************************)
(* Diff (lfs) *)
(*****************************************************************************)
type diff = Match | BnotinA | AnotinB

let (diff: (int -> int -> diff -> unit)-> (string list * string list) -> unit)=
  fun f (xs,ys) -> 
    let file1 = "/tmp/diff1-" ^ (string_of_int (Unix.getuid ())) in
    let file2 = "/tmp/diff2-" ^ (string_of_int (Unix.getuid ())) in
    let fileresult = "/tmp/diffresult-" ^ (string_of_int (Unix.getuid ())) in
    write_file file1 (unwords xs);
    write_file file2 (unwords ys);
    command2 
      ("diff --side-by-side -W 1 " ^ file1 ^ " " ^ file2 ^ " > " ^ fileresult);
    let res = cat fileresult in
    let a = ref 0 in
    let b = ref 0 in
    res +> List.iter (fun s -> 
      match s with
      | ("" | " ") -> f !a !b Match; incr a; incr b;
      | ">" -> f !a !b BnotinA; incr b;
      | ("|" | "/" | "\\" ) -> 
          f !a !b BnotinA; f !a !b AnotinB; incr a; incr b;
      | "<" -> f !a !b AnotinB; incr a;
      | _ -> raise Impossible
    )
(*    
let _ = 
  diff 
    ["0";"a";"b";"c";"d";    "f";"g";"h";"j";"q";            "z"]
    [    "a";"b";"c";"d";"e";"f";"g";"i";"j";"k";"r";"x";"y";"z"]  
   (fun x y -> pr "match") 
   (fun x y -> pr "a_not_in_b") 
   (fun x y -> pr "b_not_in_a") 
*)

let (diff2: (int -> int -> diff -> unit) -> (string * string) -> unit) = 
 fun f (xstr,ystr) -> 
    write_file "/tmp/diff1" xstr;
    write_file "/tmp/diff2" ystr;
    command2 
     ("diff --side-by-side --left-column -W 1 " ^ 
      "/tmp/diff1 /tmp/diff2 > /tmp/diffresult");
    let res = cat "/tmp/diffresult" in
    let a = ref 0 in
    let b = ref 0 in
    res +> List.iter (fun s -> 
      match s with
      | "(" -> f !a !b Match; incr a; incr b;
      | ">" -> f !a !b BnotinA; incr b;
      | "|" -> f !a !b BnotinA; f !a !b AnotinB; incr a; incr b;
      | "<" -> f !a !b AnotinB; incr a;
      | _ -> raise Impossible
    )


(*****************************************************************************)
(* Parsers (aop-colcombet) *)
(*****************************************************************************)

let parserCommon lexbuf parserer lexer =
  try 
    let result = parserer lexer lexbuf in
    result
  with Parsing.Parse_error ->
    print_string "buf: "; print_string lexbuf.Lexing.lex_buffer;
    print_string "\n";
    print_string "current: "; print_int lexbuf.Lexing.lex_curr_pos;
    print_string "\n";
    raise Parsing.Parse_error


(* marche pas ca neuneu *)
(*
let getDoubleParser parserer lexer string = 
  let lexbuf1 = Lexing.from_string string in
  let chan = open_in string in
  let lexbuf2 = Lexing.from_channel chan in
  (parserCommon lexbuf1 parserer lexer  , parserCommon lexbuf2 parserer lexer )
*)

let getDoubleParser parserer lexer = 
  (
   (function string ->
     let lexbuf1 = Lexing.from_string string in
     parserCommon lexbuf1 parserer lexer
   ),
   (function string ->
     let chan = open_in string in
     let lexbuf2 = Lexing.from_channel chan in
     parserCommon lexbuf2 parserer lexer
   ))


(*****************************************************************************)
(* parser combinators *)
(*****************************************************************************)

(* cf parser_combinators.ml
 * 
 * Could also use ocaml stream. but not backtrack and forced to do LL, 
 * so combinators are better.
 * 
 *)


(*****************************************************************************)
(* Parser related (cocci) *)
(*****************************************************************************)

type parse_info = {
    str: string;
    charpos: int;

    line: int;
    column: int;
    file: filename;
  } 
  (* with sexp *)

let fake_parse_info = { 
  charpos = -1; str = "";
  line = -1; column = -1; file = "";
}

let string_of_parse_info x = 
  spf "%s at %s:%d:%d" x.str x.file x.line x.column
let string_of_parse_info_bis x = 
  spf "%s:%d:%d" x.file x.line x.column

let (info_from_charpos2: int -> filename -> (int * int * string)) = 
 fun charpos filename ->

  (* Currently lexing.ml does not handle the line number position.
   * Even if there is some fields in the lexing structure, they are not 
   * maintained by the lexing engine :( So the following code does not work:
   *   let pos = Lexing.lexeme_end_p lexbuf in 
   *   sprintf "at file %s, line %d, char %d" pos.pos_fname pos.pos_lnum  
   *      (pos.pos_cnum - pos.pos_bol) in 
   * Hence this function to overcome the previous limitation.
   *)
  let chan = open_in filename in
  let linen  = ref 0 in
  let posl   = ref 0 in
  let rec charpos_to_pos_aux last_valid =
    let s =
      try Some (input_line chan)
      with End_of_file when charpos =|= last_valid -> None in
    incr linen;
    match s with
      Some s ->
        let s = s ^ "\n" in
        if (!posl + slength s > charpos)
        then begin
          close_in chan;
          (!linen, charpos - !posl, s)
        end
        else begin
          posl := !posl + slength s;
          charpos_to_pos_aux !posl;
        end
    | None -> (!linen, charpos - !posl, "\n")
  in 
  let res = charpos_to_pos_aux 0 in
  close_in chan;
  res

let info_from_charpos a b = 
  profile_code "Common.info_from_charpos" (fun () -> info_from_charpos2 a b)



let full_charpos_to_pos2 = fun filename ->

  let size = (filesize filename + 2) in

    let arr = Array.create size  (0,0) in

    let chan = open_in filename in

    let charpos   = ref 0 in
    let line  = ref 0 in

    let rec full_charpos_to_pos_aux () =
     try
       let s = (input_line chan) in
       incr line;

       (* '... +1 do'  cos input_line dont return the trailing \n *)
       for i = 0 to (slength s - 1) + 1 do 
         arr.(!charpos + i) <- (!line, i);
       done;
       charpos := !charpos + slength s + 1;
       full_charpos_to_pos_aux();
       
     with End_of_file -> 
       for i = !charpos to Array.length arr - 1 do
         arr.(i) <- (!line, 0);
       done;
       ();
    in 
    begin 
      full_charpos_to_pos_aux ();
      close_in chan;
      arr
    end
let full_charpos_to_pos a =
  profile_code "Common.full_charpos_to_pos" (fun () -> full_charpos_to_pos2 a)
    
let test_charpos file = 
  full_charpos_to_pos file +> dump +> pr2



let complete_parse_info filename table x = 
  { x with 
    file = filename;
    line   = fst (table.(x.charpos));
    column = snd (table.(x.charpos));
  }



let full_charpos_to_pos_large2 = fun filename ->

  let size = (filesize filename + 2) in

    (* old: let arr = Array.create size  (0,0) in *)
    let arr1 = Bigarray.Array1.create 
      Bigarray.int Bigarray.c_layout size in
    let arr2 = Bigarray.Array1.create 
      Bigarray.int Bigarray.c_layout size in
    Bigarray.Array1.fill arr1 0;
    Bigarray.Array1.fill arr2 0;

    let chan = open_in filename in

    let charpos   = ref 0 in
    let line  = ref 0 in

    let rec full_charpos_to_pos_aux () =
     try
       let s = (input_line chan) in
       incr line;

       (* '... +1 do'  cos input_line dont return the trailing \n *)
       for i = 0 to (slength s - 1) + 1 do 
         (* old: arr.(!charpos + i) <- (!line, i); *)
         arr1.{!charpos + i} <- (!line);
         arr2.{!charpos + i} <- i;
       done;
       charpos := !charpos + slength s + 1;
       full_charpos_to_pos_aux();
       
     with End_of_file -> 
       for i = !charpos to (* old: Array.length arr *) 
         Bigarray.Array1.dim arr1 - 1 do
         (* old: arr.(i) <- (!line, 0); *)
         arr1.{i} <- !line;
         arr2.{i} <- 0;
       done;
       ();
    in 
    begin 
      full_charpos_to_pos_aux ();
      close_in chan;
      (fun i -> arr1.{i}, arr2.{i})
    end
let full_charpos_to_pos_large a =
  profile_code "Common.full_charpos_to_pos_large" 
    (fun () -> full_charpos_to_pos_large2 a)


let complete_parse_info_large filename table x = 
  { x with 
    file = filename;
    line   = fst (table (x.charpos));
    column = snd (table (x.charpos));
  }

(*---------------------------------------------------------------------------*)
(* Decalage is here to handle stuff such as cpp which include file and who 
 * can make shift.
 *)
let (error_messagebis: filename -> (string * int) -> int -> string)=
 fun filename (lexeme, lexstart) decalage ->

  let charpos = lexstart      + decalage in
  let tok = lexeme in 
  let (line, pos, linecontent) =  info_from_charpos charpos filename in
  sprintf "File \"%s\", line %d, column %d,  charpos = %d
    around = '%s', whole content = %s"
    filename line pos charpos tok (chop linecontent)

let error_message = fun filename (lexeme, lexstart) -> 
  try error_messagebis filename (lexeme, lexstart) 0    
  with
    End_of_file ->
      ("PB in Common.error_message, position " ^ i_to_s lexstart ^
       " given out of file:" ^ filename)



let error_message_short = fun filename (lexeme, lexstart) -> 
  try 
  let charpos = lexstart in
  let (line, pos, linecontent) =  info_from_charpos charpos filename in
  sprintf "File \"%s\", line %d"  filename line

  with End_of_file -> 
    begin
      ("PB in Common.error_message, position " ^ i_to_s lexstart ^
          " given out of file:" ^ filename);
    end
    


(*****************************************************************************)
(* Regression testing bis (cocci) *)
(*****************************************************************************)

(* todo: keep also size of file, compute md5sum ? cos maybe the file
 * has changed!.
 * 
 * todo: could also compute the date, or some version info of the program,
 * can record the first date when was found a OK, the last date where
 * was ok, and then first date when found fail. So the 
 * Common.Ok would have more information that would be passed
 * to the Common.Pb of date * date * date * string   peut etre.
 * 
 * todo? maybe use plain text file instead of marshalling.
 *)

type score_result = Ok | Pb of string 
 (* with sexp *)
type score = (string (* usually a filename *), score_result) Hashtbl.t
 (* with sexp *)
type score_list = (string (* usually a filename *) * score_result) list
 (* with sexp *)

let empty_score () = (Hashtbl.create 101 : score)



let regression_testing_vs newscore bestscore = 

  let newbestscore = empty_score () in

  let allres = 
    (hash_to_list newscore +> List.map fst)
      $+$
    (hash_to_list bestscore +> List.map fst)
  in
  begin 
    allres +> List.iter (fun res -> 
      match 
        optionise (fun () -> Hashtbl.find newscore res),
        optionise (fun () -> Hashtbl.find bestscore res)
      with
      | None, None -> raise Impossible
      | Some x, None -> 
          Printf.printf "new test file appeared: %s\n" res;
          Hashtbl.add newbestscore res x;
      | None, Some x -> 
          Printf.printf "old test file disappeared: %s\n" res;
      | Some newone, Some bestone -> 
          (match newone, bestone with
          | Ok, Ok -> 
              Hashtbl.add newbestscore res Ok
          | Pb x, Ok -> 
              Printf.printf
                "PBBBBBBBB: a test file does not work anymore!!! : %s\n" res;
              Printf.printf "Error : %s\n" x;
              Hashtbl.add newbestscore res Ok
          | Ok, Pb x -> 
              Printf.printf "Great: a test file now works: %s\n" res;
              Hashtbl.add newbestscore res Ok
          | Pb x, Pb y -> 
              Hashtbl.add newbestscore res (Pb x);
              if not (x =$= y)
              then begin 
                Printf.printf
                  "Semipb: still error but not same error : %s\n" res;
                Printf.printf "%s\n" (chop ("Old error: " ^ y));
                Printf.printf "New error: %s\n" x;
              end
          )
    );
    flush stdout; flush stderr;
    newbestscore
  end

let regression_testing newscore best_score_file = 

  pr2 ("regression file: "^ best_score_file);
  let (bestscore : score) = 
    if not (Sys.file_exists best_score_file)
    then write_value (empty_score()) best_score_file;
    get_value best_score_file 
  in
  let newbestscore = regression_testing_vs newscore bestscore in
  write_value newbestscore (best_score_file ^ ".old");
  write_value newbestscore best_score_file;
  ()




let string_of_score_result v = 
  match v with 
  | Ok -> "Ok" 
  | Pb s -> "Pb: " ^ s

let total_scores score = 
  let total = hash_to_list score +> List.length in
  let good  = hash_to_list score +> List.filter
    (fun (s, v) -> v =*= Ok) +> List.length in
  good, total
   

let print_total_score score = 
  pr2 "--------------------------------";
  pr2 "total score";
  pr2 "--------------------------------";
  let (good, total) = total_scores score in
  pr2 (sprintf "good = %d/%d" good total)

let print_score score = 
  score +> hash_to_list +> List.iter (fun (k, v) -> 
    pr2 (sprintf "% s --> %s" k (string_of_score_result v))
  );
  print_total_score score;
  ()


(*****************************************************************************)
(* Scope managment (cocci) *)
(*****************************************************************************)

(* could also make a function Common.make_scope_functions that return
 * the new_scope, del_scope, do_in_scope, add_env. Kind of functor :)
 *)

type ('a, 'b) scoped_env = ('a, 'b) assoc list

(*
let rec lookup_env f env = 
  match env with 
  | [] -> raise Not_found
  | []::zs -> lookup_env f zs
  | (x::xs)::zs -> 
      match f x with
      | None -> lookup_env f (xs::zs)
      | Some y -> y

let member_env_key k env = 
  try 
    let _ = lookup_env (fun (k',v) -> if k = k' then Some v else None) env in
    true
  with Not_found -> false

*)

let rec lookup_env k env = 
  match env with 
  | [] -> raise Not_found
  | []::zs -> lookup_env k zs
  | ((k',v)::xs)::zs -> 
      if k =*= k'
      then v 
      else lookup_env k (xs::zs)

let member_env_key k env = 
  match optionise (fun () -> lookup_env k env) with
  | None -> false
  | Some _ -> true


let new_scope scoped_env = scoped_env := []::!scoped_env
let del_scope scoped_env = scoped_env := List.tl !scoped_env

let do_in_new_scope scoped_env f = 
  begin
    new_scope scoped_env;
    let res = f() in
    del_scope scoped_env;
    res
  end
  
let add_in_scope scoped_env def =
  let (current, older) = uncons !scoped_env in
  scoped_env := (def::current)::older





(* note that ocaml hashtbl store also old value of a binding when add
 * add a newbinding; that's why del_scope works
 *)

type ('a, 'b) scoped_h_env = {
  scoped_h : ('a, 'b) Hashtbl.t;
  scoped_list : ('a, 'b) assoc list;
}

let empty_scoped_h_env () = {
  scoped_h = Hashtbl.create 101;
  scoped_list = [[]];
}
let clone_scoped_h_env x = 
  { scoped_h = Hashtbl.copy x.scoped_h;
    scoped_list = x.scoped_list;
  }

let rec lookup_h_env k env = 
  Hashtbl.find env.scoped_h k 

let member_h_env_key k env = 
  match optionise (fun () -> lookup_h_env k env) with
  | None -> false
  | Some _ -> true


let new_scope_h scoped_env = 
  scoped_env := {!scoped_env with scoped_list = []::!scoped_env.scoped_list}
let del_scope_h scoped_env = 
  begin
    List.hd !scoped_env.scoped_list +> List.iter (fun (k, v) ->
      Hashtbl.remove !scoped_env.scoped_h k
    );
    scoped_env := {!scoped_env with scoped_list = 
        List.tl !scoped_env.scoped_list
    }
  end

let do_in_new_scope_h scoped_env f = 
  begin
    new_scope_h scoped_env;
    let res = f() in
    del_scope_h scoped_env;
    res
  end

(*  
let add_in_scope scoped_env def =
  let (current, older) = uncons !scoped_env in
  scoped_env := (def::current)::older
*)

let add_in_scope_h x (k,v) = 
  begin
    Hashtbl.add !x.scoped_h k v;
    x := { !x with scoped_list = 
        ((k,v)::(List.hd !x.scoped_list))::(List.tl !x.scoped_list);
    };
  end

(*****************************************************************************)
(* Terminal *)
(*****************************************************************************)

(* let ansi_terminal = ref true *)

let (_execute_and_show_progress_func:  (int (* length *) -> ((unit -> unit) -> unit) -> unit) ref) 
 = ref 
  (fun a b -> 
    failwith "no execute  yet, have you included common_extra.cmo?"
  )

 

let execute_and_show_progress len f =
    !_execute_and_show_progress_func len f


(* now in common_extra.ml:
 * let execute_and_show_progress len f = ...
 *)

(*****************************************************************************)
(* Random *)
(*****************************************************************************)

let _init_random = Random.self_init ()
(*
let random_insert i l = 
    let p = Random.int (length l +1)
    in let rec insert i p l = 
      if (p = 0) then i::l else (hd l)::insert i (p-1) (tl l)
    in insert i p l

let rec randomize_list = function 
  []  -> []
  | a::l -> random_insert a (randomize_list l)
*)
let random_list xs = 
  List.nth xs (Random.int (length xs))                                           

(* todo_opti: use fisher/yates algorithm.
 * ref: http://en.wikipedia.org/wiki/Knuth_shuffle 
 * 
 * public static void shuffle (int[] array) 
 * {
 *  Random rng = new Random ();
 *  int n = array.length;
 *  while (--n > 0) 
 *  {
 *    int k = rng.nextInt(n + 1);  // 0 <= k <= n (!)
 *    int temp = array[n];
 *    array[n] = array[k];
 *    array[k] = temp;
 *   }
 * }

 *)
let randomize_list xs = 
  let permut = permutation xs in
  random_list permut



let random_subset_of_list num xs =
  let array = Array.of_list xs in
  let len = Array.length array in
    
  let h = Hashtbl.create 101 in 
  let cnt = ref num in
  while !cnt > 0 do
    let x = Random.int len in
    if not (Hashtbl.mem h (array.(x))) (* bugfix2: not just x :) *)
    then begin
      Hashtbl.add h (array.(x)) true; (* bugfix1: not just x :) *)
      decr cnt;
    end
  done;
  let objs = hash_to_list h +> List.map fst in
  objs



(*****************************************************************************)
(* Flags and actions *)
(*****************************************************************************)

(* I put it inside a func as it can help to give a chance to 
 * change the globals before getting the options as some 
 * options sometimes may want to show the default value.
 *)
let cmdline_flags_devel () = 
  [
    "-debugger",         Arg.Set debugger , 
    "   option to set if launched inside ocamldebug";
    "-profile",          Arg.Unit (fun () -> profile := PALL), 
    "   gather timing information about important functions";
  ]
let cmdline_flags_verbose () =
  [
    "-verbose_level",  Arg.Set_int verbose_level, 
    " <int> guess what";
    "-disable_pr2_once",     Arg.Set disable_pr2_once, 
    "   to print more messages";
    "-show_trace_profile",          Arg.Set show_trace_profile, 
    "   show trace";
  ]

let cmdline_flags_other () = 
  [
    "-nocheck_stack",      Arg.Clear check_stack, 
    " ";
    "-batch_mode", Arg.Set _batch_mode,
    " no interactivity"
  ]

(* potentially other common options but not yet integrated:
   
  "-timeout",        Arg.Set_int timeout, 
  "  <sec> interrupt LFS or buggy external plugins";

  (* can't be factorized because of the $ cvs stuff, we want the date
   * of the main.ml file, not common.ml
   *)
  "-version",   Arg.Unit (fun () -> 
    pr2 "version: _dollar_Date: 2008/06/14 00:54:22 _dollar_";
    raise (Common.UnixExit 0)
    ), 
  "   guess what";

  "-shorthelp", Arg.Unit (fun () -> 
    !short_usage_func();
    raise (Common.UnixExit 0)
  ), 
  "    see short list of options";
  "-longhelp", Arg.Unit (fun () -> 
    !long_usage_func();
    raise (Common.UnixExit 0)
    ), 
  "-help", Arg.Unit (fun () -> 
    !long_usage_func();
    raise (Common.UnixExit 0)
  ),
  " ";
  "--help", Arg.Unit (fun () -> 
    !long_usage_func();
    raise (Common.UnixExit 0)
  ),
  " ";

*)

let cmdline_actions () = 
  [
    "-test_check_stack", "  <limit>",
    mk_action_1_arg test_check_stack_size;
  ]


(*****************************************************************************)
(* Postlude *)
(*****************************************************************************)
(* stuff put here cos of of forward definition limitation of ocaml *)

    
(* Infix trick, seen in jane street lib and harrop's code, and maybe in GMP *)
module Infix = struct
  let (+>) = (+>)
  let (==~) = (==~)
  let (=~) = (=~)
end


let main_boilerplate f = 
  if not (!Sys.interactive) then 
    exn_to_real_unixexit (fun () -> 

      Sys.set_signal Sys.sigint (Sys.Signal_handle   (fun _ -> 
        pr2 "C-c intercepted, will do some cleaning before exiting";
        (* But if do some try ... with e -> and if do not reraise the exn,
         * the bubble never goes at top and so I cant really C-c.
         * 
         * A solution would be to not raise, but do the erase_temp_file in the
         * syshandler, here, and then exit.
         * The current solution is to not do some wild  try ... with e
         * by having in the exn handler a case: UnixExit x -> raise ... | e ->
         *)
        Sys.set_signal Sys.sigint Sys.Signal_default;
        raise (UnixExit (-1))
      ));

      (* The finalize below makes it tedious to go back to exn when use
       * 'back' in the debugger. Hence this special case. But the 
       * Common.debugger will be set in main(), so too late, so 
       * have to be quicker
       *)
      if Sys.argv +> Array.to_list +> List.exists (fun x -> x =$= "-debugger")
      then debugger := true;

      finalize          (fun ()-> 
        pp_do_in_zero_box (fun () -> 
          f(); (* <---- here it is *)
        ))
       (fun()-> 
         if !profile <> PNONE 
         then pr2 (profile_diagnostic ());
         erase_temp_files ();
       )
    )
(* let _ = if not !Sys.interactive then (main ()) *)


(* based on code found in cameleon from maxence guesdon *)
let md5sum_of_string s =
  let com = spf "echo %s | md5sum | cut -d\" \" -f 1"
      (Filename.quote s)
  in
  match cmd_to_list com with
  | [s] -> 
      (*pr2 s;*)
      s
  | _ -> failwith "md5sum_of_string wrong output"



let with_pr2_to_string f = 
  let file = new_temp_file "pr2" "out" in
  redirect_stdout_stderr file f;
  cat file

(* julia: convert something printed using format to print into a string *)
let format_to_string f =
  let (nm,o) = Filename.open_temp_file "format_to_s" ".out" in
  Format.set_formatter_out_channel o;
  let _ = f() in
  Format.print_newline();
  Format.print_flush();
  Format.set_formatter_out_channel stdout;
  close_out o;
  let i = open_in nm in
  let lines = ref [] in
  let rec loop _ =
    let cur = input_line i in
    lines := cur :: !lines;
    loop() in
  (try loop() with End_of_file -> ());
  close_in i;
  command2 ("rm -f " ^ nm);
  String.concat "\n" (List.rev !lines)



(*****************************************************************************)
(* Misc/test *)
(*****************************************************************************)

let (generic_print: 'a -> string -> string) = fun v typ -> 
  write_value v "/tmp/generic_print";
  command2 
   ("printf 'let (v:" ^ typ ^ ")= Common.get_value \"/tmp/generic_print\" " ^
     " in v;;' " ^
     " | calc.top > /tmp/result_generic_print"); 
   cat "/tmp/result_generic_print" 
   +> drop_while (fun e -> not (e =~ "^#.*")) +> tail
   +> unlines
   +> (fun s -> 
       if (s =~ ".*= \\(.+\\)") 
       then matched1 s 
       else "error in generic_print, not good format:" ^ s)
   
(* let main () = pr (generic_print [1;2;3;4] "int list") *)

class ['a] olist (ys: 'a list) =
  object(o)
    val xs = ys
    method view = xs
(*    method fold f a = List.fold_left f a xs *)
    method fold : 'b. ('b -> 'a -> 'b) -> 'b -> 'b = 
      fun f accu -> List.fold_left f accu xs
  end


(* let _ = write_value ((new setb[])#add 1) "/tmp/test" *)
let typing_sux_test () = 
   let x = Obj.magic [1;2;3] in
   let f1 xs = List.iter print_int xs in
   let f2 xs = List.iter print_string xs in
   (f1 x; f2 x)

(* let (test: 'a osetb -> 'a ocollection) = fun o -> (o :> 'a ocollection) *)
(* let _ = test (new osetb (Setb.empty)) *)