-(* Copyright (C) 1998-2008 Yoann Padioleau
+(* Copyright (C) 1998-2009 Yoann Padioleau
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* - List.rev, List.mem, List.partition,
* - List.fold*, List.concat, ...
* - Str.global_replace
+ * - Filename.is_relative
*
*
* The Format library allows to hide passing an indent_level variable.
*
* Extra packages
* - ocamlbdb
- * - ocamlgtk
+ * - ocamlgtk, and gtksourceview
* - ocamlgl
* - ocamlpython
* - ocamlagrep
* - ocamlmpi
* - ocamlcalendar
*
- * Many functions were inspired by Haskell or Lisp librairies.
+ * - pcre
+ * - sdl
+ *
+ * Many functions in this file were inspired by Haskell or Lisp librairies.
*)
(*****************************************************************************)
v
end
+let cache_in_ref myref f =
+ match !myref with
+ | Some e -> e
+ | None ->
+ let e = f () in
+ myref := Some e;
+ e
+
let once f =
let already = ref false in
(fun x ->
exception Here
exception ReturnExn
+exception MultiFound
+
exception WrongFormat of string
(* old: let _TODO () = failwith "TODO", now via fix_caml with raise Todo *)
let exn_to_s exn =
Printexc.to_string exn
+(* alias *)
+let string_of_exn exn = exn_to_s exn
(* want or of merd, but cant cos cant put die ... in b (strict call) *)
* -taxo_file arg2 -sample_file arg3 -parse_c arg1.
*
*
- * Why not use the toplevel ? because to debug ocamldebug is far superior
- * to the toplevel (can go back, can go directly to a specific point, etc).
- * I want a kind of testing at cmdline level.
+ * Why not use the toplevel ?
+ * - because to debug, ocamldebug is far superior to the toplevel
+ * (can go back, can go directly to a specific point, etc).
+ * I want a kind of testing at cmdline level.
+ * - Also I don't have file completion when in the ocaml toplevel.
+ * I have to type "/path/to/xxx" without help.
*
*
* Why having variable flags ? Why use 'if !verbose_parsing then ...' ?
let pourcent_float_of_floats x total =
(x *. 100.0) /. total
+
+let pourcent_good_bad good bad =
+ (good * 100) / (good + bad)
+
+let pourcent_good_bad_float good bad =
+ (float_of_int good *. 100.0) /. (float_of_int good +. float_of_int bad)
+
+type 'a max_with_elem = int ref * 'a ref
+let update_max_with_elem (aref, aelem) ~is_better (newv, newelem) =
+ if is_better newv aref
+ then begin
+ aref := newv;
+ aelem := newelem;
+ end
+
(*****************************************************************************)
(* Numeric/overloading *)
(*****************************************************************************)
(*****************************************************************************)
-(* Regexp *)
+(* Regexp, can also use PCRE *)
(*****************************************************************************)
+(* Note: OCaml Str regexps are different from Perl regexp:
+ * - The OCaml regexp must match the entire way.
+ * So "testBee" =~ "Bee" is wrong
+ * but "testBee" =~ ".*Bee" is right
+ * Can have the perl behavior if use Str.search_forward instead of
+ * Str.string_match.
+ * - Must add some additional \ in front of some special char. So use
+ * \\( \\| and also \\b
+ * - It does not always handle newlines very well.
+ * - \\b does consider _ but not numbers in indentifiers.
+ *
+ * Note: PCRE regexps are then different from Str regexps ...
+ * - just use '(' ')' for grouping, not '\\)'
+ * - still need \\b for word boundary, but this time it works ...
+ * so can match some word that have some digits in them.
+ *
+ *)
+
(* put before String section because String section use some =~ *)
(* let gsubst = global_replace *)
-(* Different from Perl a little. Must match the entire way.
- * So "testBee" =~ "Bee" is wrong
- * but "testBee" =~ ".*Bee" is right
- * Can have the perl behavior if use Str.search_forward instead of
- * Str.string_match.
- *)
let (==~) s re = Str.string_match re s 0
try let _i = Str.search_forward re s 0 in true
with Not_found -> false
+let _ =
+ example(string_match_substring (Str.regexp "foo") "a foo b")
+let _ =
+ example(string_match_substring (Str.regexp "\\bfoo\\b") "a foo b")
+let _ =
+ example(string_match_substring (Str.regexp "\\bfoo\\b") "a\n\nfoo b")
+let _ =
+ example(string_match_substring (Str.regexp "\\bfoo_bar\\b") "a\n\nfoo_bar b")
+(* does not work :(
+let _ =
+ example(string_match_substring (Str.regexp "\\bfoo_bar2\\b") "a\n\nfoo_bar2 b")
+*)
+
+
+
let (regexp_match: string -> string -> string) = fun s re ->
assert(s =~ re);
Str.matched_group 1 s
let showCodeHex xs = List.iter (fun i -> printf "%02x" i) xs
+let take_string n s =
+ String.sub s 0 (n-1)
+
+let take_string_safe n s =
+ if n > String.length s
+ then s
+ else take_string n s
+
+
(* used by LFS *)
let size_mo_ko i =
then Sys.getcwd () ^ "/" ^ s
else s
+let is_relative s = Filename.is_relative s
+let is_absolute s = not (is_relative s)
(* @Pre: prj_path must not contain regexp symbol *)
(* Dates *)
(*****************************************************************************)
+(* maybe I should use ocamlcalendar, but I don't like all those functors ... *)
+
type month =
| Jan | Feb | Mar | Apr | May | Jun
| Jul | Aug | Sep | Oct | Nov | Dec
in
cat_aux [] () +> List.rev +> (fun x -> close_in chan; x)
+let cat_array file =
+ (""::cat file) +> Array.of_list
+
+
let interpolate str =
begin
command2 ("printf \"%s\\n\" " ^ str ^ ">/tmp/caml");
* let command2 s = ignore(Sys.command s)
*)
+
+let _batch_mode = ref false
let command2_y_or_no cmd =
- pr2 (cmd ^ " [y/n] ?");
- match read_line () with
- | "y" | "yes" | "Y" -> command2 cmd; true
- | "n" | "no" | "N" -> false
- | _ -> failwith "answer by yes or no"
+ if !_batch_mode then begin command2 cmd; true end
+ else begin
+
+ pr2 (cmd ^ " [y/n] ?");
+ match read_line () with
+ | "y" | "yes" | "Y" -> command2 cmd; true
+ | "n" | "no" | "N" -> false
+ | _ -> failwith "answer by yes or no"
+ end
+let uncat xs file =
+ with_open_outfile file (fun (pr,_chan) ->
+ xs +> List.iter (fun s -> pr s; pr "\n");
+
+ )
+
+
+
(fst e::xs), (snd e::ys)) zs ([],[])
+let map_withkeep f xs =
+ xs +> List.map (fun x -> f x, x)
+
(* now in prelude
* let rec take n xs =
* match (n,xs) with
| [] -> []
| e::l -> if List.mem e l then uniq l else e :: uniq l
+let has_no_duplicate xs =
+ List.length xs = List.length (uniq xs)
+let is_set_as_list = has_no_duplicate
+
+
+let rec get_duplicates xs =
+ match xs with
+ | [] -> []
+ | x::xs ->
+ if List.mem x xs
+ then x::get_duplicates xs (* todo? could x from xs to avoid double dups?*)
+ else get_duplicates xs
+
let rec all_assoc e = function
| [] -> []
| (e',v) :: l when e=e' -> v :: all_assoc e l
(cartesian_product [1;2] ["3";"4";"5"])
[1,"3";1,"4";1,"5"; 2,"3";2,"4";2,"5"]
+let sort_prof a b =
+ profile_code "Common.sort_by_xxx" (fun () -> List.sort a b)
+
+let sort_by_val_highfirst xs =
+ sort_prof (fun (k1,v1) (k2,v2) -> compare v2 v1) xs
+let sort_by_val_lowfirst xs =
+ sort_prof (fun (k1,v1) (k2,v2) -> compare v1 v2) xs
+
+let sort_by_key_highfirst xs =
+ sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs
+let sort_by_key_lowfirst xs =
+ sort_prof (fun (k1,v1) (k2,v2) -> compare k1 k2) xs
+
+let _ = example (sort_by_key_lowfirst [4, (); 7,()] = [4,(); 7,()])
+let _ = example (sort_by_key_highfirst [4,(); 7,()] = [7,(); 4,()])
+
(*----------------------------------*)
(* sur surEnsemble [p1;p2] [[p1;p2;p3] [p1;p2] ....] -> [[p1;p2;p3] ... *)
try array_find_index_ 0 with _ -> raise Not_found
+(*****************************************************************************)
+(* Matrix *)
+(*****************************************************************************)
+
type 'a matrix = 'a array array
let map_matrix f mat =
mat +> Array.map (fun arr -> arr +> Array.map f)
+let (make_matrix_init:
+ nrow:int -> ncolumn:int -> (int -> int -> 'a) -> 'a matrix) =
+ fun ~nrow ~ncolumn f ->
+ Array.init nrow (fun i ->
+ Array.init ncolumn (fun j ->
+ f i j
+ )
+ )
+
+let iter_matrix f m =
+ Array.iteri (fun i e ->
+ Array.iteri (fun j x ->
+ f i j x
+ ) e
+ ) m
+
+let nb_rows_matrix m =
+ Array.length m
+
+let nb_columns_matrix m =
+ assert(Array.length m > 0);
+ Array.length m.(0)
+
+(* check all nested arrays have the same size *)
+let invariant_matrix m =
+ raise Todo
+
+let (rows_of_matrix: 'a matrix -> 'a list list) = fun m ->
+ Array.to_list m +> List.map Array.to_list
+
+let (columns_of_matrix: 'a matrix -> 'a list list) = fun m ->
+ let nbcols = nb_columns_matrix m in
+ let nbrows = nb_rows_matrix m in
+ (enum 0 (nbcols -1)) +> List.map (fun j ->
+ (enum 0 (nbrows -1)) +> List.map (fun i ->
+ m.(i).(j)
+ ))
+
+
+let all_elems_matrix_by_row m =
+ rows_of_matrix m +> List.flatten
+
+
+let ex_matrix1 =
+ [|
+ [|0;1;2|];
+ [|3;4;5|];
+ [|6;7;8|];
+ |]
+let ex_rows1 =
+ [
+ [0;1;2];
+ [3;4;5];
+ [6;7;8];
+ ]
+let ex_columns1 =
+ [
+ [0;3;6];
+ [1;4;7];
+ [2;5;8];
+ ]
+let _ = example (rows_of_matrix ex_matrix1 = ex_rows1)
+let _ = example (columns_of_matrix ex_matrix1 = ex_columns1)
+
(*****************************************************************************)
(* Fast array *)
xs
else x::xs
+let is_set xs =
+ has_no_duplicate xs
+
let (single_set: 'a -> 'a set) = fun x -> insert_set x empty_set
let (set: 'a list -> 'a set) = fun xs ->
xs +> List.fold_left (flip insert_set) empty_set
-let group_assoc_bykey_eff xs =
+let group_assoc_bykey_eff2 xs =
let h = Hashtbl.create 101 in
xs +> List.iter (fun (k, v) -> Hashtbl.add h k v);
let keys = hkeys h in
keys +> List.map (fun k -> k, Hashtbl.find_all h k)
+
+let group_assoc_bykey_eff xs =
+ profile_code2 "Common.group_assoc_bykey_eff" (fun () ->
+ group_assoc_bykey_eff2 xs)
let test_group_assoc () =
pr2_gen ys
+let uniq_eff xs =
+ let h = Hashtbl.create 101 in
+ xs +> List.iter (fun k ->
+ Hashtbl.add h k true
+ );
+ hkeys h
+
let diff_two_say_set_eff xs1 xs2 =
let (top: 'a stack -> 'a) = List.hd
let (pop: 'a stack -> 'a stack) = List.tl
+let top_option = function
+ | [] -> None
+ | x::xs -> Some x
+
+
+
(* now in prelude:
* let push2 v l = l := v :: !l
end
+(*****************************************************************************)
+(* Undoable Stack *)
+(*****************************************************************************)
+
+(* Okasaki use such structure also for having efficient data structure
+ * supporting fast append.
+ *)
+
+type 'a undo_stack = 'a list * 'a list (* redo *)
+
+let (empty_undo_stack: 'a undo_stack) =
+ [], []
+
+(* push erase the possible redo *)
+let (push_undo: 'a -> 'a undo_stack -> 'a undo_stack) = fun x (undo,redo) ->
+ x::undo, []
+
+let (top_undo: 'a undo_stack -> 'a) = fun (undo, redo) ->
+ List.hd undo
+
+let (pop_undo: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) ->
+ match undo with
+ | [] -> failwith "empty undo stack"
+ | x::xs ->
+ xs, x::redo
+
+let (undo_pop: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) ->
+ match redo with
+ | [] -> failwith "empty redo, nothing to redo"
+ | x::xs ->
+ x::undo, xs
+
+let redo_undo x = undo_pop x
+
+
+let top_undo_option = fun (undo, redo) ->
+ match undo with
+ | [] -> None
+ | x::xs -> Some x
+
(*****************************************************************************)
(* Binary tree *)
(*****************************************************************************)
| NodeRef of 'a * ('a, 'b) treeref list ref
| LeafRef of 'b
+let treeref_children_ref tree =
+ match tree with
+ | LeafRef _ -> failwith "treeref_tail: leaf"
+ | NodeRef (n, x) -> x
+
+
+
let rec (treeref_node_iter:
(('a * ('a, 'b) treeref list ref) -> unit) ->
- ('a, 'b) treeref -> unit) = fun f tree ->
+ ('a, 'b) treeref -> unit) =
+ fun f tree ->
match tree with
| LeafRef _ -> ()
| NodeRef (n, xs) ->
let rec (treeref_node_iter_with_parents:
(('a * ('a, 'b) treeref list ref) -> ('a list) -> unit) ->
- ('a, 'b) treeref -> unit) = fun f tree ->
+ ('a, 'b) treeref -> unit) =
+ fun f tree ->
let rec aux acc tree =
match tree with
| LeafRef _ -> ()
match !res with
| [n,xs] -> NodeRef (n, xs)
| [] -> raise Not_found
- | x::y::zs -> failwith "multi found"
+ | x::y::zs -> raise MultiFound
+
+
+let find_treeref_with_parents_some f tree =
+ let res = ref [] in
+
+ tree +> treeref_node_iter_with_parents (fun (n, xs) parents ->
+ match f (n,xs) parents with
+ | Some v -> push2 v res;
+ | None -> ()
+ );
+ match !res with
+ | [v] -> v
+ | [] -> raise Not_found
+ | x::y::zs -> raise MultiFound
+
+let find_multi_treeref_with_parents_some f tree =
+ let res = ref [] in
+
+ tree +> treeref_node_iter_with_parents (fun (n, xs) parents ->
+ match f (n,xs) parents with
+ | Some v -> push2 v res;
+ | None -> ()
+ );
+ match !res with
+ | [v] -> !res
+ | [] -> raise Not_found
+ | x::y::zs -> !res
+
(*****************************************************************************)
(* Graph. Have a look too at Ograph_*.mli *)
let string_of_parse_info_bis x =
spf "%s:%d:%d" x.file x.line x.column
-
let (info_from_charpos2: int -> filename -> (int * int * string)) =
fun charpos filename ->
let chan = open_in filename in
let linen = ref 0 in
let posl = ref 0 in
- let rec charpos_to_pos_aux () =
- let s = (input_line chan) in
+ let rec charpos_to_pos_aux last_valid =
+ let s =
+ try Some (input_line chan)
+ with End_of_file when charpos = last_valid -> None in
incr linen;
- let s = s ^ "\n" in
- if (!posl + slength s > charpos)
- then begin
- close_in chan;
- (!linen, charpos - !posl, s)
- end
- else begin
- posl := !posl + slength s;
- charpos_to_pos_aux ();
- end
+ match s with
+ Some s ->
+ let s = s ^ "\n" in
+ if (!posl + slength s > charpos)
+ then begin
+ close_in chan;
+ (!linen, charpos - !posl, s)
+ end
+ else begin
+ posl := !posl + slength s;
+ charpos_to_pos_aux !posl;
+ end
+ | None -> (!linen, charpos - !posl, "\n")
in
- let res = charpos_to_pos_aux () in
+ let res = charpos_to_pos_aux 0 in
close_in chan;
res
filename line pos charpos tok (chop linecontent)
let error_message = fun filename (lexeme, lexstart) ->
- try
- error_messagebis filename (lexeme, lexstart) 0
- with End_of_file ->
- begin
+ try error_messagebis filename (lexeme, lexstart) 0
+ with
+ End_of_file ->
("PB in Common.error_message, position " ^ i_to_s lexstart ^
- " given out of file:" ^ filename);
- end
+ " given out of file:" ^ filename)
[
"-nocheck_stack", Arg.Clear check_stack,
" ";
+ "-batch_mode", Arg.Set _batch_mode,
+ " no interactivity"
]
(* potentially other common options but not yet integrated:
HCoop / bpt / coccinelle.git / blobdiff