ocamlspot / utils.ml

(***********************************************************************)
(*                                                                     *)
(*                            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, ""

  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
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
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.