{-# LANGUAGE AllowAmbiguousTypes #-}
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)
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
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
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)
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)
emptyCached :: Cached
emptyCached :: Cached
emptyCached = Maybe Dynamic -> Map Text Dynamic -> Cached
Cached forall a. Maybe a
Nothing forall a. Monoid a => a
mempty
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
askCache :: MonadReader Cache m => m Cache
askCache :: forall (m :: * -> *). MonadReader Cache m => m Cache
askCache = forall r (m :: * -> *). MonadReader r m => m r
ask
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)
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
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
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
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)
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
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}
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
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)