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