module Control.Monad.Component.Internal.Types where
import Protolude hiding (try)
import Control.Exception.Safe (try)
import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.Fail (MonadFail (..))
import qualified Data.Text as T
import Control.Teardown (ITeardown (..), Teardown)
data ComponentError
= ComponentFailure !Text
| ComponentStartupFailure ![SomeException]
deriving (Generic, Show)
instance Exception ComponentError
newtype ComponentM a
= ComponentM (IO (Either ([SomeException], [Teardown])
(a, [Teardown])))
instance Functor ComponentM where
fmap f (ComponentM action) =
ComponentM $ do
result <- action
return $! case result of
Left err ->
Left err
Right (a, teardownList) ->
Right (f a, teardownList)
instance Applicative ComponentM where
pure a =
ComponentM
$ return
$ Right (a, [])
(ComponentM mf) <*> (ComponentM mm) = ComponentM $ do
ef <- try mf
em <- try mm
case (ef, em) of
( Left err1, Left err2 ) ->
return $ Left ( [err1, err2], [] )
( Left err1, Right (Left (err2, cs2)) ) ->
return $ Left ( [err1] <> err2, cs2 )
( Left err1, Right (Right (_, cs2)) ) ->
return $ Left ( [err1], cs2 )
( Right (Left (err1, cs1)), Left err2 ) ->
return $ Left ( err1 <> [err2], cs1 )
( Right (Right (_, cs1)), Left err2 ) ->
return $ Left ( [err2], cs1 )
( Right (Left (err, cs1)), Right (Right (_, cs2)) ) ->
return $ Left ( err
, cs1 <> cs2
)
( Right (Left (err1, cs1)), Right (Left (err2, cs2)) ) ->
return $ Left ( err1 <> err2
, cs1 <> cs2
)
( Right (Right (_, cs1)), Right (Left (err, cs2)) ) ->
return $ Left ( err
, cs1 <> cs2
)
( Right (Right (f, cs1)), Right (Right (a, cs2)) ) ->
return $ Right ( f a
, cs1 <> cs2
)
instance Monad ComponentM where
return =
pure
(ComponentM action0) >>= f = ComponentM $ do
eResult0 <- action0
case eResult0 of
Right (a, cs0) -> do
let
(ComponentM action1) = f a
eResult1 <- try action1
case eResult1 of
Left err ->
return $ Left ([err], cs0)
Right (Left (err, cs1)) ->
return $ Left (err, cs0 <> cs1)
Right (Right (b, cs1)) ->
return $ Right (b, cs0 <> cs1)
Left (err, cs0) ->
return $ Left (err, cs0)
instance MonadFail ComponentM where
fail str =
ComponentM
$ return
$ Left ([toException $! ComponentFailure (T.pack str)], [])
instance MonadThrow ComponentM where
throwM e =
ComponentM
$ return
$ Left ([toException e], [])
instance MonadIO ComponentM where
liftIO action = ComponentM $ do
result <- action
return $ Right (result, [])
data Component a
= Component { componentResource :: !a
, componentTeardown :: !Teardown }
deriving (Generic)
fromComponent :: Component a -> a
fromComponent =
componentResource
instance NFData a => NFData (Component a)
instance ITeardown (Component a) where
teardown =
teardown . componentTeardown