-- |
--
-- Cache for individual IO values when we wish to memoize actions
-- for database connection pools for example
--
-- This is inspired by https://hackage.haskell.org/package/io-memoize
module Data.Registry.Internal.Cache where

import Data.Map.Strict
import Data.Registry.Internal.Types (SpecializationPath)
import Protolude as P

-- | A thread-safe write-once cache. If you need more functionality,
-- (e.g. multiple write, cache clearing) use an 'MVar' instead.
newtype Cache a = Cache (MVar (Map Key a))
  deriving (Cache a -> Cache a -> Bool
forall a. Cache a -> Cache a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cache a -> Cache a -> Bool
$c/= :: forall a. Cache a -> Cache a -> Bool
== :: Cache a -> Cache a -> Bool
$c== :: forall a. Cache a -> Cache a -> Bool
Eq, Typeable)

-- | We need to cache different values to account for the fact
--   that different values might be specialized for the same type
type Key = Maybe [SpecializationPath]

-- | Fetch the value stored in the cache,
-- or call the supplied fallback and store the result,
-- if the cache is empty.
fetch :: forall a m. (MonadIO m, Typeable a) => Cache a -> Key -> m a -> m a
fetch :: forall a (m :: * -> *).
(MonadIO m, Typeable a) =>
Cache a -> Key -> m a -> m a
fetch (Cache MVar (Map Key a)
var) Key
key m a
action = do
  Map Key a
m <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
P.readMVar MVar (Map Key a)
var
  case forall k a. Ord k => k -> Map k a -> Maybe a
lookup Key
key Map Key a
m of
    Just a
a ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Maybe a
Nothing -> do
      a
val <- m a
action
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map Key a)
var (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Key
key a
val)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val

-- | Create an empty cache.
newCache :: IO (Cache a)
newCache :: forall a. IO (Cache a)
newCache = forall a. MVar (Map Key a) -> Cache a
Cache forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
P.newMVar forall a. Monoid a => a
mempty