Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
172 lines (147 sloc) 5.03 KB
(* Copyright (C) 2009 Mauricio Fernandez <mfp@acm.org> *)
open ExtList
open ExtString
module type ENTRY =
sig
type 'a entry
type sort_criterion
val name : _ entry -> string
val tags : _ entry -> string list
val deps : _ entry -> string list
val signal_deps_changed : _ entry -> unit
val compare :
?secondary : sort_criterion list -> sort_criterion -> 'a entry -> 'a entry -> int
end
module type S =
sig
type 'a entry
type sort_criterion
type 'a t
val refresh : _ t -> unit
val entries : 'a t -> 'a entry list
val sorted_entries :
?reverse : bool ->
?secondary : sort_criterion list -> sort_criterion -> 'a t -> 'a entry list
val get_entry : 'a t -> string -> 'a entry option
val has_entry : _ t -> string -> bool
end
let compare_by_criteria basic_comparison ?(extra = []) crit =
let basic_sort f criterion =
let cmp = basic_comparison criterion in
(fun x y -> match cmp x y with 0 -> f x y | n -> n) in
let rec compare_loop = function
[] -> (fun x y -> 0)
| c::cs -> basic_sort (compare_loop cs) c
in compare_loop (crit :: extra)
let dir_filter_map f dir =
List.filter_map
(fun fname -> if String.starts_with fname "." then None else (f fname))
(Array.to_list (Sys.readdir dir))
module Make(Entry : sig
include ENTRY
val make : name:string -> file:string -> 'a entry
end)
: sig
include S with type 'a entry = 'a Entry.entry
and type sort_criterion = Entry.sort_criterion
val make : string -> 'a t
end =
struct
module M = Map.Make(String)
module S = Set.Make(String)
type 'a entry = 'a Entry.entry
type sort_criterion = Entry.sort_criterion
type 'a t = {
basedir : string;
mutable entries : 'a entry_info M.t;
}
and 'a entry_info = {
e_time : float;
e_name : string;
e_data : 'a entry;
}
let (/^) = Filename.concat
type entry_file = { fname : string; mtime : float; name : string }
let entry_info { mtime = mtime; name = name; fname = file } =
{ e_time = mtime; e_name = name; e_data = Entry.make ~file ~name }
let get_files basedir =
dir_filter_map
(fun f ->
let fname = basedir /^ f in
let stat = Unix.stat fname in
match stat.Unix.st_kind with
Unix.S_REG ->
Some { fname = fname; mtime = stat.Unix.st_mtime; name = f; }
| _ -> None)
basedir
let make basedir =
let entries =
List.fold_left
(fun m t -> M.add t.name (entry_info t) m) M.empty (get_files basedir)
in
{
basedir = basedir;
entries = entries;
}
let map_values m = List.rev (M.fold (fun _ v l -> v :: l) m [])
module ES =
Set.Make(struct type t = entry_file let compare = compare end)
let refresh t =
let entries', mtimes', entry_files' =
List.fold_left
(fun (s, m, s2) (t as entry_file)->
(S.add t.name s, M.add t.name t.mtime m, ES.add entry_file s2))
(S.empty, M.empty, ES.empty)
(get_files t.basedir) in
let entries, mtimes =
M.fold
(fun name e (s, m) -> (S.add name s, M.add name e.e_time m))
t.entries
(S.empty, M.empty) in
let add_entries = S.diff entries' entries in
let del_entries = S.diff entries entries' in
let changed_entries =
S.filter
(fun name -> M.find name mtimes' > M.find name mtimes)
(S.inter entries entries') in
let changed_deps e =
List.exists
(fun dep -> S.mem dep add_entries || S.mem dep del_entries)
(Entry.deps e.e_data) in
let update_entry e =
if S.mem e.e_name del_entries then None
else if S.mem e.e_name changed_entries then begin
Some (entry_info
{ name = e.e_name; fname = (t.basedir /^ e.e_name);
mtime = M.find e.e_name mtimes'; })
end else if changed_deps e then begin
Entry.signal_deps_changed e.e_data;
Some e
end else Some e (* not changed *) in
let new_entries =
ES.fold
(fun efile m -> match S.mem efile.name entries with
true -> m
| false -> M.add efile.name (entry_info efile) m)
entry_files'
M.empty
in match List.map S.is_empty [add_entries; del_entries; changed_entries] with
[true; true; true] -> ()
| _ ->
t.entries <- M.fold
(fun name e m -> match update_entry e with
None -> m
| Some e -> M.add name e m)
(M.fold M.add new_entries t.entries)
M.empty
let entries t = List.map (fun e -> e.e_data) (map_values t.entries)
let sorted_entries ?(reverse = false) ?secondary criterion t =
let l = List.fast_sort (Entry.compare ?secondary criterion)
(List.map (fun e -> e.e_data) (map_values t.entries))
in match reverse with
true -> List.rev l
| false -> l
let get_entry t name =
try Some (M.find name t.entries).e_data with Not_found -> None
let has_entry t name = M.mem name t.entries
end
Jump to Line
Something went wrong with that request. Please try again.