{-# LANGUAGE DataKinds #-}
{-# 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
import Control.Monad.Trans.Resource
import qualified Control.Monad.Trans.Resource as Resource (allocate)
import Control.Applicative
import Data.Functor.Alt
import Data.Registry.Make
import Data.Registry.Registry
import Data.Registry.Solver
import Data.Registry.Warmup
import Protolude hiding (Alt, try)
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) <$> liftIO 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)
instance Alternative RIO where
empty = RIO (const empty)
(RIO runA) <|> (RIO runB) = RIO $ \s -> do
res <- try (runA s)
case res of
Left (_::SomeException) -> runB s
Right r -> pure r
instance Alt RIO where
(<!>) = (<|>)
withRIO :: (MonadIO m) => RIO a -> (a -> IO ()) -> m Result
withRIO rio f = liftIO $ runResourceT $ withInternalState $ \is ->
do (a, warmup) <- runRIO rio (Stop is)
result <- liftIO $ runWarmup warmup
if isSuccess result then f a else pure ()
pure result
withRegistry :: forall a b ins out m . (Typeable a, Contains (RIO a) out, Solvable ins out, MonadIO m, MemoizedActions out) =>
Registry ins out
-> (Result -> a -> IO b)
-> m b
withRegistry registry f = liftIO $ runResourceT $ do
(a, warmup) <- runRegistryT @a registry
result <- lift . liftIO $ runWarmup warmup
lift $ f result a
runRegistryT :: forall a ins out m . (Typeable a, Contains (RIO a) out, Solvable ins out, MonadIO m, MemoizedActions out)
=> Registry ins out
-> ResourceT m (a, Warmup)
runRegistryT registry = withInternalState $ \is -> do
r <- liftIO $ memoizeAll @RIO registry
liftIO $ runRIO (make @(RIO a) r) (Stop is)
unsafeRunRIO :: (Typeable a, MonadIO m) => RIO a -> m a
unsafeRunRIO rio = liftIO $ do
is <- createInternalState
fst <$> runRIO rio (Stop is)
withNoWarmupRIO :: (MonadIO m) => RIO a -> (a -> IO b) -> m b
withNoWarmupRIO rio f = liftIO $
runResourceT $ withInternalState $ \is ->
f . fst =<< runRIO rio (Stop is)
withRIOIgnoreWarmupResult :: (MonadIO m) => RIO a -> (a -> IO b) -> m b
withRIOIgnoreWarmupResult = withRIOAndWarmupResult (const $ pure ())
withRIOAndWarmupResult :: (MonadIO m) => (Result -> IO ()) -> RIO a -> (a -> IO b) -> m b
withRIOAndWarmupResult withResult rio f = liftIO $
runResourceT $ withInternalState $ \is -> do
(a, warmup) <- runRIO rio (Stop is)
warmupResult <- liftIO $ runWarmup warmup
withResult warmupResult
liftIO (f a)
executeRegistry :: forall a ins out m . (Typeable a, Contains (RIO a) out, Solvable ins out, MonadIO m) => Registry ins out -> m (a, Warmup, Stop)
executeRegistry registry = liftIO $ do
is <- liftIO createInternalState
(a, w) <- runRIO (make @(RIO a) registry) (Stop is)
pure (a, w, Stop is)
unsafeRun :: forall a ins out m . (Typeable a, Contains (RIO a) out, MonadIO m) => Registry ins out -> m a
unsafeRun = unsafeRunDynamic
unsafeRunDynamic :: forall a ins out m . (Typeable a, MonadIO m) => Registry ins out -> m a
unsafeRunDynamic registry = liftIO $ fst <$> unsafeRunDynamicWithStop registry
unsafeRunWithStop :: forall a ins out m . (Typeable a, Contains (RIO a) out, MonadIO m) => Registry ins out -> m (a, Stop)
unsafeRunWithStop = unsafeRunDynamicWithStop
unsafeRunDynamicWithStop :: forall a ins out m . (Typeable a, MonadIO m) => Registry ins out -> m (a, Stop)
unsafeRunDynamicWithStop registry = liftIO $ 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