Source file `anycache.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
(******************************************************************************)
(* Copyright (c) 2014-2016 Skylable Ltd. <info-copyright@skylable.com>        *)
(*                                                                            *)
(* Permission to use, copy, modify, and/or distribute this software for any   *)
(* purpose with or without fee is hereby granted, provided that the above     *)
(* copyright notice and this permission notice appear in all copies.          *)
(*                                                                            *)
(* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES   *)
(* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF           *)
(* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR    *)
(* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES     *)
(* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN      *)
(* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF    *)
(* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.             *)
(******************************************************************************)

module type Monad = sig
  type +'a t
  type ('a, 'b) result = Ok of 'a | Error of 'b
  val return : 'a -> 'a t
  val fail : exn -> 'a t
  val ( >>? ) : 'a t -> (('a, exn) result -> 'b t) -> 'b t
end

module type S = sig
  type key
  type 'a deferred
  type 'a t
  type 'a validator = (key * 'a option) -> 'a deferred

  val create : int -> 'a t
  val with_cache : 'a t -> (key -> 'a deferred) -> key -> 'a deferred
  val with_validator : 'a t -> 'a validator -> key -> 'a deferred
  val get : 'a t -> key -> 'a option deferred
  val set : 'a t -> key -> 'a -> unit
end

module Make(K: Map.OrderedType)(M : Monad) = struct
  module Anycache_LRUMap = Anycache_LRU.Make(K)
  type 'a t = 'a M.t Anycache_LRUMap.cache

  type key = K.t
  type 'a deferred = 'a M.t
  type 'a validator = (K.t * 'a option) -> 'a M.t

  let create = Anycache_LRUMap.create

  open! M
  let find cache key ~f =
    match Anycache_LRUMap.find cache key with
    | None -> f (key,None)
    | Some old ->
        old >>? function
        | Ok data -> f (key, Some data)
        | Error _ -> f (key, None)

  let ret (_, v) = M.return v
  let get cache key = find cache key ~f:ret

  let set cache key value =
    Anycache_LRUMap.replace cache key (M.return value)

  let with_validator cache (revalidate: 'a validator) key : 'a M.t =
    let pending = find cache key ~f:revalidate in
    (* ensure ordering: first add the deferred, then inspect result *)
    Anycache_LRUMap.replace cache key pending;
    pending >>? function
    | Ok r -> M.return r
    | Error e -> M.fail e

  let with_cache cache f query =
    with_validator cache (function
      | key, None -> f key
      | _key, Some data -> M.return data
    ) query
end

module Direct = struct
    type ('a, 'b) result = ('a, 'b) Result.result = Ok of 'a | Error of 'b
    type 'a t = ('a, exn) result
    let return x = Ok x
    let fail e = Error e
    let (>>?) v f = f v
end

include Make(String)(Direct)