{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Registry.RIO where
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Trans.Resource
import qualified Control.Monad.Trans.Resource as Resource (allocate)
import Data.Registry.Make
import Data.Registry.Registry
import Data.Registry.Solver
import Data.Registry.Warmup
import Protolude
newtype Stop = Stop InternalState
runStop :: Stop -> IO ()
runStop (Stop is) = runResourceT $ closeInternalState is
newtype RIO a =
RIO
{ runRIO :: Stop -> IO (a, Warmup) }
deriving (Functor)
instance Applicative RIO where
pure a =
RIO (const (pure (a, mempty)))
RIO fab <*> RIO fa =
RIO $ \s ->
do (f, sf) <- fab s
(a, sa) <- fa s
pure (f a, sf `mappend` sa)
instance Monad RIO where
return = pure
RIO ma >>= f =
RIO $ \s ->
do (a, sa) <- ma s
(b, sb) <- runRIO (f a) s
pure (b, sa `mappend` sb)
instance MonadIO RIO where
liftIO io = RIO (const $ (, mempty) <$> io)
instance MonadThrow RIO where
throwM e = RIO (const $ throwM e)
instance MonadBase IO RIO where
liftBase = liftIO
instance MonadResource RIO where
liftResourceT action = RIO $ \(Stop s) -> liftIO ((, mempty) <$> runInternalState action s)
withRegistry :: forall a b ins out . (Typeable a, Contains (RIO a) out, Solvable ins out) =>
Registry ins out
-> (Result -> a -> IO b)
-> IO b
withRegistry registry f = runResourceT $ do
(a, warmup) <- runRegistryT @a registry
result <- lift $ runWarmup warmup
lift $ f result a
runRegistryT :: forall a ins out . (Typeable a, Contains (RIO a) out, Solvable ins out) => Registry ins out -> ResourceT IO (a, Warmup)
runRegistryT registry = withInternalState $ \is -> runRIO (make @(RIO a) registry) (Stop is)
executeRegistry :: forall a ins out . (Typeable a, Contains (RIO a) out, Solvable ins out) => Registry ins out -> IO (a, Warmup, Stop)
executeRegistry registry = do
is <- createInternalState
(a, w) <- runRIO (make @(RIO a) registry) (Stop is)
pure (a, w, Stop is)
unsafeRun :: forall a ins out . (Typeable a, Contains (RIO a) out) => Registry ins out -> IO a
unsafeRun registry = fst <$> unsafeRunWithStop registry
unsafeRunWithStop :: forall a ins out . (Typeable a, Contains (RIO a) out) => Registry ins out -> IO (a, Stop)
unsafeRunWithStop registry = do
is <- createInternalState
(a, _) <- runRIO (makeUnsafe @(RIO a) registry) (Stop is)
pure (a, Stop is)
warmupWith :: Warmup -> RIO ()
warmupWith w = RIO (const $ pure ((), w))
allocate :: IO a -> (a -> IO ()) -> RIO a
allocate resource cleanup =
snd <$> Resource.allocate resource cleanup