3 * Copyright (C) 2010 INRIA, University of Copenhagen DIKU
4 * Copyright (C) 1998-2009 Yoann Padioleau
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Lesser General Public License
8 * version 2.1 as published by the Free Software Foundation, with the
9 * special exception on linking described in file license.txt.
11 * This library is distributed in the hope that it will be useful, but
12 * WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file
14 * license.txt for more details.
17 (*****************************************************************************)
19 (*****************************************************************************)
23 (* ---------------------------------------------------------------------- *)
24 (* Maybe could split common.ml and use include tricks as in ofullcommon.ml or
25 * Jane Street core lib. But then harder to bundle simple scripts like my
26 * make_full_linux_kernel.ml because would then need to pass all the files
27 * either to ocamlc or either to some #load. Also as the code of many
28 * functions depends on other functions from this common, it would
29 * be tedious to add those dependencies. Here simpler (have just the
30 * pb of the Prelude, but it's a small problem).
32 * pixel means code from Pascal Rigaux
33 * julia means code from Julia Lawall
35 (* ---------------------------------------------------------------------- *)
37 (*****************************************************************************)
39 (*****************************************************************************)
42 * - Pervasives, of course
52 * - =, <=, max min, abs, ...
53 * - List.rev, List.mem, List.partition,
54 * - List.fold*, List.concat, ...
55 * - Str.global_replace
56 * - Filename.is_relative
57 * - String.uppercase, String.lowercase
60 * The Format library allows to hide passing an indent_level variable.
61 * You use as usual the print_string function except that there is
62 * this automatic indent_level variable handled for you (and maybe
63 * more services). src: julia in coccinelle unparse_cocci.
67 * - ocamlgtk, and gtksourceview
78 * Many functions in this file were inspired by Haskell or Lisp librairies.
81 (*****************************************************************************)
83 (*****************************************************************************)
85 (* The following functions should be in their respective sections but
86 * because some functions in some sections use functions in other
87 * sections, and because I don't want to take care of the order of
88 * those sections, of those dependencies, I put the functions causing
89 * dependency problem here. C is better than caml on this with the
90 * ability to declare prototype, enabling some form of forward
97 exception UnixExit
of int
99 let rec (do_n
: int -> (unit -> unit) -> unit) = fun i f
->
100 if i
= 0 then () else (f
(); do_n
(i
-1) f
)
101 let rec (foldn
: ('a
-> int -> 'a
) -> 'a
-> int -> 'a
) = fun f acc i
->
102 if i
= 0 then acc
else foldn f
(f acc i
) (i
-1)
104 let sum_int = List.fold_left
(+) 0
106 (* could really call it 'for' :) *)
107 let fold_left_with_index f acc
=
108 let rec fold_lwi_aux acc n
= function
110 | x
::xs
-> fold_lwi_aux (f acc x n
) (n
+1) xs
111 in fold_lwi_aux acc
0
117 | (_
,[]) -> failwith
"drop: not enough"
118 | (n
,x
::xs
) -> drop (n
-1) xs
120 let rec enum_orig x n
= if x
= n
then [n
] else x
::enum_orig (x
+1) n
124 then failwith
(Printf.sprintf
"bad values in enum, expect %d <= %d" x n
);
125 let rec enum_aux acc x n
=
126 if x
= n
then n
::acc
else enum_aux (x
::acc
) (x
+1) n
128 List.rev
(enum_aux [] x n
)
133 | (_
,[]) -> failwith
"take: not enough"
134 | (n
,x
::xs
) -> x
::take (n
-1) xs
137 let last_n n l
= List.rev
(take n
(List.rev l
))
138 let last l
= List.hd
(last_n 1 l
)
141 let (list_of_string
: string -> char list
) = function
143 | s
-> (enum 0 ((String.length s
) - 1) +> List.map
(String.get s
))
145 let (lines
: string -> string list
) = fun s
->
146 let rec lines_aux = function
148 | [x
] -> if x
= "" then [] else [x
]
152 Str.split_delim
(Str.regexp
"\n") s
+> lines_aux
158 let null xs
= match xs
with [] -> true | _
-> false
163 let debugger = ref false
165 let unwind_protect f cleanup
=
166 if !debugger then f
() else
168 with e
-> begin cleanup e
; raise e
end
170 let finalize f cleanup
=
171 if !debugger then f
() else
180 let command2 s
= ignore
(Sys.command s
)
183 let (matched
: int -> string -> string) = fun i s
->
184 Str.matched_group i s
186 let matched1 = fun s
-> matched
1 s
187 let matched2 = fun s
-> (matched
1 s
, matched
2 s
)
188 let matched3 = fun s
-> (matched
1 s
, matched
2 s
, matched
3 s
)
189 let matched4 = fun s
-> (matched
1 s
, matched
2 s
, matched
3 s
, matched
4 s
)
190 let matched5 = fun s
-> (matched
1 s
, matched
2 s
, matched
3 s
, matched
4 s
, matched
5 s
)
191 let matched6 = fun s
-> (matched
1 s
, matched
2 s
, matched
3 s
, matched
4 s
, matched
5 s
, matched
6 s
)
192 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
)
194 let (with_open_stringbuf
: (((string -> unit) * Buffer.t
) -> unit) -> string) =
196 let buf = Buffer.create
1000 in
197 let pr s
= Buffer.add_string
buf (s ^
"\n") in
202 let foldl1 p
= function x
::xs
-> List.fold_left p x xs
| _
-> failwith
"foldl1"
204 (*****************************************************************************)
205 (* Debugging/logging *)
206 (*****************************************************************************)
208 (* I used this in coccinelle where the huge logging of stuff ask for
209 * a more organized solution that use more visual indentation hints.
211 * todo? could maybe use log4j instead ? or use Format module more
215 let _tab_level_print = ref 0
219 let _prefix_pr = ref ""
222 _tab_level_print := !_tab_level_print + _tab_indent;
224 (fun () -> _tab_level_print := !_tab_level_print - _tab_indent;)
228 print_string
!_prefix_pr;
229 do_n
!_tab_level_print (fun () -> print_string
" ");
235 print_string
!_prefix_pr;
236 do_n
!_tab_level_print (fun () -> print_string
" ");
245 let _chan_pr2 = ref (None
: out_channel
option)
247 let out_chan_pr2 ?
(newline
=true) s
=
248 match !_chan_pr2 with
251 output_string chan
(s ^
(if newline
then "\n" else ""));
254 let print_to_stderr = ref true
260 prerr_string
!_prefix_pr;
261 do_n
!_tab_level_print (fun () -> prerr_string
" ");
273 prerr_string
!_prefix_pr;
274 do_n
!_tab_level_print (fun () -> prerr_string
" ");
277 out_chan_pr2 ~newline
:false s
;
282 let pr_xxxxxxxxxxxxxxxxx () =
283 pr "-----------------------------------------------------------------------"
285 let pr2_xxxxxxxxxxxxxxxxx () =
286 pr2 "-----------------------------------------------------------------------"
289 let reset_pr_indent () =
290 _tab_level_print := 0
293 * let pr s = (print_string s; print_string "\n"; flush stdout)
294 * let pr2 s = (prerr_string s; prerr_string "\n"; flush stderr)
297 (* ---------------------------------------------------------------------- *)
299 (* I can not use the _xxx ref tech that I use for common_extra.ml here because
300 * ocaml don't like the polymorphism of Dumper mixed with refs.
302 * let (_dump_func : ('a -> string) ref) = ref
303 * (fun x -> failwith "no dump yet, have you included common_extra.cmo?")
304 * let (dump : 'a -> string) = fun x ->
307 * So I have included directly dumper.ml in common.ml. It's more practical
308 * when want to give script that use my common.ml, I just have to give
312 (* start of dumper.ml *)
314 (* Dump an OCaml value into a printable string.
315 * By Richard W.M. Jones (rich@annexia.org).
316 * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp
323 string_of_int
(magic r
: int)
325 let rec get_fields acc
= function
327 | n
-> let n = n-1 in get_fields (field r
n :: acc
) n
331 if (magic r
: int) = 0 then true (* [] *)
334 let s = size r
and t
= tag r
in
335 if t
= 0 && s = 2 then is_list (field r
1) (* h :: t *)
341 else let h = field r
0 and t
= get_list (field r
1) in h :: t
344 (* XXX In future, print the address of value 'r'. Not possible in
345 * pure OCaml at the moment.
350 let s = size r
and t
= tag r
in
352 (* From the tag, determine the type of block. *)
353 if is_list r
then ( (* List. *)
354 let fields = get_list r
in
355 "[" ^
String.concat
"; " (List.map
dump fields) ^
"]"
357 else if t
= 0 then ( (* Tuple, array, record. *)
358 let fields = get_fields [] s in
359 "(" ^
String.concat
", " (List.map
dump fields) ^
")"
362 (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not
363 * clear if very large constructed values could have the same
365 else if t
= lazy_tag
then opaque "lazy"
366 else if t
= closure_tag
then opaque "closure"
367 else if t
= object_tag
then ( (* Object. *)
368 let fields = get_fields [] s in
369 let clasz, id
, slots
=
370 match fields with h::h'
::t
-> h, h'
, t
| _
-> assert false in
371 (* No information on decoding the class (first field). So just print
372 * out the ID and the slots.
374 "Object #" ^
dump id ^
375 " (" ^
String.concat
", " (List.map
dump slots
) ^
")"
377 else if t
= infix_tag
then opaque "infix"
378 else if t
= forward_tag
then opaque "forward"
380 else if t
< no_scan_tag
then ( (* Constructed value. *)
381 let fields = get_fields [] s in
382 "Tag" ^ string_of_int t ^
383 " (" ^
String.concat
", " (List.map
dump fields) ^
")"
385 else if t
= string_tag
then (
386 "\"" ^
String.escaped
(magic r
: string) ^
"\""
388 else if t
= double_tag
then (
389 string_of_float
(magic r
: float)
391 else if t
= abstract_tag
then opaque "abstract"
392 else if t
= custom_tag
then opaque "custom"
393 else if t
= final_tag
then opaque "final"
394 else failwith
("dump: impossible tag (" ^ string_of_int t ^
")")
397 let dump v
= dump (repr v
)
399 (* end of dumper.ml *)
402 let (dump : 'a -> string) = fun x ->
407 (* ---------------------------------------------------------------------- *)
408 let pr2_gen x
= pr2 (dump x
)
412 (* ---------------------------------------------------------------------- *)
415 let _already_printed = Hashtbl.create
101
416 let disable_pr2_once = ref false
419 if !disable_pr2_once then pr2 s
421 if not
(Hashtbl.mem
_already_printed s)
423 Hashtbl.add
_already_printed s true;
427 let pr2_once s = xxx_once pr2 s
429 let clear_pr2_once _
= Hashtbl.clear
_already_printed
431 (* ---------------------------------------------------------------------- *)
432 let mk_pr2_wrappers aref
=
437 (* just to the log file *)
444 xxx_once out_chan_pr2 s
448 (* ---------------------------------------------------------------------- *)
449 (* could also be in File section *)
451 let redirect_stdout file f
=
453 let chan = open_out file
in
454 let descr = Unix.descr_of_out_channel
chan in
456 let saveout = Unix.dup
Unix.stdout
in
457 Unix.dup2
descr Unix.stdout
;
461 Unix.dup2
saveout Unix.stdout
;
466 let redirect_stdout_opt optfile f
=
469 | Some outfile
-> redirect_stdout outfile f
471 let redirect_stdout_stderr file f
=
473 let chan = open_out file
in
474 let descr = Unix.descr_of_out_channel
chan in
476 let saveout = Unix.dup
Unix.stdout
in
477 let saveerr = Unix.dup
Unix.stderr
in
478 Unix.dup2
descr Unix.stdout
;
479 Unix.dup2
descr Unix.stderr
;
480 flush stdout
; flush stderr
;
482 flush stdout
; flush stderr
;
483 Unix.dup2
saveout Unix.stdout
;
484 Unix.dup2
saveerr Unix.stderr
;
488 let redirect_stdin file f
=
490 let chan = open_in file
in
491 let descr = Unix.descr_of_in_channel
chan in
493 let savein = Unix.dup
Unix.stdin
in
494 Unix.dup2
descr Unix.stdin
;
496 Unix.dup2
savein Unix.stdin
;
501 let redirect_stdin_opt optfile f
=
504 | Some infile
-> redirect_stdin infile f
508 let with_pr2_to_string f =
512 (* ---------------------------------------------------------------------- *)
516 (* cf common.mli, fprintf, printf, eprintf, sprintf.
517 * also what is this ?
518 * val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a
519 * val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
529 (* ---------------------------------------------------------------------- *)
531 let _chan = ref stderr
532 let start_log_file () =
533 let filename = (spf "/tmp/debugml%d:%d" (Unix.getuid
()) (Unix.getpid
())) in
534 pr2 (spf "now using %s for logging" filename);
535 _chan := open_out
filename
538 let dolog s = output_string
!_chan (s ^
"\n"); flush
!_chan
540 let verbose_level = ref 1
541 let log s = if !verbose_level >= 1 then dolog s
542 let log2 s = if !verbose_level >= 2 then dolog s
543 let log3 s = if !verbose_level >= 3 then dolog s
544 let log4 s = if !verbose_level >= 4 then dolog s
546 let if_log f
= if !verbose_level >= 1 then f
()
547 let if_log2 f
= if !verbose_level >= 2 then f
()
548 let if_log3 f
= if !verbose_level >= 3 then f
()
549 let if_log4 f
= if !verbose_level >= 4 then f
()
551 (* ---------------------------------------------------------------------- *)
553 let pause () = (pr2 "pause: type return"; ignore
(read_line
()))
555 (* src: from getopt from frish *)
556 let bip () = Printf.printf
"\007"; flush stdout
557 let wait () = Unix.sleep
1
559 (* was used by fix_caml *)
560 let _trace_var = ref 0
561 let add_var() = incr
_trace_var
562 let dec_var() = decr
_trace_var
563 let get_var() = !_trace_var
565 let (print_n
: int -> string -> unit) = fun i
s ->
566 do_n i
(fun () -> print_string
s)
567 let (printerr_n
: int -> string -> unit) = fun i
s ->
568 do_n i
(fun () -> prerr_string
s)
570 let _debug = ref true
571 let debugon () = _debug := true
572 let debugoff () = _debug := false
573 let debug f
= if !_debug then f
() else ()
578 * let debugger = ref false
582 (*****************************************************************************)
584 (*****************************************************************************)
587 command2("grep VmData /proc/" ^ string_of_int
(Unix.getpid
()) ^
"/status")
590 let stat = Gc.stat() in
591 let conv_mo x
= x
* 4 / 1000000 in
592 Printf.sprintf
"maximal = %d Mo\n" (conv_mo stat.Gc.top_heap_words
) ^
593 Printf.sprintf
"current = %d Mo\n" (conv_mo stat.Gc.heap_words
) ^
594 Printf.sprintf
"lives = %d Mo\n" (conv_mo stat.Gc.live_words
)
595 (* Printf.printf "fragments = %d Mo\n" (conv_mo stat.Gc.fragments); *)
598 "sys:" ^
(string_of_float
(Sys.time
())) ^
" seconds" ^
600 (let tm = Unix.time
() +> Unix.gmtime
in
601 tm.Unix.tm_min
+> string_of_int ^
" min:" ^
602 tm.Unix.tm_sec
+> string_of_int ^
".00 seconds")
610 let count1 () = incr
_count1
611 let count2 () = incr
_count2
612 let count3 () = incr
_count3
613 let count4 () = incr
_count4
614 let count5 () = incr
_count5
616 let profile_diagnostic_basic () =
618 "count1 = %d\ncount2 = %d\ncount3 = %d\ncount4 = %d\ncount5 = %d\n"
619 !_count1 !_count2 !_count3 !_count4 !_count5
624 (* let _ = Timing () in *)
626 (* let _ = Timing () in *)
629 (* ---------------------------------------------------------------------- *)
631 type prof
= PALL
| PNONE
| PSOME
of string list
632 let profile = ref PNONE
633 let show_trace_profile = ref false
635 let check_profile category
=
639 | PSOME l
-> List.mem category l
641 let _profile_table = ref (Hashtbl.create
100)
643 let adjust_profile_entry category difftime
=
644 let (xtime
, xcount
) =
645 (try Hashtbl.find
!_profile_table category
647 let xtime = ref 0.0 in
648 let xcount = ref 0 in
649 Hashtbl.add
!_profile_table category
(xtime, xcount);
652 xtime := !xtime +. difftime
;
653 xcount := !xcount + 1;
656 let profile_start category
= failwith
"todo"
657 let profile_end category
= failwith
"todo"
660 (* subtil: don't forget to give all argumens to f, otherwise partial app
661 * and will profile nothing.
663 * todo: try also detect when complexity augment each time, so can
664 * detect the situation for a function gets worse and worse ?
666 let profile_code category f
=
667 if not
(check_profile category
)
670 if !show_trace_profile then pr2 (spf "p: %s" category
);
671 let t = Unix.gettimeofday
() in
674 with Timeout
-> None
, "*"
676 let category = prefix ^
category in (* add a '*' to indicate timeout func *)
677 let t'
= Unix.gettimeofday
() in
679 adjust_profile_entry category (t'
-. t);
682 | None
-> raise Timeout
687 let _is_in_exclusif = ref (None
: string option)
689 let profile_code_exclusif category f
=
690 if not
(check_profile category)
694 match !_is_in_exclusif with
696 failwith
(spf "profile_code_exclusif: %s but already in %s " category s);
698 _is_in_exclusif := (Some
category);
701 profile_code category f
704 _is_in_exclusif := None
709 let profile_code_inside_exclusif_ok category f
=
713 (* todo: also put % ? also add % to see if coherent numbers *)
714 let profile_diagnostic () =
715 if !profile = PNONE
then "" else
717 Hashtbl.fold
(fun k v acc
-> (k
,v
)::acc
) !_profile_table []
718 +> List.sort
(fun (k1
, (t1
,n1
)) (k2
, (t2
,n2
)) -> compare t2 t1
)
720 with_open_stringbuf
(fun (pr,_) ->
721 pr "---------------------";
722 pr "profiling result";
723 pr "---------------------";
724 xs +> List.iter
(fun (k
, (t,n)) ->
725 pr (sprintf
"%-40s : %10.3f sec %10d count" k
!t !n)
731 let report_if_take_time timethreshold
s f
=
732 let t = Unix.gettimeofday
() in
734 let t'
= Unix.gettimeofday
() in
735 if (t'
-. t > float_of_int timethreshold
)
736 then pr2 (sprintf
"Note: processing took %7.1fs: %s" (t'
-. t) s);
739 let profile_code2 category f
=
740 profile_code category (fun () ->
742 then pr2 ("starting: " ^
category);
743 let t = Unix.gettimeofday
() in
745 let t'
= Unix.gettimeofday
() in
747 then pr2 (spf "ending: %s, %fs" category (t'
-. t));
752 (*****************************************************************************)
754 (*****************************************************************************)
755 let example b
= assert b
757 let _ex1 = example (enum 1 4 = [1;2;3;4])
759 let assert_equal a b
=
761 then failwith
("assert_equal: those 2 values are not equal:\n\t" ^
762 (dump a
) ^
"\n\t" ^
(dump b
) ^
"\n")
764 let (example2
: string -> bool -> unit) = fun s b
->
765 try assert b
with x -> failwith
s
767 (*-------------------------------------------------------------------*)
768 let _list_bool = ref []
770 let (example3
: string -> bool -> unit) = fun s b
->
771 _list_bool := (s,b
)::(!_list_bool)
773 (* could introduce a fun () otherwise the calculus is made at compile time
774 * and this can be long. This would require to redefine test_all.
775 * let (example3: string -> (unit -> bool) -> unit) = fun s func ->
776 * _list_bool := (s,func):: (!_list_bool)
778 * I would like to do as a func that take 2 terms, and make an = over it
779 * avoid to add this ugly fun (), but pb of type, cant do that :(
783 let (test_all
: unit -> unit) = fun () ->
784 List.iter
(fun (s, b
) ->
785 Printf.printf
"%s: %s\n" s (if b
then "passed" else "failed")
788 let (test
: string -> unit) = fun s ->
789 Printf.printf
"%s: %s\n" s
790 (if (List.assoc
s (!_list_bool)) then "passed" else "failed")
792 let _ex = example3
"++" ([1;2]++[3;4;5] = [1;2;3;4;5])
794 (*-------------------------------------------------------------------*)
795 (* Regression testing *)
796 (*-------------------------------------------------------------------*)
798 (* cf end of file. It uses too many other common functions so I
799 * have put the code at the end of this file.
804 (* todo? take code from julien signoles in calendar-2.0.2/tests *)
807 (* Generic functions used in the tests. *)
809 val reset
: unit -> unit
810 val nb_ok
: unit -> int
811 val nb_bug
: unit -> int
812 val test
: bool -> string -> unit
813 val test_exn
: 'a
Lazy.t -> string -> unit
817 let ok () = incr
ok_ref
818 let nb_ok () = !ok_ref
821 let bug () = incr
bug_ref
822 let nb_bug () = !bug_ref
829 if x then ok () else begin Printf.printf
"%s\n" s; bug () end;;
833 ignore
(Lazy.force
x);
834 Printf.printf
"%s\n" s;
841 (*****************************************************************************)
842 (* Quickcheck like (sfl) *)
843 (*****************************************************************************)
845 (* Better than quickcheck, cos cant do a test_all_prop in haskell cos
846 * prop were functions, whereas here we have not prop_Unix x = ... but
849 * How to do without overloading ? objet ? can pass a generator as a
850 * parameter, mais lourd, prefer automatic inferring of the
851 * generator? But at the same time quickcheck does not do better cos
852 * we must explictly type the property. So between a
853 * prop_unit:: [Int] -> [Int] -> bool ...
854 * prop_unit x = reverse [x] == [x]
856 * let _ = laws "unit" (fun x -> reverse [x] = [x]) (listg intg)
857 * there is no real differences.
859 * Yes I define typeg generator but quickcheck too, he must define
860 * class instance. I emulate the context Gen a => Gen [a] by making
861 * listg take as a param a type generator. Moreover I have not the pb of
862 * monad. I can do random independently, so my code is more simple
863 * I think than the haskell code of quickcheck.
865 * update: apparently Jane Street have copied some of my code for their
866 * Ounit_util.ml and quichcheck.ml in their Core library :)
869 (*---------------------------------------------------------------------------*)
871 (*---------------------------------------------------------------------------*)
872 type 'a gen
= unit -> 'a
874 let (ig
: int gen
) = fun () ->
876 let (lg
: ('a gen
) -> ('a list
) gen
) = fun gen
() ->
877 foldn
(fun acc i
-> (gen
())::acc
) [] (Random.int 10)
878 let (pg
: ('a gen
) -> ('b gen
) -> ('a
* 'b
) gen
) = fun gen1 gen2
() ->
881 let (ng
: (string gen
)) = fun () ->
882 "a" ^
(string_of_int
(ig
()))
884 let (oneofl
: ('a list
) -> 'a gen
) = fun xs () ->
885 List.nth
xs (Random.int (List.length
xs))
886 (* let oneofl l = oneof (List.map always l) *)
888 let (oneof
: (('a gen
) list
) -> 'a gen
) = fun xs ->
889 List.nth
xs (Random.int (List.length
xs))
891 let (always
: 'a
-> 'a gen
) = fun e
() -> e
893 let (frequency
: ((int * ('a gen
)) list
) -> 'a gen
) = fun xs ->
894 let sums = sum_int (List.map fst
xs) in
895 let i = Random.int sums in
896 let rec freq_aux acc
= function
897 | (x,g
)::xs -> if i < acc
+x then g
else freq_aux (acc
+x) xs
898 | _ -> failwith
"frequency"
901 let frequencyl l
= frequency
(List.map
(fun (i,e
) -> (i,always e
)) l
)
904 let b = oneof [always true; always false] ()
905 let b = frequency [3, always true; 2, always false] ()
909 * let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneofl [[]; lg gen ()]
911 * let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneof [always []; lg gen]
913 * because caml is not as lazy as haskell :( fix the pb by introducing a size
914 * limit. take the bounds/size as parameter. morover this is needed for
917 * how make a bintreeg ?? we need recursion
919 * let rec (bintreeg: ('a gen) -> ('a bintree) gen) = fun gen () ->
921 * if n = 0 then (Leaf (gen ()))
922 * else frequencyl [1, Leaf (gen ()); 4, Branch ((aux (n / 2)), aux (n / 2))]
929 (*---------------------------------------------------------------------------*)
931 (*---------------------------------------------------------------------------*)
933 (* todo: a test_all_laws, better syntax (done already a little with ig in
934 * place of intg. En cas d'erreur, print the arg that not respect
936 * todo: with monitoring, as in haskell, laws = laws2, no need for 2 func,
939 * todo classify, collect, forall
943 (* return None when good, and Just the_problematic_case when bad *)
944 let (laws
: string -> ('a
-> bool) -> ('a gen
) -> 'a
option) = fun s func gen
->
945 let res = foldn
(fun acc
i -> let n = gen
() in (n, func
n)::acc
) [] 1000 in
946 let res = List.filter
(fun (x,b) -> not
b) res in
947 if res = [] then None
else Some
(fst
(List.hd
res))
949 let rec (statistic_number
: ('a list
) -> (int * 'a
) list
) = function
951 | x::xs -> let (splitg
, splitd
) = List.partition
(fun y
-> y
= x) xs in
952 (1+(List.length splitg
), x)::(statistic_number splitd
)
955 let (statistic
: ('a list
) -> (int * 'a
) list
) = fun xs ->
956 let stat_num = statistic_number
xs in
957 let totals = sum_int (List.map fst
stat_num) in
958 List.map
(fun (i, v
) -> ((i * 100) / totals), v
) stat_num
961 string -> ('a
-> (bool * '
b)) -> ('a gen
) ->
962 ('a
option * ((int * '
b) list
))) =
964 let res = foldn
(fun acc
i -> let n = gen
() in (n, func
n)::acc
) [] 1000 in
965 let stat = statistic
(List.map
(fun (x,(b,v
)) -> v
) res) in
966 let res = List.filter
(fun (x,(b,v
)) -> not
b) res in
967 if res = [] then (None
, stat) else (Some
(fst
(List.hd
res)), stat)
971 let b = laws "unit" (fun x -> reverse [x] = [x] )ig
972 let b = laws "app " (fun (xs,ys) -> reverse (xs++ys) = reverse ys++reverse xs)(pg (lg ig)(lg ig))
973 let b = laws "rev " (fun xs -> reverse (reverse xs) = xs )(lg ig)
974 let b = laws "appb" (fun (xs,ys) -> reverse (xs++ys) = reverse xs++reverse ys)(pg (lg ig)(lg ig))
975 let b = laws "max" (fun (x,y) -> x <= y ==> (max x y = y) )(pg ig ig)
977 let b = laws2 "max" (fun (x,y) -> ((x <= y ==> (max x y = y)), x <= y))(pg ig ig)
981 (* todo, do with coarbitrary ?? idea is that given a 'a, generate a 'b
982 * depending of 'a and gen 'b, that is modify gen 'b, what is important is
983 * that each time given the same 'a, we must get the same 'b !!!
987 let (fg: ('a gen) -> ('b gen) -> ('a -> 'b) gen) = fun gen1 gen2 () ->
988 let b = laws "funs" (fun (f,g,h) -> x <= y ==> (max x y = y) )(pg ig ig)
992 let one_of xs = List.nth xs (Random.int (List.length xs))
994 if empty xs then failwith "Take_one: empty list"
996 let i = Random.int (List.length xs) in
997 List.nth xs i, filter_index (fun j _ -> i <> j) xs
1000 (*****************************************************************************)
1002 (*****************************************************************************)
1004 let get_value filename =
1005 let chan = open_in
filename in
1006 let x = input_value
chan in (* <=> Marshal.from_channel *)
1009 let write_value valu
filename =
1010 let chan = open_out
filename in
1011 (output_value
chan valu
; (* <=> Marshal.to_channel *)
1012 (* Marshal.to_channel chan valu [Marshal.Closures]; *)
1015 let write_back func
filename =
1016 write_value (func
(get_value filename)) filename
1019 let read_value f
= get_value f
1022 let marshal__to_string2 v flags
=
1023 Marshal.to_string v flags
1024 let marshal__to_string a
b =
1025 profile_code "Marshalling" (fun () -> marshal__to_string2 a
b)
1027 let marshal__from_string2 v flags
=
1028 Marshal.from_string v flags
1029 let marshal__from_string a
b =
1030 profile_code "Marshalling" (fun () -> marshal__from_string2 a
b)
1034 (*****************************************************************************)
1036 (*****************************************************************************)
1037 let _counter = ref 0
1038 let counter () = (_counter := !_counter +1; !_counter)
1040 let _counter2 = ref 0
1041 let counter2 () = (_counter2 := !_counter2 +1; !_counter2)
1043 let _counter3 = ref 0
1044 let counter3 () = (_counter3 := !_counter3 +1; !_counter3)
1046 type timestamp
= int
1048 (*****************************************************************************)
1050 (*****************************************************************************)
1051 (* To work with the macro system autogenerated string_of and print_ function
1052 (kind of deriving a la haskell) *)
1054 (* int, bool, char, float, ref ?, string *)
1056 let string_of_string s = "\"" ^
s "\""
1058 let string_of_list f
xs =
1059 "[" ^
(xs +> List.map f
+> String.concat
";" ) ^
"]"
1061 let string_of_unit () = "()"
1063 let string_of_array f
xs =
1064 "[|" ^
(xs +> Array.to_list
+> List.map f
+> String.concat
";") ^
"|]"
1066 let string_of_option f
= function
1068 | Some
x -> "Some " ^
(f
x)
1073 let print_bool x = print_string
(if x then "True" else "False")
1075 let print_option pr = function
1076 | None
-> print_string
"None"
1077 | Some
x -> print_string
"Some ("; pr x; print_string
")"
1079 let print_list pr xs =
1082 List.iter
(fun x -> pr x; print_string
",") xs;
1087 let (string_of_list: char list -> string) =
1088 List.fold_left (fun acc x -> acc^(Char.escaped x)) ""
1092 let rec print_between between fn
= function
1095 | x::xs -> fn
x; between
(); print_between between fn
xs
1100 let adjust_pp_with_indent f
=
1101 Format.open_box
!_tab_level_print;
1102 (*Format.force_newline();*)
1104 Format.close_box
();
1105 Format.print_newline
()
1107 let adjust_pp_with_indent_and_header s f
=
1108 Format.open_box
(!_tab_level_print + String.length
s);
1109 do_n
!_tab_level_print (fun () -> Format.print_string
" ");
1110 Format.print_string
s;
1112 Format.close_box
();
1113 Format.print_newline
()
1117 let pp_do_in_box f
= Format.open_box
1; f
(); Format.close_box
()
1118 let pp_do_in_zero_box f
= Format.open_box
0; f
(); Format.close_box
()
1123 Format.close_box
();
1126 let pp s = Format.print_string
s
1128 let mk_str_func_of_assoc_conv xs =
1129 let swap (x,y
) = (y
,x) in
1132 let xs'
= List.map
swap xs in
1141 (* julia: convert something printed using format to print into a string *)
1142 (* now at bottom of file
1143 let format_to_string f =
1149 (*****************************************************************************)
1151 (*****************************************************************************)
1153 (* put your macro in macro.ml4, and you can test it interactivly as in lisp *)
1154 let macro_expand s =
1155 let c = open_out
"/tmp/ttttt.ml" in
1157 output_string
c s; close_out
c;
1158 command2 ("ocamlc -c -pp 'camlp4o pa_extend.cmo q_MLast.cmo -impl' " ^
1159 "-I +camlp4 -impl macro.ml4");
1160 command2 "camlp4o ./macro.cmo pr_o.cmo /tmp/ttttt.ml";
1161 command2 "rm -f /tmp/ttttt.ml";
1165 let t = macro_expand "{ x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x>2 and y<3}"
1166 let x = { x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x > 2 and y < 3}
1167 let t = macro_expand "{1 .. 10}"
1168 let x = {1 .. 10} +> List.map (fun i -> i)
1169 let t = macro_expand "[1;2] to append to [2;4]"
1170 let t = macro_expand "{x = 2; x = 3}"
1172 let t = macro_expand "type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree)"
1177 (*****************************************************************************)
1178 (* Composition/Control *)
1179 (*****************************************************************************)
1181 (* I like the obj.func object notation. In OCaml cant use '.' so I use +>
1183 * update: it seems that F# agrees with me :) but they use |>
1187 * let (+>) o f = f o
1189 let (+!>) refo f
= refo
:= f
!refo
1191 * let ((@): 'a -> ('a -> 'b) -> 'b) = fun a b -> b a
1192 * let o f g x = f (g x)
1195 let ($
) f g
x = g
(f
x)
1196 let compose f g
x = f
(g
x)
1197 (* dont work :( let ( ° ) f g x = f(g(x)) *)
1199 (* trick to have something similar to the 1 `max` 4 haskell infix notation.
1200 by Keisuke Nakano on the caml mailing list.
1201 > let ( /* ) x y = y x
1202 > and ( */ ) x y = x y
1204 let ( <| ) x y = y x
1205 and ( |> ) x y = x y
1207 > Then we can make an infix operator <| f |> for a binary function f.
1210 let flip f
= fun a
b -> f
b a
1212 let curry f
x y
= f
(x,y
)
1213 let uncurry f
(a
,b) = f a
b
1217 let do_nothing () = ()
1219 let rec applyn n f
o = if n = 0 then o else applyn (n-1) f
(f
o)
1227 class ['a
] shared_variable_hook
(x:'a
) =
1229 val mutable data
= x
1230 val mutable registered
= []
1234 pr "refresh registered";
1235 registered
+> List.iter
(fun f
-> f
());
1238 method modify f
= self#set
(f self#get
)
1240 registered
<- f
:: registered
1243 (* src: from aop project. was called ptFix *)
1244 let rec fixpoint trans elem
=
1245 let image = trans elem
in
1247 then elem
(* point fixe *)
1248 else fixpoint trans
image
1250 (* le point fixe pour les objets. was called ptFixForObjetct *)
1251 let rec fixpoint_for_object trans elem
=
1252 let image = trans elem
in
1253 if (image#equal elem
) then elem
(* point fixe *)
1254 else fixpoint_for_object trans
image
1256 let (add_hook
: ('a
-> ('a
-> '
b) -> '
b) ref -> ('a
-> ('a
-> '
b) -> '
b) -> unit) =
1258 let oldvar = !var
in
1259 var
:= fun arg k
-> f arg
(fun x -> oldvar x k
)
1261 let (add_hook_action
: ('a
-> unit) -> ('a
-> unit) list
ref -> unit) =
1265 let (run_hooks_action
: 'a
-> ('a
-> unit) list
ref -> unit) =
1267 !hooks
+> List.iter
(fun f
-> try f obj
with _ -> ())
1270 type 'a mylazy
= (unit -> 'a
)
1273 let save_excursion reference f
=
1274 let old = !reference
in
1275 let res = try f
() with e
-> reference
:= old; raise e
in
1279 let save_excursion_and_disable reference f
=
1280 save_excursion reference
(fun () ->
1285 let save_excursion_and_enable reference f
=
1286 save_excursion reference
(fun () ->
1292 let memoized h k f
=
1293 try Hashtbl.find
h k
1301 let cache_in_ref myref f
=
1310 let already = ref false in
1313 then begin already := true; f
x end
1316 (* cache_file, cf below *)
1318 let before_leaving f
x =
1322 (* finalize, cf prelude *)
1326 let rec y f
= fun x -> f
(y f
) x
1328 (*****************************************************************************)
1330 (*****************************************************************************)
1332 (* from http://en.wikipedia.org/wiki/File_locking
1334 * "When using file locks, care must be taken to ensure that operations
1335 * are atomic. When creating the lock, the process must verify that it
1336 * does not exist and then create it, but without allowing another
1337 * process the opportunity to create it in the meantime. Various
1338 * schemes are used to implement this, such as taking advantage of
1339 * system calls designed for this purpose (but such system calls are
1340 * not usually available to shell scripts) or by creating the lock file
1341 * under a temporary name and then attempting to move it into place."
1343 * => can't use 'if(not (file_exist xxx)) then create_file xxx' because
1344 * file_exist/create_file are not in atomic section (classic problem).
1348 * "O_EXCL When used with O_CREAT, if the file already exists it
1349 * is an error and the open() will fail. In this context, a
1350 * symbolic link exists, regardless of where it points to.
1351 * O_EXCL is broken on NFS file systems; programs which
1352 * rely on it for performing locking tasks will contain a
1353 * race condition. The solution for performing atomic file
1354 * locking using a lockfile is to create a unique file on
1355 * the same file system (e.g., incorporating host- name and
1356 * pid), use link(2) to make a link to the lockfile. If
1357 * link(2) returns 0, the lock is successful. Otherwise,
1358 * use stat(2) on the unique file to check if its link
1359 * count has increased to 2, in which case the lock is also
1364 exception FileAlreadyLocked
1366 (* Racy if lock file on NFS!!! But still racy with recent Linux ? *)
1367 let acquire_file_lock filename =
1368 pr2 ("Locking file: " ^
filename);
1370 let _fd = Unix.openfile
filename [Unix.O_CREAT
;Unix.O_EXCL
] 0o777
in
1372 with Unix.Unix_error
(e, fm
, argm
) ->
1373 pr2 (spf "exn Unix_error: %s %s %s\n" (Unix.error_message
e) fm argm
);
1374 raise FileAlreadyLocked
1377 let release_file_lock filename =
1378 pr2 ("Releasing file: " ^
filename);
1379 Unix.unlink
filename;
1384 (*****************************************************************************)
1385 (* Error managment *)
1386 (*****************************************************************************)
1389 exception Impossible
1393 exception Multi_found
(* to be consistent with Not_found *)
1395 exception WrongFormat
of string
1397 (* old: let _TODO () = failwith "TODO", now via fix_caml with raise Todo *)
1399 let internal_error s = failwith
("internal error: "^
s)
1400 let error_cant_have x = internal_error ("cant have this case: " ^
(dump x))
1401 let myassert cond
= if cond
then () else failwith
"assert error"
1405 (* before warning I was forced to do stuff like this:
1407 * let (fixed_int_to_posmap: fixed_int -> posmap) = fun fixed ->
1408 * let v = ((fix_to_i fixed) / (power 2 16)) in
1409 * let _ = Printf.printf "coord xy = %d\n" v in
1412 * The need for printf make me force to name stuff :(
1413 * How avoid ? use 'it' special keyword ?
1414 * In fact dont have to name it, use +> (fun v -> ...) so when want
1415 * erase debug just have to erase one line.
1417 let warning s v = (pr2 ("Warning: " ^
s ^
"; value = " ^
(dump v)); v)
1423 Printexc.to_string exn
1426 let string_of_exn exn
= exn_to_s exn
1429 (* want or of merd, but cant cos cant put die ... in b (strict call) *)
1430 let (|||) a
b = try a
with _ -> b
1432 (* emacs/lisp inspiration, (vouillon does that too in unison I think) *)
1435 * let unwind_protect f cleanup = ...
1436 * let finalize f cleanup = ...
1439 type error
= Error
of string
1441 (* sometimes to get help from ocaml compiler to tell me places where
1442 * I should update, we sometimes need to change some type from pair
1443 * to triple, hence this kind of fake type.
1448 (*****************************************************************************)
1450 (*****************************************************************************)
1452 let check_stack = ref true
1453 let check_stack_size limit
=
1454 if !check_stack then begin
1455 pr2 "checking stack size (do ulimit -s 50000 if problem)";
1459 else 1 + aux (i + 1)
1461 assert(aux 0 = limit
);
1465 let test_check_stack_size limit
=
1466 (* bytecode: 100000000 *)
1467 (* native: 10000000 *)
1468 check_stack_size (int_of_string limit
)
1471 (* only relevant in bytecode, in native the stacklimit is the os stacklimit
1472 * (adjustable by ulimit -s)
1474 let _init_gc_stack =
1475 Gc.set
{(Gc.get
()) with Gc.stack_limit
= 100 * 1024 * 1024}
1480 (* if process a big set of files then dont want get overflow in the middle
1481 * so for this we are ready to spend some extra time at the beginning that
1482 * could save far more later.
1484 let check_stack_nbfiles nbfiles
=
1486 then check_stack_size 10000000
1488 (*****************************************************************************)
1489 (* Arguments/options and command line (cocci and acomment) *)
1490 (*****************************************************************************)
1493 * Why define wrappers ? Arg not good enough ? Well the Arg.Rest is not that
1494 * good and I need a way sometimes to get a list of argument.
1496 * I could define maybe a new Arg.spec such as
1497 * | String_list of (string list -> unit), but the action may require
1498 * some flags to be set, so better to process this after all flags have
1499 * been set by parse_options. So have to split. Otherwise it would impose
1500 * an order of the options such as
1501 * -verbose_parsing -parse_c file1 file2. and I really like to use bash
1502 * history and add just at the end of my command a -profile for instance.
1505 * Why want a -action arg1 arg2 arg3 ? (which in turn requires this
1506 * convulated scheme ...) Why not use Arg.String action such as
1507 * "-parse_c", Arg.String (fun file -> ...) ?
1508 * I want something that looks like ocaml function but at the UNIX
1509 * command line level. So natural to have this scheme instead of
1510 * -taxo_file arg2 -sample_file arg3 -parse_c arg1.
1513 * Why not use the toplevel ?
1514 * - because to debug, ocamldebug is far superior to the toplevel
1515 * (can go back, can go directly to a specific point, etc).
1516 * I want a kind of testing at cmdline level.
1517 * - Also I don't have file completion when in the ocaml toplevel.
1518 * I have to type "/path/to/xxx" without help.
1521 * Why having variable flags ? Why use 'if !verbose_parsing then ...' ?
1522 * why not use strings and do stuff like the following
1523 * 'if (get_config "verbose_parsing") then ...'
1524 * Because I want to make the interface for flags easier for the code
1525 * that use it. The programmer should not be bothered wether this
1526 * flag is set via args cmd line or a config file, so I want to make it
1527 * as simple as possible, just use a global plain caml ref variable.
1529 * Same spirit a little for the action. Instead of having function such as
1530 * test_parsing_c, I could do it only via string. But I still prefer
1531 * to have plain caml test functions. Also it makes it easier to call
1532 * those functions from a toplevel for people who prefer the toplevel.
1535 * So have flag_spec and action_spec. And in flag have debug_xxx flags,
1536 * verbose_xxx flags and other flags.
1538 * I would like to not have to separate the -xxx actions spec from the
1539 * corresponding actions, but those actions may need more than one argument
1540 * and so have to wait for parse_options, which in turn need the options
1543 * Also I dont want to mix code with data structures, so it's better that the
1544 * options variable contain just a few stuff and have no side effects except
1545 * setting global variables.
1547 * Why not have a global variable such as Common.actions that
1548 * other modules modify ? No, I prefer to do less stuff behind programmer's
1549 * back so better to let the user merge the different options at call
1550 * site, but at least make it easier by providing shortcut for set of options.
1555 * todo? isn't unison or scott-mcpeak-lib-in-cil handles that kind of
1556 * stuff better ? That is the need to localize command line argument
1557 * while still being able to gathering them. Same for logging.
1558 * Similiar to the type prof = PALL | PNONE | PSOME of string list.
1559 * Same spirit of fine grain config in log4j ?
1561 * todo? how mercurial/cvs/git manage command line options ? because they
1562 * all have a kind of DSL around arguments with some common options,
1563 * specific options, conventions, etc.
1566 * todo? generate the corresponding noxxx options ?
1567 * todo? generate list of options and show their value ?
1569 * todo? make it possible to set this value via a config file ?
1574 type arg_spec_full
= Arg.key
* Arg.spec
* Arg.doc
1575 type cmdline_options
= arg_spec_full list
1577 (* the format is a list of triples:
1578 * (title of section * (optional) explanation of sections * options)
1580 type options_with_title
= string * string * arg_spec_full list
1581 type cmdline_sections
= options_with_title list
1584 (* ---------------------------------------------------------------------- *)
1586 (* now I use argv as I like at the call sites to show that
1587 * this function internally use argv.
1589 let parse_options options usage_msg argv
=
1590 let args = ref [] in
1592 Arg.parse_argv argv options
(fun file
-> args := file
::!args) usage_msg
;
1593 args := List.rev
!args;
1596 | Arg.Bad msg
-> eprintf
"%s" msg
; exit
2
1597 | Arg.Help msg
-> printf
"%s" msg
; exit
0
1603 let usage usage_msg options
=
1604 Arg.usage (Arg.align options
) usage_msg
1607 (* for coccinelle *)
1609 (* If you don't want the -help and --help that are appended by Arg.align *)
1611 Arg.align
xs +> List.rev
+> drop 2 +> List.rev
1614 let short_usage usage_msg ~short_opt
=
1615 usage usage_msg short_opt
1617 let long_usage usage_msg ~short_opt ~long_opt
=
1620 let all_options_with_title =
1621 (("main options", "", short_opt
)::long_opt
) in
1622 all_options_with_title +> List.iter
1623 (fun (title
, explanations
, xs) ->
1625 pr_xxxxxxxxxxxxxxxxx();
1626 if explanations
<> ""
1627 then begin pr explanations
; pr "" end;
1628 arg_align2 xs +> List.iter
(fun (key
,action
,s) ->
1636 (* copy paste of Arg.parse. Don't want the default -help msg *)
1637 let arg_parse2 l msg short_usage_fun
=
1638 let args = ref [] in
1639 let f = (fun file
-> args := file
::!args) in
1640 let l = Arg.align
l in
1642 Arg.parse_argv
Sys.argv
l f msg
;
1643 args := List.rev
!args;
1647 | Arg.Bad msg
-> (* eprintf "%s" msg; exit 2; *)
1648 let xs = lines msg
in
1649 (* take only head, it's where the error msg is *)
1652 raise
(UnixExit
(2))
1653 | Arg.Help msg
-> (* printf "%s" msg; exit 0; *)
1654 raise Impossible
(* -help is specified in speclist *)
1658 (* ---------------------------------------------------------------------- *)
1659 (* kind of unit testing framework, or toplevel like functionnality
1660 * at shell command line. I realize than in fact It follows a current trend
1661 * to have a main cmdline program where can then select different actions,
1662 * as in cvs/hg/git where do hg <action> <arguments>, and the shell even
1663 * use a curried syntax :)
1666 * Not-perfect-but-basic-feels-right: an action
1667 * spec looks like this:
1669 * let actions () = [
1670 * "-parse_taxo", " <file>",
1671 * Common.mk_action_1_arg test_parse_taxo;
1675 * Not-perfect-but-basic-feels-right because for such functionality we
1676 * need a way to transform a string into a caml function and pass arguments
1677 * and the preceding design does exactly that, even if then the
1678 * functions that use this design are not so convenient to use (there
1679 * are 2 places where we need to pass those data, in the options and in the
1682 * Also it's not too much intrusive. Still have an
1683 * action ref variable in the main.ml and can still use the previous
1684 * simpler way to do where the match args with in main.ml do the
1687 * Use like this at option place:
1688 * (Common.options_of_actions actionref (Test_parsing_c.actions())) ++
1689 * Use like this at dispatch action place:
1690 * | xs when List.mem !action (Common.action_list all_actions) ->
1691 * Common.do_action !action xs all_actions
1695 type flag_spec
= Arg.key
* Arg.spec
* Arg.doc
1696 type action_spec
= Arg.key
* Arg.doc
* action_func
1697 and action_func
= (string list
-> unit)
1699 type cmdline_actions
= action_spec list
1700 exception WrongNumberOfArguments
1702 let options_of_actions action_ref
actions =
1703 actions +> List.map
(fun (key
, doc
, _func
) ->
1704 (key
, (Arg.Unit
(fun () -> action_ref
:= key
)), doc
)
1707 let (action_list
: cmdline_actions
-> Arg.key list
) = fun xs ->
1708 List.map
(fun (a
,b,c) -> a
) xs
1710 let (do_action
: Arg.key
-> string list
(* args *) -> cmdline_actions
-> unit) =
1712 let assoc = xs +> List.map
(fun (a
,b,c) -> (a
,c)) in
1713 let action_func = List.assoc key
assoc in
1717 (* todo? if have a function with default argument ? would like a
1718 * mk_action_0_or_1_arg ?
1721 let mk_action_0_arg f =
1724 | _ -> raise WrongNumberOfArguments
1727 let mk_action_1_arg f =
1730 | _ -> raise WrongNumberOfArguments
1733 let mk_action_2_arg f =
1735 | [file1
;file2
] -> f file1 file2
1736 | _ -> raise WrongNumberOfArguments
1739 let mk_action_3_arg f =
1741 | [file1
;file2
;file3
] -> f file1 file2 file3
1742 | _ -> raise WrongNumberOfArguments
1745 let mk_action_n_arg f = f
1748 (*****************************************************************************)
1750 (*****************************************************************************)
1752 (* Using the generic (=) is tempting, but it backfires, so better avoid it *)
1754 (* To infer all the code that use an equal, and that should be
1755 * transformed, is not that easy, because (=) is used by many
1756 * functions, such as List.find, List.mem, and so on. So the strategy
1757 * is to turn what you were previously using into a function, because
1758 * (=) return an exception when applied to a function. Then you simply
1759 * use ocamldebug to infer where the code has to be transformed.
1762 (* src: caml mailing list ? *)
1763 let (=|=) : int -> int -> bool = (=)
1764 let (=<=) : char
-> char
-> bool = (=)
1765 let (=$
=) : string -> string -> bool = (=)
1766 let (=:=) : bool -> bool -> bool = (=)
1768 (* the evil generic (=). I define another symbol to more easily detect
1769 * it, cos the '=' sign is syntaxically overloaded in caml. It is also
1770 * used to define function.
1774 (* if really want to forbid to use '='
1777 let (=) () () = false
1786 (*###########################################################################*)
1787 (* And now basic types *)
1788 (*###########################################################################*)
1792 (*****************************************************************************)
1794 (*****************************************************************************)
1795 let (==>) b1 b2
= if b1
then b2
else true (* could use too => *)
1797 (* superseded by another <=> below
1798 let (<=>) a b = if a =*= b then 0 else if a < b then -1 else 1
1801 let xor a
b = not
(a
=*= b)
1804 (*****************************************************************************)
1806 (*****************************************************************************)
1808 let string_of_char c = String.make
1 c
1810 let is_single = String.contains
",;()[]{}_`"
1811 let is_symbol = String.contains
"!@#$%&*+./<=>?\\^|:-~"
1812 let is_space = String.contains
"\n\t "
1813 let cbetween min max
c =
1814 (int_of_char
c) <= (int_of_char max
) &&
1815 (int_of_char
c) >= (int_of_char min
)
1816 let is_upper = cbetween 'A' 'Z'
1817 let is_lower = cbetween 'a' 'z'
1818 let is_alpha c = is_upper c || is_lower c
1819 let is_digit = cbetween '
0' '
9'
1821 let string_of_chars cs
= cs
+> List.map
(String.make
1) +> String.concat
""
1825 (*****************************************************************************)
1827 (*****************************************************************************)
1829 (* since 3.08, div by 0 raise Div_by_rezo, and not anymore a hardware trap :)*)
1830 let (/!) x y = if y =|= 0 then (log "common.ml: div by 0"; 0) else x / y
1833 * let rec (do_n: int -> (unit -> unit) -> unit) = fun i f ->
1834 * if i = 0 then () else (f(); do_n (i-1) f)
1838 * let rec (foldn: ('a -> int -> 'a) -> 'a -> int -> 'a) = fun f acc i ->
1839 * if i = 0 then acc else foldn f (f acc i) (i-1)
1842 let sum_float = List.fold_left
(+.) 0.0
1843 let sum_int = List.fold_left
(+) 0
1845 let pi = 3.14159265358979323846
1850 let (deg_to_rad
: float -> float) = fun deg
->
1851 (deg
*. pi) /. 180.0
1853 let clampf = function
1854 | n when n < 0.0 -> 0.0
1855 | n when n > 1.0 -> 1.0
1858 let square x = x *. x
1860 let rec power x n = if n =|= 0 then 1 else x * power x (n-1)
1862 let between i min max
= i > min
&& i < max
1864 let (between_strict
: int -> int -> int -> bool) = fun a
b c ->
1868 let bitrange x p
= let v = power 2 p
in between x (-v) v
1871 let (prime1
: int -> int option) = fun x ->
1872 let rec prime1_aux n =
1873 if n =|= 1 then None
1875 if (x / n) * n =|= x then Some
n else prime1_aux (n-1)
1876 in if x =|= 1 then None
else if x < 0 then failwith
"negative" else prime1_aux (x-1)
1878 (* montant, better *)
1879 let (prime
: int -> int option) = fun x ->
1880 let rec prime_aux n =
1881 if n =|= x then None
1883 if (x / n) * n =|= x then Some
n else prime_aux (n+1)
1884 in if x =|= 1 then None
else if x < 0 then failwith
"negative" else prime_aux 2
1886 let sum xs = List.fold_left
(+) 0 xs
1887 let product = List.fold_left
( * ) 1
1891 let rec decompose x =
1896 | Some
n -> n::decompose (x / n)
1898 in assert (product (decompose x) =|= x); decompose x
1900 let mysquare x = x * x
1904 type compare
= Equal
| Inf
| Sup
1905 let (<=>) a
b = if a
=*= b then Equal
else if a
< b then Inf
else Sup
1906 let (<==>) a
b = if a
=*= b then 0 else if a
< b then -1 else 1
1911 let int_of_stringchar s =
1912 fold_left_with_index (fun acc
e i -> acc
+ (Char.code
e*(power 8 i))) 0 (List.rev
(list_of_string
s))
1914 let int_of_base s base
=
1915 fold_left_with_index (fun acc
e i ->
1916 let j = Char.code
e - Char.code '
0'
in
1917 if j >= base
then failwith
"not in good base"
1918 else acc
+ (j*(power base
i))
1920 0 (List.rev
(list_of_string
s))
1922 let int_of_stringbits s = int_of_base s 2
1923 let _ = example (int_of_stringbits "1011" =|= 1*8 + 1*2 + 1*1)
1925 let int_of_octal s = int_of_base s 8
1926 let _ = example (int_of_octal "017" =|= 15)
1928 (* let int_of_hex s = int_of_base s 16, NONONONO cos 'A' - '0' does not give 10 !! *)
1931 if String.length
s >= 2 && (String.get
s 0 =<= '
0'
) && is_digit (String.get
s 1)
1932 then int_of_octal s else int_of_string
s
1935 let (+=) ref v = ref := !ref + v
1936 let (-=) ref v = ref := !ref - v
1938 let pourcent x total
=
1940 let pourcent_float x total
=
1941 ((float_of_int
x) *. 100.0) /. (float_of_int total
)
1943 let pourcent_float_of_floats x total
=
1944 (x *. 100.0) /. total
1947 let pourcent_good_bad good bad
=
1948 (good
* 100) / (good
+ bad
)
1950 let pourcent_good_bad_float good bad
=
1951 (float_of_int good
*. 100.0) /. (float_of_int good
+. float_of_int bad
)
1953 type 'a max_with_elem
= int ref * 'a
ref
1954 let update_max_with_elem (aref
, aelem
) ~is_better
(newv
, newelem
) =
1955 if is_better newv aref
1961 (*****************************************************************************)
1962 (* Numeric/overloading *)
1963 (*****************************************************************************)
1966 NumDict
of (('a
-> 'a
-> 'a
) *
1971 let add (NumDict
(a
, m
, d
, n)) = a
;;
1972 let mul (NumDict
(a
, m
, d
, n)) = m
;;
1973 let div (NumDict
(a
, m
, d
, n)) = d
;;
1974 let neg (NumDict
(a
, m
, d
, n)) = n;;
1976 let numd_int = NumDict
(( + ),( * ),( / ),( ~
- ));;
1977 let numd_float = NumDict
(( +. ),( *. ), ( /. ),( ~
-. ));;
1979 let ( * ) x y = mul dict
x y in
1980 let ( / ) x y = div dict
x y in
1981 let ( + ) x y = add dict
x y in
1982 (* Now you can define all sorts of things in terms of *, /, + *)
1983 let f num
= (num
* num
) / (num
+ num
) in
1988 module ArithFloatInfix
= struct
2000 let (+=) ref v = ref := !ref + v
2001 let (-=) ref v = ref := !ref - v
2007 (*****************************************************************************)
2009 (*****************************************************************************)
2011 type 'a pair
= 'a
* 'a
2012 type 'a triple
= 'a
* 'a
* 'a
2014 let fst3 (x,_,_) = x
2015 let snd3 (_,y,_) = y
2016 let thd3 (_,_,z
) = z
2018 let sndthd (a
,b,c) = (b,c)
2020 let map_fst f (x, y) = f x, y
2021 let map_snd f (x, y) = x, f y
2023 let pair f (x,y) = (f x, f y)
2025 (* for my ocamlbeautify script *)
2030 let swap (x,y) = (y,x)
2033 let tuple_of_list1 = function [a
] -> a
| _ -> failwith
"tuple_of_list1"
2034 let tuple_of_list2 = function [a
;b] -> a
,b | _ -> failwith
"tuple_of_list2"
2035 let tuple_of_list3 = function [a
;b;c] -> a
,b,c | _ -> failwith
"tuple_of_list3"
2036 let tuple_of_list4 = function [a
;b;c;d
] -> a
,b,c,d
| _ -> failwith
"tuple_of_list4"
2037 let tuple_of_list5 = function [a
;b;c;d
;e] -> a
,b,c,d
,e | _ -> failwith
"tuple_of_list5"
2038 let tuple_of_list6 = function [a
;b;c;d
;e;f] -> a
,b,c,d
,e,f | _ -> failwith
"tuple_of_list6"
2041 (*****************************************************************************)
2043 (*****************************************************************************)
2045 (* type 'a maybe = Just of 'a | None *)
2047 type ('a
,'
b) either
= Left
of 'a
| Right
of '
b
2049 type ('a
, '
b, '
c) either3
= Left3
of 'a
| Middle3
of '
b | Right3
of '
c
2054 | _ -> failwith
"just: pb"
2059 let fmap f = function
2061 | Some
x -> Some
(f x)
2062 let map_option = fmap
2064 let do_option f = function
2069 try Some
(f ()) with Not_found
-> None
2074 let some_or = function
2076 | Some
e -> fun _ -> e
2079 let partition_either f l =
2080 let rec part_either left right
= function
2081 | [] -> (List.rev left
, List.rev right
)
2084 | Left
e -> part_either (e :: left
) right
l
2085 | Right
e -> part_either left
(e :: right
) l) in
2088 let partition_either3 f l =
2089 let rec part_either left middle right
= function
2090 | [] -> (List.rev left
, List.rev middle
, List.rev right
)
2093 | Left3
e -> part_either (e :: left
) middle right
l
2094 | Middle3
e -> part_either left
(e :: middle
) right
l
2095 | Right3
e -> part_either left middle
(e :: right
) l) in
2096 part_either [] [] [] l
2100 let rec filter_some = function
2102 | None
:: l -> filter_some l
2103 | Some
e :: l -> e :: filter_some l
2105 let map_filter f xs = xs +> List.map
f +> filter_some
2107 (* avoid recursion *)
2108 let tail_map_filter f xs =
2118 let rec find_some p
= function
2119 | [] -> raise Not_found
2123 | None
-> find_some p
l
2127 xs +> List.map f +> List.find (function Some x -> true | None -> false)
2128 +> (function Some x -> x | None -> raise Impossible)
2132 let list_to_single_or_exn xs =
2134 | [] -> raise Not_found
2135 | x::y::zs
-> raise Multi_found
2138 (*****************************************************************************)
2140 (*****************************************************************************)
2142 type bool3
= True3
| False3
| TrueFalsePb3
of string
2146 (*****************************************************************************)
2147 (* Regexp, can also use PCRE *)
2148 (*****************************************************************************)
2150 (* Note: OCaml Str regexps are different from Perl regexp:
2151 * - The OCaml regexp must match the entire way.
2152 * So "testBee" =~ "Bee" is wrong
2153 * but "testBee" =~ ".*Bee" is right
2154 * Can have the perl behavior if use Str.search_forward instead of
2156 * - Must add some additional \ in front of some special char. So use
2157 * \\( \\| and also \\b
2158 * - It does not always handle newlines very well.
2159 * - \\b does consider _ but not numbers in indentifiers.
2161 * Note: PCRE regexps are then different from Str regexps ...
2162 * - just use '(' ')' for grouping, not '\\)'
2163 * - still need \\b for word boundary, but this time it works ...
2164 * so can match some word that have some digits in them.
2168 (* put before String section because String section use some =~ *)
2170 (* let gsubst = global_replace *)
2173 let (==~
) s re
= Str.string_match re
s 0
2175 let _memo_compiled_regexp = Hashtbl.create
101
2176 let candidate_match_func s re
=
2177 (* old: Str.string_match (Str.regexp re) s 0 *)
2179 memoized _memo_compiled_regexp re
(fun () -> Str.regexp re
)
2181 Str.string_match
compile_re s 0
2183 let match_func s re
=
2184 profile_code "Common.=~" (fun () -> candidate_match_func s re
)
2193 let string_match_substring re
s =
2194 try let _i = Str.search_forward re
s 0 in true
2195 with Not_found
-> false
2198 example(string_match_substring (Str.regexp
"foo") "a foo b")
2200 example(string_match_substring (Str.regexp
"\\bfoo\\b") "a foo b")
2202 example(string_match_substring (Str.regexp
"\\bfoo\\b") "a\n\nfoo b")
2204 example(string_match_substring (Str.regexp
"\\bfoo_bar\\b") "a\n\nfoo_bar b")
2207 example(string_match_substring (Str.regexp "\\bfoo_bar2\\b") "a\n\nfoo_bar2 b")
2212 let (regexp_match
: string -> string -> string) = fun s re
->
2214 Str.matched_group
1 s
2216 (* beurk, side effect code, but hey, it is convenient *)
2218 * let (matched: int -> string -> string) = fun i s ->
2219 * Str.matched_group i s
2221 * let matched1 = fun s -> matched 1 s
2222 * let matched2 = fun s -> (matched 1 s, matched 2 s)
2223 * let matched3 = fun s -> (matched 1 s, matched 2 s, matched 3 s)
2224 * let matched4 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s)
2225 * let matched5 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s)
2226 * let matched6 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s)
2231 let split sep
s = Str.split (Str.regexp sep
) s
2232 let _ = example (split "/" "" =*= [])
2233 let join sep
xs = String.concat sep
xs
2234 let _ = example (join "/" ["toto"; "titi"; "tata"] =$
= "toto/titi/tata")
2236 let rec join str = function
2239 | x::xs -> x ^ str ^ (join str xs)
2243 let (split_list_regexp
: string -> string list
-> (string * string list
) list
) =
2245 let rec split_lr_aux (heading
, accu
) = function
2246 | [] -> [(heading
, List.rev accu
)]
2249 then (heading
, List.rev accu
)::split_lr_aux (x, []) xs
2250 else split_lr_aux (heading
, x::accu
) xs
2252 split_lr_aux ("__noheading__", []) xs
2253 +> (fun xs -> if (List.hd
xs) =*= ("__noheading__",[]) then List.tl
xs else xs)
2257 let regexp_alpha = Str.regexp
2258 "^[a-zA-Z_][A-Za-z_0-9]*$"
2261 let all_match re
s =
2262 let regexp = Str.regexp re
in
2264 let _ = Str.global_substitute
regexp (fun _s
->
2265 let substr = Str.matched_string
s in
2266 assert(substr ==~
regexp); (* @Effect: also use it's side effect *)
2267 let paren_matched = matched1 substr in
2268 push2 paren_matched res;
2273 let _ = example (all_match "\\(@[A-Za-z]+\\)" "ca va @Et toi @Comment"
2274 =*= ["@Et";"@Comment"])
2277 let global_replace_regexp re f_on_substr
s =
2278 let regexp = Str.regexp re
in
2279 Str.global_substitute
regexp (fun _wholestr
->
2281 let substr = Str.matched_string
s in
2286 let regexp_word_str =
2287 "\\([a-zA-Z_][A-Za-z_0-9]*\\)"
2288 let regexp_word = Str.regexp regexp_word_str
2290 let regular_words s =
2291 all_match regexp_word_str s
2293 let contain_regular_word s =
2294 let xs = regular_words s in
2299 (*****************************************************************************)
2301 (*****************************************************************************)
2303 let slength = String.length
2304 let concat = String.concat
2307 let i_to_s = string_of_int
2308 let s_to_i = int_of_string
2311 (* strings take space in memory. Better when can share the space used by
2313 let _shareds = Hashtbl.create
100
2314 let (shared_string
: string -> string) = fun s ->
2315 try Hashtbl.find
_shareds s
2316 with Not_found
-> (Hashtbl.add _shareds s s; s)
2320 | s -> String.sub
s 0 (String.length
s - 1)
2323 let chop_dirsymbol = function
2324 | s when s =~
"\\(.*\\)/$" -> matched1 s
2328 let (<!!>) s (i,j) =
2329 String.sub
s i (if j < 0 then String.length
s - i + j + 1 else j - i)
2330 (* let _ = example ( "tototati"<!!>(3,-2) = "otat" ) *)
2332 let (<!>) s i = String.get
s i
2335 let rec split_on_char c s =
2337 let sp = String.index
s c in
2338 String.sub
s 0 sp ::
2339 split_on_char c (String.sub
s (sp+1) (String.length
s - sp - 1))
2340 with Not_found
-> [s]
2343 let lowercase = String.lowercase
2345 let quote s = "\"" ^
s ^
"\""
2347 (* easier to have this to be passed as hof, because ocaml dont have
2348 * haskell "section" operators
2353 let is_blank_string s =
2354 s =~
"^\\([ \t]\\)*$"
2356 (* src: lablgtk2/examples/entrycompletion.ml *)
2357 let is_string_prefix s1 s2
=
2358 (String.length s1
<= String.length s2
) &&
2359 (String.sub s2
0 (String.length s1
) =$
= s1
)
2363 then Printf.sprintf
"%d %s" i s
2364 else Printf.sprintf
"%d %ss" i s
2366 let showCodeHex xs = List.iter
(fun i -> printf
"%02x" i) xs
2368 let take_string n s =
2369 String.sub
s 0 (n-1)
2371 let take_string_safe n s =
2372 if n > String.length
s
2374 else take_string n s
2380 let ko = (i / 1024) mod 1024 in
2381 let mo = (i / 1024) / 1024 in
2383 then sprintf
"%dMo%dKo" mo ko
2384 else sprintf
"%dKo" ko
2388 let ko = i / 1024 in
2396 (* done in summer 2007 for julia
2397 * Reference: P216 of gusfeld book
2398 * For two strings S1 and S2, D(i,j) is defined to be the edit distance of S1[1..i] to S2[1..j]
2399 * So edit distance of S1 (of length n) and S2 (of length m) is D(n,m)
2401 * Dynamic programming technique
2403 * 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]
2404 * D(0,j) = j for all j (cos j characters must be inserted)
2406 * D(i,j) = min([D(i-1, j)+1, D(i, j - 1 + 1), D(i-1, j-1) + t(i,j)])
2407 * where t(i,j) is equal to 1 if S1(i) != S2(j) and 0 if equal
2408 * intuition = there is 4 possible action = deletion, insertion, substitution, or match
2411 * D(i,j) must be one of the three
2419 let matrix_distance s1 s2
=
2420 let n = (String.length s1
) in
2421 let m = (String.length s2
) in
2422 let mat = Array.make_matrix
(n+1) (m+1) 0 in
2424 if String.get s1
(i-1) =<= String.get s2
(j-1)
2428 let min3 a
b c = min
(min a
b) c in
2440 min3 (mat.(i).(j-1) + 1) (mat.(i-1).(j) + 1) (mat.(i-1).(j-1) + t i j)
2445 let edit_distance s1 s2
=
2446 (matrix_distance s1 s2
).(String.length s1
).(String.length s2
)
2449 let test = edit_distance "vintner" "writers"
2450 let _ = assert (edit_distance "winter" "winter" =|= 0)
2451 let _ = assert (edit_distance "vintner" "writers" =|= 5)
2454 (*****************************************************************************)
2456 (*****************************************************************************)
2458 let dirname = Filename.dirname
2459 let basename = Filename.basename
2461 type filename = string (* TODO could check that exist :) type sux *)
2463 type dirname = string (* TODO could check that exist :) type sux *)
2466 module BasicType
= struct
2467 type filename = string
2471 let (filesuffix
: filename -> string) = fun s ->
2472 (try regexp_match
s ".+\\.\\([a-zA-Z0-9_]+\\)$" with _ -> "NOEXT")
2473 let (fileprefix
: filename -> string) = fun s ->
2474 (try regexp_match
s "\\(.+\\)\\.\\([a-zA-Z0-9_]+\\)?$" with _ -> s)
2476 let _ = example (filesuffix
"toto.c" =$
= "c")
2477 let _ = example (fileprefix
"toto.c" =$
= "toto")
2480 assert (s = fileprefix s ^ filesuffix s)
2482 let withoutExtension s = global_replace (regexp "\\..*$") "" s
2483 let () = example "without"
2484 (withoutExtension "toto.s.toto" = "toto")
2487 let adjust_ext_if_needed filename ext
=
2488 if String.get ext
0 <> '
.'
2489 then failwith
"I need an extension such as .c not just c";
2491 if not
(filename =~
(".*\\" ^ ext
))
2497 let db_of_filename file
=
2498 dirname file
, basename file
2500 let filename_of_db (basedir
, file
) =
2501 Filename.concat basedir file
2505 let dbe_of_filename file
=
2506 (* raise Invalid_argument if no ext, so safe to use later the unsafe
2507 * fileprefix and filesuffix functions.
2509 ignore
(Filename.chop_extension file
);
2510 Filename.dirname file
,
2511 Filename.basename file
+> fileprefix
,
2512 Filename.basename file
+> filesuffix
2514 let filename_of_dbe (dir
, base
, ext
) =
2515 Filename.concat dir
(base ^
"." ^ ext
)
2518 let dbe_of_filename_safe file
=
2519 try Left
(dbe_of_filename file
)
2520 with Invalid_argument
_ ->
2521 Right
(Filename.dirname file
, Filename.basename file
)
2524 let dbe_of_filename_nodot file
=
2525 let (d
,b,e) = dbe_of_filename file
in
2526 let d = if d =$
= "." then "" else d in
2533 let replace_ext file oldext newext
=
2534 let (d,b,e) = dbe_of_filename file
in
2535 assert(e =$
= oldext
);
2536 filename_of_dbe (d,b,newext
)
2539 let normalize_path file
=
2540 let (dir
, filename) = Filename.dirname file
, Filename.basename file
in
2541 let xs = split "/" dir
in
2542 let rec aux acc
= function
2543 | [] -> List.rev acc
2547 | ".." -> aux (List.tl acc
) xs
2548 | x -> aux (x::acc
) xs
2551 let xs'
= aux [] xs in
2552 Filename.concat (join "/" xs'
) filename
2557 let relative_to_absolute s =
2558 if Filename.is_relative s
2561 let old = Sys.getcwd () in
2563 let current = Sys.getcwd () in
2570 let relative_to_absolute s =
2571 if Filename.is_relative
s
2572 then Sys.getcwd
() ^
"/" ^
s
2575 let is_relative s = Filename.is_relative s
2576 let is_absolute s = not
(is_relative s)
2579 (* @Pre: prj_path must not contain regexp symbol *)
2580 let filename_without_leading_path prj_path
s =
2581 let prj_path = chop_dirsymbol prj_path in
2582 if s =~
("^" ^
prj_path ^
"/\\(.*\\)$")
2586 (spf "cant find filename_without_project_path: %s %s" prj_path s)
2589 (*****************************************************************************)
2591 (*****************************************************************************)
2600 (*****************************************************************************)
2602 (*****************************************************************************)
2604 (* maybe I should use ocamlcalendar, but I don't like all those functors ... *)
2607 | Jan
| Feb
| Mar
| Apr
| May
| Jun
2608 | Jul
| Aug
| Sep
| Oct
| Nov
| Dec
2609 type year
= Year
of int
2610 type day
= Day
of int
2611 type wday
= Sunday
| Monday
| Tuesday
| Wednesday
| Thursday
| Friday
| Saturday
2613 type date_dmy
= DMY
of day
* month
* year
2615 type hour
= Hour
of int
2616 type minute
= Min
of int
2617 type second
= Sec
of int
2619 type time_hms
= HMS
of hour
* minute
* second
2621 type full_date
= date_dmy
* time_hms
2625 type days
= Days
of int
2627 type time_dmy
= TimeDMY
of day
* month
* year
2630 type float_time
= float
2634 let check_date_dmy (DMY
(day
, month
, year
)) =
2637 let check_time_dmy (TimeDMY
(day
, month
, year
)) =
2640 let check_time_hms (HMS
(x,y,a
)) =
2645 (* ---------------------------------------------------------------------- *)
2648 let int_to_month i =
2649 assert (i <= 12 && i >= 1);
2678 | _ -> raise Impossible
2682 1 , Jan
, "Jan", "January", 31;
2683 2 , Feb
, "Feb", "February", 28;
2684 3 , Mar
, "Mar", "March", 31;
2685 4 , Apr
, "Apr", "April", 30;
2686 5 , May
, "May", "May", 31;
2687 6 , Jun
, "Jun", "June", 30;
2688 7 , Jul
, "Jul", "July", 31;
2689 8 , Aug
, "Aug", "August", 31;
2690 9 , Sep
, "Sep", "September", 30;
2691 10 , Oct
, "Oct", "October", 31;
2692 11 , Nov
, "Nov", "November", 30;
2693 12 , Dec
, "Dec", "December", 31;
2696 let week_day_info = [
2697 0 , Sunday
, "Sun" , "Dim" , "Sunday";
2698 1 , Monday
, "Mon" , "Lun" , "Monday";
2699 2 , Tuesday
, "Tue" , "Mar" , "Tuesday";
2700 3 , Wednesday
, "Wed" , "Mer" , "Wednesday";
2701 4 , Thursday
, "Thu" ,"Jeu" ,"Thursday";
2702 5 , Friday
, "Fri" , "Ven" , "Friday";
2703 6 , Saturday
, "Sat" ,"Sam" , "Saturday";
2707 month_info +> List.map
(fun (i,month
,monthstr
,mlong
,days
) -> i, month
)
2709 month_info +> List.map
(fun (i,month
,monthstr
,mlong
,days
) -> monthstr
, month
)
2710 let slong_to_month_h =
2711 month_info +> List.map
(fun (i,month
,monthstr
,mlong
,days
) -> mlong
, month
)
2713 month_info +> List.map
(fun (i,month
,monthstr
,mlong
,days
) -> month
, monthstr
)
2715 month_info +> List.map
(fun (i,month
,monthstr
,mlong
,days
) -> month
, i)
2718 week_day_info +> List.map
(fun (i,day
,dayen
,dayfr
,daylong
) -> i, day
)
2720 week_day_info +> List.map
(fun (i,day
,dayen
,dayfr
,daylong
) -> day
, dayen
)
2722 week_day_info +> List.map
(fun (i,day
,dayen
,dayfr
,daylong
) -> day
, dayfr
)
2724 let month_of_string s =
2725 List.assoc s s_to_month_h
2727 let month_of_string_long s =
2728 List.assoc s slong_to_month_h
2730 let string_of_month s =
2731 List.assoc s month_to_s_h
2733 let month_of_int i =
2734 List.assoc i i_to_month_h
2736 let int_of_month m =
2737 List.assoc m month_to_i_h
2741 List.assoc i i_to_wday_h
2743 let string_en_of_wday wday
=
2744 List.assoc wday
wday_to_en_h
2745 let string_fr_of_wday wday
=
2746 List.assoc wday
wday_to_fr_h
2748 (* ---------------------------------------------------------------------- *)
2750 let wday_str_of_int ~langage
i =
2751 let wday = wday_of_int i in
2753 | English
-> string_en_of_wday wday
2754 | Francais
-> string_fr_of_wday wday
2755 | Deutsch
-> raise Todo
2759 let string_of_date_dmy (DMY
(Day
n, month
, Year
y)) =
2760 (spf "%02d-%s-%d" n (string_of_month month
) y)
2763 let string_of_unix_time ?
(langage
=English
) tm =
2764 let y = tm.Unix.tm_year
+ 1900 in
2765 let mon = string_of_month (month_of_int (tm.Unix.tm_mon
+ 1)) in
2766 let d = tm.Unix.tm_mday
in
2767 let h = tm.Unix.tm_hour
in
2768 let min = tm.Unix.tm_min
in
2769 let s = tm.Unix.tm_sec
in
2771 let wday = wday_str_of_int ~langage
tm.Unix.tm_wday
in
2773 spf "%02d/%03s/%04d (%s) %02d:%02d:%02d" d mon y wday h min s
2775 (* ex: 21/Jul/2008 (Lun) 21:25:12 *)
2776 let unix_time_of_string s =
2778 ("\\([0-9][0-9]\\)/\\(...\\)/\\([0-9][0-9][0-9][0-9]\\) " ^
2779 "\\(.*\\) \\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)")
2781 let (sday
, smonth
, syear
, _sday
, shour
, smin
, ssec
) = matched7 s in
2783 let y = s_to_i syear
- 1900 in
2785 smonth
+> month_of_string +> int_of_month +> (fun i -> i -1)
2788 let tm = Unix.localtime
(Unix.time
()) in
2792 Unix.tm_mday
= s_to_i sday
;
2793 Unix.tm_hour
= s_to_i shour
;
2794 Unix.tm_min
= s_to_i smin
;
2795 Unix.tm_sec
= s_to_i ssec
;
2797 else failwith
("unix_time_of_string: " ^
s)
2801 let short_string_of_unix_time ?
(langage
=English
) tm =
2802 let y = tm.Unix.tm_year
+ 1900 in
2803 let mon = string_of_month (month_of_int (tm.Unix.tm_mon
+ 1)) in
2804 let d = tm.Unix.tm_mday
in
2805 let _h = tm.Unix.tm_hour
in
2806 let _min = tm.Unix.tm_min
in
2807 let _s = tm.Unix.tm_sec
in
2809 let wday = wday_str_of_int ~langage
tm.Unix.tm_wday
in
2811 spf "%02d/%03s/%04d (%s)" d mon y wday
2814 let string_of_unix_time_lfs time
=
2817 (int_to_month (time
.Unix.tm_mon
+ 1))
2818 (time
.Unix.tm_year
+ 1900)
2821 (* ---------------------------------------------------------------------- *)
2822 let string_of_floattime ?langage
i =
2823 let tm = Unix.localtime
i in
2824 string_of_unix_time ?langage
tm
2826 let short_string_of_floattime ?langage
i =
2827 let tm = Unix.localtime
i in
2828 short_string_of_unix_time ?langage
tm
2830 let floattime_of_string s =
2831 let tm = unix_time_of_string s in
2832 let (sec
,_tm
) = Unix.mktime
tm in
2836 (* ---------------------------------------------------------------------- *)
2837 let days_in_week_of_day day
=
2838 let tm = Unix.localtime day
in
2840 let wday = tm.Unix.tm_wday
in
2841 let wday = if wday =|= 0 then 6 else wday -1 in
2843 let mday = tm.Unix.tm_mday
in
2845 let start_d = mday - wday in
2846 let end_d = mday + (6 - wday) in
2848 enum start_d end_d +> List.map
(fun mday ->
2849 Unix.mktime
{tm with Unix.tm_mday
= mday} +> fst
2852 let first_day_in_week_of_day day
=
2853 List.hd
(days_in_week_of_day day
)
2855 let last_day_in_week_of_day day
=
2856 last (days_in_week_of_day day
)
2859 (* ---------------------------------------------------------------------- *)
2861 (* (modified) copy paste from ocamlcalendar/src/date.ml *)
2863 [| 0; 31; 59; 90; 120; 151; 181; 212; 243; 273; 304; 334(*; 365*) |]
2866 let rough_days_since_jesus (DMY
(Day nday
, month
, Year year
)) =
2869 (days_month.(int_of_month month
-1)) +
2876 let is_more_recent d1 d2
=
2877 let (Days n1
) = rough_days_since_jesus d1
in
2878 let (Days n2
) = rough_days_since_jesus d2
in
2883 if is_more_recent d1 d2
2888 if is_more_recent d1 d2
2893 let maximum_dmy ds
=
2896 let minimum_dmy ds
=
2901 let rough_days_between_dates d1 d2
=
2902 let (Days n1
) = rough_days_since_jesus d1
in
2903 let (Days n2
) = rough_days_since_jesus d2
in
2907 (rough_days_between_dates
2908 (DMY
(Day
7, Jan
, Year
1977))
2909 (DMY
(Day
13, Jan
, Year
1977)) =*= Days
6)
2911 (* because of rough days, it is a bit buggy, here it should return 1 *)
2913 let _ = assert_equal
2914 (rough_days_between_dates
2915 (DMY (Day 29, Feb, Year 1977))
2916 (DMY (Day 1, Mar , Year 1977)))
2921 (* from julia, in gitsort.ml *)
2925 [(1,31);(2,28);(3,31);(4,30);(5,31); (6,6);(7,7);(8,31);(9,30);(10,31);
2926 (11,30);(12,31);(0,31)]
2928 let normalize (year,month,day,hour,minute,second) =
2931 let (day,hour) = (day - 1,hour + 24) in
2934 let month = month - 1 in
2935 let day = List.assoc month antimonths in
2937 if month = 2 && year / 4 * 4 = year && not (year / 100 * 100 = year)
2941 then (year-1,12,day,hour,minute,second)
2942 else (year,month,day,hour,minute,second)
2943 else (year,month,day,hour,minute,second)
2944 else (year,month,day,hour,minute,second)
2949 let mk_date_dmy day month year
=
2950 let date = DMY
(Day
day, month_of_int month, Year year
) in
2951 (* check_date_dmy date *)
2955 (* ---------------------------------------------------------------------- *)
2956 (* conversion to unix.tm *)
2958 let dmy_to_unixtime (DMY
(Day
n, month, Year year
)) =
2960 Unix.tm_sec
= 0; (** Seconds 0..60 *)
2961 tm_min
= 0; (** Minutes 0..59 *)
2962 tm_hour
= 12; (** Hours 0..23 *)
2963 tm_mday
= n; (** Day of month 1..31 *)
2964 tm_mon
= (int_of_month month -1); (** Month of year 0..11 *)
2965 tm_year
= year
- 1900; (** Year - 1900 *)
2966 tm_wday
= 0; (** Day of week (Sunday is 0) *)
2967 tm_yday
= 0; (** Day of year 0..365 *)
2968 tm_isdst
= false; (** Daylight time savings in effect *)
2972 let unixtime_to_dmy tm =
2973 let n = tm.Unix.tm_mday
in
2974 let month = month_of_int (tm.Unix.tm_mon
+ 1) in
2975 let year = tm.Unix.tm_year
+ 1900 in
2977 DMY
(Day
n, month, Year
year)
2980 let unixtime_to_floattime tm =
2981 Unix.mktime
tm +> fst
2983 let floattime_to_unixtime sec
=
2987 let sec_to_days sec
=
2988 let minfactor = 60 in
2989 let hourfactor = 60 * 60 in
2990 let dayfactor = 60 * 60 * 24 in
2992 let days = sec
/ dayfactor in
2993 let hours = (sec
mod dayfactor) / hourfactor in
2994 let mins = (sec
mod hourfactor) / minfactor in
2995 let sec = (sec mod 60) in
2996 (* old: Printf.sprintf "%d days, %d hours, %d minutes" days hours mins *)
2997 (if days > 0 then plural days "day" ^
" " else "") ^
2998 (if hours > 0 then plural hours "hour" ^
" " else "") ^
2999 (if mins > 0 then plural mins "min" ^
" " else "") ^
3002 let sec_to_hours sec =
3003 let minfactor = 60 in
3004 let hourfactor = 60 * 60 in
3006 let hours = sec / hourfactor in
3007 let mins = (sec mod hourfactor) / minfactor in
3008 let sec = (sec mod 60) in
3009 (* old: Printf.sprintf "%d days, %d hours, %d minutes" days hours mins *)
3010 (if hours > 0 then plural hours "hour" ^
" " else "") ^
3011 (if mins > 0 then plural mins "min" ^
" " else "") ^
3016 let test_date_1 () =
3017 let date = DMY
(Day
17, Sep
, Year
1991) in
3018 let float, tm = dmy_to_unixtime date in
3019 pr2 (spf "date: %.0f" float);
3023 (* src: ferre in logfun/.../date.ml *)
3025 let day_secs : float = 86400.
3027 let today : unit -> float = fun () -> (Unix.time
() )
3028 let yesterday : unit -> float = fun () -> (Unix.time
() -. day_secs)
3029 let tomorrow : unit -> float = fun () -> (Unix.time
() +. day_secs)
3031 let lastweek : unit -> float = fun () -> (Unix.time
() -. (7.0 *. day_secs))
3032 let lastmonth : unit -> float = fun () -> (Unix.time
() -. (30.0 *. day_secs))
3035 let week_before : float_time
-> float_time
= fun d ->
3036 (d -. (7.0 *. day_secs))
3037 let month_before : float_time
-> float_time
= fun d ->
3038 (d -. (30.0 *. day_secs))
3040 let week_after : float_time
-> float_time
= fun d ->
3041 (d +. (7.0 *. day_secs))
3045 (*****************************************************************************)
3046 (* Lines/words/strings *)
3047 (*****************************************************************************)
3050 * let (list_of_string: string -> char list) = fun s ->
3051 * (enum 0 ((String.length s) - 1) +> List.map (String.get s))
3054 let _ = example (list_of_string
"abcd" =*= ['a'
;'
b'
;'
c'
;'
d'
])
3057 let rec (list_of_stream: ('a Stream.t) -> 'a list) =
3059 | [< 'c ; stream >] -> c :: list_of_stream stream
3062 let (list_of_string: string -> char list) =
3063 Stream.of_string $ list_of_stream
3067 * let (lines: string -> string list) = fun s -> ...
3070 let (lines_with_nl
: string -> string list
) = fun s ->
3071 let rec lines_aux = function
3073 | [x] -> if x =$
= "" then [] else [x ^
"\n"] (* old: [x] *)
3078 (time_func (fun () -> Str.split_delim
(Str.regexp "\n") s)) +> lines_aux
3080 (* in fact better make it return always complete lines, simplify *)
3081 (* Str.split, but lines "\n1\n2\n" dont return the \n and forget the first \n => split_delim better than split *)
3082 (* +> List.map (fun s -> s ^ "\n") but add an \n even at the end => lines_aux *)
3084 let chars = list_of_string s in
3085 chars +> List.fold_left (fun (acc, lines) char ->
3086 let newacc = acc ^ (String.make 1 char) in
3088 then ("", newacc::lines)
3089 else (newacc, lines)
3091 +> (fun (s, lines) -> List.rev (s::lines))
3094 (* CHECK: unlines (lines x) = x *)
3095 let (unlines
: string list
-> string) = fun s ->
3096 (String.concat "\n" s) ^
"\n"
3097 let (words
: string -> string list
) = fun s ->
3098 Str.split (Str.regexp "[ \t()\";]+") s
3099 let (unwords
: string list
-> string) = fun s ->
3102 let (split_space
: string -> string list
) = fun s ->
3103 Str.split (Str.regexp "[ \t\n]+") s
3108 lines
s +> List.length
3109 let _ = example (nblines "" =|= 0)
3110 let _ = example (nblines "toto" =|= 1)
3111 let _ = example (nblines "toto\n" =|= 1)
3112 let _ = example (nblines "toto\ntata" =|= 2)
3113 let _ = example (nblines "toto\ntata\n" =|= 2)
3115 (*****************************************************************************)
3117 (*****************************************************************************)
3119 let chan = open_in file
in
3120 let rec cat_orig_aux () =
3122 (* cant do input_line chan::aux() cos ocaml eval from right to left ! *)
3123 let l = input_line
chan in
3124 l :: cat_orig_aux ()
3125 with End_of_file
-> [] in
3128 (* tail recursive efficient version *)
3130 let chan = open_in file
in
3131 let rec cat_aux acc
() =
3132 (* cant do input_line chan::aux() cos ocaml eval from right to left ! *)
3133 let (b, l) = try (true, input_line
chan) with End_of_file
-> (false, "") in
3135 then cat_aux (l::acc
) ()
3138 cat_aux [] () +> List.rev
+> (fun x -> close_in
chan; x)
3140 let cat_array file
=
3141 (""::cat file
) +> Array.of_list
3144 let interpolate str
=
3146 command2 ("printf \"%s\\n\" " ^ str ^
">/tmp/caml");
3150 (* could do a print_string but printf dont like print_string *)
3151 let echo s = printf
"%s" s; flush stdout
; s
3153 let usleep s = for i = 1 to s do () done
3155 let sleep_little () =
3158 (*ignore(Sys.command ("usleep " ^ !_sleep_time))*)
3162 * let command2 s = ignore(Sys.command s)
3166 let pid = Unix.fork
() in
3170 (* Unix.setsid(); *)
3171 Sys.set_signal
Sys.sigint
(Sys.Signal_handle
(fun _ ->
3173 Unix.kill
0 Sys.sigkill
;
3181 let process_output_to_list2 = fun command
->
3182 let chan = Unix.open_process_in command
in
3183 let res = ref ([] : string list
) in
3184 let rec process_otl_aux () =
3185 let e = input_line
chan in
3187 process_otl_aux() in
3188 try process_otl_aux ()
3190 let stat = Unix.close_process_in
chan in (List.rev
!res,stat)
3191 let cmd_to_list command
=
3192 let (l,_) = process_output_to_list2 command
in l
3193 let process_output_to_list = cmd_to_list
3194 let cmd_to_list_and_status = process_output_to_list2
3197 * let command2 s = ignore(Sys.command s)
3201 let _batch_mode = ref false
3202 let command2_y_or_no cmd
=
3203 if !_batch_mode then begin command2 cmd
; true end
3206 pr2 (cmd ^
" [y/n] ?");
3207 match read_line
() with
3208 | "y" | "yes" | "Y" -> command2 cmd
; true
3209 | "n" | "no" | "N" -> false
3210 | _ -> failwith
"answer by yes or no"
3213 let command2_y_or_no_exit_if_no cmd
=
3214 let res = command2_y_or_no cmd
in
3217 else raise
(UnixExit
(1))
3222 let mkdir ?
(mode
=0o770
) file
=
3223 Unix.mkdir file mode
3225 let read_file_orig file
= cat file
+> unlines
3226 let read_file file
=
3227 let ic = open_in file
in
3228 let size = in_channel_length
ic in
3229 let buf = String.create
size in
3230 really_input
ic buf 0 size;
3235 let write_file ~file
s =
3236 let chan = open_out file
in
3237 (output_string
chan s; close_out
chan)
3240 (Unix.stat file
).Unix.st_size
3242 let filemtime file
=
3243 (Unix.stat file
).Unix.st_mtime
3245 (* opti? use wc -l ? *)
3246 let nblines_file file
=
3247 cat file
+> List.length
3249 let lfile_exists filename =
3251 (match (Unix.lstat
filename).Unix.st_kind
with
3252 | (Unix.S_REG
| Unix.S_LNK
) -> true
3256 Unix.Unix_error
(Unix.ENOENT
, _, _) -> false
3257 | Unix.Unix_error
(Unix.ENOTDIR
, _, _) -> false
3258 | Unix.Unix_error
(error
, _, fl
) ->
3260 (Printf.sprintf
"unexpected error %s for file %s"
3261 (Unix.error_message error
) fl
)
3263 let is_directory file
=
3264 (Unix.stat file
).Unix.st_kind
=*= Unix.S_DIR
3267 (* src: from chailloux et al book *)
3268 let capsule_unix f args =
3270 with Unix.Unix_error
(e, fm
, argm
) ->
3271 log (Printf.sprintf
"exn Unix_error: %s %s %s\n" (Unix.error_message
e) fm argm
)
3274 let (readdir_to_kind_list
: string -> Unix.file_kind
-> string list
) =
3278 +> List.filter
(fun s ->
3280 let stat = Unix.lstat
(path ^
"/" ^
s) in
3281 stat.Unix.st_kind
=*= kind
3283 pr2 ("EXN pb stating file: " ^
s);
3287 let (readdir_to_dir_list
: string -> string list
) = fun path
->
3288 readdir_to_kind_list path
Unix.S_DIR
3290 let (readdir_to_file_list
: string -> string list
) = fun path
->
3291 readdir_to_kind_list path
Unix.S_REG
3293 let (readdir_to_link_list
: string -> string list
) = fun path
->
3294 readdir_to_kind_list path
Unix.S_LNK
3297 let (readdir_to_dir_size_list
: string -> (string * int) list
) = fun path
->
3300 +> map_filter (fun s ->
3301 let stat = Unix.lstat
(path ^
"/" ^
s) in
3302 if stat.Unix.st_kind
=*= Unix.S_DIR
3303 then Some
(s, stat.Unix.st_size
)
3307 (* could be in control section too *)
3309 (* Why a use_cache argument ? because sometimes want disable it but dont
3310 * want put the cache_computation funcall in comment, so just easier to
3311 * pass this extra option.
3313 let cache_computation2 ?
(verbose
=false) ?
(use_cache
=true) file ext_cache
f =
3317 if not
(Sys.file_exists file
)
3318 then failwith
("can't find: " ^ file
);
3319 let file_cache = (file ^ ext_cache
) in
3320 if Sys.file_exists
file_cache &&
3321 filemtime file_cache >= filemtime file
3323 if verbose
then pr2 ("using cache: " ^
file_cache);
3324 get_value file_cache
3328 write_value res file_cache;
3332 let cache_computation ?verbose ?use_cache a
b c =
3333 profile_code "Common.cache_computation" (fun () ->
3334 cache_computation2 ?verbose ?use_cache a
b c)
3337 let cache_computation_robust2
3338 dest_dir file ext_cache
3339 (need_no_changed_files
, need_no_changed_variables
) ext_depend
3341 (if not
(Sys.file_exists file
)
3342 then failwith
("can't find: " ^ file
));
3344 let (file_cache,dependencies_cache
) =
3345 let file_cache = (file ^ ext_cache
) in
3346 let dependencies_cache = (file ^ ext_depend
) in
3348 None
-> (file_cache, dependencies_cache)
3352 (if String.get
file_cache 0 =*= '
/'
3353 then String.sub
file_cache 1 ((String.length
file_cache) - 1)
3355 let dependencies_cache =
3357 (if String.get
dependencies_cache 0 =*= '
/'
3359 String.sub
dependencies_cache 1
3360 ((String.length
dependencies_cache) - 1)
3361 else dependencies_cache) in
3363 (Printf.sprintf
"mkdir -p %s" (Filename.dirname file_cache)) in
3364 (file_cache,dependencies_cache) in
3367 (* could do md5sum too *)
3368 ((file
::need_no_changed_files
) +> List.map
(fun f -> f, filemtime f),
3369 need_no_changed_variables
)
3372 if Sys.file_exists
dependencies_cache &&
3373 get_value dependencies_cache =*= dependencies
3376 pr2 ("cache computation reuse " ^ file);*)
3377 get_value file_cache
3380 (*pr2 ("cache computation recompute " ^ file);*)
3382 write_value dependencies dependencies_cache;
3383 write_value res file_cache;
3387 let cache_computation_robust a
b c d e =
3388 profile_code "Common.cache_computation_robust" (fun () ->
3389 cache_computation_robust2 None a
b c d e)
3391 let cache_computation_robust_in_dir a
b c d e f =
3392 profile_code "Common.cache_computation_robust" (fun () ->
3393 cache_computation_robust2 a
b c d e f)
3398 (* dont forget that cmd_to_list call bash and so pattern may contain
3399 * '*' symbols that will be expanded, so can do glob "*.c"
3402 cmd_to_list ("ls -1 " ^ pattern
)
3405 (* update: have added the -type f, so normally need less the sanity_check_xxx
3407 let files_of_dir_or_files ext
xs =
3408 xs +> List.map
(fun x ->
3410 then cmd_to_list ("find " ^
x ^
" -noleaf -type f -name \"*." ^ext^
"\"")
3415 let files_of_dir_or_files_no_vcs ext
xs =
3416 xs +> List.map
(fun x ->
3420 ("find " ^
x ^
" -noleaf -type f -name \"*." ^ext^
"\"" ^
3421 "| grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/ |grep -v /_darcs/"
3427 let files_of_dir_or_files_no_vcs_post_filter regex
xs =
3428 xs +> List.map
(fun x ->
3433 " -noleaf -type f | grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/ |grep -v /_darcs/"
3435 +> List.filter
(fun s -> s =~ regex
)
3440 let sanity_check_files_and_adjust ext files
=
3441 let files = files +> List.filter
(fun file
->
3442 if not
(file
=~
(".*\\."^ext
))
3444 pr2 ("warning: seems not a ."^ext^
" file");
3448 if is_directory file
3450 pr2 (spf "warning: %s is a directory" file
);
3460 (* taken from mlfuse, the predecessor of ocamlfuse *)
3461 type rwx
= [`R
|`W
|`X
] list
3462 let file_perm_of : u
:rwx
-> g
:rwx
-> o:rwx
-> Unix.file_perm
=
3465 List.fold_left
(fun acc p
-> acc
lor ((function `R
-> 4 | `W
-> 2 | `X
-> 1) p
)) 0 l in
3467 ((to_oct u
) lsl 6) lor
3468 ((to_oct g
) lsl 3) lor
3477 let _ = Sys.getenv var
in true
3478 with Not_found
-> false
3480 (* emacs/lisp inspiration (eric cooper and yaron minsky use that too) *)
3481 let (with_open_outfile
: filename -> (((string -> unit) * out_channel
) -> 'a
) -> 'a
) =
3483 let chan = open_out file
in
3484 let pr s = output_string
chan s in
3485 unwind_protect (fun () ->
3486 let res = f (pr, chan) in
3489 (fun e -> close_out
chan)
3491 let (with_open_infile
: filename -> ((in_channel
) -> 'a
) -> 'a
) = fun file
f ->
3492 let chan = open_in file
in
3493 unwind_protect (fun () ->
3497 (fun e -> close_in
chan)
3500 let (with_open_outfile_append
: filename -> (((string -> unit) * out_channel
) -> 'a
) -> 'a
) =
3502 let chan = open_out_gen
[Open_creat
;Open_append
] 0o666 file
in
3503 let pr s = output_string
chan s in
3504 unwind_protect (fun () ->
3505 let res = f (pr, chan) in
3508 (fun e -> close_out
chan)
3515 (* it seems that the toplevel block such signals, even with this explicit
3517 * let _ = Unix.sigprocmask Unix.SIG_UNBLOCK [Sys.sigalrm]
3520 (* could be in Control section *)
3522 (* subtil: have to make sure that timeout is not intercepted before here, so
3523 * avoid exn handle such as try (...) with _ -> cos timeout will not bubble up
3524 * enough. In such case, add a case before such as
3525 * with Timeout -> raise Timeout | _ -> ...
3527 * question: can we have a signal and so exn when in a exn handler ?
3530 let interval_timer = ref true
3532 let timeout_function timeoutval
= fun f ->
3537 Sys.set_signal
Sys.sigvtalrm
3538 (Sys.Signal_handle
(fun _ -> raise Timeout
));
3540 (Unix.setitimer
Unix.ITIMER_VIRTUAL
3541 {Unix.it_interval
=float_of_int timeoutval
;
3542 Unix.it_value
=float_of_int timeoutval
});
3544 ignore
(Unix.alarm
0);
3549 Sys.set_signal
Sys.sigalrm
3550 (Sys.Signal_handle
(fun _ -> raise Timeout
));
3551 ignore
(Unix.alarm timeoutval
);
3553 ignore
(Unix.alarm
0);
3558 log "timeout (we abort)";
3559 (*pr2 (List.hd(cmd_to_list "free -m | grep Mem"));*)
3563 (* subtil: important to disable the alarm before relaunching the exn,
3564 * otherwise the alarm is still running.
3566 * robust?: and if alarm launched after the log (...) ?
3567 * Maybe signals are disabled when process an exception handler ?
3570 ignore
(Unix.alarm
0);
3571 (* log ("exn while in transaction (we abort too, even if ...) = " ^
3572 Printexc.to_string e);
3574 log "exn while in timeout_function";
3578 let timeout_function_opt timeoutvalopt
f =
3579 match timeoutvalopt
with
3581 | Some
x -> timeout_function x f
3585 (* creation of tmp files, a la gcc *)
3587 let _temp_files_created = ref ([] : filename list
)
3589 (* ex: new_temp_file "cocci" ".c" will give "/tmp/cocci-3252-434465.c" *)
3590 let new_temp_file prefix suffix
=
3591 let processid = i_to_s (Unix.getpid
()) in
3592 let tmp_file = Filename.temp_file
(prefix ^
"-" ^
processid ^
"-") suffix
in
3593 push2 tmp_file _temp_files_created;
3597 let save_tmp_files = ref false
3598 let erase_temp_files () =
3599 if not
!save_tmp_files then begin
3600 !_temp_files_created +> List.iter
(fun s ->
3601 (* pr2 ("erasing: " ^ s); *)
3602 command2 ("rm -f " ^
s)
3604 _temp_files_created := []
3607 let erase_this_temp_file f =
3608 if not
!save_tmp_files then begin
3609 _temp_files_created :=
3610 List.filter
(function x -> not
(x =$
= f)) !_temp_files_created;
3611 command2 ("rm -f " ^
f)
3615 (* now in prelude: exception UnixExit of int *)
3616 let exn_to_real_unixexit f =
3618 with UnixExit
x -> exit
x
3624 with_open_outfile file
(fun (pr,_chan) ->
3625 xs +> List.iter
(fun s -> pr s; pr "\n");
3634 (*****************************************************************************)
3636 (*****************************************************************************)
3639 let uncons l = (List.hd
l, List.tl
l)
3642 let safe_tl l = try List.tl
l with _ -> []
3650 | ([],_) -> failwith
"zip: not same length"
3651 | (_,[]) -> failwith
"zip: not same length"
3652 | (x::xs,y::ys
) -> (x,y)::zip xs ys
3654 let rec zip_safe xs ys
=
3658 | (x::xs,y::ys
) -> (x,y)::zip_safe xs ys
3661 List.fold_right
(fun e (xs, ys
) ->
3662 (fst e::xs), (snd e::ys
)) zs
([],[])
3665 let map_withkeep f xs =
3666 xs +> List.map
(fun x -> f x, x)
3669 * let rec take n xs =
3672 * | (_,[]) -> failwith "take: not enough"
3673 * | (n,x::xs) -> x::take (n-1) xs
3676 let rec take_safe n xs =
3680 | (n,x::xs) -> x::take_safe (n-1) xs
3682 let rec take_until p
= function
3684 | x::xs -> if p
x then [] else x::(take_until p
xs)
3686 let take_while p
= take_until (p $ not
)
3689 (* now in prelude: let rec drop n xs = ... *)
3690 let _ = example (drop 3 [1;2;3;4] =*= [4])
3692 let rec drop_while p
= function
3694 | x::xs -> if p
x then drop_while p
xs else x::xs
3697 let rec drop_until p
xs =
3698 drop_while (fun x -> not
(p
x)) xs
3699 let _ = example (drop_until (fun x -> x =|= 3) [1;2;3;4;5] =*= [3;4;5])
3702 let span p
xs = (take_while p
xs, drop_while p
xs)
3705 let rec (span: ('a
-> bool) -> 'a list
-> 'a list
* 'a list
) =
3710 let (l1
, l2
) = span p
xs in
3713 let _ = example ((span (fun x -> x <= 3) [1;2;3;4;1;2] =*= ([1;2;3],[4;1;2])))
3715 let rec groupBy eq
l =
3719 let (xs1
,xs2
) = List.partition
(fun x'
-> eq
x x'
) xs in
3720 (x::xs1
)::(groupBy eq xs2
)
3722 let rec group_by_mapped_key fkey
l =
3727 let (xs1
,xs2
) = List.partition
(fun x'
-> let k2 = fkey
x'
in k=*=k2) xs
3729 (k, (x::xs1
))::(group_by_mapped_key fkey xs2
)
3734 let (exclude_but_keep_attached
: ('a
-> bool) -> 'a list
-> ('a
* 'a list
) list
)=
3736 let rec aux_filter acc ans
= function
3737 | [] -> (* drop what was accumulated because nothing to attach to *)
3741 then aux_filter (x::acc
) ans
xs
3742 else aux_filter [] ((x, List.rev acc
)::ans
) xs
3746 (exclude_but_keep_attached
(fun x -> x =|= 3) [3;3;1;3;2;3;3;3] =*=
3747 [(1,[3;3]);(2,[3])])
3749 let (group_by_post
: ('a
-> bool) -> 'a list
-> ('a list
* 'a
) list
* 'a list
)=
3751 let rec aux_filter grouped_acc acc
= function
3753 List.rev grouped_acc
, List.rev acc
3757 aux_filter ((List.rev acc
,x)::grouped_acc
) [] xs
3759 aux_filter grouped_acc
(x::acc
) xs
3764 (group_by_post
(fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*=
3765 ([([1;1],3);([2],3);[4;5],3], [6;6;6]))
3767 let (group_by_pre
: ('a
-> bool) -> 'a list
-> 'a list
* ('a
* 'a list
) list
)=
3769 let xs'
= List.rev
xs in
3770 let (ys
, unclassified
) = group_by_post
f xs'
in
3771 List.rev unclassified
,
3772 ys
+> List.rev
+> List.map
(fun (xs, x) -> x, List.rev
xs )
3775 (group_by_pre
(fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*=
3776 ([1;1], [(3,[2]); (3,[4;5]); (3,[6;6;6])]))
3779 let (split_when
: ('a
-> bool) -> 'a list
-> 'a list
* 'a
* 'a list
) =
3781 let rec loop acc
= function
3782 | [] -> raise Not_found
3786 else loop (x :: acc
) xs in
3788 let _ = example (split_when
(fun x -> x =|= 3)
3789 [1;2;3;4;1;2] =*= ([1;2],3,[4;1;2]))
3792 (* not so easy to come up with ... used in aComment for split_paragraph *)
3793 let rec split_gen_when_aux f acc
xs =
3800 (match f (x::xs) with
3802 split_gen_when_aux f (x::acc
) xs
3804 let before = List.rev acc
in
3806 then split_gen_when_aux f [] rest
3807 else before::split_gen_when_aux f [] rest
3809 (* could avoid introduce extra aux function by using ?(acc = []) *)
3810 let split_gen_when f xs =
3811 split_gen_when_aux f [] xs
3815 (* generate exception (Failure "tl") if there is no element satisfying p *)
3816 let rec (skip_until
: ('a list
-> bool) -> 'a list
-> 'a list
) = fun p
xs ->
3817 if p
xs then xs else skip_until p
(List.tl
xs)
3819 (skip_until
(function 1::2::xs -> true | _ -> false)
3820 [1;3;4;1;2;4;5] =*= [1;2;4;5])
3822 let rec skipfirst e = function
3824 | e'
::l when e =*= e'
-> skipfirst e l
3829 * let rec enum x n = ...
3834 if null xs then [] (* enum 0 (-1) generate an exception *)
3835 else zip xs (enum 0 ((List.length
xs) -1))
3837 let index_list_and_total xs =
3838 let total = List.length
xs in
3839 if null xs then [] (* enum 0 (-1) generate an exception *)
3840 else zip xs (enum 0 ((List.length
xs) -1))
3841 +> List.map
(fun (a
,b) -> (a
,b,total))
3843 let index_list_1 xs =
3844 xs +> index_list +> List.map
(fun (x,i) -> x, i+1)
3846 let or_list = List.fold_left
(||) false
3847 let and_list = List.fold_left
(&&) true
3850 let sum = sum_int xs in
3851 (float_of_int
sum) /. (float_of_int
(List.length
xs))
3853 let snoc x xs = xs @ [x]
3854 let cons x xs = x::xs
3856 let head_middle_tail xs =
3860 let reversed = List.rev
(y::xs) in
3861 let tail = List.hd
reversed in
3862 let middle = List.rev
(List.tl
reversed) in
3864 | _ -> failwith
"head_middle_tail, too small list"
3866 let _ = assert_equal (head_middle_tail [1;2;3]) (1, [2], 3)
3867 let _ = assert_equal (head_middle_tail [1;3]) (1, [], 3)
3873 (* let (++) = (@), could do that, but if load many times the common, then pb *)
3874 (* let (++) l1 l2 = List.fold_right (fun x acc -> x::acc) l1 l2 *)
3877 let newxs = List.filter
(fun y -> y <> x) xs in
3878 assert (List.length
newxs =|= List.length
xs - 1);
3883 List.filter
(fun x -> not
(p
x)) xs
3888 let fold_k f lastk acc
xs =
3889 let rec fold_k_aux acc
= function
3892 f acc
x (fun acc
-> fold_k_aux acc
xs)
3897 let rec list_init = function
3898 | [] -> raise Not_found
3900 | x::y::xs -> x::(list_init (y::xs))
3902 let rec list_last = function
3903 | [] -> raise Not_found
3905 | x::y::xs -> list_last (y::xs)
3909 * let last_n n l = List.rev (take n (List.rev l))
3910 * let last l = List.hd (last_n 1 l)
3913 let rec join_gen a
= function
3916 | x::xs -> x::a
::(join_gen a
xs)
3919 (* todo: foldl, foldr (a more consistent foldr) *)
3922 let iter_index f l =
3923 let rec iter_ n = function
3925 | e::l -> f e n ; iter_ (n+1) l
3929 let rec map_ n = function
3931 | e::l -> f e n :: map_ (n+1) l
3936 let filter_index f l =
3937 let rec filt i = function
3939 | e::l -> if f i e then e :: filt (i+1) l else filt (i+1) l
3944 let do_withenv doit
f env
l =
3945 let r_env = ref env
in
3946 let l'
= doit
(fun e ->
3947 let e'
, env'
= f !r_env e in
3953 * let fold_left_with_index f acc = ...
3956 let map_withenv f env
e = do_withenv List.map
f env
e
3958 let rec collect_accu f accu
= function
3960 | e::l -> collect_accu f (List.rev_append
(f e) accu
) l
3962 let collect f l = List.rev
(collect_accu f [] l)
3964 (* cf also List.partition *)
3966 let rec fpartition p
l =
3967 let rec part yes no
= function
3968 | [] -> (List.rev yes
, List.rev no
)
3971 | None
-> part yes
(x :: no
) l
3972 | Some
v -> part (v :: yes
) no
l) in
3977 let rec removelast = function
3978 | [] -> failwith
"removelast"
3980 | e::l -> e :: removelast l
3982 let remove x = List.filter
(fun y -> y != x)
3983 let empty list
= null list
3986 let rec inits = function
3988 | e::l -> [] :: List.map
(fun l -> e::l) (inits l)
3990 let rec tails = function
3992 | (_::xs) as xxs
-> xxs
:: tails xs
3995 let reverse = List.rev
3999 let fold_left = List.fold_left
4000 let rev_map = List.rev_map
4003 let rec fold_right1 f = function
4004 | [] -> failwith
"fold_right1"
4006 | e::l -> f e (fold_right1 f l)
4008 let maximum l = foldl1 max
l
4009 let minimum l = foldl1 min l
4011 (* do a map tail recursive, and result is reversed, it is a tail recursive map => efficient *)
4012 let map_eff_rev = fun f l ->
4013 let rec map_eff_aux acc
=
4016 | x::xs -> map_eff_aux ((f x)::acc
) xs
4021 let rec loop acc
= function
4023 | x::xs -> loop ((f x)::acc
) xs in
4027 let rec (generate
: int -> 'a
-> 'a list
) = fun i el
->
4029 else el
::(generate
(i-1) el
)
4031 let rec uniq = function
4033 | e::l -> if List.mem
e l then uniq l else e :: uniq l
4035 let has_no_duplicate xs =
4036 List.length
xs =|= List.length
(uniq xs)
4037 let is_set_as_list = has_no_duplicate
4040 let rec get_duplicates xs =
4045 then x::get_duplicates xs (* todo? could x from xs to avoid double dups?*)
4046 else get_duplicates xs
4048 let rec all_assoc e = function
4050 | (e'
,v) :: l when e=*=e'
-> v :: all_assoc e l
4051 | _ :: l -> all_assoc e l
4053 let prepare_want_all_assoc l =
4054 List.map
(fun n -> n, uniq (all_assoc n l)) (uniq (List.map
fst l))
4056 let rotate list
= List.tl list
++ [(List.hd list
)]
4058 let or_list = List.fold_left (||) false
4059 let and_list = List.fold_left (&&) true
4061 let rec (return_when
: ('a
-> '
b option) -> 'a list
-> '
b) = fun p
-> function
4062 | [] -> raise Not_found
4063 | x::xs -> (match p
x with None
-> return_when p
xs | Some
b -> b)
4065 let rec splitAt n xs =
4066 if n =|= 0 then ([],xs)
4070 | (x::xs) -> let (a
,b) = splitAt (n-1) xs in (x::a
, b)
4074 let rec pack_aux l i = function
4075 | [] -> failwith
"not on a boundary"
4076 | [x] -> if i =|= n then [l++[x]] else failwith
"not on a boundary"
4079 then (l++[x])::(pack_aux [] 1 xs)
4080 else pack_aux (l++[x]) (i+1) xs
4084 let min_with f = function
4085 | [] -> raise Not_found
4087 let rec min_with_ min_val min_elt
= function
4092 then min_with_ val_ e l
4093 else min_with_ min_val min_elt
l
4094 in min_with_ (f e) e l
4096 let two_mins_with f = function
4098 let rec min_with_ min_val min_elt min_val2 min_elt2
= function
4099 | [] -> min_elt
, min_elt2
4105 then min_with_ val_ e min_val min_elt
l
4106 else min_with_ min_val min_elt
val_ e l
4107 else min_with_ min_val min_elt min_val2 min_elt2
l
4111 if v1 < v2 then min_with_ v1 e1
v2 e2
l else min_with_ v2 e2
v1 e1
l
4112 | _ -> raise Not_found
4114 let grep_with_previous f = function
4117 let rec grep_with_previous_ previous
= function
4119 | e::l -> if f previous
e then e :: grep_with_previous_ e l else grep_with_previous_ previous
l
4120 in e :: grep_with_previous_ e l
4122 let iter_with_previous f = function
4125 let rec iter_with_previous_ previous
= function
4127 | e::l -> f previous
e ; iter_with_previous_ e l
4128 in iter_with_previous_ e l
4131 let iter_with_before_after f xs =
4132 let rec aux before_rev after
=
4137 aux (x::before_rev
) xs
4143 (* kind of cartesian product of x*x *)
4144 let rec (get_pair
: ('a list
) -> (('a
* 'a
) list
)) = function
4146 | x::xs -> (List.map
(fun y -> (x,y)) xs) ++ (get_pair
xs)
4149 (* retourne le rang dans une liste d'un element *)
4150 let rang elem liste
=
4151 let rec rang_rec elem accu
= function
4152 | [] -> raise Not_found
4153 | a
::l -> if a
=*= elem
then accu
4154 else rang_rec elem
(accu
+1) l in
4155 rang_rec elem
1 liste
4157 (* retourne vrai si une liste contient des doubles *)
4158 let rec doublon = function
4160 | a
::l -> if List.mem a
l then true
4163 let rec (insert_in
: 'a
-> 'a list
-> 'a list list
) = fun x -> function
4165 | y::ys
-> (x::y::ys
) :: (List.map
(fun xs -> y::xs) (insert_in
x ys
))
4166 (* insert_in 3 [1;2] = [[3; 1; 2]; [1; 3; 2]; [1; 2; 3]] *)
4168 let rec (permutation
: 'a list
-> 'a list list
) = function
4171 | x::xs -> List.flatten
(List.map
(insert_in
x) (permutation
xs))
4172 (* permutation [1;2;3] =
4173 * [[1; 2; 3]; [2; 1; 3]; [2; 3; 1]; [1; 3; 2]; [3; 1; 2]; [3; 2; 1]]
4177 let rec remove_elem_pos pos
xs =
4178 match (pos
, xs) with
4179 | _, [] -> failwith
"remove_elem_pos"
4181 | n, x::xs -> x::(remove_elem_pos (n-1) xs)
4183 let rec insert_elem_pos (e, pos
) xs =
4184 match (pos
, xs) with
4186 | n, x::xs -> x::(insert_elem_pos (e, (n-1)) xs)
4187 | n, [] -> failwith
"insert_elem_pos"
4189 let rec uncons_permut xs =
4190 let indexed = index_list xs in
4191 indexed +> List.map
(fun (x, pos
) -> (x, pos
), remove_elem_pos pos
xs)
4194 (uncons_permut ['a'
;'
b'
;'
c'
] =*=
4195 [('a'
, 0), ['
b'
;'
c'
];
4196 ('
b'
, 1), ['a'
;'
c'
];
4200 let rec uncons_permut_lazy xs =
4201 let indexed = index_list xs in
4202 indexed +> List.map
(fun (x, pos
) ->
4204 lazy (remove_elem_pos pos
xs)
4211 let rec map_flatten f l =
4212 let rec map_flatten_aux accu
= function
4214 | e :: l -> map_flatten_aux (List.rev (f e) ++ accu
) l
4215 in List.rev (map_flatten_aux [] l)
4218 let rec repeat e n =
4219 let rec repeat_aux acc
= function
4221 | n when n < 0 -> failwith
"repeat"
4222 | n -> repeat_aux (e::acc
) (n-1) in
4225 let rec map2 f = function
4227 | x::xs -> let r = f x in r::map2 f xs
4230 let rec map3_aux acc
= function
4232 | x::xs -> map3_aux (f x::acc
) xs in
4236 let tails2 xs = map rev (inits (rev xs))
4237 let res = tails2 [1;2;3;4]
4238 let res = tails [1;2;3;4]
4242 let pack_sorted same
xs =
4243 let rec pack_s_aux acc
xs =
4245 | ((cur
,rest
),[]) -> cur
::rest
4246 | ((cur
,rest
), y::ys
) ->
4247 if same
(List.hd cur
) y then pack_s_aux (y::cur
, rest
) ys
4248 else pack_s_aux ([y], cur
::rest
) ys
4249 in pack_s_aux ([List.hd
xs],[]) (List.tl
xs) +> List.rev
4250 let test = pack_sorted (=*=) [1;1;1;2;2;3;4]
4253 let rec keep_best f =
4254 let rec partition e = function
4258 | None
-> let (e''
, l'
) = partition e l in e''
, e'
:: l'
4259 | Some
e''
-> partition e''
l
4263 let (e'
, l'
) = partition e l in
4264 e'
:: keep_best f l'
4266 let rec sorted_keep_best f = function
4271 | None
-> a
:: sorted_keep_best f (b :: l)
4272 | Some
e -> sorted_keep_best f (e :: l)
4276 let (cartesian_product
: 'a list
-> '
b list
-> ('a
* '
b) list
) = fun xs ys
->
4277 xs +> List.map
(fun x -> ys
+> List.map
(fun y -> (x,y)))
4280 let _ = assert_equal
4281 (cartesian_product
[1;2] ["3";"4";"5"])
4282 [1,"3";1,"4";1,"5"; 2,"3";2,"4";2,"5"]
4285 profile_code "Common.sort_by_xxx" (fun () -> List.sort a
b)
4287 let sort_by_val_highfirst xs =
4288 sort_prof (fun (k1
,v1) (k2,v2) -> compare
v2 v1) xs
4289 let sort_by_val_lowfirst xs =
4290 sort_prof (fun (k1
,v1) (k2,v2) -> compare
v1 v2) xs
4292 let sort_by_key_highfirst xs =
4293 sort_prof (fun (k1
,v1) (k2,v2) -> compare
k2 k1
) xs
4294 let sort_by_key_lowfirst xs =
4295 sort_prof (fun (k1
,v1) (k2,v2) -> compare k1
k2) xs
4297 let _ = example (sort_by_key_lowfirst [4, (); 7,()] =*= [4,(); 7,()])
4298 let _ = example (sort_by_key_highfirst [4,(); 7,()] =*= [7,(); 4,()])
4301 let sortgen_by_key_highfirst xs =
4302 sort_prof (fun (k1
,v1) (k2,v2) -> compare
k2 k1
) xs
4303 let sortgen_by_key_lowfirst xs =
4304 sort_prof (fun (k1
,v1) (k2,v2) -> compare k1
k2) xs
4306 (*----------------------------------*)
4308 (* sur surEnsemble [p1;p2] [[p1;p2;p3] [p1;p2] ....] -> [[p1;p2;p3] ... *)
4309 (* mais pas p2;p3 *)
4311 let surEnsemble liste_el liste_liste_el
=
4313 (function liste_elbis
->
4314 List.for_all
(function el
-> List.mem el liste_elbis
) liste_el
4319 (*----------------------------------*)
4320 (* combinaison/product/.... (aop) *)
4321 (* 123 -> 123 12 13 23 1 2 3 *)
4322 let rec realCombinaison = function
4326 let res = realCombinaison l in
4327 let res2 = List.map
(function x -> a
::x) res in
4328 res2 ++ res ++ [[a
]]
4330 (* genere toutes les combinaisons possible de paire *)
4331 (* par exemple combinaison [1;2;4] -> [1, 2; 1, 4; 2, 4] *)
4332 let rec combinaison = function
4336 | a
::b::l -> (List.map
(function elem
-> (a
, elem
)) (b::l)) ++
4337 (combinaison (b::l))
4339 (*----------------------------------*)
4341 (* list of list(aop) *)
4342 (* insere elem dans la liste de liste (si elem est deja present dans une de *)
4343 (* ces listes, on ne fait rien *)
4344 let rec insere elem
= function
4347 if (List.mem elem a
) then a
::l
4348 else a
::(insere elem
l)
4350 let rec insereListeContenant lis el
= function
4353 if List.mem el a
then
4354 (List.append lis a
)::l
4355 else a
::(insereListeContenant lis el
l)
4357 (* fusionne les listes contenant et1 et et2 dans la liste de liste*)
4358 let rec fusionneListeContenant (et1
, et2
) = function
4359 | [] -> [[et1
; et2
]]
4361 (* si les deux sont deja dedans alors rien faire *)
4362 if List.mem et1 a
then
4363 if List.mem et2 a
then a
::l
4365 insereListeContenant a et2
l
4366 else if List.mem et2 a
then
4367 insereListeContenant a et1
l
4368 else a
::(fusionneListeContenant (et1
, et2
) l)
4370 (*****************************************************************************)
4372 (*****************************************************************************)
4374 (* do bound checking ? *)
4375 let array_find_index f a
=
4376 let rec array_find_index_ i =
4377 if f i then i else array_find_index_ (i+1)
4379 try array_find_index_ 0 with _ -> raise Not_found
4381 let array_find_index_via_elem f a
=
4382 let rec array_find_index_ i =
4383 if f a
.(i) then i else array_find_index_ (i+1)
4385 try array_find_index_ 0 with _ -> raise Not_found
4389 type idx
= Idx
of int
4390 let next_idx (Idx
i) = (Idx
(i+1))
4391 let int_of_idx (Idx
i) = i
4393 let array_find_index_typed f a
=
4394 let rec array_find_index_ i =
4395 if f i then i else array_find_index_ (next_idx i)
4397 try array_find_index_ (Idx
0) with _ -> raise Not_found
4401 (*****************************************************************************)
4403 (*****************************************************************************)
4405 type 'a matrix
= 'a array array
4407 let map_matrix f mat =
4408 mat +> Array.map
(fun arr
-> arr
+> Array.map
f)
4410 let (make_matrix_init
:
4411 nrow
:int -> ncolumn
:int -> (int -> int -> 'a
) -> 'a matrix
) =
4412 fun ~nrow ~ncolumn
f ->
4413 Array.init nrow
(fun i ->
4414 Array.init ncolumn
(fun j ->
4419 let iter_matrix f m =
4420 Array.iteri
(fun i e ->
4421 Array.iteri
(fun j x ->
4426 let nb_rows_matrix m =
4429 let nb_columns_matrix m =
4430 assert(Array.length
m > 0);
4433 (* check all nested arrays have the same size *)
4434 let invariant_matrix m =
4437 let (rows_of_matrix
: 'a matrix
-> 'a list list
) = fun m ->
4438 Array.to_list
m +> List.map
Array.to_list
4440 let (columns_of_matrix
: 'a matrix
-> 'a list list
) = fun m ->
4441 let nbcols = nb_columns_matrix m in
4442 let nbrows = nb_rows_matrix m in
4443 (enum 0 (nbcols -1)) +> List.map
(fun j ->
4444 (enum 0 (nbrows -1)) +> List.map
(fun i ->
4449 let all_elems_matrix_by_row m =
4450 rows_of_matrix
m +> List.flatten
4471 let _ = example (rows_of_matrix
ex_matrix1 =*= ex_rows1)
4472 let _ = example (columns_of_matrix
ex_matrix1 =*= ex_columns1)
4475 (*****************************************************************************)
4477 (*****************************************************************************)
4479 module B_Array = Bigarray.Array2
4488 (* for the string_of auto generation of camlp4
4489 val b_array_string_of_t : 'a -> 'b -> string
4490 val bigarray_string_of_int16_unsigned_elt : 'a -> string
4491 val bigarray_string_of_c_layout : 'a -> string
4492 let b_array_string_of_t f a = "<>"
4493 let bigarray_string_of_int16_unsigned_elt a = "<>"
4494 let bigarray_string_of_c_layout a = "<>"
4499 (*****************************************************************************)
4500 (* Set. Have a look too at set*.mli *)
4501 (*****************************************************************************)
4502 type 'a set
= 'a list
4505 let (empty_set
: 'a set
) = []
4506 let (insert_set
: 'a
-> 'a set
-> 'a set
) = fun x xs ->
4508 then (* let _ = print_string "warning insert: already exist" in *)
4515 let (single_set
: 'a
-> 'a set
) = fun x -> insert_set
x empty_set
4516 let (set
: 'a list
-> 'a set
) = fun xs ->
4517 xs +> List.fold_left (flip insert_set
) empty_set
4519 let (exists_set
: ('a
-> bool) -> 'a set
-> bool) = List.exists
4520 let (forall_set
: ('a
-> bool) -> 'a set
-> bool) = List.for_all
4521 let (filter_set
: ('a
-> bool) -> 'a set
-> 'a set
) = List.filter
4522 let (fold_set
: ('a
-> '
b -> 'a
) -> 'a
-> '
b set
-> 'a
) = List.fold_left
4523 let (map_set
: ('a
-> '
b) -> 'a set
-> '
b set
) = List.map
4524 let (member_set
: 'a
-> 'a set
-> bool) = List.mem
4526 let find_set = List.find
4527 let sort_set = List.sort
4528 let iter_set = List.iter
4530 let (top_set
: 'a set
-> 'a
) = List.hd
4532 let (inter_set
: 'a set
-> 'a set
-> 'a set
) = fun s1 s2
->
4533 s1
+> fold_set
(fun acc
x -> if member_set
x s2
then insert_set
x acc
else acc
) empty_set
4534 let (union_set
: 'a set
-> 'a set
-> 'a set
) = fun s1 s2
->
4535 s2
+> fold_set
(fun acc
x -> if member_set
x s1
then acc
else insert_set
x acc
) s1
4536 let (minus_set
: 'a set
-> 'a set
-> 'a set
) = fun s1 s2
->
4537 s1
+> filter_set
(fun x -> not
(member_set
x s2
))
4540 let union_all l = List.fold_left union_set
[] l
4542 let big_union_set f xs = xs +> map_set
f +> fold_set union_set empty_set
4544 let (card_set
: 'a set
-> int) = List.length
4546 let (include_set
: 'a set
-> 'a set
-> bool) = fun s1 s2
->
4547 (s1
+> forall_set
(fun p
-> member_set p s2
))
4549 let equal_set s1 s2
= include_set s1 s2
&& include_set s2 s1
4551 let (include_set_strict
: 'a set
-> 'a set
-> bool) = fun s1 s2
->
4552 (card_set s1
< card_set s2
) && (include_set s1 s2
)
4554 let ($
*$
) = inter_set
4555 let ($
+$
) = union_set
4556 let ($
-$
) = minus_set
4557 let ($?$
) a
b = profile_code "$?$" (fun () -> member_set a
b)
4558 let ($
<$
) = include_set_strict
4559 let ($
<=$
) = include_set
4560 let ($
=$
) = equal_set
4562 (* as $+$ but do not check for memberness, allow to have set of func *)
4563 let ($
@$
) = fun a
b -> a
@ b
4565 let rec nub = function
4567 | x::xs -> if List.mem
x xs then nub xs else x::(nub xs)
4569 (*****************************************************************************)
4570 (* Set as normal list *)
4571 (*****************************************************************************)
4573 let (union: 'a list -> 'a list -> 'a list) = fun l1 l2 ->
4574 List.fold_left (fun acc x -> if List.mem x l1 then acc else x::acc) l1 l2
4576 let insert_normal x xs = union xs [x]
4578 (* retourne lis1 - lis2 *)
4579 let minus l1 l2
= List.filter
(fun x -> not
(List.mem
x l2
)) l1
4581 let inter l1 l2
= List.fold_left (fun acc
x -> if List.mem
x l2
then x::acc
else acc
) [] l1
4583 let union_list = List.fold_left union
[]
4586 List.fold_left (function acc
-> function el
-> union
[el
] acc
) [] lis
4589 let rec non_uniq = function
4591 | e::l -> if mem
e l then e :: non_uniq l else non_uniq l
4593 let rec inclu lis1 lis2
=
4594 List.for_all
(function el
-> List.mem el lis2
) lis1
4596 let equivalent lis1 lis2
=
4597 (inclu lis1 lis2
) && (inclu lis2 lis1
)
4602 (*****************************************************************************)
4603 (* Set as sorted list *)
4604 (*****************************************************************************)
4605 (* liste trie, cos we need to do intersection, and insertion (it is a set
4606 cos when introduce has, if we create a new has => must do a recurse_rep
4607 and another categ can have to this has => must do an union
4610 let rec insert x = function
4614 else (if x < y then x::y::ys else y::(insert x ys))
4616 (* same, suppose sorted list *)
4617 let rec intersect x y =
4622 if x = y then x::(intersect xs ys
)
4624 (if x < y then intersect xs (y::ys
)
4625 else intersect (x::xs) ys
4627 (* intersect [1;3;7] [2;3;4;7;8];; *)
4630 (*****************************************************************************)
4632 (*****************************************************************************)
4633 type ('a
,'
b) assoc = ('a
* '
b) list
4637 let (assoc_to_function
: ('a
, '
b) assoc -> ('a
-> '
b)) = fun xs ->
4638 xs +> List.fold_left (fun acc
(k, v) ->
4640 if k =*= k'
then v else acc
k'
4641 )) (fun k -> failwith
"no key in this assoc")
4643 let (assoc_to_function: ('a, 'b) assoc -> ('a -> 'b)) = fun xs ->
4644 fun k -> List.assoc k xs
4647 let (empty_assoc
: ('a
, '
b) assoc) = []
4648 let fold_assoc = List.fold_left
4649 let insert_assoc = fun x xs -> x::xs
4650 let map_assoc = List.map
4651 let filter_assoc = List.filter
4653 let assoc = List.assoc
4654 let keys xs = List.map
fst xs
4658 (* assert unique key ?*)
4659 let del_assoc key
xs = xs +> List.filter
(fun (k,v) -> k <> key
)
4660 let replace_assoc (key
, v) xs = insert_assoc (key
, v) (del_assoc key
xs)
4662 let apply_assoc key
f xs =
4663 let old = assoc key
xs in
4664 replace_assoc (key
, f old) xs
4666 let big_union_assoc f xs = xs +> map_assoc f +> fold_assoc union_set empty_set
4668 (* todo: pb normally can suppr fun l -> .... l but if do that, then strange type _a
4669 => assoc_map is strange too => equal dont work
4671 let (assoc_reverse
: (('a
* '
b) list
) -> (('
b * 'a
) list
)) = fun l ->
4672 List.map
(fun(x,y) -> (y,x)) l
4674 let (assoc_map
: (('a
* '
b) list
) -> (('a
* '
b) list
) -> (('a
* 'a
) list
)) =
4676 let (l1bis
, l2bis
) = (assoc_reverse l1
, assoc_reverse l2
) in
4677 List.map
(fun (x,y) -> (y, List.assoc x l2bis
)) l1bis
4679 let rec (lookup_list
: 'a
-> ('a
, '
b) assoc list
-> '
b) = fun el
-> function
4680 | [] -> raise Not_found
4681 | (xs::xxs
) -> try List.assoc el
xs with Not_found
-> lookup_list el xxs
4683 let (lookup_list2
: 'a
-> ('a
, '
b) assoc list
-> ('
b * int)) = fun el xxs
->
4684 let rec lookup_l_aux i = function
4685 | [] -> raise Not_found
4687 try let res = List.assoc el
xs in (res,i)
4688 with Not_found
-> lookup_l_aux (i+1) xxs
4689 in lookup_l_aux 0 xxs
4692 (lookup_list2
"c" [["a",1;"b",2];["a",1;"b",3];["a",1;"c",7]] =*= (7,2))
4695 let assoc_option k l =
4696 optionise (fun () -> List.assoc k l)
4698 let assoc_with_err_msg k l =
4701 pr2 (spf "pb assoc_with_err_msg: %s" (dump k));
4704 (*****************************************************************************)
4705 (* Assoc int -> xxx with binary tree. Have a look too at Mapb.mli *)
4706 (*****************************************************************************)
4708 (* ex: type robot_list = robot_info IntMap.t *)
4709 module IntMap
= Map.Make
4712 let compare = compare
4714 let intmap_to_list m = IntMap.fold
(fun id v acc
-> (id, v) :: acc
) m []
4715 let intmap_string_of_t f a
= "<Not Yet>"
4717 module IntIntMap
= Map.Make
4720 let compare = compare
4723 let intintmap_to_list m = IntIntMap.fold
(fun id v acc
-> (id, v) :: acc
) m []
4724 let intintmap_string_of_t f a
= "<Not Yet>"
4727 (*****************************************************************************)
4729 (*****************************************************************************)
4731 (* il parait que better when choose a prime *)
4732 let hcreate () = Hashtbl.create
401
4733 let hadd (k,v) h = Hashtbl.add h k v
4734 let hmem k h = Hashtbl.mem
h k
4735 let hfind k h = Hashtbl.find
h k
4736 let hreplace (k,v) h = Hashtbl.replace
h k v
4737 let hiter = Hashtbl.iter
4738 let hfold = Hashtbl.fold
4739 let hremove k h = Hashtbl.remove h k
4742 let hash_to_list h =
4743 Hashtbl.fold
(fun k v acc
-> (k,v)::acc
) h []
4744 +> List.sort
compare
4746 let hash_to_list_unsorted h =
4747 Hashtbl.fold
(fun k v acc
-> (k,v)::acc
) h []
4749 let hash_of_list xs =
4750 let h = Hashtbl.create
101 in
4752 xs +> List.iter
(fun (k, v) -> Hashtbl.add h k v);
4757 let h = Hashtbl.create
101 in
4758 Hashtbl.add h "toto" 1;
4759 Hashtbl.add h "toto" 1;
4760 assert(hash_to_list h =*= ["toto",1; "toto",1])
4763 let hfind_default key value_if_not_found
h =
4764 try Hashtbl.find
h key
4766 (Hashtbl.add h key
(value_if_not_found
()); Hashtbl.find
h key
)
4768 (* not as easy as Perl $h->{key}++; but still possible *)
4769 let hupdate_default key op value_if_not_found
h =
4770 let old = hfind_default key value_if_not_found
h in
4771 Hashtbl.replace
h key
(op
old)
4774 let hfind_option key
h =
4775 optionise (fun () -> Hashtbl.find
h key
)
4778 (* see below: let hkeys h = ... *)
4781 (*****************************************************************************)
4783 (*****************************************************************************)
4785 type 'a hashset
= ('a
, bool) Hashtbl.t
4789 let hash_hashset_add k e h =
4790 match optionise (fun () -> Hashtbl.find
h k) with
4791 | Some hset
-> Hashtbl.replace hset
e true
4793 let hset = Hashtbl.create
11 in
4795 Hashtbl.add h k hset;
4796 Hashtbl.replace
hset e true;
4799 let hashset_to_set baseset
h =
4800 h +> hash_to_list +> List.map
fst +> (fun xs -> baseset#fromlist
xs)
4802 let hashset_to_list h = hash_to_list h +> List.map
fst
4804 let hashset_of_list xs =
4805 xs +> List.map
(fun x -> x, true) +> hash_of_list
4810 let hkey = Hashtbl.create
101 in
4811 h +> Hashtbl.iter
(fun k v -> Hashtbl.replace
hkey k true);
4812 hashset_to_list hkey
4816 let group_assoc_bykey_eff2 xs =
4817 let h = Hashtbl.create
101 in
4818 xs +> List.iter
(fun (k, v) -> Hashtbl.add h k v);
4819 let keys = hkeys h in
4820 keys +> List.map
(fun k -> k, Hashtbl.find_all
h k)
4822 let group_assoc_bykey_eff xs =
4823 profile_code2 "Common.group_assoc_bykey_eff" (fun () ->
4824 group_assoc_bykey_eff2 xs)
4827 let test_group_assoc () =
4828 let xs = enum 0 10000 +> List.map
(fun i -> i_to_s i, i) in
4829 let xs = ("0", 2)::xs in
4830 (* let _ys = xs +> Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) *)
4831 let ys = xs +> group_assoc_bykey_eff
4837 let h = Hashtbl.create
101 in
4838 xs +> List.iter
(fun k ->
4839 Hashtbl.add h k true
4845 let diff_two_say_set_eff xs1 xs2
=
4846 let h1 = hashset_of_list xs1
in
4847 let h2 = hashset_of_list xs2
in
4849 let hcommon = Hashtbl.create
101 in
4850 let honly_in_h1 = Hashtbl.create
101 in
4851 let honly_in_h2 = Hashtbl.create
101 in
4853 h1 +> Hashtbl.iter
(fun k _ ->
4855 then Hashtbl.replace
hcommon k true
4856 else Hashtbl.add honly_in_h1 k true
4858 h2 +> Hashtbl.iter
(fun k _ ->
4860 then Hashtbl.replace
hcommon k true
4861 else Hashtbl.add honly_in_h2 k true
4863 hashset_to_list hcommon,
4864 hashset_to_list honly_in_h1,
4865 hashset_to_list honly_in_h2
4868 (*****************************************************************************)
4870 (*****************************************************************************)
4871 type 'a stack
= 'a list
4874 let (empty_stack
: 'a stack
) = []
4875 let (push: 'a
-> 'a stack
-> 'a stack
) = fun x xs -> x::xs
4876 let (top
: 'a stack
-> 'a
) = List.hd
4877 let (pop
: 'a stack
-> 'a stack
) = List.tl
4879 let top_option = function
4887 * let push2 v l = l := v :: !l
4891 let v = List.hd
!l in
4898 (*****************************************************************************)
4899 (* Undoable Stack *)
4900 (*****************************************************************************)
4902 (* Okasaki use such structure also for having efficient data structure
4903 * supporting fast append.
4906 type 'a undo_stack
= 'a list
* 'a list
(* redo *)
4908 let (empty_undo_stack
: 'a undo_stack
) =
4911 (* push erase the possible redo *)
4912 let (push_undo
: 'a
-> 'a undo_stack
-> 'a undo_stack
) = fun x (undo
,redo
) ->
4915 let (top_undo
: 'a undo_stack
-> 'a
) = fun (undo
, redo
) ->
4918 let (pop_undo
: 'a undo_stack
-> 'a undo_stack
) = fun (undo
, redo
) ->
4920 | [] -> failwith
"empty undo stack"
4924 let (undo_pop
: 'a undo_stack
-> 'a undo_stack
) = fun (undo
, redo
) ->
4926 | [] -> failwith
"empty redo, nothing to redo"
4930 let redo_undo x = undo_pop
x
4933 let top_undo_option = fun (undo
, redo
) ->
4938 (*****************************************************************************)
4940 (*****************************************************************************)
4941 type 'a bintree
= Leaf
of 'a
| Branch
of ('a bintree
* 'a bintree
)
4944 (*****************************************************************************)
4946 (*****************************************************************************)
4948 (* no empty tree, must have one root at list *)
4949 type 'a tree
= Tree
of 'a
* ('a tree
) list
4951 let rec (tree_iter
: ('a
-> unit) -> 'a tree
-> unit) = fun f tree
->
4953 | Tree
(node
, xs) ->
4955 xs +> List.iter
(tree_iter
f)
4958 (*****************************************************************************)
4959 (* N-ary tree with updatable childrens *)
4960 (*****************************************************************************)
4962 (* no empty tree, must have one root at list *)
4965 | NodeRef
of 'a
* 'a treeref list
ref
4967 let treeref_children_ref tree
=
4969 | NodeRef
(n, x) -> x
4973 let rec (treeref_node_iter
:
4974 (* (('a * ('a, 'b) treeref list ref) -> unit) ->
4975 ('a, 'b) treeref -> unit
4980 (* | LeafRef _ -> ()*)
4981 | NodeRef
(n, xs) ->
4983 !xs +> List.iter
(treeref_node_iter
f)
4986 let find_treeref f tree
=
4989 tree
+> treeref_node_iter
(fun (n, xs) ->
4991 then push2 (n, xs) res;
4994 | [n,xs] -> NodeRef
(n, xs)
4995 | [] -> raise Not_found
4996 | x::y::zs
-> raise Multi_found
4998 let rec (treeref_node_iter_with_parents
:
4999 (* (('a * ('a, 'b) treeref list ref) -> ('a list) -> unit) ->
5000 ('a, 'b) treeref -> unit)
5004 let rec aux acc tree
=
5006 (* | LeafRef _ -> ()*)
5007 | NodeRef
(n, xs) ->
5009 !xs +> List.iter
(aux (n::acc
))
5014 (* ---------------------------------------------------------------------- *)
5015 (* Leaf can seem redundant, but sometimes want to directly see if
5016 * a children is a leaf without looking if the list is empty.
5018 type ('a
, '
b) treeref2
=
5019 | NodeRef2
of 'a
* ('a
, '
b) treeref2 list
ref
5023 let treeref2_children_ref tree
=
5025 | LeafRef2
_ -> failwith
"treeref_tail: leaf"
5026 | NodeRef2
(n, x) -> x
5030 let rec (treeref_node_iter2
:
5031 (('a
* ('a
, '
b) treeref2 list
ref) -> unit) ->
5032 ('a
, '
b) treeref2
-> unit) =
5036 | NodeRef2
(n, xs) ->
5038 !xs +> List.iter
(treeref_node_iter2
f)
5041 let find_treeref2 f tree
=
5044 tree
+> treeref_node_iter2
(fun (n, xs) ->
5046 then push2 (n, xs) res;
5049 | [n,xs] -> NodeRef2
(n, xs)
5050 | [] -> raise Not_found
5051 | x::y::zs
-> raise Multi_found
5056 let rec (treeref_node_iter_with_parents2
:
5057 (('a
* ('a
, '
b) treeref2 list
ref) -> ('a list
) -> unit) ->
5058 ('a
, '
b) treeref2
-> unit) =
5060 let rec aux acc tree
=
5063 | NodeRef2
(n, xs) ->
5065 !xs +> List.iter
(aux (n::acc
))
5081 let find_treeref_with_parents_some f tree
=
5084 tree
+> treeref_node_iter_with_parents
(fun (n, xs) parents
->
5085 match f (n,xs) parents
with
5086 | Some
v -> push2 v res;
5091 | [] -> raise Not_found
5092 | x::y::zs
-> raise Multi_found
5094 let find_multi_treeref_with_parents_some f tree
=
5097 tree
+> treeref_node_iter_with_parents
(fun (n, xs) parents
->
5098 match f (n,xs) parents
with
5099 | Some
v -> push2 v res;
5104 | [] -> raise Not_found
5108 (*****************************************************************************)
5109 (* Graph. Have a look too at Ograph_*.mli *)
5110 (*****************************************************************************)
5111 (* todo: generalise to put in common (need 'edge (and 'c ?),
5112 * and take in param a display func, cos caml sux, no overloading of show :(
5113 * Simple impelemntation. Can do also matrix, or adjacent list, or pointer(ref)
5114 * todo: do some check (dont exist already, ...)
5117 type 'node graph
= ('node set
) * (('node
* 'node
) set
)
5119 let (add_node
: 'a
-> 'a graph
-> 'a graph
) = fun node
(nodes
, arcs
) ->
5122 let (del_node
: 'a
-> 'a graph
-> 'a graph
) = fun node
(nodes
, arcs
) ->
5123 (nodes $
-$ set
[node
], arcs
)
5124 (* could do more job:
5125 let _ = assert (successors node (nodes, arcs) = empty) in
5126 +> List.filter (fun (src, dst) -> dst != node))
5128 let (add_arc
: ('a
* 'a
) -> 'a graph
-> 'a graph
) = fun arc
(nodes
, arcs
) ->
5129 (nodes
, set
[arc
] $
+$ arcs
)
5131 let (del_arc
: ('a
* 'a
) -> 'a graph
-> 'a graph
) = fun arc
(nodes
, arcs
) ->
5132 (nodes
, arcs
+> List.filter
(fun a
-> not
(arc
=*= a
)))
5134 let (successors
: 'a
-> 'a graph
-> 'a set
) = fun x (nodes
, arcs
) ->
5135 arcs
+> List.filter
(fun (src
, dst
) -> src
=*= x) +> List.map
snd
5137 let (predecessors
: 'a
-> 'a graph
-> 'a set
) = fun x (nodes
, arcs
) ->
5138 arcs
+> List.filter
(fun (src
, dst
) -> dst
=*= x) +> List.map
fst
5140 let (nodes
: 'a graph
-> 'a set
) = fun (nodes
, arcs
) -> nodes
5143 let rec (fold_upward
: ('
b -> 'a
-> '
b) -> 'a set
-> '
b -> 'a graph
-> '
b) =
5144 fun f xs acc graph
->
5147 | x::xs -> (f acc
x)
5148 +> (fun newacc -> fold_upward
f (graph
+> predecessors
x) newacc graph
)
5149 +> (fun newacc -> fold_upward
f xs newacc graph
)
5150 (* TODO avoid already visited *)
5152 let empty_graph = ([], [])
5157 let (add_arcs_toward: int -> (int list) -> 'a graph -> 'a graph) = fun i xs ->
5159 (nodes, arcs) -> (nodes, (List.map (fun j -> (j,i) ) xs)++arcs)
5160 let (del_arcs_toward: int -> (int list) -> 'a graph -> 'a graph)= fun i xs g ->
5161 List.fold_left (fun acc el -> del_arc (el, i) acc) g xs
5162 let (add_arcs_from: int -> (int list) -> 'a graph -> 'a graph) = fun i xs ->
5164 (nodes, arcs) -> (nodes, (List.map (fun j -> (i,j) ) xs)++arcs)
5167 let (del_node: (int * 'node) -> 'node graph -> 'node graph) = fun node ->
5168 function (nodes, arcs) ->
5169 let newnodes = List.filter (fun a -> not (node = a)) nodes in
5170 if newnodes = nodes then (raise Not_found) else (newnodes, arcs)
5171 let (replace_node: int -> 'node -> 'node graph -> 'node graph) = fun i n ->
5172 function (nodes, arcs) ->
5173 let newnodes = List.filter (fun (j,_) -> not (i = j)) nodes in
5174 ((i,n)::newnodes, arcs)
5175 let (get_node: int -> 'node graph -> 'node) = fun i -> function
5176 (nodes, arcs) -> List.assoc i nodes
5178 let (get_free: 'a graph -> int) = function
5179 (nodes, arcs) -> (maximum (List.map fst nodes))+1
5180 (* require no cycle !!
5181 TODO if cycle check that we have already visited a node *)
5182 let rec (succ_all
: int -> 'a graph
-> (int list
)) = fun i -> function
5183 (nodes
, arcs
) as g
->
5184 let direct = succ
i g
in
5185 union
direct (union_list (List.map
(fun i -> succ_all
i g
) direct))
5186 let rec (pred_all
: int -> 'a graph
-> (int list
)) = fun i -> function
5187 (nodes
, arcs
) as g
->
5188 let direct = pred
i g
in
5189 union
direct (union_list (List.map
(fun i -> pred_all
i g
) direct))
5190 (* require that the nodes are different !! *)
5191 let rec (equal
: 'a graph
-> 'a graph
-> bool) = fun g1 g2
->
5192 let ((nodes1
, arcs1
),(nodes2
, arcs2
)) = (g1
,g2
) in
5194 (* do 2 things, check same length and to assoc *)
5195 let conv = assoc_map nodes1 nodes2
in
5196 List.for_all
(fun (i1
,i2
) ->
5197 List.mem
(List.assoc i1
conv, List.assoc i2
conv) arcs2
)
5199 && (List.length arcs1
= List.length arcs2
)
5200 (* could think that only forall is needed, but need check same lenth too*)
5203 let (display
: 'a graph
-> ('a
-> unit) -> unit) = fun g display_func
->
5204 let rec aux depth
i =
5206 print_int
i; print_string
"->"; display_func
(get_node
i g
);
5208 List.iter
(aux (depth
+2)) (succ
i g
)
5211 let (display_dot
: 'a graph
-> ('a
-> string) -> unit)= fun (nodes
,arcs
) func
->
5212 let file = open_out
"test.dot" in
5213 output_string
file "digraph misc {\n" ;
5214 List.iter
(fun (n, node
) ->
5215 output_int
file n; output_string
file " [label=\"";
5216 output_string
file (func node
); output_string
file " \"];\n"; ) nodes
;
5217 List.iter
(fun (i1
,i2
) -> output_int
file i1
; output_string
file " -> " ;
5218 output_int
file i2
; output_string
file " ;\n"; ) arcs
;
5219 output_string
file "}\n" ;
5221 let status = Unix.system
"viewdot test.dot" in
5223 (* todo: faire = graphe (int can change !!! => cant make simply =)
5224 reassign number first !!
5227 (* todo: mettre diff(modulo = !!) en rouge *)
5228 let (display_dot2
: 'a graph
-> 'a graph
-> ('a
-> string) -> unit) =
5229 fun (nodes1
, arcs1
) (nodes2
, arcs2
) func
->
5230 let file = open_out
"test.dot" in
5231 output_string
file "digraph misc {\n" ;
5232 output_string
file "rotate = 90;\n";
5233 List.iter
(fun (n, node
) ->
5234 output_string
file "100"; output_int
file n;
5235 output_string
file " [label=\"";
5236 output_string
file (func node
); output_string
file " \"];\n"; ) nodes1
;
5237 List.iter
(fun (n, node
) ->
5238 output_string
file "200"; output_int
file n;
5239 output_string
file " [label=\"";
5240 output_string
file (func node
); output_string
file " \"];\n"; ) nodes2
;
5241 List.iter
(fun (i1
,i2
) ->
5242 output_string
file "100"; output_int
file i1
; output_string
file " -> " ;
5243 output_string
file "100"; output_int
file i2
; output_string
file " ;\n";
5246 List.iter
(fun (i1
,i2
) ->
5247 output_string
file "200"; output_int
file i1
; output_string
file " -> " ;
5248 output_string
file "200"; output_int
file i2
; output_string
file " ;\n"; )
5250 (* output_string file "500 -> 1001; 500 -> 2001}\n" ; *)
5251 output_string
file "}\n" ;
5253 let status = Unix.system
"viewdot test.dot" in
5258 (*****************************************************************************)
5260 (*****************************************************************************)
5263 let map = List.map (* note: really really slow, use rev_map if possible *)
5264 let filter = List.filter
5265 let fold = List.fold_left
5266 let member = List.mem
5267 let iter = List.iter
5268 let find = List.find
5269 let exists = List.exists
5270 let forall = List.for_all
5271 let big_union f xs = xs +> map f +> fold union_set empty_set
5272 (* let empty = [] *)
5274 let sort = List.sort
5275 let length = List.length
5276 (* in prelude now: let null xs = match xs with [] -> true | _ -> false *)
5279 let is_singleton = fun xs -> List.length xs =|= 1
5281 let tail_map f l = (* tail recursive map, using rev *)
5282 let rec loop acc
= function
5284 | x::xs -> loop ((f x) :: acc
) xs in
5287 (*****************************************************************************)
5288 (* Geometry (raytracer) *)
5289 (*****************************************************************************)
5291 type vector
= (float * float * float)
5293 type color
= vector
(* color(0-1) *)
5295 (* todo: factorise *)
5296 let (dotproduct
: vector
* vector
-> float) =
5297 fun ((x1
,y1
,z1
),(x2
,y2
,z2
)) -> (x1
*.x2
+. y1
*.y2
+. z1
*.z2
)
5298 let (vector_length
: vector
-> float) =
5299 fun (x,y,z
) -> sqrt
(square x +. square y +. square z
)
5300 let (minus_point
: point
* point
-> vector
) =
5301 fun ((x1
,y1
,z1
),(x2
,y2
,z2
)) -> ((x1
-. x2
),(y1
-. y2
),(z1
-. z2
))
5302 let (distance
: point
* point
-> float) =
5303 fun (x1
, x2
) -> vector_length
(minus_point
(x2
,x1
))
5304 let (normalise
: vector
-> vector
) =
5306 let len = vector_length
(x,y,z
) in (x /. len, y /. len, z
/. len)
5307 let (mult_coeff
: vector
-> float -> vector
) =
5308 fun (x,y,z
) c -> (x *. c, y *. c, z
*. c)
5309 let (add_vector
: vector
-> vector
-> vector
) =
5310 fun v1 v2 -> let ((x1
,y1
,z1
),(x2
,y2
,z2
)) = (v1,v2) in
5311 (x1
+.x2
, y1
+.y2
, z1
+.z2
)
5312 let (mult_vector
: vector
-> vector
-> vector
) =
5313 fun v1 v2 -> let ((x1
,y1
,z1
),(x2
,y2
,z2
)) = (v1,v2) in
5314 (x1
*.x2
, y1
*.y2
, z1
*.z2
)
5315 let sum_vector = List.fold_left add_vector
(0.0,0.0,0.0)
5317 (*****************************************************************************)
5318 (* Pics (raytracer) *)
5319 (*****************************************************************************)
5321 type pixel
= (int * int * int) (* RGB *)
5323 (* required pixel list in row major order, line after line *)
5324 let (write_ppm
: int -> int -> (pixel list
) -> string -> unit) = fun
5325 width height
xs filename ->
5326 let chan = open_out
filename in
5328 output_string
chan "P6\n";
5329 output_string
chan ((string_of_int width
) ^
"\n");
5330 output_string
chan ((string_of_int height
) ^
"\n");
5331 output_string
chan "255\n";
5332 List.iter (fun (r,g
,b) ->
5333 List.iter (fun byt
-> output_byte
chan byt
) [r;g
;b]
5338 let test_ppm1 () = write_ppm
100 100
5339 ((generate
(50*100) (1,45,100)) ++ (generate
(50*100) (1,1,100)))
5342 (*****************************************************************************)
5344 (*****************************************************************************)
5345 type diff
= Match
| BnotinA
| AnotinB
5347 let (diff
: (int -> int -> diff
-> unit)-> (string list
* string list
) -> unit)=
5349 let file1 = "/tmp/diff1-" ^
(string_of_int
(Unix.getuid
())) in
5350 let file2 = "/tmp/diff2-" ^
(string_of_int
(Unix.getuid
())) in
5351 let fileresult = "/tmp/diffresult-" ^
(string_of_int
(Unix.getuid
())) in
5352 write_file file1 (unwords
xs);
5353 write_file file2 (unwords
ys);
5355 ("diff --side-by-side -W 1 " ^
file1 ^
" " ^
file2 ^
" > " ^
fileresult);
5356 let res = cat fileresult in
5359 res +> List.iter (fun s ->
5361 | ("" | " ") -> f !a !b Match
; incr
a; incr
b;
5362 | ">" -> f !a !b BnotinA
; incr
b;
5363 | ("|" | "/" | "\\" ) ->
5364 f !a !b BnotinA
; f !a !b AnotinB
; incr
a; incr
b;
5365 | "<" -> f !a !b AnotinB
; incr
a;
5366 | _ -> raise Impossible
5371 ["0";"a";"b";"c";"d"; "f";"g";"h";"j";"q"; "z"]
5372 [ "a";"b";"c";"d";"e";"f";"g";"i";"j";"k";"r";"x";"y";"z"]
5373 (fun x y -> pr "match")
5374 (fun x y -> pr "a_not_in_b")
5375 (fun x y -> pr "b_not_in_a")
5378 let (diff2
: (int -> int -> diff
-> unit) -> (string * string) -> unit) =
5379 fun f (xstr
,ystr
) ->
5380 write_file "/tmp/diff1" xstr
;
5381 write_file "/tmp/diff2" ystr
;
5383 ("diff --side-by-side --left-column -W 1 " ^
5384 "/tmp/diff1 /tmp/diff2 > /tmp/diffresult");
5385 let res = cat "/tmp/diffresult" in
5388 res +> List.iter (fun s ->
5390 | "(" -> f !a !b Match
; incr
a; incr
b;
5391 | ">" -> f !a !b BnotinA
; incr
b;
5392 | "|" -> f !a !b BnotinA
; f !a !b AnotinB
; incr
a; incr
b;
5393 | "<" -> f !a !b AnotinB
; incr
a;
5394 | _ -> raise Impossible
5398 (*****************************************************************************)
5399 (* Parsers (aop-colcombet) *)
5400 (*****************************************************************************)
5402 let parserCommon lexbuf parserer lexer
=
5404 let result = parserer lexer lexbuf
in
5406 with Parsing.Parse_error
->
5407 print_string
"buf: "; print_string lexbuf
.Lexing.lex_buffer
;
5409 print_string
"current: "; print_int lexbuf
.Lexing.lex_curr_pos
;
5411 raise
Parsing.Parse_error
5414 (* marche pas ca neuneu *)
5416 let getDoubleParser parserer lexer string =
5417 let lexbuf1 = Lexing.from_string string in
5418 let chan = open_in string in
5419 let lexbuf2 = Lexing.from_channel chan in
5420 (parserCommon lexbuf1 parserer lexer , parserCommon lexbuf2 parserer lexer )
5423 let getDoubleParser parserer lexer
=
5426 let lexbuf1 = Lexing.from_string
string in
5427 parserCommon lexbuf1 parserer lexer
5430 let chan = open_in
string in
5431 let lexbuf2 = Lexing.from_channel
chan in
5432 parserCommon lexbuf2 parserer lexer
5436 (*****************************************************************************)
5437 (* parser combinators *)
5438 (*****************************************************************************)
5440 (* cf parser_combinators.ml
5442 * Could also use ocaml stream. but not backtrack and forced to do LL,
5443 * so combinators are better.
5448 (*****************************************************************************)
5449 (* Parser related (cocci) *)
5450 (*****************************************************************************)
5462 let fake_parse_info = {
5463 charpos
= -1; str
= "";
5464 line
= -1; column
= -1; file = "";
5467 let string_of_parse_info x =
5468 spf "%s at %s:%d:%d" x.str
x.file x.line
x.column
5469 let string_of_parse_info_bis x =
5470 spf "%s:%d:%d" x.file x.line
x.column
5472 let (info_from_charpos2
: int -> filename -> (int * int * string)) =
5473 fun charpos
filename ->
5475 (* Currently lexing.ml does not handle the line number position.
5476 * Even if there is some fields in the lexing structure, they are not
5477 * maintained by the lexing engine :( So the following code does not work:
5478 * let pos = Lexing.lexeme_end_p lexbuf in
5479 * sprintf "at file %s, line %d, char %d" pos.pos_fname pos.pos_lnum
5480 * (pos.pos_cnum - pos.pos_bol) in
5481 * Hence this function to overcome the previous limitation.
5483 let chan = open_in
filename in
5484 let linen = ref 0 in
5486 let rec charpos_to_pos_aux last_valid
=
5488 try Some
(input_line
chan)
5489 with End_of_file
when charpos
=|= last_valid
-> None
in
5494 if (!posl + slength s > charpos
)
5497 (!linen, charpos
- !posl, s)
5500 posl := !posl + slength s;
5501 charpos_to_pos_aux !posl;
5503 | None
-> (!linen, charpos
- !posl, "\n")
5505 let res = charpos_to_pos_aux 0 in
5509 let info_from_charpos a b =
5510 profile_code "Common.info_from_charpos" (fun () -> info_from_charpos2
a b)
5514 let full_charpos_to_pos2 = fun filename ->
5516 let size = (filesize filename + 2) in
5518 let arr = Array.create
size (0,0) in
5520 let chan = open_in
filename in
5522 let charpos = ref 0 in
5525 let rec full_charpos_to_pos_aux () =
5527 let s = (input_line
chan) in
5530 (* '... +1 do' cos input_line dont return the trailing \n *)
5531 for i = 0 to (slength s - 1) + 1 do
5532 arr.(!charpos + i) <- (!line, i);
5534 charpos := !charpos + slength s + 1;
5535 full_charpos_to_pos_aux();
5538 for i = !charpos to Array.length arr - 1 do
5539 arr.(i) <- (!line, 0);
5544 full_charpos_to_pos_aux ();
5548 let full_charpos_to_pos a =
5549 profile_code "Common.full_charpos_to_pos" (fun () -> full_charpos_to_pos2 a)
5551 let test_charpos file =
5552 full_charpos_to_pos file +> dump +> pr2
5556 let complete_parse_info filename table
x =
5559 line = fst (table
.(x.charpos));
5560 column
= snd (table
.(x.charpos));
5565 let full_charpos_to_pos_large2 = fun filename ->
5567 let size = (filesize filename + 2) in
5569 (* old: let arr = Array.create size (0,0) in *)
5570 let arr1 = Bigarray.Array1.create
5571 Bigarray.int Bigarray.c_layout
size in
5572 let arr2 = Bigarray.Array1.create
5573 Bigarray.int Bigarray.c_layout
size in
5574 Bigarray.Array1.fill
arr1 0;
5575 Bigarray.Array1.fill
arr2 0;
5577 let chan = open_in
filename in
5579 let charpos = ref 0 in
5582 let rec full_charpos_to_pos_aux () =
5583 let s = (input_line
chan) in
5586 (* '... +1 do' cos input_line dont return the trailing \n *)
5587 for i = 0 to (slength s - 1) + 1 do
5588 (* old: arr.(!charpos + i) <- (!line, i); *)
5589 arr1.{!charpos + i} <- (!line);
5590 arr2.{!charpos + i} <- i;
5592 charpos := !charpos + slength s + 1;
5593 full_charpos_to_pos_aux() in
5596 full_charpos_to_pos_aux ();
5598 for i = !charpos to (* old: Array.length arr *)
5599 Bigarray.Array1.dim
arr1 - 1 do
5600 (* old: arr.(i) <- (!line, 0); *)
5606 (fun i -> arr1.{i}, arr2.{i})
5608 let full_charpos_to_pos_large a =
5609 profile_code "Common.full_charpos_to_pos_large"
5610 (fun () -> full_charpos_to_pos_large2 a)
5613 let complete_parse_info_large filename table
x =
5616 line = fst (table
(x.charpos));
5617 column
= snd (table
(x.charpos));
5620 (*---------------------------------------------------------------------------*)
5621 (* Decalage is here to handle stuff such as cpp which include file and who
5624 let (error_messagebis
: filename -> (string * int) -> int -> string)=
5625 fun filename (lexeme
, lexstart
) decalage
->
5627 let charpos = lexstart
+ decalage
in
5629 let (line, pos, linecontent
) = info_from_charpos charpos filename in
5630 sprintf
"File \"%s\", line %d, column %d, charpos = %d
5631 around = '%s', whole content = %s"
5632 filename line pos charpos tok (chop linecontent
)
5634 let error_message = fun filename (lexeme
, lexstart
) ->
5635 try error_messagebis
filename (lexeme
, lexstart
) 0
5638 ("PB in Common.error_message, position " ^
i_to_s lexstart ^
5639 " given out of file:" ^
filename)
5643 let error_message_short = fun filename (lexeme
, lexstart
) ->
5645 let charpos = lexstart
in
5646 let (line, pos, linecontent
) = info_from_charpos charpos filename in
5647 sprintf
"File \"%s\", line %d" filename line
5651 ("PB in Common.error_message, position " ^
i_to_s lexstart ^
5652 " given out of file:" ^
filename);
5657 (*****************************************************************************)
5658 (* Regression testing bis (cocci) *)
5659 (*****************************************************************************)
5661 (* todo: keep also size of file, compute md5sum ? cos maybe the file
5664 * todo: could also compute the date, or some version info of the program,
5665 * can record the first date when was found a OK, the last date where
5666 * was ok, and then first date when found fail. So the
5667 * Common.Ok would have more information that would be passed
5668 * to the Common.Pb of date * date * date * string peut etre.
5670 * todo? maybe use plain text file instead of marshalling.
5673 type score_result
= Ok
| Pb
of string
5675 type score
= (string (* usually a filename *), score_result
) Hashtbl.t
5677 type score_list
= (string (* usually a filename *) * score_result
) list
5680 let empty_score () = (Hashtbl.create
101 : score
)
5684 let regression_testing_vs newscore bestscore
=
5686 let newbestscore = empty_score () in
5689 (hash_to_list newscore
+> List.map fst)
5691 (hash_to_list bestscore
+> List.map fst)
5694 allres +> List.iter (fun res ->
5696 optionise (fun () -> Hashtbl.find newscore
res),
5697 optionise (fun () -> Hashtbl.find bestscore
res)
5699 | None
, None
-> raise Impossible
5701 Printf.printf
"new test file appeared: %s\n" res;
5702 Hashtbl.add newbestscore res x;
5704 Printf.printf
"old test file disappeared: %s\n" res;
5705 | Some newone
, Some bestone
->
5706 (match newone
, bestone
with
5708 Hashtbl.add newbestscore res Ok
5711 "PBBBBBBBB: a test file does not work anymore!!! : %s\n" res;
5712 Printf.printf
"Error : %s\n" x;
5713 Hashtbl.add newbestscore res Ok
5715 Printf.printf
"Great: a test file now works: %s\n" res;
5716 Hashtbl.add newbestscore res Ok
5718 Hashtbl.add newbestscore res (Pb
x);
5722 "Semipb: still error but not same error : %s\n" res;
5723 Printf.printf
"%s\n" (chop ("Old error: " ^
y));
5724 Printf.printf
"New error: %s\n" x;
5728 flush stdout
; flush stderr
;
5732 let regression_testing newscore best_score_file
=
5734 pr2 ("regression file: "^ best_score_file
);
5735 let (bestscore
: score
) =
5736 if not
(Sys.file_exists best_score_file
)
5737 then write_value (empty_score()) best_score_file
;
5738 get_value best_score_file
5740 let newbestscore = regression_testing_vs newscore bestscore
in
5741 write_value newbestscore (best_score_file ^
".old");
5742 write_value newbestscore best_score_file
;
5748 let string_of_score_result v =
5751 | Pb
s -> "Pb: " ^
s
5753 let total_scores score
=
5754 let total = hash_to_list score
+> List.length in
5755 let good = hash_to_list score
+> List.filter
5756 (fun (s, v) -> v =*= Ok
) +> List.length in
5760 let print_total_score score
=
5761 pr2 "--------------------------------";
5763 pr2 "--------------------------------";
5764 let (good, total) = total_scores score
in
5765 pr2 (sprintf
"good = %d/%d" good total)
5767 let print_score score
=
5768 score
+> hash_to_list +> List.iter (fun (k, v) ->
5769 pr2 (sprintf
"% s --> %s" k (string_of_score_result v))
5771 print_total_score score
;
5775 (*****************************************************************************)
5776 (* Scope managment (cocci) *)
5777 (*****************************************************************************)
5779 (* could also make a function Common.make_scope_functions that return
5780 * the new_scope, del_scope, do_in_scope, add_env. Kind of functor :)
5783 type ('
a, '
b) scoped_env
= ('
a, '
b) assoc list
5786 let rec lookup_env f env =
5788 | [] -> raise Not_found
5789 | []::zs -> lookup_env f zs
5792 | None -> lookup_env f (xs::zs)
5795 let member_env_key k env =
5797 let _ = lookup_env (fun (k',v) -> if k = k' then Some v else None) env in
5799 with Not_found -> false
5803 let rec lookup_env k env
=
5805 | [] -> raise Not_found
5806 | []::zs
-> lookup_env k zs
5807 | ((k'
,v)::xs)::zs
->
5810 else lookup_env k (xs::zs
)
5812 let member_env_key k env
=
5813 match optionise (fun () -> lookup_env k env
) with
5818 let new_scope scoped_env
= scoped_env
:= []::!scoped_env
5819 let del_scope scoped_env
= scoped_env
:= List.tl
!scoped_env
5821 let do_in_new_scope scoped_env
f =
5823 new_scope scoped_env
;
5825 del_scope scoped_env
;
5829 let add_in_scope scoped_env def
=
5830 let (current, older
) = uncons !scoped_env
in
5831 scoped_env
:= (def
::current)::older
5837 (* note that ocaml hashtbl store also old value of a binding when add
5838 * add a newbinding; that's why del_scope works
5841 type ('
a, '
b) scoped_h_env
= {
5842 scoped_h
: ('
a, '
b) Hashtbl.t;
5843 scoped_list
: ('
a, '
b) assoc list
;
5846 let empty_scoped_h_env () = {
5847 scoped_h
= Hashtbl.create
101;
5850 let clone_scoped_h_env x =
5851 { scoped_h
= Hashtbl.copy
x.scoped_h
;
5852 scoped_list
= x.scoped_list
;
5855 let rec lookup_h_env k env
=
5856 Hashtbl.find env
.scoped_h
k
5858 let member_h_env_key k env
=
5859 match optionise (fun () -> lookup_h_env k env
) with
5864 let new_scope_h scoped_env
=
5865 scoped_env
:= {!scoped_env
with scoped_list
= []::!scoped_env
.scoped_list
}
5867 let del_scope_h scoped_env
=
5869 List.hd
!scoped_env
.scoped_list
+> List.iter (fun (k, v) ->
5870 Hashtbl.remove !scoped_env
.scoped_h
k
5872 scoped_env
:= {!scoped_env
with scoped_list
=
5873 List.tl
!scoped_env
.scoped_list
5877 let clean_scope_h scoped_env
= (* keep only top level (last scope) *)
5879 match (!scoped_env
).scoped_list
with
5881 | _::_ -> del_scope_h scoped_env
; loop () in
5884 let do_in_new_scope_h scoped_env
f =
5886 new_scope_h scoped_env
;
5888 del_scope_h scoped_env
;
5893 let add_in_scope scoped_env def =
5894 let (current, older) = uncons !scoped_env in
5895 scoped_env := (def::current)::older
5898 let add_in_scope_h x (k,v) =
5900 Hashtbl.add !x.scoped_h
k v;
5901 x := { !x with scoped_list
=
5902 ((k,v)::(List.hd
!x.scoped_list
))::(List.tl
!x.scoped_list
);
5906 (*****************************************************************************)
5908 (*****************************************************************************)
5910 (* let ansi_terminal = ref true *)
5912 let (_execute_and_show_progress_func
: (int (* length *) -> ((unit -> unit) -> unit) -> unit) ref)
5915 failwith
"no execute yet, have you included common_extra.cmo?"
5920 let execute_and_show_progress len f =
5921 !_execute_and_show_progress_func
len f
5924 (* now in common_extra.ml:
5925 * let execute_and_show_progress len f = ...
5928 (*****************************************************************************)
5930 (*****************************************************************************)
5932 let _init_random = Random.self_init
()
5934 let random_insert i l =
5935 let p = Random.int (length l +1)
5936 in let rec insert i p l =
5937 if (p = 0) then i::l else (hd l)::insert i (p-1) (tl l)
5940 let rec randomize_list = function
5942 | a::l -> random_insert a (randomize_list l)
5944 let random_list xs =
5945 List.nth xs (Random.int (length xs))
5947 (* todo_opti: use fisher/yates algorithm.
5948 * ref: http://en.wikipedia.org/wiki/Knuth_shuffle
5950 * public static void shuffle (int[] array)
5952 * Random rng = new Random ();
5953 * int n = array.length;
5956 * int k = rng.nextInt(n + 1); // 0 <= k <= n (!)
5957 * int temp = array[n];
5958 * array[n] = array[k];
5964 let randomize_list xs =
5965 let permut = permutation
xs in
5970 let random_subset_of_list num
xs =
5971 let array = Array.of_list
xs in
5972 let len = Array.length array in
5974 let h = Hashtbl.create
101 in
5975 let cnt = ref num
in
5977 let x = Random.int len in
5978 if not
(Hashtbl.mem
h (array.(x))) (* bugfix2: not just x :) *)
5980 Hashtbl.add h (array.(x)) true; (* bugfix1: not just x :) *)
5984 let objs = hash_to_list h +> List.map fst in
5989 (*****************************************************************************)
5990 (* Flags and actions *)
5991 (*****************************************************************************)
5993 (* I put it inside a func as it can help to give a chance to
5994 * change the globals before getting the options as some
5995 * options sometimes may want to show the default value.
5997 let cmdline_flags_devel () =
5999 "-debugger", Arg.Set
debugger ,
6000 " option to set if launched inside ocamldebug";
6001 "-profile", Arg.Unit
(fun () -> profile := PALL
),
6002 " gather timing information about important functions";
6004 let cmdline_flags_verbose () =
6006 "-verbose_level", Arg.Set_int
verbose_level,
6007 " <int> guess what";
6008 "-disable_pr2_once", Arg.Set
disable_pr2_once,
6009 " to print more messages";
6010 "-show_trace_profile", Arg.Set
show_trace_profile,
6014 let cmdline_flags_other () =
6016 "-nocheck_stack", Arg.Clear
check_stack,
6018 "-batch_mode", Arg.Set
_batch_mode,
6022 (* potentially other common options but not yet integrated:
6024 "-timeout", Arg.Set_int timeout,
6025 " <sec> interrupt LFS or buggy external plugins";
6027 (* can't be factorized because of the $ cvs stuff, we want the date
6028 * of the main.ml file, not common.ml
6030 "-version", Arg.Unit
(fun () ->
6031 pr2 "version: _dollar_Date: 2008/06/14 00:54:22 _dollar_";
6032 raise
(Common.UnixExit
0)
6036 "-shorthelp", Arg.Unit
(fun () ->
6037 !short_usage_func
();
6038 raise
(Common.UnixExit
0)
6040 " see short list of options";
6041 "-longhelp", Arg.Unit
(fun () ->
6043 raise
(Common.UnixExit
0)
6045 "-help", Arg.Unit
(fun () ->
6047 raise
(Common.UnixExit
0)
6050 "--help", Arg.Unit
(fun () ->
6052 raise
(Common.UnixExit
0)
6058 let cmdline_actions () =
6060 "-test_check_stack", " <limit>",
6061 mk_action_1_arg test_check_stack_size;
6065 (*****************************************************************************)
6067 (*****************************************************************************)
6068 (* stuff put here cos of of forward definition limitation of ocaml *)
6071 (* Infix trick, seen in jane street lib and harrop's code, and maybe in GMP *)
6072 module Infix
= struct
6079 let main_boilerplate f =
6080 if not
(!Sys.interactive
) then
6081 exn_to_real_unixexit (fun () ->
6083 Sys.set_signal
Sys.sigint
(Sys.Signal_handle
(fun _ ->
6084 pr2 "C-c intercepted, will do some cleaning before exiting";
6085 (* But if do some try ... with e -> and if do not reraise the exn,
6086 * the bubble never goes at top and so I cant really C-c.
6088 * A solution would be to not raise, but do the erase_temp_file in the
6089 * syshandler, here, and then exit.
6090 * The current solution is to not do some wild try ... with e
6091 * by having in the exn handler a case: UnixExit x -> raise ... | e ->
6093 Sys.set_signal
Sys.sigint
Sys.Signal_default
;
6094 raise
(UnixExit
(-1))
6097 (* The finalize below makes it tedious to go back to exn when use
6098 * 'back' in the debugger. Hence this special case. But the
6099 * Common.debugger will be set in main(), so too late, so
6100 * have to be quicker
6102 if Sys.argv
+> Array.to_list
+> List.exists (fun x -> x =$
= "-debugger")
6103 then debugger := true;
6106 pp_do_in_zero_box (fun () ->
6107 f(); (* <---- here it is *)
6110 if !profile <> PNONE
6111 then pr2 (profile_diagnostic ());
6112 erase_temp_files ();
6116 (* let _ = if not !Sys.interactive then (main ()) *)
6119 (* based on code found in cameleon from maxence guesdon *)
6120 let md5sum_of_string s =
6121 let com = spf "echo %s | md5sum | cut -d\" \" -f 1"
6124 match cmd_to_list com with
6128 | _ -> failwith
"md5sum_of_string wrong output"
6132 let with_pr2_to_string f =
6133 let file = new_temp_file "pr2" "out" in
6134 redirect_stdout_stderr file f;
6137 (* julia: convert something printed using format to print into a string *)
6138 let format_to_string f =
6139 let (nm
,o) = Filename.open_temp_file
"format_to_s" ".out" in
6140 Format.set_formatter_out_channel
o;
6142 Format.print_newline
();
6143 Format.print_flush
();
6144 Format.set_formatter_out_channel stdout
;
6146 let i = open_in nm
in
6147 let lines = ref [] in
6149 let cur = input_line
i in
6150 lines := cur :: !lines;
6152 (try loop() with End_of_file
-> ());
6154 command2 ("rm -f " ^ nm
);
6155 String.concat "\n" (List.rev !lines)
6159 (*****************************************************************************)
6161 (*****************************************************************************)
6163 let (generic_print
: '
a -> string -> string) = fun v typ
->
6164 write_value v "/tmp/generic_print";
6166 ("printf 'let (v:" ^ typ ^
")= Common.get_value \"/tmp/generic_print\" " ^
6168 " | calc.top > /tmp/result_generic_print");
6169 cat "/tmp/result_generic_print"
6170 +> drop_while (fun e -> not
(e =~
"^#.*")) +> tail
6173 if (s =~
".*= \\(.+\\)")
6175 else "error in generic_print, not good format:" ^
s)
6177 (* let main () = pr (generic_print [1;2;3;4] "int list") *)
6179 class ['
a] olist
(ys: '
a list
) =
6183 (* method fold f a = List.fold_left f a xs *)
6184 method fold : '
b. ('
b -> '
a -> '
b) -> '
b -> '
b =
6185 fun f accu
-> List.fold_left f accu
xs
6189 (* let _ = write_value ((new setb[])#add 1) "/tmp/test" *)
6190 let typing_sux_test () =
6191 let x = Obj.magic
[1;2;3] in
6192 let f1 xs = List.iter print_int
xs in
6193 let f2 xs = List.iter print_string
xs in
6196 (* let (test: 'a osetb -> 'a ocollection) = fun o -> (o :> 'a ocollection) *)
6197 (* let _ = test (new osetb (Setb.empty)) *)