summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorwarlock <>2017-12-07 11:18:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-12-07 11:18:00 (GMT)
commit0f66b29b0903fbaa6f5f2cf366d1d5fa478d0e1d (patch)
treed2964a829c0a40a1c2681864e39bec47bd9a6529
parentd875da2a2e56d4ac28ba5e4d7e99ce2036901cde (diff)
version 0.40.4
-rw-r--r--errors-ext.cabal11
-rw-r--r--src/Control/Error/Extensions.hs45
2 files changed, 38 insertions, 18 deletions
diff --git a/errors-ext.cabal b/errors-ext.cabal
index 4cf54bf..a73faa4 100644
--- a/errors-ext.cabal
+++ b/errors-ext.cabal
@@ -1,7 +1,7 @@
name: errors-ext
-version: 0.2.1
-synopsis: Bracket-like functions for ExceptT over IO monad.
-description: Bracket-like functions for ExceptT over IO monad.
+version: 0.4
+synopsis: `bracket`-like functions for `ExceptT` over `IO` monad.
+description: `bracket`-like functions for `ExceptT` over `IO` monad.
homepage: https://github.com/A1-Triard/errors-ext#readme
license: Apache
license-file: LICENSE
@@ -16,10 +16,13 @@ cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Control.Error.Extensions
+ default-extensions: FlexibleContexts
ghc-options: -fmax-pmcheck-iterations=100000000 -Wall -fprint-potential-instances
build-depends: base >= 4.7 && < 5
, errors
, exceptions
+ , monad-control
+ , mtl
, transformers
default-language: Haskell2010
@@ -34,6 +37,8 @@ test-suite errors-ext-test
, errors-ext
, errors
, exceptions
+ , monad-control
+ , mtl
, transformers
default-language: Haskell2010
diff --git a/src/Control/Error/Extensions.hs b/src/Control/Error/Extensions.hs
index 71d9ed9..036f0a9 100644
--- a/src/Control/Error/Extensions.hs
+++ b/src/Control/Error/Extensions.hs
@@ -14,40 +14,55 @@
-- limitations under the License.
--
--- | This module exports bracket-like functions for 'ExceptT'.
---
+-- | This module exports 'bracket'-like functions for 'ExceptT'.
module Control.Error.Extensions
( bracketE
, bracketE_
) where
+import Control.Exception
import Control.Error.Util
import Control.Monad
-import Control.Monad.Catch
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Except
-
--- | Analogous to 'bracket', but for 'ExceptT' over 'IO' (or any 'MonadMask' monad).
-bracketE :: MonadMask m => ExceptT e m a -> (a -> ExceptT e m b) -> (a -> ExceptT e m c) -> ExceptT e m c
-bracketE acquire release action = (hoistEither =<<) $ lift $ do
- resource <- runExceptT acquire
- result <- bracketOnError (return resource) (ignoreAll . ioRelease) ioAction
+import Control.Monad.Catch (handleAll)
+import Control.Monad.Error.Class
+import Control.Monad.Trans.Control
+import Control.Monad.Trans.Except ()
+
+liftedBracketOnError :: MonadBaseControl IO m => m a -> (a -> m b) -> (a -> m c) -> m c
+liftedBracketOnError acquire release action = control $ \run ->
+ bracketOnError (run acquire) (\saved -> run (restoreM saved >>= release)) (\saved -> run (restoreM saved >>= action))
+
+liftedHandleAll :: MonadBaseControl IO m => (SomeException -> m a) -> m a -> m a
+liftedHandleAll handler action = control $ \run ->
+ handleAll (run . handler) (run action)
+
+runErrorM :: MonadError e m => m a -> m (Either e a)
+runErrorM a = catchError (Right <$> a) (return . Left)
+
+errorM :: MonadError e m => m (Either e a) -> m a
+errorM = (either throwError return =<<)
+
+-- | Analogous to 'bracket', but for @'ExceptT' e 'IO'@ (or any 'MonadError' allowing 'bracket' lifting).
+bracketE :: (MonadBaseControl IO m, MonadError e m) => m a -> (a -> m b) -> (a -> m c) -> m c
+bracketE acquire release action = errorM $ do
+ resource <- runErrorM acquire
+ result <- liftedBracketOnError (return resource) (ignoreAll . ioRelease) ioAction
if isLeft result
then ignoreAll (ioRelease resource) >> return result
else caseResult result <$> ioRelease resource
where
- ignoreAll = handleAll (const $ return ()) . void
+ ignoreAll = liftedHandleAll (const $ return ()) . void
ioAction (Left e) = return $ Left e
- ioAction (Right r) = runExceptT $ action r
+ ioAction (Right r) = runErrorM $ action r
ioRelease (Left e) = return $ Left e
- ioRelease (Right r) = runExceptT $ release r
+ ioRelease (Right r) = runErrorM $ release r
caseResult (Left e) _ = Left e
caseResult (Right _) (Left e) = Left e
caseResult (Right r) (Right _) = Right r
{-# INLINE bracketE #-}
-- | A variant of 'bracketE' where the return value from the first computation is not required.
-bracketE_ :: MonadMask m => ExceptT e m a -> ExceptT e m b -> ExceptT e m c -> ExceptT e m c
+bracketE_ :: (MonadBaseControl IO m, MonadError e m) => m a -> m b -> m c -> m c
bracketE_ acquire release action = bracketE acquire (const release) (const action)
{-# INLINE bracketE_ #-}