rescue 0.3.0 → 0.4.0
raw patch · 13 files changed
+399/−285 lines, 13 files
Files
- README.md +1/−1
- library/Control/Monad/Cleanup/Class.hs +1/−1
- library/Control/Monad/Raise/Class.hs +3/−8
- library/Control/Monad/Rescue.hs +207/−54
- library/Control/Monad/Rescue/Class.hs +77/−158
- library/Control/Monad/Rescue/Constraint.hs +3/−18
- library/Control/Monad/Trans/Cleanup/Types.hs +15/−23
- library/Control/Monad/Trans/Error.hs +21/−0
- library/Control/Monad/Trans/Error/Class.hs +16/−0
- library/Control/Monad/Trans/Rescue/Types.hs +16/−10
- library/Data/Exception/Types.hs +29/−6
- library/Data/WorldPeace/Subset/Class.hs +1/−0
- rescue.cabal +9/−6
README.md view
@@ -1,4 +1,4 @@-# 🚒 Rescue+# 🚒✨ Rescue ## More Understandable Error Handling 
library/Control/Monad/Cleanup/Class.hs view
@@ -8,7 +8,7 @@ import Control.Monad.Rescue -- | Safely work with resources when an asynchronous exception may be thrown-class (m `Raises` SomeException, MonadRescueFrom m m) => MonadCleanup m where+class (m `Raises` SomeException, MonadRescue m) => MonadCleanup m where cleanup :: m resource -- ^ Acquire some resource -> (resource -> ErrorCase m -> m _ig1) -- ^ Cleanup and re-raise
library/Control/Monad/Raise/Class.hs view
@@ -18,7 +18,6 @@ import Control.Monad.Catch.Pure import Control.Monad.Cont- import Control.Monad.ST import Control.Monad.Trans.Except@@ -128,13 +127,9 @@ type Errors (IdentityT m) = Errors m raise = lift . raise -instance- ( () `IsMember` Errors m- , MonadRaise m- )- => MonadRaise (MaybeT m) where- type Errors (MaybeT m) = Errors m- raise err = MaybeT $ raise err+instance (MonadRaise m, () `IsMember` Errors m) => MonadRaise (MaybeT m) where+ type Errors (MaybeT m) = Errors m+ raise err = MaybeT $ raise err instance MonadRaise m => MonadRaise (ReaderT cfg m) where type Errors (ReaderT cfg m) = Errors m
library/Control/Monad/Rescue.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -- | Rescue semantics & helpers --@@ -10,40 +12,59 @@ -- This is the opposite of 'Control.Monad.Raise', which embeds en error. -- 'Rescue' takes a potential error out of the surrounding context -- and either handles or exposes it.- module Control.Monad.Rescue- ( rescue- , handle+ ( attemptM + -- * Recover from exceptions++ , rescue+ , rescueT+ , rescueM+ , rescueBase++ , rescueEach+ , rescueEachM+ , rescueEachT++ , rescueAll+ -- * Guaranteed runs , reattempt- , onRaise+ , report , lastly + -- * Error access++ , mapError+ , replaceError+ , asNotFound+ -- * Reexports , module Control.Monad.Raise- , module Control.Monad.Rescue.Class , module Control.Monad.Rescue.Constraint ) where -import Data.Result.Types+import Numeric.Natural++import Data.Bifunctor as Bifunctor+import Data.Exception.Types import Data.WorldPeace +import Control.Monad.Base import Control.Monad.Raise- import Control.Monad.Rescue.Class import Control.Monad.Rescue.Constraint--import Numeric.Natural+import Control.Monad.Trans.Error -- $setup -- -- >>> :set -XDataKinds -- >>> :set -XFlexibleContexts -- >>> :set -XTypeApplications+-- >>> :set -XLambdaCase -- -- >>> import Control.Monad.Trans.Rescue -- >>> import Data.Proxy@@ -53,57 +74,156 @@ -- >>> data BarErr = BarErr deriving Show -- >>> data QuuxErr = QuuxErr deriving Show --- | Handle all exceptions+-- | Simpler helper to eliminate the bind operator from an attempt flow -- -- >>> type MyErrs = '[FooErr, BarErr]--- >>> myErrs = Proxy @MyErrs -- -- >>> :{--- goesBoom :: Int -> Rescue MyErrs String--- goesBoom x =--- if x > 50--- then return (show x)--- else raise FooErr+-- boom :: Rescue MyErrs String+-- boom = raise FooErr -- :} ----- >>> handler = catchesOpenUnion (\foo -> "Foo: " <> show foo, \bar -> "Bar:" <> show bar)--- >>> rescue (goesBoom 42) (pure . handler) :: Rescue MyErrs String--- RescueT (Identity (Right "Foo: FooErr"))+-- >>> :{+-- attempt boom >>= \case+-- Left err -> return ("err: " ++ show err)+-- Right val -> return val+-- :}+-- RescueT (Identity (Right "err: Identity FooErr"))+--+-- >>> :{+-- attemptM boom $ \case+-- Left err -> return ("err: " ++ show err)+-- Right val -> return val+-- :}+-- RescueT (Identity (Right "err: Identity FooErr"))+attemptM :: MonadRescue m => m a -> (Either (ErrorCase m) a -> m b) -> m b+attemptM action handler = attempt action >>= handler+ rescue- :: MonadRescueFrom n m- => n a- -> (ErrorCase n -> m a)- -> m a-rescue action handler = either handler pure =<< attempt action+ :: ( Bifunctor m+ , ElemRemove err errs+ )+ => (err -> OpenUnion (Remove err errs))+ -> m (OpenUnion errs) a+ -> m (OpenUnion (Remove err errs)) a+rescue handler = Bifunctor.first (openUnionHandle id handler) -handle- :: ( MonadRaise m- , MonadRescueFrom n m- , Handles err n m+-- | Handle and eliminate a single error+rescueT ::+ ( MonadTransError t errs m+ , MonadRaise (t (Remove err errs) m)+ , CheckErrors (t (Remove err errs) m)+ , ElemRemove err (Errors (t errs m))+ , Remove err (Errors (t errs m)) ~ Errors (t (Remove err errs) m)+ )+ => (err -> (t (Remove err errs)) m a)+ -> t errs m a+ -> t (Remove err errs) m a+rescueT handler = onRaise (openUnionHandle raise handler)++-- | The more generic (MonadBase-ified) version of handle+rescueBase+ :: ( MonadRescue wide+ , MonadBase wide narrow+ , MonadRaise narrow+ , CheckErrors narrow+ , Remove err (Errors wide) ~ Errors narrow+ , ElemRemove err (Errors wide) )- => n a- -> (err -> m a)- -> m a-handle action handler =- either runHandler pure =<< attempt action- where- runHandler = openUnionHandle raise handler+ => (err -> narrow a)+ -> wide a+ -> narrow a+rescueBase handler action =+ liftBase (attempt action) >>= \case+ Left err -> openUnionHandle raise handler err+ Right value -> return value -onRaise+rescueM+ :: ( MonadBase (m (OpenUnion wide)) (m (OpenUnion (Remove err wide)))+ , MonadRescue (m (OpenUnion wide))+ , MonadRaise (m (OpenUnion narrow))+ --+ , wide ~ Errors (m (OpenUnion wide))+ , narrow ~ Errors (m (OpenUnion narrow))+ , narrow ~ Remove err wide+ , CheckErrors (m (OpenUnion narrow))+ , ElemRemove err wide+ )+ => (err -> m (OpenUnion narrow) a)+ -> m (OpenUnion wide) a+ -> m (OpenUnion narrow) a+rescueM handler action =+ liftBase (attempt action) >>= \case+ Right val ->+ return val++ Left errs ->+ case openUnionRemove errs of+ Left remainingErrs -> raise remainingErrs+ Right matchedErr -> handler matchedErr++rescueEach+ :: ( Bifunctor m+ , ToOpenProduct handlerTuple (ReturnX (OpenUnion targetErrs) errs)+ )+ => handlerTuple+ -> m (OpenUnion errs) a+ -> m (OpenUnion targetErrs) a+rescueEach handleCases = Bifunctor.first (catchesOpenUnion handleCases)++rescueEachM+ :: ( sourceErrs ~ Errors (m (OpenUnion sourceErrs))+ , MonadRescue (m (OpenUnion sourceErrs))+ , MonadBase (m (OpenUnion sourceErrs)) (m (OpenUnion targetErrs))+ , ToOpenProduct handlerTuple (ReturnX (m (OpenUnion targetErrs) a) sourceErrs)+ )+ => handlerTuple+ -> m (OpenUnion sourceErrs) a+ -> m (OpenUnion targetErrs) a+rescueEachM handleCases action =+ liftBase (attempt action) >>= \case+ Left errs -> catchesOpenUnion handleCases errs+ Right val -> return val++rescueEachT+ :: ( sourceErrs ~ Errors (t sourceErrs m)+ , MonadTransError t sourceErrs m+ , ToOpenProduct handlerTuple (ReturnX (t targetErrs m a) sourceErrs)+ )+ => handlerTuple+ -> t sourceErrs m a+ -> t targetErrs m a+rescueEachT handleCases = onRaise (catchesOpenUnion handleCases)++rescueAll+ :: ( MonadRescue (m (OpenUnion errs))+ , MonadBase (m (OpenUnion errs)) (m ())+ , errs ~ Errors (m (OpenUnion errs))+ )+ => (OpenUnion errs -> m () a)+ -> m (OpenUnion errs) a+ -> m () a+rescueAll handler action =+ liftBase (attempt action) >>= \case+ Left errs -> handler errs+ Right val -> return val++report :: ( MonadRescue m , RaisesOnly m errs+ , CheckErrors m )- => (OpenUnion errs -> m ())+ => (ErrorCase m -> m ()) -> m a- -> m (Result errs a)-onRaise errHandler action =+ -> m a+report withErr action = attempt action >>= \case Left err -> do- errHandler err- return $ Err err+ withErr err+ raise err Right val ->- return $ Ok val+ return val -- | 'retry' without asynchoronous exception cleanup. -- Useful when not dealing with external resources that may@@ -117,15 +237,48 @@ -- | Run an additional step, and throw away the result. -- Return the result of the action passed.-lastly- :: ( Errors m `Contains` Errors m- , MonadRaise m- , MonadRescueFrom m m- )- => m a- -> m b- -> m a+lastly :: (CheckErrors m, MonadRescue m) => m a -> m b -> m a lastly action finalizer = do errOrOk <- attempt action _ <- finalizer ensure errOrOk++-- AKA reinterpret+mapError+ :: ( MonadRescue m+ , MonadBase m n+ , MonadRaise n+ , CheckErrors n+ )+ => (ErrorCase m -> ErrorCase n)+ -> m a+ -> n a+mapError mapper action =+ liftBase (attempt action) >>= \case+ Left errCaseN -> raise $ mapper errCaseN+ Right value -> return value++replaceError+ :: ( MonadRescue m+ , MonadBase m n+ , MonadRaise n+ , n `Raises` err+ )+ => err+ -> m a+ -> n a+replaceError err action =+ liftBase (attempt action) >>= \case+ Left _ -> raise err+ Right value -> return value++asNotFound+ :: forall n m a .+ ( MonadRescue m+ , MonadBase m n+ , MonadRaise n+ , n `Raises` NotFound a+ )+ => m a+ -> n a+asNotFound = replaceError (NotFound @a)
library/Control/Monad/Rescue/Class.hs view
@@ -9,14 +9,13 @@ -- | The 'MonadRescue' class, meant for retrieving the success/failure branches -module Control.Monad.Rescue.Class (MonadRescueFrom (..)) where+module Control.Monad.Rescue.Class (MonadRescue (..)) where -import Data.Functor import Data.WorldPeace -import Exception+import Control.Exception -import Control.Monad.Base+import qualified Control.Monad.Catch as Catch import Control.Monad.Cont import Control.Monad.Raise@@ -40,6 +39,7 @@ -- >>> :set -XDataKinds -- >>> :set -XFlexibleContexts -- >>> :set -XTypeApplications+-- >>> :set -XLambdaCase -- -- >>> import Control.Monad.Trans.Rescue -- >>> import Data.Functor.Identity@@ -52,7 +52,7 @@ -- | Pull a potential error out of the surrounding context -- NOTE that the target `m` may not even be aware of Raise/Rescue. It's an escape to the "normal" world-class (Monad m, MonadRaise n) => MonadRescueFrom n m where+class MonadRaise m => MonadRescue m where -- | Attempt some action, exposing the success and error branches -- -- ==== __Examples__@@ -65,187 +65,106 @@ -- else raise FooErr -- :} --- -- >>> :{- -- result :: Identity (Either (OpenUnion '[FooErr, BarErr]) Int)- -- result = attempt $ goesBoom 42- -- :}+ -- >>> runRescue . attempt $ goesBoom 42+ -- Right (Left (Identity FooErr)) --- -- >>> result- -- Identity (Left (Identity FooErr))+ -- Where @Identity fooErr@ is the selection of the 'OpenUnion'.+ -- In practice you would handle the 'OpenUnion' like so: --+ -- >>> let handleErr = catchesOpenUnion (show, show)+ -- >>> let x = attempt (goesBoom 42) >>= pure . either handleErr show+ -- >>> runRescue x+ -- Right "FooErr"+ -- -- Where @Identity FooErr@ is the selection of the 'OpenUnion'.- attempt :: n a -> m (Either (ErrorCase n) a)+ attempt :: m a -> m (Either (ErrorCase m) a) -instance Monad n => MonadRescueFrom Maybe n where- attempt = pure . \case- Nothing -> Left $ openUnionLift ()- Just x -> Right x+instance MonadRescue Maybe where+ attempt Nothing = Just . Left $ openUnionLift ()+ attempt (Just x) = Just $ Right x -instance Monad m => MonadRescueFrom [] m where- attempt = return . \case- [] -> Left $ include ()- (a : _) -> Right a+instance MonadRescue [] where+ attempt [] = [Left $ include ()]+ attempt xs = Right <$> xs -instance Monad m => MonadRescueFrom (Either (OpenUnion errs)) m where- attempt action = pure action+instance MonadRescue (Either (OpenUnion errs)) where+ attempt action = Right action -instance MonadIO m => MonadRescueFrom IO m where+instance MonadRescue IO 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+ Catch.try action >>= \case+ Left (err :: IOException) -> return . Left $ include err+ Right val -> return $ Right val instance- ( Monoid w- , MonadBase n m- , MonadRescueFrom n n+ ( MonadRescue m+ , () `IsMember` Errors m+ , Errors m `Contains` Errors m )- => MonadRescueFrom n (Lazy.WriterT w m) where- attempt = liftBase . attempt+ => MonadRescue (MaybeT m) where+ attempt (MaybeT action) =+ MaybeT $+ attempt action >>= \case+ Left errs -> return . Just . Left $ include errs+ Right Nothing -> return . Just . Left $ include ()+ Right (Just val) -> return . Just $ Right val -instance- ( Monoid w- , MonadBase n m- , MonadRescueFrom n m- )- => MonadRescueFrom (Strict.WriterT w n) (Strict.WriterT w m) where- attempt = Strict.mapWriterT runner2+instance MonadRescue m => MonadRescue (IdentityT m) where+ attempt (IdentityT action) = IdentityT $ attempt action instance- ( Monoid w- , MonadBase n m- , MonadRescueFrom n n+ ( MonadRescue m+ , Contains (Errors m) errs )- => MonadRescueFrom n (Strict.WriterT w m) where- attempt = liftBase . attempt+ => MonadRescue (ExceptT (OpenUnion errs) m) where+ attempt (ExceptT action) =+ lift $+ attempt action >>= \case+ Left err -> return . Left $ include err+ Right errOrVal -> return errOrVal -instance- ( MonadBase n m- , MonadRescueFrom n m- )- => MonadRescueFrom (Lazy.StateT s n) (Lazy.StateT s m) where- attempt = Lazy.mapStateT runner2+instance MonadRescue m => MonadRescue (ReaderT cfg m) where+ attempt = mapReaderT attempt -instance- ( MonadBase n m- , MonadRescueFrom n n- )- => MonadRescueFrom n (Lazy.StateT s m) where- attempt = liftBase . attempt+instance (Monoid w, MonadRescue m) => MonadRescue (Lazy.WriterT w m) where+ attempt = Lazy.mapWriterT runner2 -instance- ( MonadBase n m- , MonadRescueFrom n m- )- => MonadRescueFrom (Strict.StateT s n) (Strict.StateT s m) where- attempt = Strict.mapStateT runner2+instance (Monoid w, MonadRescue m) => MonadRescue (Strict.WriterT w m) where+ attempt = Strict.mapWriterT 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 MonadRescue m => MonadRescue (Lazy.StateT s m) where+ attempt = Lazy.mapStateT runner2 -instance- ( MonadBase n m- , MonadRescueFrom n n- )- => MonadRescueFrom n (Strict.StateT s m) where- attempt = liftBase . attempt+instance MonadRescue m => MonadRescue (Strict.StateT s m) where+ attempt = Strict.mapStateT runner2 -instance- ( Monoid w- , MonadBase n m- , MonadRescueFrom n n- )- => MonadRescueFrom n (Strict.RWST r w s m) where- attempt = liftBase . attempt+instance (Monoid w, MonadRescue m) => MonadRescue (Lazy.RWST r w s m) where+ attempt = Lazy.mapRWST runner3 -instance- ( MonadBase n m- , MonadRescueFrom n n- )- => MonadRescueFrom n (ContT r m) where- attempt = liftBase . attempt+instance (Monoid w, MonadRescue m) => MonadRescue (Strict.RWST r w s m) where+ attempt = Strict.mapRWST runner3 -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)+instance MonadRescue m => MonadRescue (ContT r m) where+ attempt = withContT $ \b_mr current -> b_mr =<< attempt (pure current) runner2- :: forall m n errs a w .- ( MonadBase n m- , MonadRescueFrom n m- , n `RaisesOnly` errs+ :: ( MonadRescue m+ , RaisesOnly m errs )- => n (a, w)- -> m (Either (ErrorCase n) a, w)+ => m (a, w)+ -> m (Either (OpenUnion errs) a, w) runner2 inner = do- (val, log') <- liftBase inner- result <- attempt (pure val :: n a)- return (result, log')+ (a, w) <- inner+ errOrVal <- attempt (pure a)+ return (errOrVal, w) runner3- :: forall m n errs a s w .- ( MonadBase n m- , MonadRescueFrom n m- , n `RaisesOnly` errs+ :: ( MonadRescue m+ , RaisesOnly m errs )- => n (a, s, w)- -> m (Either (OpenUnion errs) a, s, w)+ => m (a, b, c)+ -> m (Either (OpenUnion errs) a, b, c) runner3 inner = do- (val, state, log') <- liftBase inner- result <- attempt (pure val :: n a)- return (result, state, log')+ (a, s, w) <- inner+ errOrVal <- attempt (pure a)+ return (errOrVal, s, w)
library/Control/Monad/Rescue/Constraint.hs view
@@ -1,23 +1,8 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-} -module Control.Monad.Rescue.Constraint- ( Handles- , MonadRescue- ) where+module Control.Monad.Rescue.Constraint (CheckErrors) where import Control.Monad.Raise.Class-import Control.Monad.Rescue.Class- import Data.WorldPeace --- | Express the ability to 'handle' / eliminate an exception case-type Handles err n m- = ( ElemRemove err (Errors n)- , Contains (Remove err (Errors n)) (Errors m)- )---- | Rescue from the existing context only------ Note: cannot 'handle' (elimininate) exceptions-type MonadRescue m = MonadRescueFrom m m+type CheckErrors m = Contains (Errors m) (Errors m)
library/Control/Monad/Trans/Cleanup/Types.hs view
@@ -24,9 +24,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class -import Data.Functor import Data.Functor.Contravariant- import Data.WorldPeace -- | Adds 'SomeException' to an exception stack,@@ -122,36 +120,30 @@ instance MonadBase m m => MonadBase m (CleanupT m) where liftBase = liftBaseDefault -instance (Monad m, MonadRescue m) => MonadRescueFrom m (CleanupT m) where- attempt = CleanupT . attempt--instance forall n m .- ( MonadRescueFrom n m- , MonadBase n m- , MonadRescue n- , MonadCatch n- , Contains (Errors n) (Errors n)- , Contains (Errors n) (SomeException ': Errors n)+instance+ ( MonadRescue m+ , MonadCatch m+ , CheckErrors m+ , Errors m `Contains` (SomeException ': Errors m) )- => MonadRescueFrom (CleanupT n) m where+ => MonadRescue (CleanupT m) where attempt (CleanupT action) =- liftBase $- inner <&> \case- Left err -> Left $ include err- Right (Left err) -> Left $ include err- Right (Right val) -> Right val+ CleanupT $+ inner >>= \case+ Left err -> return . Left $ include err+ Right (Left err) -> return . Left $ include err+ Right (Right val) -> return $ Right val where inner = Catch.try action >>= \case Left e@(SomeException _) -> return $ Left e- Right (val :: a) -> Right <$> attempt (pure val :: n a)+ Right val -> Right <$> attempt (pure val) instance- ( Contains (Errors m) (Errors m)- , Contains (Errors m) (SomeException ': Errors m)- , MonadBase m m- , MonadRescue m+ ( MonadRescue m , MonadMask m+ , CheckErrors m+ , Contains (Errors m) (SomeException ': Errors m) ) => MonadCleanup (CleanupT m) where cleanup acquire onErr onOk action =
+ library/Control/Monad/Trans/Error.hs view
@@ -0,0 +1,21 @@+module Control.Monad.Trans.Error+ ( mapErrorT+ -- * Reexports+ , module Control.Monad.Trans.Error.Class+ ) where++import Control.Monad.Raise+import Control.Monad.Rescue.Constraint+import Control.Monad.Trans.Error.Class++import Data.WorldPeace++mapErrorT+ :: ( MonadTransError t sourceErrs m+ , MonadRaise (t targetErrs m)+ , CheckErrors (t targetErrs m)+ )+ => (OpenUnion (Errors (t sourceErrs m)) -> OpenUnion (Errors (t targetErrs m)))+ -> t sourceErrs m a+ -> t targetErrs m a+mapErrorT f = onRaise (raise . f)
+ library/Control/Monad/Trans/Error/Class.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Control.Monad.Trans.Error.Class (MonadTransError (..)) where++import Control.Monad.Raise.Class+import Control.Monad.Trans.Class++import Data.Kind+import Data.WorldPeace++class MonadTrans (t sourceErrs) => MonadTransError t (sourceErrs :: [Type]) m where+ onRaise+ :: (OpenUnion (Errors (t sourceErrs m)) -> t targetErrs m a)+ -> t sourceErrs m a+ -> t targetErrs m a
library/Control/Monad/Trans/Rescue/Types.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}@@ -12,14 +12,13 @@ , runRescue ) where -import Prelude-+import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Cont import Control.Monad.Fix import Control.Monad.Reader import Control.Monad.Rescue-import Control.Monad.Base+import Control.Monad.Trans.Error.Class import Data.Functor.Identity import Data.WorldPeace@@ -66,6 +65,13 @@ instance MonadTrans (RescueT errs) where lift action = RescueT (Right <$> action) +instance Monad m => MonadTransError RescueT errs m where+ onRaise f (RescueT inner) =+ RescueT $+ inner >>= \case+ Left err -> runRescueT $ f err+ Right val -> return $ Right val+ instance MonadBase b m => MonadBase b (RescueT errs m) where liftBase = liftBaseDefault @@ -95,12 +101,12 @@ type Errors (RescueT errs m) = errs raise err = RescueT . pure $ raise err -instance- ( Monad m- , MonadBase n m- )- => MonadRescueFrom (RescueT errs n) m where- attempt (RescueT action) = liftBase action+instance Monad m => MonadRescue (RescueT errs m) where+ attempt (RescueT inner) =+ RescueT $+ inner >>= \case+ Left err -> return . Right $ Left err+ Right val -> return . Right $ Right val instance MonadThrow m => MonadThrow (RescueT errs m) where throwM = lift . throwM
library/Data/Exception/Types.hs view
@@ -1,38 +1,58 @@ -- | Common exceptions module Data.Exception.Types- ( NotFound (..)+ ( AlreadyExists (..)+ , DivideByZero (..)+ , InvalidFormat (..) , NotAllowed (..)- , AlreadyExists (..)+ , NotFound (..) , OutOfBounds (..)- , DivideByZero (..)+ , WithMessage (..) ) where import Data.Text +-- | Entity not found data NotFound entity = NotFound deriving (Show, Eq) -data NotAllowed entity user- = NotAllowed entity user+-- | Action not allowed by user+data NotAllowed user entity =+ NotAllowed+ { user :: !user+ , entity :: !entity+ } deriving (Show, Eq) +-- | Requested entity already exists; a conflict newtype AlreadyExists entity = AlreadyExists entity deriving (Show, Eq) +instance Functor AlreadyExists where+ fmap f (AlreadyExists entity') = AlreadyExists $ f entity'++-- | Requested index is out of bounds newtype OutOfBounds entity index = OutOfBounds index deriving (Show, Eq) +instance Functor (OutOfBounds entity) where+ fmap f (OutOfBounds index') = OutOfBounds $ f index'++-- | Arithmetic divide by zero error data DivideByZero = DivideByZero deriving (Show, Eq) +-- | Invalid format for entity (e.g. bad JSON) newtype InvalidFormat entity = InvalidFormat entity deriving (Show, Eq) +instance Functor InvalidFormat where+ fmap f (InvalidFormat entity') = InvalidFormat $ f entity'+ -- | Attach a message to an exception, typicaly for runtime user feedback -- -- ==== __Examples__@@ -41,5 +61,8 @@ -- >>> show $ InvalidFormat "foo" `WithMessage` "Not a valid JSON object" -- "InvalidFormat \"foo\" `WithMessage` \"Not a valid JSON object\"" data WithMessage err- = err `WithMessage` Text+ = !err `WithMessage` !Text deriving (Show, Eq)++instance Functor WithMessage where+ fmap f (WithMessage err msg) = WithMessage (f err) msg
library/Data/WorldPeace/Subset/Class.hs view
@@ -23,3 +23,4 @@ instance (IsOpenUnion err ~ flag, Subset' flag err errs) => Subset err (OpenUnion errs) where include = include' (Proxy @flag) {-# INLINE include #-}+
rescue.cabal view
@@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.2.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: 6fb768a7355701f4063e91ba078ad7698c52571f65d298ebcf667cacd6a8b1a8 name: rescue-version: 0.3.0+version: 0.4.0 synopsis: More understandable exceptions description: An error handling library focused on clarity and control category: Error Handling@@ -15,11 +13,12 @@ bug-reports: https://github.com/expede/rescue/issues author: Brooklyn Zelenka maintainer: hello@brooklynzelenka.com-copyright: © 2020 Brooklyn Zelenka+copyright: © 2021 Brooklyn Zelenka license: Apache-2.0 license-file: LICENSE-tested-with: GHC==8.8.3 build-type: Simple+tested-with:+ GHC==8.10.4 extra-source-files: README.md @@ -39,6 +38,8 @@ Control.Monad.Rescue.Constraint Control.Monad.Trans.Cleanup Control.Monad.Trans.Cleanup.Types+ Control.Monad.Trans.Error+ Control.Monad.Trans.Error.Class Control.Monad.Trans.Rescue Control.Monad.Trans.Rescue.Types Data.Exception.Types@@ -125,6 +126,8 @@ Control.Monad.Rescue.Constraint Control.Monad.Trans.Cleanup Control.Monad.Trans.Cleanup.Types+ Control.Monad.Trans.Error+ Control.Monad.Trans.Error.Class Control.Monad.Trans.Rescue Control.Monad.Trans.Rescue.Types Data.Exception.Types