src/utilities/misc.ml

   1 module LexingExt = struct
   2
   3   open Lexing
   4
   5   let new_line lexbuf =
   6     lexbuf.lex_curr_p <- {
   7       lexbuf.lex_curr_p with
   8         pos_bol  = 0;
   9         pos_lnum = lexbuf.lex_curr_p.pos_lnum + 1
  10     }
  11
  12   let lex_num s pos =
  13     let rec num i =
  14         if s.[i] >= '0' && s.[i] <= '9' then
  15           num (i + 1)
  16         else
  17           i
  18     in
  19     let pos' = num pos in
  20     if pos = pos' then
  21       None
  22     else
  23       Some (pos, pos', int_of_string (String.sub s pos (pos' - pos)))
  24
  25 end
  26
  27 module ListExt = struct
  28
  29   let inv_assoc l = List.map (fun (x, y) -> (y, x)) l
  30
  31   exception EmptyList
  32
  33   let last l = try List.hd (List.rev l) with _ -> raise EmptyList
  34
  35   let cut_last l =
  36     let rec aux l = function
  37       | []      -> raise EmptyList
  38       | [ x ]   -> (x, List.rev l)
  39       | x :: xs -> aux (x :: l) xs
  40     in
  41     aux [] l
  42
  43   let multi_set_of_list l =
  44     let h = Hashtbl.create 13 in
  45     let incr_occ x =
  46       let o = try Hashtbl.find h x with Not_found -> 0 in
  47       Hashtbl.replace h x (o + 1)
  48     in
  49     List.iter incr_occ l;
  50     Hashtbl.fold (fun k v accu -> (k, v) :: accu) h []
  51
  52   let hashtbl_of_assoc l =
  53     let h = Hashtbl.create 13 in
  54     List.iter (fun (k, v) -> Hashtbl.add h k v) l;
  55     h
  56
  57   exception Conflict
  58   let assoc_union l1 l2 =
  59     let h1 = hashtbl_of_assoc l1 in
  60     l1
  61     @ List.filter
  62       (fun (k, v1) ->
  63         try
  64           let v2 = Hashtbl.find h1 k in
  65           if v1 <> v2 then raise Conflict;
  66           false
  67         with _ -> true) l2
  68
  69   let assoc_diff l1 l2 =
  70     let h1 = hashtbl_of_assoc l1 in
  71     let h2 = hashtbl_of_assoc l2 in
  72     let diff h1 h2 f =
  73       Hashtbl.fold
  74         (fun k v1 accu ->
  75           let v2 =
  76             try Some (Hashtbl.find h2 k)
  77             with Not_found -> None
  78           in
  79           if Some v1 <> v2 then
  80             if f then
  81               (k, (Some v1, v2)) :: accu
  82             else
  83               (k, (v2, Some v1)) :: accu
  84           else
  85             accu)
  86         h1 []
  87     in
  88     let d1 = diff h1 h2 true in
  89     let d2 = diff h2 h1 false in
  90     try assoc_union d1 d2
  91     with Conflict -> assert false
  92
  93   let transitive_forall2 p l =
  94     let rec aux = function
  95       | []  -> None
  96       | [x] -> None
  97       | x1 :: ((x2 :: _) as xs) ->
  98         if not (p x1 x2) then Some (x1, x2) else aux xs
  99     in
 100     aux l
 101
 102   let repeat init n f =
 103     let rec aux accu vs i =
 104       if i = 0 then (accu, vs) else
 105         let (accu, v) = f accu i in
 106         aux accu (v :: vs) (pred i)
 107     in
 108     assert (n >= 0);
 109     aux init [] n
 110
 111 end
 112
 113 module ArgExt = struct
 114
 115   let extra_doc s = "", Arg.Unit ignore, s
 116
 117 end
 118
 119 module SysExt = struct
 120
 121   let safe_remove name =
 122     try Sys.remove name with Sys_error _ -> ()
 123
 124   let rec alternative name =
 125     let split name =
 126       match LexingExt.lex_num name 0 with
 127         | None -> None
 128         | Some (start, stop, num) ->
 129           let len = String.length name in
 130           Some (num, String.sub name (stop+1) (len - stop - 1))
 131     in
 132     if not (Sys.file_exists name) then
 133       name
 134     else
 135       let dirname = Filename.dirname name in
 136       let filename = Filename.basename name in
 137       let filename =
 138         match split filename with
 139           | None ->
 140             "01-" ^ filename
 141           | Some (i, name) ->
 142             Printf.sprintf "%02d-%s" (i + 1) name
 143       in
 144       alternative (Filename.concat dirname filename)
 145
 146 end
 147
 148 module IOExt = struct
 149
 150   let stdout_buffer    = Buffer.create 13
 151   let stdout_formatter = Format.formatter_of_buffer stdout_buffer
 152   let stderr_buffer    = Buffer.create 13
 153   let stderr_formatter = Format.formatter_of_buffer stderr_buffer
 154   let enable_buffering = ref false
 155
 156   let printf fmt =
 157     if !enable_buffering then
 158       Format.fprintf stdout_formatter fmt
 159     else
 160       Format.printf fmt
 161
 162   let eprintf fmt =
 163     if !enable_buffering then
 164       Format.fprintf stderr_formatter fmt
 165     else
 166       Format.eprintf fmt
 167
 168   let get_buffers () =
 169     let out =
 170       (Buffer.contents stdout_buffer, Buffer.contents stderr_buffer)
 171     in
 172     Buffer.clear stdout_buffer;
 173     Buffer.clear stderr_buffer;
 174     out
 175
 176   let set_buffered_mode () =
 177     enable_buffering := true
 178
 179 end
 180
 181 module Timed = struct
 182
 183   let time now print_date f =
 184     fun x ->
 185       let start_date = now () in
 186       let y = f x in
 187       let stop_date = now () in
 188       print_date start_date stop_date;
 189       y
 190
 191   let get_now = ref (fun () -> 0.)
 192
 193   let set_now now = get_now := now
 194
 195   let enable_profiling = ref false
 196
 197   let set_profiling_flag t = enable_profiling := t
 198
 199   let profile title f =
 200     let print_date start stop =
 201       IOExt.eprintf "[%05.0fms] %s\n" (stop -. start) title
 202     in
 203     if !enable_profiling then
 204       time !get_now print_date f
 205     else
 206       f
 207
 208 end