Release coccinelle-0.2.3rc1

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

(* Yoann Padioleau
 *
 * Copyright (C) 2010 INRIA, University of Copenhagen DIKU
 * 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 print_to_stderr = ref true

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

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


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 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
      Unix.dup2 descr Unix.stdout;
      flush stdout;
      let res = f() in
	flush stdout;
	Unix.dup2 saveout Unix.stdout;
	close_out chan;
	res
  end

let redirect_stdout_opt optfile f =
  match optfile with
    | None -> f()
    | Some outfile -> redirect_stdout outfile f

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: processing took %7.1fs: %s" (t' -. t) 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)