Source

ocaml / ocamlbuild / my_std.ml

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
(***********************************************************************)
(*                                                                     *)
(*                             ocamlbuild                              *)
(*                                                                     *)
(*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
(*                                                                     *)
(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)


(* Original author: Nicolas Pouillard *)
open Format

exception Exit_OK
exception Exit_usage of string
exception Exit_system_error of string
exception Exit_with_code of int
exception Exit_silently_with_code of int

module Outcome = struct
  type ('a,'b) t =
    | Good of 'a
    | Bad of 'b

  let ignore_good =
    function
    | Good _ -> ()
    | Bad e -> raise e

  let good =
    function
    | Good x -> x
    | Bad exn -> raise exn

  let wrap f x =
    try Good (f x) with e -> Bad e

end

let opt_print elt ppf =
  function
  | Some x -> fprintf ppf "@[<2>Some@ %a@]" elt x
  | None -> pp_print_string ppf "None"

open Format
let ksbprintf g fmt =
  let buff = Buffer.create 42 in
  let f = formatter_of_buffer buff in
  kfprintf (fun f -> (pp_print_flush f (); g (Buffer.contents buff))) f fmt
let sbprintf fmt = ksbprintf (fun x -> x) fmt

(** Some extensions of the standard library *)
module Set = struct

  module type OrderedTypePrintable = sig
    include Set.OrderedType
    val print : formatter -> t -> unit
  end

  module type S = sig
    include Set.S
    val find : (elt -> bool) -> t -> elt
    val map : (elt -> elt) -> t -> t
    val of_list : elt list -> t
    val print : formatter -> t -> unit
  end

  module Make (M : OrderedTypePrintable) : S with type elt = M.t = struct
    include Set.Make(M)
    exception Found of elt
    let find p set =
      try
        iter begin fun elt ->
          if p elt then raise (Found elt)
        end set; raise Not_found
      with Found elt -> elt
    let map f set = fold (fun x -> add (f x)) set empty
    let of_list l = List.fold_right add l empty
    let print f s =
      let () = fprintf f "@[<hv0>@[<hv2>{.@ " in
      let _ =
        fold begin fun elt first ->
          if not first then fprintf f ",@ ";
          M.print f elt;
          false
        end s true in
      fprintf f "@]@ .}@]"
  end
end

module List = struct
  include List
  let print pp_elt f ls =
    fprintf f "@[<2>[@ ";
    let _ =
      fold_left begin fun first elt ->
        if not first then fprintf f ";@ ";
        pp_elt f elt;
        false
      end true ls in
    fprintf f "@ ]@]"

  let filter_opt f xs =
    List.fold_right begin fun x acc ->
      match f x with
      | Some x -> x :: acc
      | None -> acc
    end xs []

  let rec rev_append_uniq acc =
    function
    | [] -> acc
    | x :: xs ->
        if mem x acc then rev_append_uniq acc xs
        else rev_append_uniq (x :: acc) xs

  let union a b =
    rev (rev_append_uniq (rev_append_uniq [] a) b)

  let ordered_unique (type el) (lst : el list)  =
    let module Set = Set.Make(struct
      type t = el
      let compare = Pervasives.compare
      let print _ _ = ()
    end)
    in
    let _, lst =
      List.fold_left (fun (set,acc) el ->
        if Set.mem el set
        then set, acc
        else Set.add el set, el :: acc) (Set.empty,[]) lst
    in
    List.rev lst

end

module String = struct
  include String

  let print f s = fprintf f "%S" s

  let chomp s =
    let is_nl_char = function '\n' | '\r' -> true | _ -> false in
    let rec cut n =
      if n = 0 then 0 else if is_nl_char s.[n-1] then cut (n-1) else n
    in
    let ls = length s in
    let n = cut ls in
    if n = ls then s else sub s 0 n

  let before s pos = sub s 0 pos
  let after s pos = sub s pos (length s - pos)
  let first_chars s n = sub s 0 n
  let last_chars s n = sub s (length s - n) n

  let rec eq_sub_strings s1 p1 s2 p2 len =
    if len > 0 then s1.[p1] = s2.[p2] && eq_sub_strings s1 (p1+1) s2 (p2+1) (len-1)
    else true

  let rec contains_string s1 p1 s2 =
    let ls1 = length s1 in
    let ls2 = length s2 in
    try let pos = index_from s1 p1 s2.[0] in
        if ls1 - pos < ls2 then None
        else if eq_sub_strings s1 pos s2 0 ls2 then
        Some pos else contains_string s1 (pos + 1) s2
    with Not_found -> None

  let subst patt repl s =
    let lpatt = length patt in
    let lrepl = length repl in
    let rec loop s from =
      match contains_string s from patt with
      | Some pos ->
          loop (before s pos ^ repl ^ after s (pos + lpatt)) (pos + lrepl)
      | None -> s
    in loop s 0

  let tr patt subst text =
    let len = length text in
    let text = copy text in
    let rec loop pos =
      if pos < len then begin
        (if text.[pos] = patt then text.[pos] <- subst);
        loop (pos + 1)
      end
    in loop 0; text

  (*** is_prefix : is u a prefix of v ? *)
  let is_prefix u v =
    let m = String.length u
    and n = String.length v
    in
    m <= n &&
      let rec loop i = i = m or u.[i] = v.[i] && loop (i + 1) in
      loop 0
  (* ***)

  (*** is_suffix : is v a suffix of u ? *)
  let is_suffix u v =
    let m = String.length u
    and n = String.length v
    in
    n <= m &&
      let rec loop i = i = n or u.[m - 1 - i] = v.[n - 1 - i] && loop (i + 1) in
      loop 0
  (* ***)

  let rev s =
    let sl = String.length s in
    let s' = String.create sl in
    for i = 0 to sl - 1 do
      s'.[i] <- s.[sl - i - 1]
    done;
    s';;

  let implode l =
    match l with
    | [] -> ""
    | cs ->
        let r = create (List.length cs) in
        let pos = ref 0 in
        List.iter begin fun c ->
          unsafe_set r !pos c;
          incr pos
        end cs;
        r

  let explode s =
    let sl = String.length s in
    let rec go pos =
      if pos >= sl then [] else unsafe_get s pos :: go (pos + 1)
    in go 0
end

module StringSet = Set.Make(String)

let sys_readdir, reset_readdir_cache, reset_readdir_cache_for =
  let cache = Hashtbl.create 103 in
  let sys_readdir dir =
    try Hashtbl.find cache dir with Not_found ->
      let res = Outcome.wrap Sys.readdir dir in
      (Hashtbl.add cache dir res; res)
  and reset_readdir_cache () =
    Hashtbl.clear cache
  and reset_readdir_cache_for dir =
    Hashtbl.remove cache dir in
  (sys_readdir, reset_readdir_cache, reset_readdir_cache_for)

let sys_file_exists x =
  let dirname = Filename.dirname x in
  let basename = Filename.basename x in
  match sys_readdir dirname with
  | Outcome.Bad _ -> false
  | Outcome.Good a ->
      if basename = Filename.current_dir_name then true else
      try Array.iter (fun x -> if x = basename then raise Exit) a; false
      with Exit -> true

let sys_command =
  match Sys.os_type with
  | "Win32" -> fun cmd ->
      if cmd = "" then 0 else
      let cmd = "bash -c "^Filename.quote cmd in
      Sys.command cmd
  | _ -> fun cmd -> if cmd = "" then 0 else Sys.command cmd

(* FIXME warning fix and use Filename.concat *)
let filename_concat x y =
  if x = Filename.current_dir_name || x = "" then y else
  if Sys.os_type = "Win32" && (x.[String.length x - 1] = '\\') || x.[String.length x - 1] = '/' then
    if y = "" then x
    else x ^ y
  else
    x ^ "/" ^ y

(* let reslash =
  match Sys.os_type with
  | "Win32" -> tr '\\' '/'
  | _ -> (fun x -> x) *)

open Format

let invalid_arg' fmt = ksbprintf invalid_arg fmt

let the = function Some x -> x | None -> invalid_arg "the: expect Some not None"

let getenv ?default var =
  try Sys.getenv var
  with Not_found ->
    match default with
    | Some x -> x
    | None -> failwith (sprintf "This command must have %S in his environment" var);;

let with_input_file ?(bin=false) x f =
  let ic = (if bin then open_in_bin else open_in) x in
  try let res = f ic in close_in ic; res with e -> (close_in ic; raise e)

let with_output_file ?(bin=false) x f =
  reset_readdir_cache_for (Filename.dirname x);
  let oc = (if bin then open_out_bin else open_out) x in
  try let res = f oc in close_out oc; res with e -> (close_out oc; raise e)

let read_file x =
  with_input_file ~bin:true x begin fun ic ->
    let len = in_channel_length ic in
    let buf = String.create len in
    let () = really_input ic buf 0 len in
    buf
  end

let copy_chan ic oc =
  let m = in_channel_length ic in
  let m = (m lsr 12) lsl 12 in
  let m = max 16384 (min Sys.max_string_length m) in
  let buf = String.create m in
  let rec loop () =
    let len = input ic buf 0 m in
    if len > 0 then begin
      output oc buf 0 len;
      loop ()
    end
  in loop ()

let copy_file src dest =
  reset_readdir_cache_for (Filename.dirname dest);
  with_input_file ~bin:true src begin fun ic ->
    with_output_file ~bin:true dest begin fun oc ->
      copy_chan ic oc
    end
  end

let ( !* ) = Lazy.force

let ( @:= ) ref list = ref := !ref @ list

let ( & ) f x = f x

let ( |> ) x f = f x

let print_string_list = List.print String.print

module Digest = struct
  include Digest
(* USEFUL FOR DIGEST DEBUGING
  let digest_log_hash = Hashtbl.create 103;;
  let digest_log = "digest.log";;
  let digest_log_oc = open_out_gen [Open_append;Open_wronly;Open_text;Open_creat] 0o666 digest_log;;
  let my_to_hex x = to_hex x ^ ";";;
  if sys_file_exists digest_log then
    with_input_file digest_log begin fun ic ->
      try while true do
        let l = input_line ic in
        Scanf.sscanf l "%S: %S" (Hashtbl.replace digest_log_hash)
      done with End_of_file -> ()
    end;;
  let string s =
    let res = my_to_hex (string s) in
    if try let x = Hashtbl.find digest_log_hash res in s <> x with Not_found -> true then begin
      Hashtbl.replace digest_log_hash res s;
      Printf.fprintf digest_log_oc "%S: %S\n%!" res s
    end;
    res
  let file f = my_to_hex (file f)
  let to_hex x = x
*)

  let digest_cache = Hashtbl.create 103
  let reset_digest_cache () = Hashtbl.clear digest_cache
  let reset_digest_cache_for file = Hashtbl.remove digest_cache file
  let file f =
    try Hashtbl.find digest_cache f
    with Not_found ->
      let res = file f in
      (Hashtbl.add digest_cache f res; res)
end

let reset_filesys_cache () =
  Digest.reset_digest_cache ();
  reset_readdir_cache ()

let reset_filesys_cache_for_file file =
  Digest.reset_digest_cache_for file;
  reset_readdir_cache_for (Filename.dirname file)

let sys_remove x =
  reset_filesys_cache_for_file x;
  Sys.remove x

let with_temp_file pre suf fct =
  let tmp = Filename.temp_file pre suf in
  (* Sys.remove is used instead of sys_remove since we know that the tempfile is not that important *)
  try let res = fct tmp in Sys.remove tmp; res
  with e -> (Sys.remove tmp; raise e)

let memo f =
  let cache = Hashtbl.create 103 in
  fun x ->
    try Hashtbl.find cache x
    with Not_found ->
      let res = f x in
      (Hashtbl.add cache x res; res)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.