{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}

-- | Utilities for working with resources
module Data.Registry.Rio
  ( module Data.Registry.Rio,
    singleton,
    cacheAt
  )
where

import Control.Monad.Morph
import Control.Monad.Trans.Resource
import Data.Dynamic
import Data.Registry.Internal.Cache
import Data.Registry.Make (make)
import Data.Registry.Registry
import Protolude

-- | This data type provides some support for creating effectful components with resources
--   You can use the regular MonadResource functions like allocate to make sure that resources are cleaned up
--   You can also use the 'cacheAt' function
newtype Rio a = Rio {forall a. Rio a -> ReaderT Cache (ResourceT IO) a
rioRun :: ReaderT Cache (ResourceT IO) a}
  deriving ((forall a b. (a -> b) -> Rio a -> Rio b)
-> (forall a b. a -> Rio b -> Rio a) -> Functor Rio
forall a b. a -> Rio b -> Rio a
forall a b. (a -> b) -> Rio a -> Rio b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Rio a -> Rio b
fmap :: forall a b. (a -> b) -> Rio a -> Rio b
$c<$ :: forall a b. a -> Rio b -> Rio a
<$ :: forall a b. a -> Rio b -> Rio a
Functor, Functor Rio
Functor Rio =>
(forall a. a -> Rio a)
-> (forall a b. Rio (a -> b) -> Rio a -> Rio b)
-> (forall a b c. (a -> b -> c) -> Rio a -> Rio b -> Rio c)
-> (forall a b. Rio a -> Rio b -> Rio b)
-> (forall a b. Rio a -> Rio b -> Rio a)
-> Applicative Rio
forall a. a -> Rio a
forall a b. Rio a -> Rio b -> Rio a
forall a b. Rio a -> Rio b -> Rio b
forall a b. Rio (a -> b) -> Rio a -> Rio b
forall a b c. (a -> b -> c) -> Rio a -> Rio b -> Rio c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Rio a
pure :: forall a. a -> Rio a
$c<*> :: forall a b. Rio (a -> b) -> Rio a -> Rio b
<*> :: forall a b. Rio (a -> b) -> Rio a -> Rio b
$cliftA2 :: forall a b c. (a -> b -> c) -> Rio a -> Rio b -> Rio c
liftA2 :: forall a b c. (a -> b -> c) -> Rio a -> Rio b -> Rio c
$c*> :: forall a b. Rio a -> Rio b -> Rio b
*> :: forall a b. Rio a -> Rio b -> Rio b
$c<* :: forall a b. Rio a -> Rio b -> Rio a
<* :: forall a b. Rio a -> Rio b -> Rio a
Applicative, Applicative Rio
Applicative Rio =>
(forall a b. Rio a -> (a -> Rio b) -> Rio b)
-> (forall a b. Rio a -> Rio b -> Rio b)
-> (forall a. a -> Rio a)
-> Monad Rio
forall a. a -> Rio a
forall a b. Rio a -> Rio b -> Rio b
forall a b. Rio a -> (a -> Rio b) -> Rio b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Rio a -> (a -> Rio b) -> Rio b
>>= :: forall a b. Rio a -> (a -> Rio b) -> Rio b
$c>> :: forall a b. Rio a -> Rio b -> Rio b
>> :: forall a b. Rio a -> Rio b -> Rio b
$creturn :: forall a. a -> Rio a
return :: forall a. a -> Rio a
Monad, MonadReader Cache, Monad Rio
Monad Rio => (forall a. IO a -> Rio a) -> MonadIO Rio
forall a. IO a -> Rio a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Rio a
liftIO :: forall a. IO a -> Rio a
MonadIO, MonadIO Rio
MonadIO Rio =>
(forall a. ResourceT IO a -> Rio a) -> MonadResource Rio
forall a. ResourceT IO a -> Rio a
forall (m :: * -> *).
MonadIO m =>
(forall a. ResourceT IO a -> m a) -> MonadResource m
$cliftResourceT :: forall a. ResourceT IO a -> Rio a
liftResourceT :: forall a. ResourceT IO a -> Rio a
MonadResource, MonadIO Rio
MonadIO Rio =>
(forall b. ((forall a. Rio a -> IO a) -> IO b) -> Rio b)
-> MonadUnliftIO Rio
forall b. ((forall a. Rio a -> IO a) -> IO b) -> Rio b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b. ((forall a. Rio a -> IO a) -> IO b) -> Rio b
withRunInIO :: forall b. ((forall a. Rio a -> IO a) -> IO b) -> Rio b
MonadUnliftIO)

-- | Run a Rio action by providing an empty cache and allocating / destroying resources
runRio :: MonadIO m => Rio a -> m a
runRio :: forall (m :: * -> *) a. MonadIO m => Rio a -> m a
runRio = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (Rio a -> IO a) -> Rio a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO a -> IO a)
-> (Rio a -> ResourceT IO a) -> Rio a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rio a -> ResourceT IO a
forall a. Rio a -> ResourceT IO a
runCache

-- | Run a Rio action by providing an empty cache and allocating / destroying resources
execRio :: MonadIO m => Rio a -> m (a, Cache)
execRio :: forall (m :: * -> *) a. MonadIO m => Rio a -> m (a, Cache)
execRio = IO (a, Cache) -> m (a, Cache)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, Cache) -> m (a, Cache))
-> (Rio a -> IO (a, Cache)) -> Rio a -> m (a, Cache)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceT IO (a, Cache) -> IO (a, Cache)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO (a, Cache) -> IO (a, Cache))
-> (Rio a -> ResourceT IO (a, Cache)) -> Rio a -> IO (a, Cache)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rio a -> ResourceT IO (a, Cache)
forall a. Rio a -> ResourceT IO (a, Cache)
execCache

-- | Use the value created by a Rio action so that resources are properly allocated and cached
withRio :: MonadIO m => Rio a -> (a -> IO b) -> m b
withRio :: forall (m :: * -> *) a b. MonadIO m => Rio a -> (a -> IO b) -> m b
withRio Rio a
action a -> IO b
f = IO b -> m b
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> (ResourceT IO b -> IO b) -> ResourceT IO b -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceT IO b -> IO b
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO b -> m b) -> ResourceT IO b -> m b
forall a b. (a -> b) -> a -> b
$ do
  a
a <- Rio a -> ResourceT IO a
forall a. Rio a -> ResourceT IO a
runCache Rio a
action
  IO b -> ResourceT IO b
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> ResourceT IO b) -> IO b -> ResourceT IO b
forall a b. (a -> b) -> a -> b
$ a -> IO b
f a
a

-- | Use the value created by a Rio action so that resources are properly allocated and cached
--   inside a monad transformer
withRioM :: (MonadResource (m (ResourceT IO)), MFunctor m) => Rio a -> (a -> m IO b) -> m IO b
withRioM :: forall (m :: (* -> *) -> * -> *) a b.
(MonadResource (m (ResourceT IO)), MFunctor m) =>
Rio a -> (a -> m IO b) -> m IO b
withRioM Rio a
action a -> m IO b
f = (forall a. ResourceT IO a -> IO a) -> m (ResourceT IO) b -> m IO b
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> m m b -> m n b
hoist ResourceT IO a -> IO a
forall a. ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (m (ResourceT IO) b -> m IO b) -> m (ResourceT IO) b -> m IO b
forall a b. (a -> b) -> a -> b
$ do
  a
a <- ResourceT IO a -> m (ResourceT IO) a
forall a. ResourceT IO a -> m (ResourceT IO) a
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT (Rio a -> ResourceT IO a
forall a. Rio a -> ResourceT IO a
runCache Rio a
action)
  (forall a. IO a -> ResourceT IO a) -> m IO b -> m (ResourceT IO) b
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> m m b -> m n b
hoist IO a -> ResourceT IO a
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (a -> m IO b
f a
a)

-- | Run a Rio action by providing an empty cache
runCache :: Rio a -> ResourceT IO a
runCache :: forall a. Rio a -> ResourceT IO a
runCache (Rio ReaderT Cache (ResourceT IO) a
action) = do
  Cache
cache <- IO Cache -> ResourceT IO Cache
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Cache
forall (m :: * -> *). MonadIO m => m Cache
newCache
  ReaderT Cache (ResourceT IO) a -> Cache -> ResourceT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Cache (ResourceT IO) a
action Cache
cache

-- | Run a Rio action by providing an empty cache, and return the final cache
--   for inspection
execCache :: Rio a -> ResourceT IO (a, Cache)
execCache :: forall a. Rio a -> ResourceT IO (a, Cache)
execCache (Rio ReaderT Cache (ResourceT IO) a
action) = do
  Cache
cache <- IO Cache -> ResourceT IO Cache
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Cache
forall (m :: * -> *). MonadIO m => m Cache
newCache
  (,Cache
cache) (a -> (a, Cache)) -> ResourceT IO a -> ResourceT IO (a, Cache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Cache (ResourceT IO) a -> Cache -> ResourceT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Cache (ResourceT IO) a
action Cache
cache

-- | Lift a resourceful value into Rio
liftRio :: ResourceT IO a -> Rio a
liftRio :: forall a. ResourceT IO a -> Rio a
liftRio = ReaderT Cache (ResourceT IO) a -> Rio a
forall a. ReaderT Cache (ResourceT IO) a -> Rio a
Rio (ReaderT Cache (ResourceT IO) a -> Rio a)
-> (ResourceT IO a -> ReaderT Cache (ResourceT IO) a)
-> ResourceT IO a
-> Rio a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceT IO a -> ReaderT Cache (ResourceT IO) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Cache m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | This function must be used to run services involving resources
--   The value a is created using the registry, used with the function 'f'
--   and all resources are freed at the end
withRegistry :: forall a b ins out m. (Typeable a, MonadIO m, MakeSingletons out) => Registry ins out -> (a -> IO b) -> m b
withRegistry :: forall a b (ins :: [*]) (out :: [*]) (m :: * -> *).
(Typeable a, MonadIO m, MakeSingletons out) =>
Registry ins out -> (a -> IO b) -> m b
withRegistry Registry ins out
registry a -> IO b
f =
  IO b -> m b
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> IO b -> m b
forall a b. (a -> b) -> a -> b
$ ResourceT IO b -> IO b
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (forall a (ins :: [*]) (out :: [*]).
(Typeable a, MakeSingletons out) =>
Registry ins out -> ResourceT IO a
runRegistryT @a Registry ins out
registry ResourceT IO a -> (a -> ResourceT IO b) -> ResourceT IO b
forall a b.
ResourceT IO a -> (a -> ResourceT IO b) -> ResourceT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO b -> ResourceT IO b
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> ResourceT IO b) -> (a -> IO b) -> a -> ResourceT IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO b
f)

-- | This function works like 'withRegistry' for a higher-order monad, typically `PropertyT IO` when
--   writing property tests with Hedgehog
withRegistryM ::
  forall a b ins out m.
  (Typeable a, MonadResource (m (ResourceT IO)), MFunctor m, MakeSingletons out) =>
  Registry ins out ->
  (a -> m IO b) ->
  m IO b
withRegistryM :: forall a b (ins :: [*]) (out :: [*]) (m :: (* -> *) -> * -> *).
(Typeable a, MonadResource (m (ResourceT IO)), MFunctor m,
 MakeSingletons out) =>
Registry ins out -> (a -> m IO b) -> m IO b
withRegistryM = Rio a -> (a -> m IO b) -> m IO b
forall (m :: (* -> *) -> * -> *) a b.
(MonadResource (m (ResourceT IO)), MFunctor m) =>
Rio a -> (a -> m IO b) -> m IO b
withRioM (Rio a -> (a -> m IO b) -> m IO b)
-> (Registry ins out -> Rio a)
-> Registry ins out
-> (a -> m IO b)
-> m IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> a
make @(Rio a) (Registry ins out -> Rio a)
-> (Registry ins out -> Registry ins out)
-> Registry ins out
-> Rio a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Registry ins out -> Registry ins out
forall (ins :: [*]) (out :: [*]).
MakeSingletons out =>
Registry ins out -> Registry ins out
singletons

-- | Create a function of type a with a given registry
--   Return a ResourceT value to control resource allocation
runRegistryT :: forall a ins out. (Typeable a, MakeSingletons out) => Registry ins out -> ResourceT IO a
runRegistryT :: forall a (ins :: [*]) (out :: [*]).
(Typeable a, MakeSingletons out) =>
Registry ins out -> ResourceT IO a
runRegistryT = Rio a -> ResourceT IO a
forall a. Rio a -> ResourceT IO a
runCache (Rio a -> ResourceT IO a)
-> (Registry ins out -> Rio a)
-> Registry ins out
-> ResourceT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> a
make @(Rio a) (Registry ins out -> Rio a)
-> (Registry ins out -> Registry ins out)
-> Registry ins out
-> Rio a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Registry ins out -> Registry ins out
forall (ins :: [*]) (out :: [*]).
MakeSingletons out =>
Registry ins out -> Registry ins out
singletons

-- | Make singletons for all the output types of a registry
--   but only if they not specialized values
singletons :: forall ins out. (MakeSingletons out) => Registry ins out -> Registry ins out
singletons :: forall (ins :: [*]) (out :: [*]).
MakeSingletons out =>
Registry ins out -> Registry ins out
singletons Registry ins out
r = SingletonsRegistry '[] ins out -> Registry ins out
forall (todo :: [*]) (ins :: [*]) (out :: [*]).
SingletonsRegistry todo ins out -> Registry ins out
_singletonsRegistry (SingletonsRegistry '[] ins out -> Registry ins out)
-> SingletonsRegistry '[] ins out -> Registry ins out
forall a b. (a -> b) -> a -> b
$ SingletonsRegistry out ins out -> SingletonsRegistry '[] ins out
forall (ls :: [*]) (ins :: [*]) (out :: [*]).
MakeSingletons ls =>
SingletonsRegistry ls ins out -> SingletonsRegistry '[] ins out
forall (ins :: [*]) (out :: [*]).
SingletonsRegistry out ins out -> SingletonsRegistry '[] ins out
makeSingletons (Registry ins out -> SingletonsRegistry out ins out
forall (ins :: [*]) (out :: [*]).
Registry ins out -> SingletonsRegistry out ins out
startSingletonsRegistry Registry ins out
r)

-- | Registry where all Rio values are singletons
newtype SingletonsRegistry (todo :: [Type]) (ins :: [Type]) (out :: [Type]) = SingletonsRegistry {forall (todo :: [*]) (ins :: [*]) (out :: [*]).
SingletonsRegistry todo ins out -> Registry ins out
_singletonsRegistry :: Registry ins out}

-- | Prepare a Registry for making singletons
startSingletonsRegistry :: Registry ins out -> SingletonsRegistry out ins out
startSingletonsRegistry :: forall (ins :: [*]) (out :: [*]).
Registry ins out -> SingletonsRegistry out ins out
startSingletonsRegistry = Registry ins out -> SingletonsRegistry out ins out
forall (todo :: [*]) (ins :: [*]) (out :: [*]).
Registry ins out -> SingletonsRegistry todo ins out
SingletonsRegistry

-- | Prepare a Registry for making singletons on a specific list of types
makeSingletonsRegistry :: forall todo ins out. Registry ins out -> SingletonsRegistry todo ins out
makeSingletonsRegistry :: forall (todo :: [*]) (ins :: [*]) (out :: [*]).
Registry ins out -> SingletonsRegistry todo ins out
makeSingletonsRegistry = forall (todo :: [*]) (ins :: [*]) (out :: [*]).
Registry ins out -> SingletonsRegistry todo ins out
SingletonsRegistry @todo

-- | This typeclass take an existing registry and makes a singleton for each Rio output type
class MakeSingletons ls where
  makeSingletons :: SingletonsRegistry ls ins out -> SingletonsRegistry '[] ins out

-- | If the list of types is empty there is nothing to do
instance MakeSingletons '[] where
  makeSingletons :: forall (ins :: [*]) (out :: [*]).
SingletonsRegistry '[] ins out -> SingletonsRegistry '[] ins out
makeSingletons = SingletonsRegistry '[] ins out -> SingletonsRegistry '[] ins out
forall a. a -> a
identity

-- | If the type represents an effectful value, make a singleton for it and recurse on the rest
instance {-# OVERLAPPING #-} (Typeable a, MakeSingletons rest) => MakeSingletons (Rio a : rest) where
  makeSingletons :: forall (ins :: [*]) (out :: [*]).
SingletonsRegistry (Rio a : rest) ins out
-> SingletonsRegistry '[] ins out
makeSingletons (SingletonsRegistry Registry ins out
r) =
    SingletonsRegistry rest ins out -> SingletonsRegistry '[] ins out
forall (ls :: [*]) (ins :: [*]) (out :: [*]).
MakeSingletons ls =>
SingletonsRegistry ls ins out -> SingletonsRegistry '[] ins out
forall (ins :: [*]) (out :: [*]).
SingletonsRegistry rest ins out -> SingletonsRegistry '[] ins out
makeSingletons (SingletonsRegistry rest ins out -> SingletonsRegistry '[] ins out)
-> SingletonsRegistry rest ins out
-> SingletonsRegistry '[] ins out
forall a b. (a -> b) -> a -> b
$ forall (todo :: [*]) (ins :: [*]) (out :: [*]).
Registry ins out -> SingletonsRegistry todo ins out
SingletonsRegistry @rest (forall a (ins :: [*]) (out :: [*]).
Typeable a =>
(a -> a) -> Registry ins out -> Registry ins out
tweakUnspecialized @(Rio a) Rio a -> Rio a
forall a (m :: * -> *).
(Typeable a, MonadIO m, MonadReader Cache m) =>
m a -> m a
singleton Registry ins out
r)

-- | If the type represents a pure value, make singletons for the rest
instance (MakeSingletons rest) => MakeSingletons (a : rest) where
  makeSingletons :: forall (ins :: [*]) (out :: [*]).
SingletonsRegistry (a : rest) ins out
-> SingletonsRegistry '[] ins out
makeSingletons (SingletonsRegistry Registry ins out
r) = SingletonsRegistry rest ins out -> SingletonsRegistry '[] ins out
forall (ls :: [*]) (ins :: [*]) (out :: [*]).
MakeSingletons ls =>
SingletonsRegistry ls ins out -> SingletonsRegistry '[] ins out
forall (ins :: [*]) (out :: [*]).
SingletonsRegistry rest ins out -> SingletonsRegistry '[] ins out
makeSingletons (forall (todo :: [*]) (ins :: [*]) (out :: [*]).
Registry ins out -> SingletonsRegistry todo ins out
makeSingletonsRegistry @rest Registry ins out
r)