{-# 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 = forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
Key -> m a -> m a
cacheAtKey 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 = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cache -> Cache -> Bool
$c/= :: Cache -> Cache -> Bool
== :: Cache -> Cache -> Bool
$c== :: 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cached] -> ShowS
$cshowList :: [Cached] -> ShowS
show :: Cached -> String
$cshow :: Cached -> String
showsPrec :: Int -> Cached -> ShowS
$cshowsPrec :: Int -> Cached -> ShowS
Show)

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

-- | Create an empty cache
newCache :: MonadIO m => m Cache
newCache :: forall (m :: * -> *). MonadIO m => m Cache
newCache = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MVar (Map Text Cached) -> Cache
Cache forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar 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 = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c== :: Key -> Key -> Bool
Eq, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key] -> ShowS
$cshowList :: [Key] -> ShowS
show :: Key -> String
$cshow :: Key -> String
showsPrec :: Int -> Key -> ShowS
$cshowsPrec :: Int -> Key -> ShowS
Show, Eq 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
min :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmax :: Key -> Key -> Key
>= :: Key -> Key -> Bool
$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
compare :: Key -> Key -> Ordering
$ccompare :: Key -> Key -> Ordering
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 ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Maybe a
Nothing -> do
      a
a <- m a
action
      forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
Key -> a -> m ()
setCached Key
key a
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 = forall (m :: * -> *). MonadReader Cache m => m Cache
askCache forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 =
  forall (m :: * -> *). MonadReader Cache m => m Cache
askCache 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) = 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 Text Cached)
ms forall a b. (a -> b) -> a -> b
$
        \Map Text Cached
m -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 (forall a. Typeable a => a -> Dynamic
toDyn a
a)) (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) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Map Text Cached
m <- forall a. MVar a -> IO a
readMVar MVar (Map Text Cached)
ms
  let c :: Maybe Cached
c = forall k a. Ord k => k -> Map k a -> Maybe a
lookup (forall {k} (a :: k). Typeable a => Text
makeTypeText @a) Map Text Cached
m
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Cached
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Cached -> Maybe Dynamic
getDynValue Key
key 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Cached
emptyCached {singletonCached :: Maybe Dynamic
singletonCached = forall a. a -> Maybe a
Just Dynamic
dynamic}
cacheDynValue Key
Singleton Dynamic
dynamic (Just Cached
cached) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Cached
cached {singletonCached :: Maybe Dynamic
singletonCached = Cached -> Maybe Dynamic
singletonCached Cached
cached forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just Dynamic
dynamic}
cacheDynValue (Custom Text
key) Dynamic
dynamic Maybe Cached
Nothing = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Cached
emptyCached {customCached :: Map Text Dynamic
customCached = forall k a. k -> a -> Map k a
M.singleton Text
key Dynamic
dynamic}
cacheDynValue (Custom Text
key) Dynamic
dynamic (Just Cached
cached) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Cached
cached {customCached :: Map Text Dynamic
customCached = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
key Dynamic
dynamic forall a b. (a -> b) -> a -> b
$ Cached -> Map Text Dynamic
customCached Cached
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) = 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 forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)