{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Rescue.Class (MonadRescueFrom (..)) where
import Data.Functor
import Data.WorldPeace
import Exception
import Control.Monad.Base
import Control.Monad.Cont
import Control.Monad.Raise
import Control.Monad.Trans.Except
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import qualified Control.Monad.RWS.Lazy as Lazy
import qualified Control.Monad.RWS.Strict as Strict
import qualified Control.Monad.State.Lazy as Lazy
import qualified Control.Monad.State.Strict as Strict
import qualified Control.Monad.Writer.Lazy as Lazy
import qualified Control.Monad.Writer.Strict as Strict
class (Monad m, MonadRaise n) => MonadRescueFrom n m where
attempt :: n a -> m (Either (ErrorCase n) a)
instance Monad n => MonadRescueFrom Maybe n where
attempt = pure . \case
Nothing -> Left $ openUnionLift ()
Just x -> Right x
instance Monad m => MonadRescueFrom [] m where
attempt = return . \case
[] -> Left $ include ()
(a : _) -> Right a
instance Monad m => MonadRescueFrom (Either (OpenUnion errs)) m where
attempt action = pure action
instance MonadIO m => MonadRescueFrom IO m where
attempt action =
liftIO (tryIO action) <&> \case
Right val -> Right val
Left ioExc -> Left $ include ioExc
instance
( Monad m
, MonadRescueFrom n m
, n `RaisesOne` ()
)
=> MonadRescueFrom (MaybeT n) m where
attempt (MaybeT action) =
attempt action <&> \case
Right (Just val) -> Right val
Right Nothing -> Left $ include ()
Left errs -> Left errs
instance MonadRescueFrom n m => MonadRescueFrom (IdentityT n) m where
attempt (IdentityT action) = attempt action
instance
( MonadBase n m
, MonadRescueFrom n n
, Contains (Errors n) errs
)
=> MonadRescueFrom n (ExceptT (OpenUnion errs) m) where
attempt = liftBase . attempt
instance
( Monad m
, MonadBase n m
, MonadRaise n
, MonadRescueFrom n m
)
=> MonadRescueFrom (ReaderT cfg n) (ReaderT cfg m) where
attempt = mapReaderT attempt
instance
( Monad m
, MonadBase n m
, MonadRaise n
, MonadRescueFrom n n
)
=> MonadRescueFrom n (ReaderT cfg m) where
attempt = liftBase . attempt
instance
( Monoid w
, MonadBase n m
, MonadRescueFrom n m
)
=> MonadRescueFrom (Lazy.WriterT w n) (Lazy.WriterT w m) where
attempt = Lazy.mapWriterT runner2
instance
( Monoid w
, MonadBase n m
, MonadRescueFrom n n
)
=> MonadRescueFrom n (Lazy.WriterT w m) where
attempt = liftBase . attempt
instance
( Monoid w
, MonadBase n m
, MonadRescueFrom n m
)
=> MonadRescueFrom (Strict.WriterT w n) (Strict.WriterT w m) where
attempt = Strict.mapWriterT runner2
instance
( Monoid w
, MonadBase n m
, MonadRescueFrom n n
)
=> MonadRescueFrom n (Strict.WriterT w m) where
attempt = liftBase . attempt
instance
( MonadBase n m
, MonadRescueFrom n m
)
=> MonadRescueFrom (Lazy.StateT s n) (Lazy.StateT s m) where
attempt = Lazy.mapStateT runner2
instance
( MonadBase n m
, MonadRescueFrom n n
)
=> MonadRescueFrom n (Lazy.StateT s m) where
attempt = liftBase . attempt
instance
( MonadBase n m
, MonadRescueFrom n m
)
=> MonadRescueFrom (Strict.StateT s n) (Strict.StateT s m) where
attempt = Strict.mapStateT runner2
instance
( Monoid w
, MonadBase n m
, MonadRescueFrom n m
)
=> MonadRescueFrom (Lazy.RWST r w s n) (Lazy.RWST r w s m) where
attempt = Lazy.mapRWST runner3
instance
( MonadBase n m
, MonadRescueFrom n n
)
=> MonadRescueFrom n (Strict.StateT s m) where
attempt = liftBase . attempt
instance
( Monoid w
, MonadBase n m
, MonadRescueFrom n n
)
=> MonadRescueFrom n (Strict.RWST r w s m) where
attempt = liftBase . attempt
instance
( MonadBase n m
, MonadRescueFrom n n
)
=> MonadRescueFrom n (ContT r m) where
attempt = liftBase . attempt
instance forall m r . (MonadRescueFrom (ContT r m) m) => MonadRescueFrom (ContT r m) (ContT r m) where
attempt =
withContT $ \b_mr (current :: a) ->
b_mr =<< attempt (pure current :: ContT r m a)
runner2
:: forall m n errs a w .
( MonadBase n m
, MonadRescueFrom n m
, n `RaisesOnly` errs
)
=> n (a, w)
-> m (Either (ErrorCase n) a, w)
runner2 inner = do
(val, log') <- liftBase inner
result <- attempt (pure val :: n a)
return (result, log')
runner3
:: forall m n errs a s w .
( MonadBase n m
, MonadRescueFrom n m
, n `RaisesOnly` errs
)
=> n (a, s, w)
-> m (Either (OpenUnion errs) a, s, w)
runner3 inner = do
(val, state, log') <- liftBase inner
result <- attempt (pure val :: n a)
return (result, state, log')