{-# LANGUAGE AllowAmbiguousTypes #-}

{- Cache for Rio values, backed by a MVar -}
module Data.Registry.Internal.Cache where

import Data.Dynamic
import Data.Map as M hiding (singleton)
import Data.Map qualified as M
import Data.Registry.Internal.Reflection (showSingleType)
import Protolude
import Type.Reflection (someTypeRep)

-- * EXPORTED FUNCTIONS

-- | Cache an effectful value with a given text key
--   so that the value is not recreated for the same key
cacheAt :: forall a m. (Typeable a, MonadIO m, MonadReader Cache m) => Text -> m a -> m a
cacheAt :: forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
Text -> m a -> m a
cacheAt = Key -> m a -> m a
forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
Key -> m a -> m a
cacheAtKey (Key -> m a -> m a) -> (Text -> Key) -> Text -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
Custom

-- | Cache an effectful value by using its type as the cache key
singleton :: forall a m. (Typeable a, MonadIO m, MonadReader Cache m) => m a -> m a
singleton :: forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
m a -> m a
singleton = Key -> m a -> m a
forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
Key -> m a -> m a
cacheAtKey Key
Singleton

-- * IMPLEMENTATION

-- | A cache for created values, with a map from
--   the textual representation of a type to various cached values
newtype Cache = Cache (MVar (Map Text Cached))
  deriving (Cache -> Cache -> Bool
(Cache -> Cache -> Bool) -> (Cache -> Cache -> Bool) -> Eq Cache
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cache -> Cache -> Bool
== :: Cache -> Cache -> Bool
$c/= :: Cache -> Cache -> Bool
/= :: Cache -> Cache -> Bool
Eq)

-- | Cache for a value of a single type
--   There is at most one singleton and possibly some custom values, indexed by a specific key
data Cached = Cached
  { Cached -> Maybe Dynamic
singletonCached :: Maybe Dynamic,
    Cached -> Map Text Dynamic
customCached :: Map Text Dynamic
  }
  deriving (Int -> Cached -> ShowS
[Cached] -> ShowS
Cached -> String
(Int -> Cached -> ShowS)
-> (Cached -> String) -> ([Cached] -> ShowS) -> Show Cached
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cached -> ShowS
showsPrec :: Int -> Cached -> ShowS
$cshow :: Cached -> String
show :: Cached -> String
$cshowList :: [Cached] -> ShowS
showList :: [Cached] -> ShowS
Show)

-- | An empty cached value (with no cached instances yet)
emptyCached :: Cached
emptyCached :: Cached
emptyCached = Maybe Dynamic -> Map Text Dynamic -> Cached
Cached Maybe Dynamic
forall a. Maybe a
Nothing Map Text Dynamic
forall a. Monoid a => a
mempty

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

-- | Get the current cache
askCache :: MonadReader Cache m => m Cache
askCache :: forall (m :: * -> *). MonadReader Cache m => m Cache
askCache = m Cache
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Type of keys used to cache values
--   A value can either be cached with a specific key, or it is a singleton
data Key
  = Custom Text
  | Singleton
  deriving (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
/= :: Key -> Key -> Bool
Eq, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Key -> ShowS
showsPrec :: Int -> Key -> ShowS
$cshow :: Key -> String
show :: Key -> String
$cshowList :: [Key] -> ShowS
showList :: [Key] -> ShowS
Show, Eq Key
Eq Key =>
(Key -> Key -> Ordering)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> Ord Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Key -> Key -> Ordering
compare :: Key -> Key -> Ordering
$c< :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
>= :: Key -> Key -> Bool
$cmax :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
min :: Key -> Key -> Key
Ord)

-- | Make sure that an effectful value is cached after the first evaluation for a specific key
cacheAtKey :: forall a m. (Typeable a, MonadIO m, MonadReader Cache m) => Key -> m a -> m a
cacheAtKey :: forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
Key -> m a -> m a
cacheAtKey Key
key m a
action = do
  Maybe a
m <- forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
Key -> m (Maybe a)
getCached @a Key
key
  case Maybe a
m of
    Just a
a ->
      a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Maybe a
Nothing -> do
      a
a <- m a
action
      Key -> a -> m ()
forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
Key -> a -> m ()
setCached Key
key a
a
      a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | Get a cached value from the cache
--   This is a IO operation since we access the cache MVar
getCached :: (Typeable a, MonadIO m, MonadReader Cache m) => Key -> m (Maybe a)
getCached :: forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
Key -> m (Maybe a)
getCached Key
key = m Cache
forall (m :: * -> *). MonadReader Cache m => m Cache
askCache m Cache -> (Cache -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Cache -> m (Maybe a)
forall a (m :: * -> *).
(Typeable a, MonadIO m) =>
Key -> Cache -> m (Maybe a)
getCachedValue Key
key

-- | Cache a value at a given key in the cache
--   This is a IO operation since we access the cache MVar
setCached :: forall a m. (Typeable a, MonadIO m, MonadReader Cache m) => Key -> a -> m ()
setCached :: forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
Key -> a -> m ()
setCached Key
key a
a =
  m Cache
forall (m :: * -> *). MonadReader Cache m => m Cache
askCache m Cache -> (Cache -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cache -> m ()
cacheValue
  where
    -- \| Cache a value as a Dynamic value for a given key
    cacheValue :: Cache -> m ()
    cacheValue :: Cache -> m ()
cacheValue (Cache MVar (Map Text Cached)
ms) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      MVar (Map Text Cached)
-> (Map Text Cached -> IO (Map Text Cached)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map Text Cached)
ms ((Map Text Cached -> IO (Map Text Cached)) -> IO ())
-> (Map Text Cached -> IO (Map Text Cached)) -> IO ()
forall a b. (a -> b) -> a -> b
$
        \Map Text Cached
m -> Map Text Cached -> IO (Map Text Cached)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe Cached -> Maybe Cached)
-> Text -> Map Text Cached -> Map Text Cached
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Key -> Dynamic -> Maybe Cached -> Maybe Cached
cacheDynValue Key
key (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
a)) (forall a. Typeable a => Text
forall {k} (a :: k). Typeable a => Text
makeTypeText @a) Map Text Cached
m)

-- | Retrieve a cached value given its key
getCachedValue :: forall a m. (Typeable a, MonadIO m) => Key -> Cache -> m (Maybe a)
getCachedValue :: forall a (m :: * -> *).
(Typeable a, MonadIO m) =>
Key -> Cache -> m (Maybe a)
getCachedValue Key
key (Cache MVar (Map Text Cached)
ms) = IO (Maybe a) -> m (Maybe a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> m (Maybe a)) -> IO (Maybe a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
  Map Text Cached
m <- MVar (Map Text Cached) -> IO (Map Text Cached)
forall a. MVar a -> IO a
readMVar MVar (Map Text Cached)
ms
  let c :: Maybe Cached
c = Text -> Map Text Cached -> Maybe Cached
forall k a. Ord k => k -> Map k a -> Maybe a
lookup (forall a. Typeable a => Text
forall {k} (a :: k). Typeable a => Text
makeTypeText @a) Map Text Cached
m
  Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe Cached
c Maybe Cached -> (Cached -> Maybe Dynamic) -> Maybe Dynamic
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Cached -> Maybe Dynamic
getDynValue Key
key Maybe Dynamic -> (Dynamic -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @a

-- | Insert a (dynamic) value in the Cached data structure for a specific type of value
cacheDynValue :: Key -> Dynamic -> Maybe Cached -> Maybe Cached
cacheDynValue :: Key -> Dynamic -> Maybe Cached -> Maybe Cached
cacheDynValue Key
Singleton Dynamic
dynamic Maybe Cached
Nothing = Cached -> Maybe Cached
forall a. a -> Maybe a
Just (Cached -> Maybe Cached) -> Cached -> Maybe Cached
forall a b. (a -> b) -> a -> b
$ Cached
emptyCached {singletonCached = Just dynamic}
cacheDynValue Key
Singleton Dynamic
dynamic (Just Cached
cached) = Cached -> Maybe Cached
forall a. a -> Maybe a
Just (Cached -> Maybe Cached) -> Cached -> Maybe Cached
forall a b. (a -> b) -> a -> b
$ Cached
cached {singletonCached = singletonCached cached <|> Just dynamic}
cacheDynValue (Custom Text
key) Dynamic
dynamic Maybe Cached
Nothing = Cached -> Maybe Cached
forall a. a -> Maybe a
Just (Cached -> Maybe Cached) -> Cached -> Maybe Cached
forall a b. (a -> b) -> a -> b
$ Cached
emptyCached {customCached = M.singleton key dynamic}
cacheDynValue (Custom Text
key) Dynamic
dynamic (Just Cached
cached) = Cached -> Maybe Cached
forall a. a -> Maybe a
Just (Cached -> Maybe Cached) -> Cached -> Maybe Cached
forall a b. (a -> b) -> a -> b
$ Cached
cached {customCached = M.insert key dynamic $ customCached cached}

-- | Return the dynamic value cached at a given key
getDynValue :: Key -> Cached -> Maybe Dynamic
getDynValue :: Key -> Cached -> Maybe Dynamic
getDynValue Key
Singleton (Cached Maybe Dynamic
s Map Text Dynamic
_) = Maybe Dynamic
s
getDynValue (Custom Text
k) (Cached Maybe Dynamic
_ Map Text Dynamic
m) = Text -> Map Text Dynamic -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
k Map Text Dynamic
m

-- | Return a textual description of a Haskell type
makeTypeText :: forall a. (Typeable a) => Text
makeTypeText :: forall {k} (a :: k). Typeable a => Text
makeTypeText = SomeTypeRep -> Text
showSingleType (SomeTypeRep -> Text) -> SomeTypeRep -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a -> SomeTypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)