module Data.Cache where

import Control.Monad.IO.Class
import Data.IORef
import qualified Data.Map as M
import qualified Data.Text as T

newtype CacheRegistry v = CacheRegistry { CacheRegistry v -> IORef (Map Text v)
getCacheRegistry :: IORef (M.Map T.Text v) }

new :: MonadIO m => m (CacheRegistry v)
new :: m (CacheRegistry v)
new = IO (CacheRegistry v) -> m (CacheRegistry v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CacheRegistry v) -> m (CacheRegistry v))
-> IO (CacheRegistry v) -> m (CacheRegistry v)
forall a b. (a -> b) -> a -> b
$ (IORef (Map Text v) -> CacheRegistry v)
-> IO (IORef (Map Text v)) -> IO (CacheRegistry v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IORef (Map Text v) -> CacheRegistry v
forall v. IORef (Map Text v) -> CacheRegistry v
CacheRegistry (IO (IORef (Map Text v)) -> IO (CacheRegistry v))
-> IO (IORef (Map Text v)) -> IO (CacheRegistry v)
forall a b. (a -> b) -> a -> b
$ Map Text v -> IO (IORef (Map Text v))
forall a. a -> IO (IORef a)
newIORef Map Text v
forall k a. Map k a
M.empty

size :: MonadIO m => CacheRegistry v -> m Int
size :: CacheRegistry v -> m Int
size (CacheRegistry ref :: IORef (Map Text v)
ref) = IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ (Map Text v -> Int) -> IO (Map Text v) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map Text v -> Int
forall k a. Map k a -> Int
M.size (IO (Map Text v) -> IO Int) -> IO (Map Text v) -> IO Int
forall a b. (a -> b) -> a -> b
$ IORef (Map Text v) -> IO (Map Text v)
forall a. IORef a -> IO a
readIORef IORef (Map Text v)
ref

register :: MonadIO m => T.Text -> v -> CacheRegistry v -> m ()
register :: Text -> v -> CacheRegistry v -> m ()
register t :: Text
t v :: v
v cache :: CacheRegistry v
cache =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Map Text v) -> (Map Text v -> Map Text v) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (CacheRegistry v -> IORef (Map Text v)
forall v. CacheRegistry v -> IORef (Map Text v)
getCacheRegistry CacheRegistry v
cache) ((Map Text v -> Map Text v) -> IO ())
-> (Map Text v -> Map Text v) -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> v -> Map Text v -> Map Text v
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
t v
v

lookup :: MonadIO m => T.Text -> CacheRegistry v -> m (Maybe v)
lookup :: Text -> CacheRegistry v -> m (Maybe v)
lookup t :: Text
t cache :: CacheRegistry v
cache =
  IO (Maybe v) -> m (Maybe v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe v) -> m (Maybe v)) -> IO (Maybe v) -> m (Maybe v)
forall a b. (a -> b) -> a -> b
$ (Map Text v -> Maybe v) -> IO (Map Text v) -> IO (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Map Text v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
t) (IO (Map Text v) -> IO (Maybe v))
-> IO (Map Text v) -> IO (Maybe v)
forall a b. (a -> b) -> a -> b
$ IORef (Map Text v) -> IO (Map Text v)
forall a. IORef a -> IO a
readIORef (CacheRegistry v -> IORef (Map Text v)
forall v. CacheRegistry v -> IORef (Map Text v)
getCacheRegistry CacheRegistry v
cache)

clear :: MonadIO m => CacheRegistry v -> m (M.Map T.Text v)
clear :: CacheRegistry v -> m (Map Text v)
clear cache :: CacheRegistry v
cache = IO (Map Text v) -> m (Map Text v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Text v) -> m (Map Text v))
-> IO (Map Text v) -> m (Map Text v)
forall a b. (a -> b) -> a -> b
$ do
  let ref :: IORef (Map Text v)
ref = CacheRegistry v -> IORef (Map Text v)
forall v. CacheRegistry v -> IORef (Map Text v)
getCacheRegistry CacheRegistry v
cache
  Map Text v
m <- IORef (Map Text v) -> IO (Map Text v)
forall a. IORef a -> IO a
readIORef IORef (Map Text v)
ref
  IORef (Map Text v) -> Map Text v -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Map Text v)
ref Map Text v
forall k a. Map k a
M.empty
  Map Text v -> IO (Map Text v)
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text v
m

getOrCreate :: MonadIO m => (T.Text -> m v) -> T.Text -> CacheRegistry v -> m v
getOrCreate :: (Text -> m v) -> Text -> CacheRegistry v -> m v
getOrCreate alloc :: Text -> m v
alloc key :: Text
key cache :: CacheRegistry v
cache = do
  Maybe v
result <- Text -> CacheRegistry v -> m (Maybe v)
forall (m :: * -> *) v.
MonadIO m =>
Text -> CacheRegistry v -> m (Maybe v)
Data.Cache.lookup Text
key CacheRegistry v
cache
  (\f :: m v
f -> m v -> (v -> m v) -> Maybe v -> m v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m v
f v -> m v
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
result) (m v -> m v) -> m v -> m v
forall a b. (a -> b) -> a -> b
$ do
    v
fig <- Text -> m v
alloc Text
key
    Text -> v -> CacheRegistry v -> m ()
forall (m :: * -> *) v.
MonadIO m =>
Text -> v -> CacheRegistry v -> m ()
register Text
key v
fig CacheRegistry v
cache
    v -> m v
forall (m :: * -> *) a. Monad m => a -> m a
return v
fig

clearAll :: MonadIO m => (v -> m ()) -> CacheRegistry v -> m ()
clearAll :: (v -> m ()) -> CacheRegistry v -> m ()
clearAll free :: v -> m ()
free cache :: CacheRegistry v
cache = do
  Map Text v
m <- CacheRegistry v -> m (Map Text v)
forall (m :: * -> *) v.
MonadIO m =>
CacheRegistry v -> m (Map Text v)
clear CacheRegistry v
cache
  (v -> m ()) -> [v] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ v -> m ()
free (Map Text v -> [v]
forall k a. Map k a -> [a]
M.elems Map Text v
m)