{-# 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 -> 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
<$ :: forall a b. a -> Rio b -> Rio a
$c<$ :: forall a b. a -> Rio b -> Rio a
fmap :: forall a b. (a -> b) -> Rio a -> Rio b
$cfmap :: forall a b. (a -> b) -> Rio a -> Rio b
Functor, Functor 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
<* :: forall a b. Rio a -> Rio b -> Rio a
$c<* :: forall a b. Rio a -> Rio b -> Rio a
*> :: forall a b. Rio a -> Rio b -> Rio b
$c*> :: forall a b. Rio a -> Rio b -> Rio b
liftA2 :: forall a b c. (a -> b -> c) -> Rio a -> Rio b -> Rio c
$cliftA2 :: forall a b c. (a -> b -> c) -> Rio a -> Rio b -> Rio c
<*> :: forall a b. Rio (a -> b) -> Rio a -> Rio b
$c<*> :: forall a b. Rio (a -> b) -> Rio a -> Rio b
pure :: forall a. a -> Rio a
$cpure :: forall a. a -> Rio a
Applicative, Applicative 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
return :: forall a. a -> Rio a
$creturn :: forall a. a -> Rio a
>> :: forall a b. Rio a -> Rio b -> Rio b
$c>> :: forall a b. Rio a -> Rio b -> Rio b
>>= :: forall a b. Rio a -> (a -> Rio b) -> Rio b
$c>>= :: forall a b. Rio a -> (a -> Rio b) -> Rio b
Monad, MonadReader Cache, Monad Rio
forall a. IO a -> Rio a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> Rio a
$cliftIO :: forall a. IO a -> Rio a
MonadIO, MonadIO Rio
forall a. ResourceT IO a -> Rio a
forall (m :: * -> *).
MonadIO m -> (forall a. ResourceT IO a -> m a) -> MonadResource m
liftResourceT :: forall a. ResourceT IO a -> Rio a
$cliftResourceT :: forall a. ResourceT IO a -> Rio a
MonadResource, MonadIO 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
withRunInIO :: forall b. ((forall a. Rio a -> IO a) -> IO b) -> Rio b
$cwithRunInIO :: 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall a b. (a -> b) -> a -> b
$ do
  a
a <- forall a. Rio a -> ResourceT IO a
runCache Rio a
action
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall a b. (a -> b) -> a -> b
$ do
  a
a <- forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT (forall a. Rio a -> ResourceT IO a
runCache Rio a
action)
  forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *). MonadIO m => m Cache
newCache
  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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *). MonadIO m => m Cache
newCache
  (,Cache
cache) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. ReaderT Cache (ResourceT IO) a -> Rio a
Rio forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 = forall (m :: (* -> *) -> * -> *) a b.
(MonadResource (m (ResourceT IO)), MFunctor m) =>
Rio a -> (a -> m IO b) -> m IO b
withRioM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> a
make @(Rio a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Rio a -> ResourceT IO a
runCache forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> a
make @(Rio a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (todo :: [*]) (ins :: [*]) (out :: [*]).
SingletonsRegistry todo ins out -> Registry ins out
_singletonsRegistry forall a b. (a -> b) -> a -> b
$ forall (ls :: [*]) (ins :: [*]) (out :: [*]).
MakeSingletons ls =>
SingletonsRegistry ls ins out -> SingletonsRegistry '[] ins out
makeSingletons (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 = 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 = 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) =
    forall (ls :: [*]) (ins :: [*]) (out :: [*]).
MakeSingletons ls =>
SingletonsRegistry ls ins out -> SingletonsRegistry '[] ins out
makeSingletons 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) 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) = forall (ls :: [*]) (ins :: [*]) (out :: [*]).
MakeSingletons ls =>
SingletonsRegistry ls ins out -> SingletonsRegistry '[] ins out
makeSingletons (forall (todo :: [*]) (ins :: [*]) (out :: [*]).
Registry ins out -> SingletonsRegistry todo ins out
makeSingletonsRegistry @rest Registry ins out
r)