Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
5938 lines (4634 sloc) 162 KB
(* 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 pr2 s =
prerr_string !_prefix_pr;
do_n !_tab_level_print (fun () -> prerr_string " ");
prerr_string s;
prerr_string "\n";
flush stderr
let pr2_no_nl s =
prerr_string !_prefix_pr;
do_n !_tab_level_print (fun () -> prerr_string " ");
prerr_string s;
flush stderr
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 pr2_once s =
if !disable_pr2_once then pr2 s
else
if not (Hashtbl.mem _already_printed s)
then begin
Hashtbl.add _already_printed s true;
pr2 ("(ONCE) " ^ s);
end
(* ---------------------------------------------------------------------- *)
(* 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
(* ---------------------------------------------------------------------- *)
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
(* julia: convert something printed using format to print into a string *)
let format_to_string f =
let o = open_out "/tmp/out" in
Format.set_formatter_out_channel o;
let _ = f() in
Format.print_flush();
Format.set_formatter_out_channel stdout;
close_out o;
let i = open_in "/tmp/out" 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;
String.concat "\n" (List.rev !lines)
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
)
(*****************************************************************************)
(* 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 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/"
)
+> 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])]))<