Source

ocamlspot / utils.ml

camlspotter fb1f10e 





camlspotter d0e75b7 
camlspotter fb1f10e 





































































camlspotter 5214e6d 

camlspotter fb1f10e 







































camlspotter 4e0e0a6 
camlspotter bab26a1 
camlspotter 1a66287 
camlspotter 4e0e0a6 
camlspotter fb1f10e 














camlspotter 801ebf6 

camlspotter 1a66287 


camlspotter 142de67 




camlspotter fb1f10e 


camlspotter 313e8d6 


camlspotter 801ebf6 








camlspotter 981b73d 






camlspotter 801ebf6 


camlspotter 981b73d 

camlspotter 801ebf6 




camlspotter 313e8d6 




camlspotter fb1f10e 





























camlspotter bbf1990 
camlspotter fb1f10e 




































































camlspotter 1fd4dcd 


camlspotter bd376ab 
camlspotter 1fd4dcd 




camlspotter bd376ab 








camlspotter 74e2d29 





camlspotter 1fd4dcd 
camlspotter 981b73d 






















(***********************************************************************)
(*                                                                     *)
(*                            OCamlSpotter                             *)
(*                                                                     *)
(*                             Jun FURUSE                              *)
(*                                                                     *)
(*   Copyright 2008-2012 Jun Furuse. All rights reserved.              *)
(*   This file is distributed under the terms of the GNU Library       *)
(*   General Public License, with the special exception on linking     *)
(*   described in file LICENSE.                                        *)
(*                                                                     *)
(***********************************************************************)

open Format

module List = struct
  include List

  let rec find_map_opt f = function
    | [] -> None
    | x::xs ->
        match f x with
        | Some v -> Some v
        | None -> find_map_opt f xs

  let filter_map f lst =
    List.rev (List.fold_left (fun st x ->
      match f x with
      | Some v -> v :: st
      | None -> st) [] lst)

  (** concatMap of Haskell *)
  let concat_map f l = List.concat (List.map f l)
end

module Debug = struct
  let on = ref false

  let format fmt = 
    if !on then eprintf fmt
    else Format.ifprintf Format.err_formatter fmt
end

module Lazy = struct
  include Lazy

  module Open = struct
    let (!!) = Lazy.force 
    let eager = Lazy.lazy_from_val
  end

  open Open

  let peek v = if lazy_is_val v then Some (!!v) else None
      
  let apply f v = 
    if lazy_is_val v then eager (f !!v)
    else lazy (f !!v)

  let is_val = lazy_is_val
end

include Lazy.Open

module Filename = struct
  include Filename
      
  let split_extension s = 
    try
      let body = chop_extension s in
      body, 
      String.sub s 
	(String.length body) 
	(String.length s - String.length body)
    with
    | Invalid_argument _ -> s, ""

  let concats xs = String.concat dir_sep xs

  module Open = struct
    let (^/) p1 p2 =
      if Filename.is_relative p2 then Filename.concat p1 p2 else p2
  end
end

include Filename.Open

module Format = struct
  include Format
  let rec list (sep : (unit, formatter, unit) format)  f ppf = function
    | [] -> ()
    | [x] -> f ppf x
    | x::xs -> 
        fprintf ppf "@[%a@]%t%a" 
	  f x
	  (fun ppf -> fprintf ppf sep)
	  (list sep f) xs

  let option f ppf = function
    | None -> fprintf ppf "None"
    | Some v -> fprintf ppf "Some(%a)" f v 

  let lazy_ p ppf v =
    if Lazy.is_val v then p ppf (Lazy.Open.(!!) v)
    else fprintf ppf "lazy"
end

module Option = struct
  let map ~f = function
    | None -> None
    | Some v -> Some (f v)

  let bind v f = match v with
    | None -> None
    | Some v -> f v

  let iter ~f = function
    | None -> ()
    | Some v -> f v

  let default v df = match v with
    | None -> df ()
    | Some v -> v
end

exception Finally of exn * exn
;;

let protect ~f x ~(finally : 'a -> unit) =
  let res =
    try f x with exn ->
      (try finally x with final_exn -> raise (Finally (exn, final_exn)));
    raise exn
  in
  finally x;
  res
;;

let catch ~f v = try `Ok (f v) with e -> `Error e;;

let failwithf fmt = Printf.kprintf failwith fmt
let invalid_argf fmt = Printf.kprintf invalid_arg fmt

let with_ref r v f =
  let back_v = !r in
  r := v;
  protect ~f () ~finally:(fun () -> r := back_v)

module Unix = struct
  include Unix

  let kind path = try Some (Unix.stat path).st_kind with _ -> None

  let is_dir path = kind path = Some S_DIR

  let gen_timed get minus f v = 
    let t1 = get () in
    let res = f v  in
    let t2 = get () in
    res, minus t2 t1

  let timed f v = gen_timed Unix.gettimeofday (-.) f v

  let dev_inode path =
    try
      let st = Unix.lstat path in
      Some (st.Unix.st_dev, st.Unix.st_ino)
    with
    | _ -> None

  module Process_times = struct
    type t = process_times
    let (-) pt1 pt2 = {
      tms_utime  = pt1.tms_utime -. pt2.tms_utime;
      tms_stime  = pt1.tms_stime -. pt2.tms_stime;
      tms_cutime = pt1.tms_utime -. pt2.tms_cutime;
      tms_cstime = pt1.tms_utime -. pt2.tms_cstime;
    }
    let timed f v = gen_timed Unix.times (-) f v
  end
end

module Find = struct
  open Unix

  (* run [f] on files in [path] *)
  let folddir ~f ~init path =
    let dh = opendir path in
    protect ~f:(fun () ->
      let rec loop st =
	try
	  let st' = f st (readdir dh) in
	  loop st'
	with
	| End_of_file -> st
      in
      loop init)
      ~finally:(fun () -> closedir dh) ()
  ;;

  module Inodes = Set.Make(struct
    type t = int
    let compare : int -> int -> int = fun x y -> compare x y
  end)
  ;;
  
  type path = 
      { dir : string;
	base : string;
	path : string; (* dir / name *)
	stat : [ `Ok of stats | `Error of exn ];
	depth : int;
      }

  let path ~depth ~dir base =
    let path = match dir ^/ base with
      | "./." -> "."
      | s -> s
    in
    { dir = dir;
      base = base;
      path = path;
      depth = depth; 
      stat = try `Ok (stat path) with e -> `Error e;
    }
  ;;

  let kind path =
    match path.stat with
    | `Error _exn -> None
    | `Ok stat -> Some stat.st_kind
  ;;

  let is_dir path = kind path = Some S_DIR

  let inode path = 
    match path.stat with
    | `Ok stat -> Some stat.st_ino
    | `Error _ -> None
  ;;

  exception Prune

  let prune () = raise Prune

  let find ~f fnames =

    (* visited cache *)
    let visited = ref Inodes.empty in
    let if_not_visited_then path ~f = match inode path with
      | None -> ()
      | Some inode ->
	  if Inodes.mem inode !visited then ()
	  else begin
	    visited := Inodes.add inode !visited;
	    f path
	  end
    in

    let rec find_dir pth =
      try 
	f pth;
	let subdirs =
	  folddir pth.path ~init:[] ~f:(fun dirs -> function
	    | "." | ".." -> dirs
	    | name -> 
		let pth = path ~depth:(pth.depth + 1) ~dir:pth.path name in
		if try is_dir pth with _ -> false then pth::dirs
		else begin find_non_dir pth; dirs end)
	in
	List.iter (if_not_visited_then ~f:find_dir) subdirs
      with
      | Prune -> ()

    and find_non_dir path = try f path with Prune -> ()
    in

    List.iter (fun fname ->
      let path = 
	path ~depth: 0 ~dir:(Filename.dirname fname) (Filename.basename fname)
      in
      if is_dir path then find_dir path
      else find_non_dir path) fnames
  ;;
end

module Hashtbl = struct
  include Hashtbl

  let of_list size kvs =
    let tbl = Hashtbl.create size in
    List.iter (fun (k,v) ->
      Hashtbl.replace tbl k v) kvs;
    tbl

  let memoize tbl f k =
    try 
      Hashtbl.find tbl k 
    with
    | Not_found ->
        let v = f k in
        Hashtbl.replace tbl k v;
        v

  let find_default def tbl k = try find tbl k with Not_found -> def

  let multi_add tbl k v =
    let vs = v :: find_default [] tbl k in
    replace tbl k vs
end

module Hashset = struct
  (* poorman's hash set by hashtbl *)
  type 'a t = ('a, 'a) Hashtbl.t
  
  let create = Hashtbl.create
  let add set x = Hashtbl.replace set x x
  let remove = Hashtbl.remove
  let mem = Hashtbl.mem
  let find = Hashtbl.find
  let find_opt t k = try Some (Hashtbl.find t k) with Not_found -> None
  let iter f = Hashtbl.iter (fun v _ -> f v)
  let fold f = Hashtbl.fold (fun v _ st -> f v st)
  let elements = Hashtbl.length
  let clear = Hashtbl.clear
  
  let of_list size vs = 
    let set = create size in
    List.iter (add set) vs;
    set
  
  let to_list set = fold (fun x y -> x::y) set []
end