Commit | Line | Data |
---|---|---|
b1b2de81 C |
1 | (* Yoann Padioleau |
2 | * | |
ae4735db | 3 | * Copyright (C) 2010 INRIA, University of Copenhagen DIKU |
b1b2de81 | 4 | * Copyright (C) 1998-2009 Yoann Padioleau |
34e49164 C |
5 | * |
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. | |
ae4735db | 10 | * |
34e49164 C |
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. | |
15 | *) | |
16 | ||
17 | (*****************************************************************************) | |
18 | (* Notes *) | |
19 | (*****************************************************************************) | |
20 | ||
21 | ||
22 | ||
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). | |
ae4735db | 31 | * |
34e49164 C |
32 | * pixel means code from Pascal Rigaux |
33 | * julia means code from Julia Lawall | |
34 | *) | |
35 | (* ---------------------------------------------------------------------- *) | |
36 | ||
37 | (*****************************************************************************) | |
38 | (* We use *) | |
39 | (*****************************************************************************) | |
ae4735db | 40 | (* |
34e49164 C |
41 | * modules: |
42 | * - Pervasives, of course | |
43 | * - List | |
44 | * - Str | |
45 | * - Hashtbl | |
ae4735db | 46 | * - Format |
34e49164 C |
47 | * - Buffer |
48 | * - Unix and Sys | |
49 | * - Arg | |
ae4735db C |
50 | * |
51 | * functions: | |
52 | * - =, <=, max min, abs, ... | |
34e49164 | 53 | * - List.rev, List.mem, List.partition, |
ae4735db | 54 | * - List.fold*, List.concat, ... |
34e49164 | 55 | * - Str.global_replace |
91eba41f | 56 | * - Filename.is_relative |
0708f913 | 57 | * - String.uppercase, String.lowercase |
ae4735db C |
58 | * |
59 | * | |
34e49164 C |
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. | |
ae4735db C |
64 | * |
65 | * Extra packages | |
34e49164 | 66 | * - ocamlbdb |
91eba41f | 67 | * - ocamlgtk, and gtksourceview |
34e49164 C |
68 | * - ocamlgl |
69 | * - ocamlpython | |
70 | * - ocamlagrep | |
71 | * - ocamlfuse | |
72 | * - ocamlmpi | |
73 | * - ocamlcalendar | |
ae4735db | 74 | * |
91eba41f C |
75 | * - pcre |
76 | * - sdl | |
ae4735db | 77 | * |
91eba41f | 78 | * Many functions in this file were inspired by Haskell or Lisp librairies. |
34e49164 C |
79 | *) |
80 | ||
81 | (*****************************************************************************) | |
82 | (* Prelude *) | |
83 | (*****************************************************************************) | |
84 | ||
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 | |
91 | * reference. *) | |
92 | ||
93 | let (+>) o f = f o | |
94 | let (++) = (@) | |
95 | ||
96 | exception Timeout | |
ae4735db | 97 | exception UnixExit of int |
34e49164 C |
98 | |
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) | |
103 | ||
104 | let sum_int = List.fold_left (+) 0 | |
105 | ||
106 | (* could really call it 'for' :) *) | |
107 | let fold_left_with_index f acc = | |
108 | let rec fold_lwi_aux acc n = function | |
109 | | [] -> acc | |
ae4735db | 110 | | x::xs -> fold_lwi_aux (f acc x n) (n+1) xs |
34e49164 C |
111 | in fold_lwi_aux acc 0 |
112 | ||
113 | ||
ae4735db | 114 | let rec drop n xs = |
34e49164 C |
115 | match (n,xs) with |
116 | | (0,_) -> xs | |
117 | | (_,[]) -> failwith "drop: not enough" | |
118 | | (n,x::xs) -> drop (n-1) xs | |
119 | ||
120 | let rec enum_orig x n = if x = n then [n] else x::enum_orig (x+1) n | |
121 | ||
ae4735db | 122 | let enum x n = |
34e49164 C |
123 | if not(x <= n) |
124 | then failwith (Printf.sprintf "bad values in enum, expect %d <= %d" x n); | |
ae4735db C |
125 | let rec enum_aux acc x n = |
126 | if x = n then n::acc else enum_aux (x::acc) (x+1) n | |
34e49164 C |
127 | in |
128 | List.rev (enum_aux [] x n) | |
129 | ||
ae4735db | 130 | let rec take n xs = |
34e49164 C |
131 | match (n,xs) with |
132 | | (0,_) -> [] | |
133 | | (_,[]) -> failwith "take: not enough" | |
134 | | (n,x::xs) -> x::take (n-1) xs | |
135 | ||
136 | ||
137 | let last_n n l = List.rev (take n (List.rev l)) | |
138 | let last l = List.hd (last_n 1 l) | |
139 | ||
140 | ||
141 | let (list_of_string: string -> char list) = function | |
142 | "" -> [] | |
143 | | s -> (enum 0 ((String.length s) - 1) +> List.map (String.get s)) | |
144 | ||
ae4735db | 145 | let (lines: string -> string list) = fun s -> |
34e49164 C |
146 | let rec lines_aux = function |
147 | | [] -> [] | |
ae4735db C |
148 | | [x] -> if x = "" then [] else [x] |
149 | | x::xs -> | |
150 | x::lines_aux xs | |
34e49164 C |
151 | in |
152 | Str.split_delim (Str.regexp "\n") s +> lines_aux | |
153 | ||
154 | ||
155 | let push2 v l = | |
156 | l := v :: !l | |
157 | ||
b1b2de81 | 158 | let null xs = match xs with [] -> true | _ -> false |
34e49164 C |
159 | |
160 | ||
161 | ||
162 | ||
ae4735db | 163 | let debugger = ref false |
34e49164 C |
164 | |
165 | let unwind_protect f cleanup = | |
ae4735db | 166 | if !debugger then f() else |
34e49164 C |
167 | try f () |
168 | with e -> begin cleanup e; raise e end | |
169 | ||
ae4735db C |
170 | let finalize f cleanup = |
171 | if !debugger then f() else | |
172 | try | |
34e49164 C |
173 | let res = f () in |
174 | cleanup (); | |
175 | res | |
ae4735db | 176 | with e -> |
34e49164 C |
177 | cleanup (); |
178 | raise e | |
179 | ||
180 | let command2 s = ignore(Sys.command s) | |
181 | ||
182 | ||
ae4735db | 183 | let (matched: int -> string -> string) = fun i s -> |
34e49164 C |
184 | Str.matched_group i s |
185 | ||
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) | |
193 | ||
194 | let (with_open_stringbuf: (((string -> unit) * Buffer.t) -> unit) -> string) = | |
195 | fun f -> | |
196 | let buf = Buffer.create 1000 in | |
197 | let pr s = Buffer.add_string buf (s ^ "\n") in | |
198 | f (pr, buf); | |
199 | Buffer.contents buf | |
200 | ||
201 | ||
485bce71 C |
202 | let foldl1 p = function x::xs -> List.fold_left p x xs | _ -> failwith "foldl1" |
203 | ||
34e49164 C |
204 | (*****************************************************************************) |
205 | (* Debugging/logging *) | |
206 | (*****************************************************************************) | |
207 | ||
ae4735db | 208 | (* I used this in coccinelle where the huge logging of stuff ask for |
34e49164 | 209 | * a more organized solution that use more visual indentation hints. |
ae4735db C |
210 | * |
211 | * todo? could maybe use log4j instead ? or use Format module more | |
34e49164 C |
212 | * consistently ? |
213 | *) | |
214 | ||
215 | let _tab_level_print = ref 0 | |
216 | let _tab_indent = 5 | |
217 | ||
218 | ||
219 | let _prefix_pr = ref "" | |
220 | ||
ae4735db | 221 | let indent_do f = |
34e49164 | 222 | _tab_level_print := !_tab_level_print + _tab_indent; |
ae4735db | 223 | finalize f |
34e49164 C |
224 | (fun () -> _tab_level_print := !_tab_level_print - _tab_indent;) |
225 | ||
226 | ||
ae4735db | 227 | let pr s = |
34e49164 C |
228 | print_string !_prefix_pr; |
229 | do_n !_tab_level_print (fun () -> print_string " "); | |
230 | print_string s; | |
ae4735db | 231 | print_string "\n"; |
34e49164 C |
232 | flush stdout |
233 | ||
ae4735db | 234 | let pr_no_nl s = |
34e49164 C |
235 | print_string !_prefix_pr; |
236 | do_n !_tab_level_print (fun () -> print_string " "); | |
237 | print_string s; | |
238 | flush stdout | |
239 | ||
240 | ||
708f4980 C |
241 | |
242 | ||
243 | ||
244 | ||
245 | let _chan_pr2 = ref (None: out_channel option) | |
246 | ||
ae4735db | 247 | let out_chan_pr2 ?(newline=true) s = |
708f4980 C |
248 | match !_chan_pr2 with |
249 | | None -> () | |
ae4735db C |
250 | | Some chan -> |
251 | output_string chan (s ^ (if newline then "\n" else "")); | |
708f4980 C |
252 | flush chan |
253 | ||
ae4735db | 254 | let print_to_stderr = ref true |
708f4980 | 255 | |
ae4735db C |
256 | let pr2 s = |
257 | if !print_to_stderr | |
258 | then | |
259 | begin | |
260 | prerr_string !_prefix_pr; | |
261 | do_n !_tab_level_print (fun () -> prerr_string " "); | |
262 | prerr_string s; | |
263 | prerr_string "\n"; | |
264 | flush stderr; | |
265 | out_chan_pr2 s; | |
266 | () | |
267 | end | |
34e49164 | 268 | |
ae4735db C |
269 | let pr2_no_nl s = |
270 | if !print_to_stderr | |
271 | then | |
272 | begin | |
273 | prerr_string !_prefix_pr; | |
274 | do_n !_tab_level_print (fun () -> prerr_string " "); | |
275 | prerr_string s; | |
276 | flush stderr; | |
277 | out_chan_pr2 ~newline:false s; | |
278 | () | |
279 | end | |
708f4980 | 280 | |
34e49164 | 281 | |
ae4735db | 282 | let pr_xxxxxxxxxxxxxxxxx () = |
34e49164 C |
283 | pr "-----------------------------------------------------------------------" |
284 | ||
ae4735db | 285 | let pr2_xxxxxxxxxxxxxxxxx () = |
34e49164 C |
286 | pr2 "-----------------------------------------------------------------------" |
287 | ||
288 | ||
289 | let reset_pr_indent () = | |
290 | _tab_level_print := 0 | |
291 | ||
ae4735db | 292 | (* old: |
34e49164 | 293 | * let pr s = (print_string s; print_string "\n"; flush stdout) |
ae4735db | 294 | * let pr2 s = (prerr_string s; prerr_string "\n"; flush stderr) |
34e49164 C |
295 | *) |
296 | ||
297 | (* ---------------------------------------------------------------------- *) | |
298 | ||
ae4735db | 299 | (* I can not use the _xxx ref tech that I use for common_extra.ml here because |
34e49164 | 300 | * ocaml don't like the polymorphism of Dumper mixed with refs. |
ae4735db C |
301 | * |
302 | * let (_dump_func : ('a -> string) ref) = ref | |
34e49164 C |
303 | * (fun x -> failwith "no dump yet, have you included common_extra.cmo?") |
304 | * let (dump : 'a -> string) = fun x -> | |
305 | * !_dump_func x | |
ae4735db | 306 | * |
34e49164 C |
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 | |
309 | * this file. | |
310 | *) | |
311 | ||
abad11c5 | 312 | (* don't the code below, use the Dumper module in ocamlextra instead. |
34e49164 C |
313 | (* start of dumper.ml *) |
314 | ||
315 | (* Dump an OCaml value into a printable string. | |
316 | * By Richard W.M. Jones (rich@annexia.org). | |
ae4735db | 317 | * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp |
34e49164 C |
318 | *) |
319 | open Printf | |
320 | open Obj | |
321 | ||
322 | let rec dump r = | |
323 | if is_int r then | |
324 | string_of_int (magic r : int) | |
325 | else ( (* Block. *) | |
326 | let rec get_fields acc = function | |
327 | | 0 -> acc | |
328 | | n -> let n = n-1 in get_fields (field r n :: acc) n | |
329 | in | |
330 | let rec is_list r = | |
331 | if is_int r then ( | |
332 | if (magic r : int) = 0 then true (* [] *) | |
333 | else false | |
334 | ) else ( | |
335 | let s = size r and t = tag r in | |
336 | if t = 0 && s = 2 then is_list (field r 1) (* h :: t *) | |
337 | else false | |
338 | ) | |
339 | in | |
340 | let rec get_list r = | |
341 | if is_int r then [] | |
342 | else let h = field r 0 and t = get_list (field r 1) in h :: t | |
343 | in | |
344 | let opaque name = | |
345 | (* XXX In future, print the address of value 'r'. Not possible in | |
346 | * pure OCaml at the moment. | |
347 | *) | |
348 | "<" ^ name ^ ">" | |
349 | in | |
350 | ||
351 | let s = size r and t = tag r in | |
352 | ||
353 | (* From the tag, determine the type of block. *) | |
354 | if is_list r then ( (* List. *) | |
355 | let fields = get_list r in | |
356 | "[" ^ String.concat "; " (List.map dump fields) ^ "]" | |
357 | ) | |
358 | else if t = 0 then ( (* Tuple, array, record. *) | |
359 | let fields = get_fields [] s in | |
360 | "(" ^ String.concat ", " (List.map dump fields) ^ ")" | |
361 | ) | |
362 | ||
363 | (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not | |
364 | * clear if very large constructed values could have the same | |
365 | * tag. XXX *) | |
366 | else if t = lazy_tag then opaque "lazy" | |
367 | else if t = closure_tag then opaque "closure" | |
368 | else if t = object_tag then ( (* Object. *) | |
369 | let fields = get_fields [] s in | |
370 | let clasz, id, slots = | |
371 | match fields with h::h'::t -> h, h', t | _ -> assert false in | |
372 | (* No information on decoding the class (first field). So just print | |
373 | * out the ID and the slots. | |
374 | *) | |
375 | "Object #" ^ dump id ^ | |
376 | " (" ^ String.concat ", " (List.map dump slots) ^ ")" | |
377 | ) | |
378 | else if t = infix_tag then opaque "infix" | |
379 | else if t = forward_tag then opaque "forward" | |
380 | ||
381 | else if t < no_scan_tag then ( (* Constructed value. *) | |
382 | let fields = get_fields [] s in | |
383 | "Tag" ^ string_of_int t ^ | |
384 | " (" ^ String.concat ", " (List.map dump fields) ^ ")" | |
385 | ) | |
386 | else if t = string_tag then ( | |
387 | "\"" ^ String.escaped (magic r : string) ^ "\"" | |
388 | ) | |
389 | else if t = double_tag then ( | |
390 | string_of_float (magic r : float) | |
391 | ) | |
392 | else if t = abstract_tag then opaque "abstract" | |
393 | else if t = custom_tag then opaque "custom" | |
394 | else if t = final_tag then opaque "final" | |
395 | else failwith ("dump: impossible tag (" ^ string_of_int t ^ ")") | |
396 | ) | |
397 | ||
398 | let dump v = dump (repr v) | |
399 | ||
400 | (* end of dumper.ml *) | |
abad11c5 | 401 | *) |
34e49164 C |
402 | |
403 | (* | |
404 | let (dump : 'a -> string) = fun x -> | |
405 | Dumper.dump x | |
406 | *) | |
407 | ||
408 | ||
409 | (* ---------------------------------------------------------------------- *) | |
abad11c5 | 410 | let pr2_gen x = pr2 (Dumper.dump x) |
34e49164 C |
411 | |
412 | ||
413 | ||
414 | (* ---------------------------------------------------------------------- *) | |
415 | ||
416 | ||
417 | let _already_printed = Hashtbl.create 101 | |
ae4735db | 418 | let disable_pr2_once = ref false |
708f4980 | 419 | |
ae4735db | 420 | let xxx_once f s = |
34e49164 | 421 | if !disable_pr2_once then pr2 s |
ae4735db | 422 | else |
34e49164 C |
423 | if not (Hashtbl.mem _already_printed s) |
424 | then begin | |
425 | Hashtbl.add _already_printed s true; | |
708f4980 | 426 | f ("(ONCE) " ^ s); |
34e49164 C |
427 | end |
428 | ||
708f4980 C |
429 | let pr2_once s = xxx_once pr2 s |
430 | ||
3a314143 C |
431 | let clear_pr2_once _ = Hashtbl.clear _already_printed |
432 | ||
708f4980 | 433 | (* ---------------------------------------------------------------------- *) |
978fd7e5 C |
434 | let mk_pr2_wrappers aref = |
435 | let fpr2 s = | |
708f4980 C |
436 | if !aref |
437 | then pr2 s | |
978fd7e5 | 438 | else |
708f4980 C |
439 | (* just to the log file *) |
440 | out_chan_pr2 s | |
441 | in | |
978fd7e5 | 442 | let fpr2_once s = |
708f4980 C |
443 | if !aref |
444 | then pr2_once s | |
978fd7e5 | 445 | else |
708f4980 C |
446 | xxx_once out_chan_pr2 s |
447 | in | |
978fd7e5 | 448 | fpr2, fpr2_once |
34e49164 C |
449 | |
450 | (* ---------------------------------------------------------------------- *) | |
451 | (* could also be in File section *) | |
452 | ||
978fd7e5 C |
453 | let redirect_stdout file f = |
454 | begin | |
455 | let chan = open_out file in | |
456 | let descr = Unix.descr_of_out_channel chan in | |
457 | ||
458 | let saveout = Unix.dup Unix.stdout in | |
459 | Unix.dup2 descr Unix.stdout; | |
460 | flush stdout; | |
461 | let res = f() in | |
462 | flush stdout; | |
463 | Unix.dup2 saveout Unix.stdout; | |
464 | close_out chan; | |
465 | res | |
466 | end | |
467 | ||
468 | let redirect_stdout_opt optfile f = | |
469 | match optfile with | |
470 | | None -> f() | |
471 | | Some outfile -> redirect_stdout outfile f | |
472 | ||
473 | let redirect_stdout_stderr file f = | |
34e49164 C |
474 | begin |
475 | let chan = open_out file in | |
476 | let descr = Unix.descr_of_out_channel chan in | |
477 | ||
478 | let saveout = Unix.dup Unix.stdout in | |
479 | let saveerr = Unix.dup Unix.stderr in | |
480 | Unix.dup2 descr Unix.stdout; | |
481 | Unix.dup2 descr Unix.stderr; | |
482 | flush stdout; flush stderr; | |
483 | f(); | |
484 | flush stdout; flush stderr; | |
485 | Unix.dup2 saveout Unix.stdout; | |
486 | Unix.dup2 saveerr Unix.stderr; | |
487 | close_out chan; | |
488 | end | |
489 | ||
978fd7e5 | 490 | let redirect_stdin file f = |
34e49164 C |
491 | begin |
492 | let chan = open_in file in | |
493 | let descr = Unix.descr_of_in_channel chan in | |
494 | ||
495 | let savein = Unix.dup Unix.stdin in | |
496 | Unix.dup2 descr Unix.stdin; | |
3a314143 | 497 | let res = f() in |
34e49164 C |
498 | Unix.dup2 savein Unix.stdin; |
499 | close_in chan; | |
3a314143 | 500 | res |
34e49164 C |
501 | end |
502 | ||
978fd7e5 | 503 | let redirect_stdin_opt optfile f = |
34e49164 C |
504 | match optfile with |
505 | | None -> f() | |
506 | | Some infile -> redirect_stdin infile f | |
507 | ||
508 | ||
ae4735db C |
509 | (* cf end |
510 | let with_pr2_to_string f = | |
708f4980 | 511 | *) |
ae4735db | 512 | |
34e49164 C |
513 | |
514 | (* ---------------------------------------------------------------------- *) | |
515 | ||
516 | include Printf | |
517 | ||
518 | (* cf common.mli, fprintf, printf, eprintf, sprintf. | |
519 | * also what is this ? | |
520 | * val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a | |
521 | * val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b | |
522 | *) | |
523 | ||
ae4735db | 524 | (* ex of printf: |
34e49164 C |
525 | * printf "%02d" i |
526 | * for padding | |
527 | *) | |
528 | ||
529 | let spf = sprintf | |
530 | ||
531 | (* ---------------------------------------------------------------------- *) | |
532 | ||
533 | let _chan = ref stderr | |
ae4735db | 534 | let start_log_file () = |
34e49164 C |
535 | let filename = (spf "/tmp/debugml%d:%d" (Unix.getuid()) (Unix.getpid())) in |
536 | pr2 (spf "now using %s for logging" filename); | |
537 | _chan := open_out filename | |
ae4735db | 538 | |
34e49164 C |
539 | |
540 | let dolog s = output_string !_chan (s ^ "\n"); flush !_chan | |
541 | ||
542 | let verbose_level = ref 1 | |
543 | let log s = if !verbose_level >= 1 then dolog s | |
544 | let log2 s = if !verbose_level >= 2 then dolog s | |
545 | let log3 s = if !verbose_level >= 3 then dolog s | |
546 | let log4 s = if !verbose_level >= 4 then dolog s | |
547 | ||
548 | let if_log f = if !verbose_level >= 1 then f() | |
549 | let if_log2 f = if !verbose_level >= 2 then f() | |
550 | let if_log3 f = if !verbose_level >= 3 then f() | |
551 | let if_log4 f = if !verbose_level >= 4 then f() | |
552 | ||
553 | (* ---------------------------------------------------------------------- *) | |
554 | ||
555 | let pause () = (pr2 "pause: type return"; ignore(read_line ())) | |
556 | ||
557 | (* src: from getopt from frish *) | |
558 | let bip () = Printf.printf "\007"; flush stdout | |
ae4735db | 559 | let wait () = Unix.sleep 1 |
34e49164 C |
560 | |
561 | (* was used by fix_caml *) | |
562 | let _trace_var = ref 0 | |
563 | let add_var() = incr _trace_var | |
564 | let dec_var() = decr _trace_var | |
565 | let get_var() = !_trace_var | |
566 | ||
ae4735db | 567 | let (print_n: int -> string -> unit) = fun i s -> |
34e49164 | 568 | do_n i (fun () -> print_string s) |
ae4735db | 569 | let (printerr_n: int -> string -> unit) = fun i s -> |
34e49164 C |
570 | do_n i (fun () -> prerr_string s) |
571 | ||
572 | let _debug = ref true | |
573 | let debugon () = _debug := true | |
574 | let debugoff () = _debug := false | |
575 | let debug f = if !_debug then f () else () | |
576 | ||
577 | ||
578 | ||
579 | (* now in prelude: | |
ae4735db | 580 | * let debugger = ref false |
34e49164 C |
581 | *) |
582 | ||
583 | ||
584 | (*****************************************************************************) | |
585 | (* Profiling *) | |
586 | (*****************************************************************************) | |
587 | ||
588 | let get_mem() = | |
589 | command2("grep VmData /proc/" ^ string_of_int (Unix.getpid()) ^ "/status") | |
590 | ||
591 | let memory_stat () = | |
592 | let stat = Gc.stat() in | |
593 | let conv_mo x = x * 4 / 1000000 in | |
594 | Printf.sprintf "maximal = %d Mo\n" (conv_mo stat.Gc.top_heap_words) ^ | |
595 | Printf.sprintf "current = %d Mo\n" (conv_mo stat.Gc.heap_words) ^ | |
596 | Printf.sprintf "lives = %d Mo\n" (conv_mo stat.Gc.live_words) | |
597 | (* Printf.printf "fragments = %d Mo\n" (conv_mo stat.Gc.fragments); *) | |
598 | ||
ae4735db | 599 | let timenow () = |
34e49164 | 600 | "sys:" ^ (string_of_float (Sys.time ())) ^ " seconds" ^ |
ae4735db | 601 | ":real:" ^ |
34e49164 | 602 | (let tm = Unix.time () +> Unix.gmtime in |
ae4735db | 603 | tm.Unix.tm_min +> string_of_int ^ " min:" ^ |
34e49164 C |
604 | tm.Unix.tm_sec +> string_of_int ^ ".00 seconds") |
605 | ||
ae4735db C |
606 | let _count1 = ref 0 |
607 | let _count2 = ref 0 | |
608 | let _count3 = ref 0 | |
609 | let _count4 = ref 0 | |
610 | let _count5 = ref 0 | |
34e49164 C |
611 | |
612 | let count1 () = incr _count1 | |
613 | let count2 () = incr _count2 | |
614 | let count3 () = incr _count3 | |
615 | let count4 () = incr _count4 | |
616 | let count5 () = incr _count5 | |
617 | ||
ae4735db C |
618 | let profile_diagnostic_basic () = |
619 | Printf.sprintf | |
620 | "count1 = %d\ncount2 = %d\ncount3 = %d\ncount4 = %d\ncount5 = %d\n" | |
34e49164 C |
621 | !_count1 !_count2 !_count3 !_count4 !_count5 |
622 | ||
623 | ||
624 | ||
ae4735db | 625 | let time_func f = |
34e49164 C |
626 | (* let _ = Timing () in *) |
627 | let x = f () in | |
628 | (* let _ = Timing () in *) | |
629 | x | |
630 | ||
631 | (* ---------------------------------------------------------------------- *) | |
632 | ||
633 | type prof = PALL | PNONE | PSOME of string list | |
634 | let profile = ref PNONE | |
485bce71 | 635 | let show_trace_profile = ref false |
34e49164 C |
636 | |
637 | let check_profile category = | |
638 | match !profile with | |
639 | PALL -> true | |
640 | | PNONE -> false | |
641 | | PSOME l -> List.mem category l | |
642 | ||
643 | let _profile_table = ref (Hashtbl.create 100) | |
485bce71 C |
644 | |
645 | let adjust_profile_entry category difftime = | |
ae4735db | 646 | let (xtime, xcount) = |
485bce71 | 647 | (try Hashtbl.find !_profile_table category |
ae4735db | 648 | with Not_found -> |
485bce71 C |
649 | let xtime = ref 0.0 in |
650 | let xcount = ref 0 in | |
651 | Hashtbl.add !_profile_table category (xtime, xcount); | |
652 | (xtime, xcount) | |
653 | ) in | |
654 | xtime := !xtime +. difftime; | |
655 | xcount := !xcount + 1; | |
656 | () | |
657 | ||
34e49164 C |
658 | let profile_start category = failwith "todo" |
659 | let profile_end category = failwith "todo" | |
660 | ||
485bce71 | 661 | |
34e49164 C |
662 | (* subtil: don't forget to give all argumens to f, otherwise partial app |
663 | * and will profile nothing. | |
ae4735db | 664 | * |
0708f913 | 665 | * todo: try also detect when complexity augment each time, so can |
ae4735db C |
666 | * detect the situation for a function gets worse and worse ? |
667 | *) | |
668 | let profile_code category f = | |
34e49164 | 669 | if not (check_profile category) |
fc1ad971 | 670 | then f() |
34e49164 | 671 | else begin |
485bce71 | 672 | if !show_trace_profile then pr2 (spf "p: %s" category); |
34e49164 | 673 | let t = Unix.gettimeofday () in |
ae4735db | 674 | let res, prefix = |
34e49164 C |
675 | try Some (f ()), "" |
676 | with Timeout -> None, "*" | |
677 | in | |
678 | let category = prefix ^ category in (* add a '*' to indicate timeout func *) | |
679 | let t' = Unix.gettimeofday () in | |
485bce71 C |
680 | |
681 | adjust_profile_entry category (t' -. t); | |
34e49164 C |
682 | (match res with |
683 | | Some res -> res | |
684 | | None -> raise Timeout | |
685 | ); | |
686 | end | |
687 | ||
485bce71 | 688 | |
ae4735db | 689 | let _is_in_exclusif = ref (None: string option) |
485bce71 | 690 | |
ae4735db | 691 | let profile_code_exclusif category f = |
485bce71 | 692 | if not (check_profile category) |
ae4735db | 693 | then f() |
485bce71 C |
694 | else begin |
695 | ||
696 | match !_is_in_exclusif with | |
ae4735db | 697 | | Some s -> |
485bce71 | 698 | failwith (spf "profile_code_exclusif: %s but already in %s " category s); |
ae4735db | 699 | | None -> |
485bce71 | 700 | _is_in_exclusif := (Some category); |
ae4735db C |
701 | finalize |
702 | (fun () -> | |
485bce71 | 703 | profile_code category f |
ae4735db C |
704 | ) |
705 | (fun () -> | |
485bce71 C |
706 | _is_in_exclusif := None |
707 | ) | |
708 | ||
709 | end | |
710 | ||
ae4735db | 711 | let profile_code_inside_exclusif_ok category f = |
485bce71 C |
712 | failwith "Todo" |
713 | ||
714 | ||
34e49164 | 715 | (* todo: also put % ? also add % to see if coherent numbers *) |
ae4735db | 716 | let profile_diagnostic () = |
34e49164 | 717 | if !profile = PNONE then "" else |
ae4735db C |
718 | let xs = |
719 | Hashtbl.fold (fun k v acc -> (k,v)::acc) !_profile_table [] | |
34e49164 C |
720 | +> List.sort (fun (k1, (t1,n1)) (k2, (t2,n2)) -> compare t2 t1) |
721 | in | |
ae4735db | 722 | with_open_stringbuf (fun (pr,_) -> |
34e49164 C |
723 | pr "---------------------"; |
724 | pr "profiling result"; | |
725 | pr "---------------------"; | |
ae4735db | 726 | xs +> List.iter (fun (k, (t,n)) -> |
34e49164 C |
727 | pr (sprintf "%-40s : %10.3f sec %10d count" k !t !n) |
728 | ) | |
729 | ) | |
730 | ||
731 | ||
732 | ||
ae4735db | 733 | let report_if_take_time timethreshold s f = |
34e49164 C |
734 | let t = Unix.gettimeofday () in |
735 | let res = f () in | |
736 | let t' = Unix.gettimeofday () in | |
ae4735db | 737 | if (t' -. t > float_of_int timethreshold) |
978fd7e5 | 738 | then pr2 (sprintf "Note: processing took %7.1fs: %s" (t' -. t) s); |
34e49164 C |
739 | res |
740 | ||
ae4735db C |
741 | let profile_code2 category f = |
742 | profile_code category (fun () -> | |
34e49164 C |
743 | if !profile = PALL |
744 | then pr2 ("starting: " ^ category); | |
745 | let t = Unix.gettimeofday () in | |
746 | let res = f () in | |
747 | let t' = Unix.gettimeofday () in | |
748 | if !profile = PALL | |
749 | then pr2 (spf "ending: %s, %fs" category (t' -. t)); | |
750 | res | |
751 | ) | |
ae4735db | 752 | |
34e49164 C |
753 | |
754 | (*****************************************************************************) | |
755 | (* Test *) | |
756 | (*****************************************************************************) | |
757 | let example b = assert b | |
758 | ||
759 | let _ex1 = example (enum 1 4 = [1;2;3;4]) | |
760 | ||
ae4735db C |
761 | let assert_equal a b = |
762 | if not (a = b) | |
763 | then failwith ("assert_equal: those 2 values are not equal:\n\t" ^ | |
abad11c5 | 764 | (Dumper.dump a) ^ "\n\t" ^ (Dumper.dump b) ^ "\n") |
34e49164 | 765 | |
ae4735db | 766 | let (example2: string -> bool -> unit) = fun s b -> |
34e49164 C |
767 | try assert b with x -> failwith s |
768 | ||
769 | (*-------------------------------------------------------------------*) | |
770 | let _list_bool = ref [] | |
771 | ||
ae4735db | 772 | let (example3: string -> bool -> unit) = fun s b -> |
34e49164 C |
773 | _list_bool := (s,b)::(!_list_bool) |
774 | ||
775 | (* could introduce a fun () otherwise the calculus is made at compile time | |
776 | * and this can be long. This would require to redefine test_all. | |
ae4735db | 777 | * let (example3: string -> (unit -> bool) -> unit) = fun s func -> |
34e49164 | 778 | * _list_bool := (s,func):: (!_list_bool) |
ae4735db | 779 | * |
34e49164 C |
780 | * I would like to do as a func that take 2 terms, and make an = over it |
781 | * avoid to add this ugly fun (), but pb of type, cant do that :( | |
782 | *) | |
783 | ||
784 | ||
ae4735db C |
785 | let (test_all: unit -> unit) = fun () -> |
786 | List.iter (fun (s, b) -> | |
34e49164 C |
787 | Printf.printf "%s: %s\n" s (if b then "passed" else "failed") |
788 | ) !_list_bool | |
789 | ||
ae4735db C |
790 | let (test: string -> unit) = fun s -> |
791 | Printf.printf "%s: %s\n" s | |
34e49164 C |
792 | (if (List.assoc s (!_list_bool)) then "passed" else "failed") |
793 | ||
794 | let _ex = example3 "++" ([1;2]++[3;4;5] = [1;2;3;4;5]) | |
795 | ||
796 | (*-------------------------------------------------------------------*) | |
797 | (* Regression testing *) | |
798 | (*-------------------------------------------------------------------*) | |
799 | ||
ae4735db | 800 | (* cf end of file. It uses too many other common functions so I |
34e49164 C |
801 | * have put the code at the end of this file. |
802 | *) | |
803 | ||
804 | ||
805 | ||
806 | (* todo? take code from julien signoles in calendar-2.0.2/tests *) | |
807 | (* | |
808 | ||
809 | (* Generic functions used in the tests. *) | |
810 | ||
811 | val reset : unit -> unit | |
812 | val nb_ok : unit -> int | |
813 | val nb_bug : unit -> int | |
814 | val test : bool -> string -> unit | |
815 | val test_exn : 'a Lazy.t -> string -> unit | |
816 | ||
817 | ||
818 | let ok_ref = ref 0 | |
819 | let ok () = incr ok_ref | |
820 | let nb_ok () = !ok_ref | |
821 | ||
822 | let bug_ref = ref 0 | |
823 | let bug () = incr bug_ref | |
824 | let nb_bug () = !bug_ref | |
825 | ||
826 | let reset () = | |
827 | ok_ref := 0; | |
828 | bug_ref := 0 | |
829 | ||
ae4735db | 830 | let test x s = |
34e49164 C |
831 | if x then ok () else begin Printf.printf "%s\n" s; bug () end;; |
832 | ||
833 | let test_exn x s = | |
834 | try | |
835 | ignore (Lazy.force x); | |
836 | Printf.printf "%s\n" s; | |
837 | bug () | |
838 | with _ -> | |
839 | ok ();; | |
840 | *) | |
841 | ||
842 | ||
843 | (*****************************************************************************) | |
844 | (* Quickcheck like (sfl) *) | |
845 | (*****************************************************************************) | |
846 | ||
847 | (* Better than quickcheck, cos cant do a test_all_prop in haskell cos | |
848 | * prop were functions, whereas here we have not prop_Unix x = ... but | |
ae4735db | 849 | * laws "unit" ... |
34e49164 C |
850 | * |
851 | * How to do without overloading ? objet ? can pass a generator as a | |
852 | * parameter, mais lourd, prefer automatic inferring of the | |
853 | * generator? But at the same time quickcheck does not do better cos | |
ae4735db C |
854 | * we must explictly type the property. So between a |
855 | * prop_unit:: [Int] -> [Int] -> bool ... | |
856 | * prop_unit x = reverse [x] == [x] | |
857 | * and | |
858 | * let _ = laws "unit" (fun x -> reverse [x] = [x]) (listg intg) | |
859 | * there is no real differences. | |
34e49164 C |
860 | * |
861 | * Yes I define typeg generator but quickcheck too, he must define | |
862 | * class instance. I emulate the context Gen a => Gen [a] by making | |
863 | * listg take as a param a type generator. Moreover I have not the pb of | |
ae4735db | 864 | * monad. I can do random independently, so my code is more simple |
34e49164 | 865 | * I think than the haskell code of quickcheck. |
ae4735db | 866 | * |
34e49164 C |
867 | * update: apparently Jane Street have copied some of my code for their |
868 | * Ounit_util.ml and quichcheck.ml in their Core library :) | |
869 | *) | |
870 | ||
871 | (*---------------------------------------------------------------------------*) | |
872 | (* generators *) | |
873 | (*---------------------------------------------------------------------------*) | |
874 | type 'a gen = unit -> 'a | |
875 | ||
876 | let (ig: int gen) = fun () -> | |
877 | Random.int 10 | |
ae4735db | 878 | let (lg: ('a gen) -> ('a list) gen) = fun gen () -> |
34e49164 | 879 | foldn (fun acc i -> (gen ())::acc) [] (Random.int 10) |
ae4735db | 880 | let (pg: ('a gen) -> ('b gen) -> ('a * 'b) gen) = fun gen1 gen2 () -> |
34e49164 C |
881 | (gen1 (), gen2 ()) |
882 | let polyg = ig | |
ae4735db | 883 | let (ng: (string gen)) = fun () -> |
34e49164 C |
884 | "a" ^ (string_of_int (ig ())) |
885 | ||
ae4735db C |
886 | let (oneofl: ('a list) -> 'a gen) = fun xs () -> |
887 | List.nth xs (Random.int (List.length xs)) | |
34e49164 C |
888 | (* let oneofl l = oneof (List.map always l) *) |
889 | ||
ae4735db C |
890 | let (oneof: (('a gen) list) -> 'a gen) = fun xs -> |
891 | List.nth xs (Random.int (List.length xs)) | |
34e49164 C |
892 | |
893 | let (always: 'a -> 'a gen) = fun e () -> e | |
894 | ||
ae4735db | 895 | let (frequency: ((int * ('a gen)) list) -> 'a gen) = fun xs -> |
34e49164 C |
896 | let sums = sum_int (List.map fst xs) in |
897 | let i = Random.int sums in | |
ae4735db C |
898 | let rec freq_aux acc = function |
899 | | (x,g)::xs -> if i < acc+x then g else freq_aux (acc+x) xs | |
900 | | _ -> failwith "frequency" | |
34e49164 C |
901 | in |
902 | freq_aux 0 xs | |
903 | let frequencyl l = frequency (List.map (fun (i,e) -> (i,always e)) l) | |
904 | ||
ae4735db | 905 | (* |
34e49164 C |
906 | let b = oneof [always true; always false] () |
907 | let b = frequency [3, always true; 2, always false] () | |
908 | *) | |
909 | ||
910 | (* cant do this: | |
911 | * let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneofl [[]; lg gen ()] | |
912 | * nor | |
913 | * let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneof [always []; lg gen] | |
ae4735db | 914 | * |
34e49164 C |
915 | * because caml is not as lazy as haskell :( fix the pb by introducing a size |
916 | * limit. take the bounds/size as parameter. morover this is needed for | |
917 | * more complex type. | |
ae4735db | 918 | * |
34e49164 | 919 | * how make a bintreeg ?? we need recursion |
ae4735db C |
920 | * |
921 | * let rec (bintreeg: ('a gen) -> ('a bintree) gen) = fun gen () -> | |
922 | * let rec aux n = | |
34e49164 C |
923 | * if n = 0 then (Leaf (gen ())) |
924 | * else frequencyl [1, Leaf (gen ()); 4, Branch ((aux (n / 2)), aux (n / 2))] | |
925 | * () | |
926 | * in aux 20 | |
ae4735db | 927 | * |
34e49164 C |
928 | *) |
929 | ||
930 | ||
931 | (*---------------------------------------------------------------------------*) | |
932 | (* property *) | |
933 | (*---------------------------------------------------------------------------*) | |
934 | ||
935 | (* todo: a test_all_laws, better syntax (done already a little with ig in | |
ae4735db C |
936 | * place of intg. En cas d'erreur, print the arg that not respect |
937 | * | |
34e49164 C |
938 | * todo: with monitoring, as in haskell, laws = laws2, no need for 2 func, |
939 | * but hard i found | |
ae4735db C |
940 | * |
941 | * todo classify, collect, forall | |
34e49164 C |
942 | *) |
943 | ||
944 | ||
945 | (* return None when good, and Just the_problematic_case when bad *) | |
946 | let (laws: string -> ('a -> bool) -> ('a gen) -> 'a option) = fun s func gen -> | |
947 | let res = foldn (fun acc i -> let n = gen() in (n, func n)::acc) [] 1000 in | |
948 | let res = List.filter (fun (x,b) -> not b) res in | |
949 | if res = [] then None else Some (fst (List.hd res)) | |
950 | ||
951 | let rec (statistic_number: ('a list) -> (int * 'a) list) = function | |
952 | | [] -> [] | |
953 | | x::xs -> let (splitg, splitd) = List.partition (fun y -> y = x) xs in | |
954 | (1+(List.length splitg), x)::(statistic_number splitd) | |
955 | ||
956 | (* in pourcentage *) | |
957 | let (statistic: ('a list) -> (int * 'a) list) = fun xs -> | |
958 | let stat_num = statistic_number xs in | |
959 | let totals = sum_int (List.map fst stat_num) in | |
ae4735db C |
960 | List.map (fun (i, v) -> ((i * 100) / totals), v) stat_num |
961 | ||
962 | let (laws2: | |
963 | string -> ('a -> (bool * 'b)) -> ('a gen) -> | |
964 | ('a option * ((int * 'b) list ))) = | |
34e49164 C |
965 | fun s func gen -> |
966 | let res = foldn (fun acc i -> let n = gen() in (n, func n)::acc) [] 1000 in | |
967 | let stat = statistic (List.map (fun (x,(b,v)) -> v) res) in | |
968 | let res = List.filter (fun (x,(b,v)) -> not b) res in | |
969 | if res = [] then (None, stat) else (Some (fst (List.hd res)), stat) | |
970 | ||
971 | ||
972 | (* | |
973 | let b = laws "unit" (fun x -> reverse [x] = [x] )ig | |
974 | let b = laws "app " (fun (xs,ys) -> reverse (xs++ys) = reverse ys++reverse xs)(pg (lg ig)(lg ig)) | |
975 | let b = laws "rev " (fun xs -> reverse (reverse xs) = xs )(lg ig) | |
976 | let b = laws "appb" (fun (xs,ys) -> reverse (xs++ys) = reverse xs++reverse ys)(pg (lg ig)(lg ig)) | |
977 | let b = laws "max" (fun (x,y) -> x <= y ==> (max x y = y) )(pg ig ig) | |
978 | ||
ae4735db | 979 | let b = laws2 "max" (fun (x,y) -> ((x <= y ==> (max x y = y)), x <= y))(pg ig ig) |
34e49164 C |
980 | *) |
981 | ||
982 | ||
983 | (* todo, do with coarbitrary ?? idea is that given a 'a, generate a 'b | |
984 | * depending of 'a and gen 'b, that is modify gen 'b, what is important is | |
985 | * that each time given the same 'a, we must get the same 'b !!! | |
986 | *) | |
987 | ||
988 | (* | |
989 | let (fg: ('a gen) -> ('b gen) -> ('a -> 'b) gen) = fun gen1 gen2 () -> | |
990 | let b = laws "funs" (fun (f,g,h) -> x <= y ==> (max x y = y) )(pg ig ig) | |
991 | *) | |
992 | ||
993 | (* | |
ae4735db | 994 | let one_of xs = List.nth xs (Random.int (List.length xs)) |
34e49164 C |
995 | let take_one xs = |
996 | if empty xs then failwith "Take_one: empty list" | |
ae4735db | 997 | else |
34e49164 C |
998 | let i = Random.int (List.length xs) in |
999 | List.nth xs i, filter_index (fun j _ -> i <> j) xs | |
ae4735db | 1000 | *) |
34e49164 C |
1001 | |
1002 | (*****************************************************************************) | |
1003 | (* Persistence *) | |
1004 | (*****************************************************************************) | |
1005 | ||
ae4735db | 1006 | let get_value filename = |
34e49164 C |
1007 | let chan = open_in filename in |
1008 | let x = input_value chan in (* <=> Marshal.from_channel *) | |
1009 | (close_in chan; x) | |
1010 | ||
ae4735db | 1011 | let write_value valu filename = |
34e49164 C |
1012 | let chan = open_out filename in |
1013 | (output_value chan valu; (* <=> Marshal.to_channel *) | |
1014 | (* Marshal.to_channel chan valu [Marshal.Closures]; *) | |
ae4735db | 1015 | close_out chan) |
34e49164 | 1016 | |
ae4735db | 1017 | let write_back func filename = |
34e49164 C |
1018 | write_value (func (get_value filename)) filename |
1019 | ||
1020 | ||
485bce71 C |
1021 | let read_value f = get_value f |
1022 | ||
34e49164 | 1023 | |
ae4735db | 1024 | let marshal__to_string2 v flags = |
0708f913 | 1025 | Marshal.to_string v flags |
ae4735db | 1026 | let marshal__to_string a b = |
0708f913 C |
1027 | profile_code "Marshalling" (fun () -> marshal__to_string2 a b) |
1028 | ||
ae4735db | 1029 | let marshal__from_string2 v flags = |
0708f913 | 1030 | Marshal.from_string v flags |
ae4735db | 1031 | let marshal__from_string a b = |
0708f913 C |
1032 | profile_code "Marshalling" (fun () -> marshal__from_string2 a b) |
1033 | ||
1034 | ||
1035 | ||
34e49164 C |
1036 | (*****************************************************************************) |
1037 | (* Counter *) | |
1038 | (*****************************************************************************) | |
1039 | let _counter = ref 0 | |
1040 | let counter () = (_counter := !_counter +1; !_counter) | |
1041 | ||
1042 | let _counter2 = ref 0 | |
1043 | let counter2 () = (_counter2 := !_counter2 +1; !_counter2) | |
1044 | ||
1045 | let _counter3 = ref 0 | |
1046 | let counter3 () = (_counter3 := !_counter3 +1; !_counter3) | |
1047 | ||
1048 | type timestamp = int | |
1049 | ||
1050 | (*****************************************************************************) | |
1051 | (* String_of *) | |
1052 | (*****************************************************************************) | |
1053 | (* To work with the macro system autogenerated string_of and print_ function | |
1054 | (kind of deriving a la haskell) *) | |
1055 | ||
ae4735db | 1056 | (* int, bool, char, float, ref ?, string *) |
34e49164 C |
1057 | |
1058 | let string_of_string s = "\"" ^ s "\"" | |
1059 | ||
ae4735db | 1060 | let string_of_list f xs = |
34e49164 C |
1061 | "[" ^ (xs +> List.map f +> String.concat ";" ) ^ "]" |
1062 | ||
1063 | let string_of_unit () = "()" | |
1064 | ||
1065 | let string_of_array f xs = | |
1066 | "[|" ^ (xs +> Array.to_list +> List.map f +> String.concat ";") ^ "|]" | |
1067 | ||
1068 | let string_of_option f = function | |
1069 | | None -> "None " | |
1070 | | Some x -> "Some " ^ (f x) | |
1071 | ||
1072 | ||
1073 | ||
1074 | ||
1075 | let print_bool x = print_string (if x then "True" else "False") | |
1076 | ||
1077 | let print_option pr = function | |
1078 | | None -> print_string "None" | |
1079 | | Some x -> print_string "Some ("; pr x; print_string ")" | |
1080 | ||
ae4735db | 1081 | let print_list pr xs = |
34e49164 | 1082 | begin |
ae4735db C |
1083 | print_string "["; |
1084 | List.iter (fun x -> pr x; print_string ",") xs; | |
34e49164 C |
1085 | print_string "]"; |
1086 | end | |
1087 | ||
ae4735db C |
1088 | (* specialised |
1089 | let (string_of_list: char list -> string) = | |
34e49164 C |
1090 | List.fold_left (fun acc x -> acc^(Char.escaped x)) "" |
1091 | *) | |
1092 | ||
1093 | ||
1094 | let rec print_between between fn = function | |
1095 | | [] -> () | |
1096 | | [x] -> fn x | |
1097 | | x::xs -> fn x; between(); print_between between fn xs | |
1098 | ||
1099 | ||
1100 | ||
1101 | ||
ae4735db C |
1102 | let adjust_pp_with_indent f = |
1103 | Format.open_box !_tab_level_print; | |
34e49164 | 1104 | (*Format.force_newline();*) |
ae4735db | 1105 | f(); |
34e49164 C |
1106 | Format.close_box (); |
1107 | Format.print_newline() | |
1108 | ||
ae4735db C |
1109 | let adjust_pp_with_indent_and_header s f = |
1110 | Format.open_box (!_tab_level_print + String.length s); | |
34e49164 C |
1111 | do_n !_tab_level_print (fun () -> Format.print_string " "); |
1112 | Format.print_string s; | |
1113 | f(); | |
1114 | Format.close_box (); | |
1115 | Format.print_newline() | |
1116 | ||
1117 | ||
1118 | ||
1119 | let pp_do_in_box f = Format.open_box 1; f(); Format.close_box () | |
1120 | let pp_do_in_zero_box f = Format.open_box 0; f(); Format.close_box () | |
1121 | ||
ae4735db C |
1122 | let pp_f_in_box f = |
1123 | Format.open_box 1; | |
1124 | let res = f() in | |
34e49164 C |
1125 | Format.close_box (); |
1126 | res | |
1127 | ||
1128 | let pp s = Format.print_string s | |
1129 | ||
ae4735db | 1130 | let mk_str_func_of_assoc_conv xs = |
0708f913 C |
1131 | let swap (x,y) = (y,x) in |
1132 | ||
ae4735db | 1133 | (fun s -> |
0708f913 C |
1134 | let xs' = List.map swap xs in |
1135 | List.assoc s xs' | |
1136 | ), | |
ae4735db | 1137 | (fun a -> |
0708f913 C |
1138 | List.assoc a xs |
1139 | ) | |
1140 | ||
708f4980 C |
1141 | |
1142 | ||
1143 | (* julia: convert something printed using format to print into a string *) | |
1144 | (* now at bottom of file | |
1145 | let format_to_string f = | |
1146 | ... | |
1147 | *) | |
1148 | ||
1149 | ||
1150 | ||
34e49164 C |
1151 | (*****************************************************************************) |
1152 | (* Macro *) | |
1153 | (*****************************************************************************) | |
1154 | ||
1155 | (* put your macro in macro.ml4, and you can test it interactivly as in lisp *) | |
ae4735db | 1156 | let macro_expand s = |
34e49164 C |
1157 | let c = open_out "/tmp/ttttt.ml" in |
1158 | begin | |
1159 | output_string c s; close_out c; | |
feec80c3 C |
1160 | command2 (Commands.ocamlc_cmd ^ " -c -pp '" ^ Commands.camlp4o_cmd ^" pa_extend.cmo q_MLast.cmo -impl' " ^ |
1161 | "-I +" ^ Commands.camlp4_cmd ^ " -impl macro.ml4"); | |
1162 | command2 (Commands.camlp4o_cmd ^" ./macro.cmo pr_o.cmo /tmp/ttttt.ml"); | |
1163 | Unix.unlink "/tmp/ttttt.ml"; | |
34e49164 C |
1164 | end |
1165 | ||
1166 | (* | |
1167 | let t = macro_expand "{ x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x>2 and y<3}" | |
1168 | let x = { x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x > 2 and y < 3} | |
1169 | let t = macro_expand "{1 .. 10}" | |
1170 | let x = {1 .. 10} +> List.map (fun i -> i) | |
1171 | let t = macro_expand "[1;2] to append to [2;4]" | |
1172 | let t = macro_expand "{x = 2; x = 3}" | |
1173 | ||
1174 | let t = macro_expand "type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree)" | |
1175 | *) | |
1176 | ||
ae4735db | 1177 | |
34e49164 C |
1178 | |
1179 | (*****************************************************************************) | |
1180 | (* Composition/Control *) | |
1181 | (*****************************************************************************) | |
1182 | ||
1183 | (* I like the obj.func object notation. In OCaml cant use '.' so I use +> | |
ae4735db | 1184 | * |
34e49164 C |
1185 | * update: it seems that F# agrees with me :) but they use |> |
1186 | *) | |
1187 | ||
1188 | (* now in prelude: | |
1189 | * let (+>) o f = f o | |
1190 | *) | |
ae4735db C |
1191 | let (+!>) refo f = refo := f !refo |
1192 | (* alternatives: | |
34e49164 | 1193 | * let ((@): 'a -> ('a -> 'b) -> 'b) = fun a b -> b a |
ae4735db | 1194 | * let o f g x = f (g x) |
34e49164 C |
1195 | *) |
1196 | ||
1197 | let ($) f g x = g (f x) | |
1198 | let compose f g x = f (g x) | |
1199 |