2 * Zack's own OCaml library -- set of "helpers" function for the OCaml language
5 * Stefano Zacchiroli <zack@bononia.it>
7 * This module is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * This module is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with this module; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
25 exception Not_implemented ;;
27 let (newline, newline_len) =
28 let default_newline = "\n" in
30 match Sys.os_type with
32 | "Win32" | "Cygwin" -> "\r\n"
34 | _ -> default_newline
36 (newline, String.length newline)
42 let non pred x = not (pred x) ;;
43 let conj p1 p2 x = (p1 x) && (p2 x) ;;
44 let disj p1 p2 x = (p1 x) || (p2 x) ;;
45 let imply p1 p2 x = (non p1) x || p2 x ;;
57 exception Found of int;;
59 (** return the index of first element in ary on which pred is true *)
62 Array.iteri (fun idx e -> if pred e then raise (Found idx)) ary;
66 (** as index but return the element itself instead of the index *)
67 let find pred ary = ary.(index pred ary) ;;
68 (** check if at least one element in ary satisfies pred *)
71 ignore (find pred ary);
73 with Not_found -> false
75 (** check if all elements in ary satisfy pred *)
76 let for_all pred ary = not (exists (ZLogic.non pred) ary) ;;
78 (** return a fresh array containing all elements of ary that satisfy pred
81 let indexes = (* indexes of element on which pred is satisfied *)
84 (fun (i, acc) e -> if pred e then (i+1, i::acc) else (i+1, acc))
90 let size = List.length indexes in
91 let newary = Array.make size ary.(0) in
92 let rec fill i = function
95 newary.(i) <- ary.(idx);
103 raise Not_implemented; () ;;
105 raise Not_implemented; () ;;
111 (** fold on dbm key and values, processing order is not specified *)
112 let fold f init dbm =
113 let res = ref init in
114 Dbm.iter (fun key value -> res := f !res key value) dbm;
121 let keys tbl = Hashtbl.fold (fun key _ acc -> key :: acc) tbl [] ;;
122 let values tbl = Hashtbl.fold (fun _ valu acc -> valu :: acc) tbl [] ;;
123 let remove_all tbl key =
124 for i = 1 to List.length (Hashtbl.find_all tbl key) do
125 Hashtbl.remove tbl key
132 (** tail recursive version of List.map *)
134 let rec aux acc = function
136 | hd :: tl -> aux (f hd :: acc) tl
140 (** guarded map on lists. List.length output <= List.length input.
141 Not tail recursive *)
142 let rec map_if f pred = function
144 | hd::tl when pred hd -> f hd :: map_if f pred tl
145 | hd::tl -> map_if f pred tl
147 (** tail recursive version of map_if *)
148 let map_if' f pred l =
149 let rec aux acc = function
151 | hd::tl when pred hd -> aux (f hd :: acc) tl
152 | hd::tl -> aux acc tl
156 (** low level to implement assoc_all and assq_all *)
157 let assoc_all_gen eq key list =
158 let rec aux acc = function
160 | (k, v)::tl when (eq k key) -> aux (v :: acc) tl
161 | _::tl -> aux acc tl
163 List.rev (aux [] list)
165 (** return all binding of k in association list l in the order they appear
166 in l. Uses structural equality *)
167 let assoc_all k l = assoc_all_gen (=) k l ;;
168 (** as assoc_all but uses physical equality *)
169 let assq_all k l = assoc_all_gen (==) k l ;;
170 let lrotate = function
171 | [] -> raise (Invalid_argument "Zack.List.lrotate")
172 | hd::tl -> tl @ [hd]
175 match List.rev l with
176 | [] -> raise (Invalid_argument "Zack.List.rrotate")
177 | hd::tl -> hd :: List.rev tl
184 raise Not_implemented; () ;;
191 raise Not_implemented; () ;;
193 let get_stats follow_symlink =
194 if follow_symlink then Unix.stat else Unix.lstat
196 (* low level for is_* predicates *)
197 let is_file_kind follow_symlink kind fname =
198 (get_stats follow_symlink fname).Unix.st_kind = kind
200 let is_regular ?(follow_symlink = true) =
201 is_file_kind follow_symlink Unix.S_REG ;;
202 let is_directory ?(follow_symlink = true) =
203 is_file_kind follow_symlink Unix.S_DIR ;;
204 let is_chardev ?(follow_symlink = true) =
205 is_file_kind follow_symlink Unix.S_CHR ;;
206 let is_blockdev ?(follow_symlink = true) =
207 is_file_kind follow_symlink Unix.S_BLK ;;
208 let is_symlink ?(follow_symlink = false) =
209 is_file_kind follow_symlink Unix.S_LNK ;;
210 let is_fifo ?(follow_symlink = true) =
211 is_file_kind follow_symlink Unix.S_FIFO ;;
212 let is_socket ?(follow_symlink = true) =
213 is_file_kind follow_symlink Unix.S_SOCK ;;
215 let size ?(follow_symlink = true) fname =
216 (get_stats follow_symlink fname).Unix.st_size ;;
218 (** return a list of all entries contained in a directory. Return order is
221 let dir = Unix.opendir dirname in
223 match (try Some (Unix.readdir dir) with End_of_file -> None) with
224 | Some entry -> aux (entry :: acc)
237 (** string -> char list *)
239 let chars = ref [] in
240 for i = String.length s - 1 downto 0 do
241 chars := s.[i] :: !chars
246 (** char list -> string *)
248 let buf = Buffer.create (List.length l) in
249 let rec implode' = function
250 | [] -> Buffer.contents buf
252 Buffer.add_char buf hd;
258 (** perl's chomp, remove once trailing "\n", if any *)
260 let len = String.length s in
261 let diff = len - newline_len in
262 if String.sub s diff newline_len = newline then (* trailing newline *)
270 for i = 0 to String.length s do
275 (** fold_left on string *)
276 let fold_left f init s =
277 let len = String.length s in
278 let rec fold_left' idx acc =
282 fold_left' (idx + 1) (f acc s.[idx])
288 let fold_right f s init =
289 let len = String.length s in
290 let rec fold_right' idx acc =
294 fold_right' (idx - 1) (f s.[idx] acc)
296 fold_right' len (init - 1)
299 (** iter on string *)
300 let iter (f: char -> unit) = fold_left (fun _ c -> f c) () ;;
302 let string_iter (f: char -> unit) s =
303 for i = 0 to String.length s do
310 raise Not_implemented; () ;;
312 (** create a string of length len and sets each char of them to the result
313 of applying f to the char's index *)
315 let str = String.create len in
316 for i = 0 to len - 1 do
327 type ranges = (int * int) list
329 let digit_range = [48, 57] ;;
330 let alpha_upper_range = [65, 90] ;;
331 let alpha_lower_range = [97, 122] ;;
332 let alpha_range = alpha_upper_range @ alpha_lower_range ;;
333 let alphanum_range = digit_range @ alpha_range ;;
334 let word_range = alphanum_range @ [95, 95] ;; (* alphanum + '_' *)
336 let rec ranges_are_sane = function
337 | (min, max) :: tl ->
338 if min > max || min < 0 || max > 255 then
339 failwith (sprintf "ZRandom: invalid range %d .. %d" min max);
343 let size_of_ranges = (* assumption: ranges are sane *)
344 let rec aux acc = function
346 | ((min, max) as range) :: tl -> aux (acc + (max - min + 1)) tl
350 let nth_in_ranges idx ranges = (* assumption: ranges are sane *)
352 failwith "ZRandom: no range provided";
353 let rec aux idx = function
355 | (min, max) :: tl ->
356 let nth = min + idx in
357 if nth <= max then nth else aux (nth - max - 1) tl
362 (* low level for char and string *)
364 let int = Random.int (size_of_ranges ranges) in
365 Char.chr (nth_in_ranges int ranges)
368 (** generate a random char inside provided ranges. Ranges are provided as
369 a list of int pairs. Each pair represent an inclusive interval of possible
370 character codes. Default range is [0, 255] *)
371 let char ?(ranges = [0,255]) () =
372 ranges_are_sane ranges;
376 (** generate a string of random characters inside provided range *)
377 let string ?(ranges = [0,255]) len =
378 ranges_are_sane ranges;
379 ZString.init len (fun _ -> char' ranges)
387 (** map on streams. Beware that this function build stream using
388 Stream.from. That kind of stream can't be mixed with ordinary streams *)
391 (fun _ -> try Some (f (Stream.next stream)) with Stream.Failure -> None)
393 (** fold on streams. Beware that this function build stream using
394 Stream.from. That kind of stream can't be mixed with ordinary streams *)
395 let rec fold f init stream =
396 match (try Some (Stream.next stream) with Stream.Failure -> None) with
397 | Some item -> fold f (f init item) stream
401 (** given an input channel return the stream of its lines (without
402 trailing new line) *)
404 Stream.from (fun _ -> try Some (input_line ic) with End_of_file -> None)
409 (** fold_left on input channel lines *)
410 let rec fold_in f init ic =
411 match (try Some (input_line ic) with End_of_file -> None) with
412 | Some l -> fold_in f (f init l) ic
416 (** iter on input channel lines *)
417 let iter_in f = fold_in (fun _ line -> f line) () ;;
419 (** map on input channel lines *)
420 let map_in f ic = List.rev (fold_in (fun acc line -> f line :: acc) [] ic) ;;
422 (** return list of lines read from an input channel *)
423 let input_lines ic = List.rev (fold_in (fun acc line -> line :: acc) [] ic) ;;
425 (** read all data available on an input channel and return them as a string *)
428 let buflen = 8192 * 2 in
429 let str = String.create strlen in
431 let buf = Buffer.create buflen in
433 let bytes = input ic str 0 strlen in
434 if bytes = 0 then (* EOF *)
437 Buffer.add_substring buf str 0 bytes;
444 (** write a list of lines to an output channel. Newline is added at the end of
446 let rec output_lines lines oc =
450 output_string oc (hd ^ newline);
454 (** read_lines on stdin *)
455 let read_lines () = input_lines stdin ;;
456 (** read_all on stdin *)
457 let read_all () = input_all stdin ;;
459 (** Some constructor inverse *)
460 let unsome = function
462 | None -> raise (Invalid_argument "Zack.unsome")
465 module Array = ZArray ;;
467 module Hashtbl = ZHashtbl ;;
468 module List = ZList ;;
469 module Logic = ZLogic ;;
470 module Random = ZRandom ;;
471 module Stream = ZStream ;;
472 module String = ZString ;;
474 module Unix = ZUnix ;;