helm/ocaml/extlib/hExtlib.ml

   1 (* Copyright (C) 2005, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM 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.
  11  *
  12  * HELM 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.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://cs.unibo.it/helm/.
  24  *)
  25
  26
  27 (** PROFILING *)
  28
  29 (* we should use a key in te registry, but we can't see the registry.. *)
  30 let profiling_enabled = true
  31
  32 let profiling_printings = ref (fun () -> true)
  33 let set_profiling_printings f = profiling_printings := f
  34
  35 type profiler = { profile : 'a 'b. ('a -> 'b) -> 'a -> 'b }
  36 let profile ?(enable = true) =
  37  if profiling_enabled  && enable then
  38   function s ->
  39    let total = ref 0.0 in
  40    let profile f x =
  41     let before = Unix.gettimeofday () in
  42     try
  43      let res = f x in
  44      let after = Unix.gettimeofday () in
  45       total := !total +. (after -. before);
  46       res
  47     with
  48      exc ->
  49       let after = Unix.gettimeofday () in
  50        total := !total +. (after -. before);
  51        raise exc
  52    in
  53    at_exit
  54     (fun () ->
  55       if !profiling_printings () then
  56         prerr_endline
  57          ("!! TOTAL TIME SPENT IN " ^ s ^ ": " ^ string_of_float !total));
  58    { profile = profile }
  59  else
  60   function _ -> { profile = fun f x -> f x }
  61
  62 (** {2 Optional values} *)
  63
  64 let map_option f = function None -> None | Some v -> Some (f v)
  65 let iter_option f = function None -> () | Some v -> f v
  66 let unopt = function None -> failwith "unopt: None" | Some v -> v
  67
  68 (** {2 String processing} *)
  69
  70 let split ?(sep = ' ') s =
  71   let pieces = ref [] in
  72   let rec aux idx =
  73     match (try Some (String.index_from s idx sep) with Not_found -> None) with
  74     | Some pos ->
  75         pieces := String.sub s idx (pos - idx) :: !pieces;
  76         aux (pos + 1)
  77     | None -> pieces := String.sub s idx (String.length s - idx) :: !pieces
  78   in
  79   aux 0;
  80   List.rev !pieces
  81
  82 let trim_blanks s =
  83   let rec find_left idx =
  84     match s.[idx] with
  85     | ' ' | '\t' | '\r' | '\n' -> find_left (idx + 1)
  86     | _ -> idx
  87   in
  88   let rec find_right idx =
  89     match s.[idx] with
  90     | ' ' | '\t' | '\r' | '\n' -> find_right (idx - 1)
  91     | _ -> idx
  92   in
  93   let s_len = String.length s in
  94   let left, right = find_left 0, find_right (s_len - 1) in
  95   String.sub s left (right - left + 1)
  96
  97 (** {2 Char processing} *)
  98
  99 let is_alpha c =
 100   let code = Char.code c in
 101   (code >= 65 && code <= 90) || (code >= 97 && code <= 122)
 102
 103 let is_digit c =
 104   let code = Char.code c in
 105   code >= 48 && code <= 57
 106
 107 let is_blank c =
 108   let code = Char.code c in
 109   code = 9 || code = 10 || code = 13 || code = 32
 110
 111 let is_alphanum c = is_alpha c || is_digit c
 112
 113 (** {2 List processing} *)
 114
 115 let rec list_uniq ?(eq=(=)) = function
 116   | [] -> []
 117   | h::[] -> [h]
 118   | h1::h2::tl when eq h1 h2 -> list_uniq ~eq (h2 :: tl)
 119   | h1::tl (* when h1 <> h2 *) -> h1 :: list_uniq ~eq tl
 120
 121 let rec filter_map f =
 122   function
 123   | [] -> []
 124   | hd :: tl ->
 125       (match f hd with
 126       | None -> filter_map f tl
 127       | Some v -> v :: filter_map f tl)
 128
 129 let list_concat ?(sep = []) =
 130   let rec aux acc =
 131     function
 132     | [] -> []
 133     | [ last ] -> List.flatten (List.rev (last :: acc))
 134     | hd :: tl -> aux ([sep; hd] @ acc) tl
 135   in
 136   aux []
 137
 138 (** {2 File predicates} *)
 139
 140 let is_dir fname =
 141   try
 142     (Unix.stat fname).Unix.st_kind = Unix.S_DIR
 143   with Unix.Unix_error _ -> false
 144
 145 let is_regular fname =
 146   try
 147     (Unix.stat fname).Unix.st_kind = Unix.S_REG
 148   with Unix.Unix_error _ -> false
 149
 150 let mkdir path =
 151   let components = split ~sep:'/' path in
 152   let rec aux where = function
 153     | [] -> ()
 154     | piece::tl ->
 155         let path = where ^ "/" ^ piece in
 156         (try
 157           Unix.mkdir path 0o755
 158         with
 159         | Unix.Unix_error (Unix.EEXIST,_,_) -> ()
 160         | Unix.Unix_error (e,_,_) ->
 161             raise
 162               (Failure
 163                 ("Unix.mkdir " ^ path ^ " 0o755 :" ^ (Unix.error_message e))));
 164         aux path tl
 165   in
 166   aux "" components
 167
 168 (** {2 Filesystem} *)
 169
 170 let input_file fname =
 171   let size = (Unix.stat fname).Unix.st_size in
 172   let buf = Buffer.create size in
 173   let ic = open_in fname in
 174   Buffer.add_channel buf ic size;
 175   close_in ic;
 176   Buffer.contents buf
 177
 178 let input_all ic =
 179   let size = 10240 in
 180   let buf = Buffer.create size in
 181   let s = String.create size in
 182   (try
 183     while true do
 184       let bytes = input ic s 0 size in
 185       if bytes = 0 then raise End_of_file
 186       else Buffer.add_substring buf s 0 bytes
 187     done
 188   with End_of_file -> ());
 189   Buffer.contents buf
 190
 191 let output_file ~filename ~text =
 192   let oc = open_out filename in
 193   output_string oc text;
 194   close_out oc
 195
 196 let blank_split s =
 197   let len = String.length s in
 198   let buf = Buffer.create 0 in
 199   let rec aux acc i =
 200     if i >= len
 201     then begin
 202       if Buffer.length buf > 0
 203       then List.rev (Buffer.contents buf :: acc)
 204       else List.rev acc
 205     end else begin
 206       if is_blank s.[i] then
 207         if Buffer.length buf > 0 then begin
 208           let s = Buffer.contents buf in
 209           Buffer.clear buf;
 210           aux (s :: acc) (i + 1)
 211         end else
 212           aux acc (i + 1)
 213       else begin
 214         Buffer.add_char buf s.[i];
 215         aux acc (i + 1)
 216       end
 217     end
 218   in
 219   aux [] 0
 220
 221   (* Rules: * "~name" -> home dir of "name"
 222    * "~" -> value of $HOME if defined, home dir of the current user otherwise *)
 223 let tilde_expand s =
 224   let get_home login = (Unix.getpwnam login).Unix.pw_dir in
 225   let expand_one s =
 226     let len = String.length s in
 227     if len > 0 && s.[0] = '~' then begin
 228       let login_len = ref 1 in
 229       while !login_len < len && is_alphanum (s.[!login_len]) do
 230         incr login_len
 231       done;
 232       let login = String.sub s 1 (!login_len - 1) in
 233       try
 234         let home =
 235           if login = "" then
 236             try Sys.getenv "HOME" with Not_found -> get_home (Unix.getlogin ())
 237           else
 238             get_home login
 239         in
 240         home ^ String.sub s !login_len (len - !login_len)
 241       with Not_found | Invalid_argument _ -> s
 242     end else
 243       s
 244   in
 245   String.concat " " (List.map expand_one (blank_split s))
 246
 247 let find ?(test = fun _ -> true) path =
 248   let rec aux acc todo =
 249     match todo with
 250     | [] -> acc
 251     | path :: tl ->
 252         try
 253           let handle = Unix.opendir path in
 254           let dirs = ref [] in
 255           let matching_files = ref [] in
 256           (try
 257             while true do
 258               match Unix.readdir handle with
 259               | "." | ".." -> ()
 260               | entry ->
 261                   let qentry = path ^ "/" ^ entry in
 262                   (try
 263                     if is_dir qentry then
 264                       dirs := qentry :: !dirs
 265                     else if test qentry then
 266                       matching_files := qentry :: !matching_files;
 267                   with Unix.Unix_error _ -> ())
 268             done
 269           with End_of_file -> Unix.closedir handle);
 270           aux (!matching_files @ acc) (!dirs @ tl)
 271         with Unix.Unix_error _ -> aux acc tl
 272   in
 273   aux [] [path]
 274
 275 (** {2 Exception handling} *)
 276
 277 let finally at_end f arg =
 278   let res =
 279     try f arg
 280     with exn -> at_end (); raise exn
 281   in
 282   at_end ();
 283   res
 284