{- |

 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
(Cache a -> Cache a -> Bool)
-> (Cache a -> Cache a -> Bool) -> Eq (Cache a)
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 :: Cache a -> Key -> m a -> m a
fetch (Cache MVar (Map Key a)
var) Key
key m a
action =
  do Map Key a
m <- IO (Map Key a) -> m (Map Key a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Key a) -> m (Map Key a))
-> IO (Map Key a) -> m (Map Key a)
forall a b. (a -> b) -> a -> b
$ MVar (Map Key a) -> IO (Map Key a)
forall a. MVar a -> IO a
P.readMVar MVar (Map Key a)
var
     case Key -> Map Key a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
lookup Key
key Map Key a
m of
        Just a
a ->
          a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

        Maybe a
Nothing -> do
          a
val <- m a
action
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (Map Key a) -> (Map Key a -> IO (Map Key a)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map Key a)
var (\Map Key a
cached -> Map Key a -> IO (Map Key a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Key a -> IO (Map Key a)) -> Map Key a -> IO (Map Key a)
forall a b. (a -> b) -> a -> b
$ Key -> a -> Map Key a -> Map Key a
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Key
key a
val Map Key a
cached)
          a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val

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