errors-ext 0.4.1 → 0.4.2
raw patch · 3 files changed
+132/−56 lines, 3 filesdep +binary-extdep +bytestringdep +conduitdep ~base
Dependencies added: binary-ext, bytestring, conduit, monad-loops
Dependency ranges changed: base
Files
- errors-ext.cabal +58/−38
- src/Control/Error/Extensions.hs +31/−1
- test/Control/Error/Extensions/Spec.hs +43/−17
errors-ext.cabal view
@@ -1,47 +1,67 @@-name: errors-ext-version: 0.4.1-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-author: Warlock <internalmike@gmail.com>-maintainer: Warlock <internalmike@gmail.com>-copyright: 2017 Warlock <internalmike@gmail.com>-category: Control, Error Handling-build-type: Simple--- extra-source-files:-cabal-version: >=1.10+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 81ddf04aa29463fe76044d3296fe782c805664465d860021824bb5250ebc18e3 +name: errors-ext+version: 0.4.2+synopsis: `bracket`-like functions for `ExceptT` over `IO` monad.+description: Please see the README on GitHub at <https://github.com/A1-Triard/errors-ext#readme>+category: Control, Error Handling+homepage: https://github.com/A1-Triard/errors-ext#readme+bug-reports: https://github.com/A1-Triard/errors-ext/issues+author: Warlock <internalmike@gmail.com>+maintainer: Warlock <internalmike@gmail.com>+copyright: 2017, 2018 Warlock <internalmike@gmail.com>+license: Apache+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++source-repository head+ type: git+ location: https://github.com/A1-Triard/errors-ext+ library- hs-source-dirs: src- exposed-modules: Control.Error.Extensions+ exposed-modules:+ Control.Error.Extensions+ other-modules:+ Paths_errors_ext+ hs-source-dirs:+ src 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+ ghc-options: -fmax-pmcheck-iterations=100000000 -Wall -fprint-potential-instances -fsimpl-tick-factor=110+ build-depends:+ base >=4.7 && <5+ , errors+ , exceptions+ , monad-control+ , mtl+ , transformers default-language: Haskell2010 test-suite errors-ext-test type: exitcode-stdio-1.0- hs-source-dirs: test main-is: Spec.hs- other-modules: Control.Error.Extensions.Spec- ghc-options: -threaded -rtsopts -with-rtsopts=-N -fmax-pmcheck-iterations=100000000 -Wall -fprint-potential-instances- build-depends: base- , HUnit- , errors-ext- , errors- , exceptions- , monad-control- , mtl- , transformers+ other-modules:+ Control.Error.Extensions.Spec+ Paths_errors_ext+ hs-source-dirs:+ test+ default-extensions: FlexibleContexts BangPatterns OverloadedStrings+ ghc-options: -fmax-pmcheck-iterations=100000000 -Wall -fprint-potential-instances -fsimpl-tick-factor=110 -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HUnit+ , base >=4.7 && <5+ , binary-ext >=2.0.4+ , bytestring+ , conduit+ , errors+ , errors-ext+ , exceptions+ , monad-control+ , monad-loops+ , mtl+ , transformers default-language: Haskell2010--source-repository head- type: git- location: https://github.com/A1-Triard/errors-ext
src/Control/Error/Extensions.hs view
@@ -1,5 +1,5 @@ ----- Copyright 2017 Warlock <internalmike@gmail.com>+-- Copyright 2017, 2018 Warlock <internalmike@gmail.com> -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -19,6 +19,10 @@ module Control.Error.Extensions ( bracketE , bracketE_+ , eitherMaybe+ , maybeEither+ , eitherVoidL+ , eitherVoidR ) where import Control.Exception@@ -28,6 +32,7 @@ import Control.Monad.Error.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Except ()+import Data.Void liftedBracketOnError :: MonadBaseControl IO m => m a -> (a -> m b) -> (a -> m c) -> m c liftedBracketOnError acquire release action = control $ \run ->@@ -71,3 +76,28 @@ 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_ #-}++-- | Converts 'Maybe' to 'Either'. Specialization of 'maybe'.+--+-- @maybeEither . 'eitherMaybe' = 'id'@+maybeEither :: Maybe a -> Either () a+maybeEither = maybe (Left ()) Right+{-# INLINE maybeEither #-}++-- | Converts 'Either' to 'Maybe'. Specialization of 'either'.+--+-- @'maybeEither' . eitherMaybe = 'id'@+eitherMaybe :: Either () a -> Maybe a+eitherMaybe = either (const Nothing) Just+{-# INLINE eitherMaybe #-}+++-- | Removes right zero term from sum type. Specialization of 'either'.+eitherVoidR :: Either a Void -> a+eitherVoidR = either id absurd+{-# INLINE eitherVoidR #-}++-- | Removes left zero term from sum type. Specialization of 'either'.+eitherVoidL :: Either Void a -> a+eitherVoidL = either absurd id+{-# INLINE eitherVoidL #-}
test/Control/Error/Extensions/Spec.hs view
@@ -1,5 +1,5 @@ ----- Copyright 2017 Warlock <internalmike@gmail.com>+-- Copyright 2017, 2018 Warlock <internalmike@gmail.com> -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -21,13 +21,23 @@ import Test.HUnit.Base hiding (Label) import Control.Error.Extensions import Control.Exception+import Control.Monad.Error.Class+import Control.Monad.Loops import Control.Monad.Trans.Class import Control.Monad.Trans.Except+import qualified Data.ByteString as S (ByteString)+import Data.Conduit hiding (ConduitM)+import qualified Data.Conduit.Combinators as N+import Data.Conduit.Lift+import Data.Conduit.Parsers.Binary.Get+import Data.Conduit.Parsers.Binary.Put import Data.IORef import System.IO.Error tests :: Test-tests = TestList $ (TestCase . runBracketTest) <$> bracketTests+tests = TestList+ $ ((TestCase . runBracketTest) <$> bracketTests)+ ++ [TestCase testPrevNaturalsFile] data Resource = Resource { acquired :: !Bool, released :: !Bool, processed :: !Bool } deriving (Eq, Show) @@ -72,34 +82,50 @@ processEr :: Process processEr _ = throwE "processEr" -data Error = Error { isException :: !Bool, message :: !String } deriving (Eq, Show)+data Err = Err { isException :: !Bool, message :: !String } deriving (Eq, Show) -bracketTest :: Acquire -> Release -> Process -> IO (Resource, Either Error Resource)+bracketTest :: Acquire -> Release -> Process -> IO (Resource, Either Err Resource) bracketTest acquire release process = do r <- resource- p <- catch (either (\x -> Left $ Error False x) Right <$> (runExceptT $ bracketE (acquire r) release process)) $ \e ->- let _ = e :: IOError in return $ Left $ Error True $ ioeGetErrorString e+ p <- catch (either (\x -> Left $ Err False x) Right <$> (runExceptT $ bracketE (acquire r) release process)) $ \e ->+ let _ = e :: IOError in return $ Left $ Err True $ ioeGetErrorString e f <- readIORef r return (f, p) -data TestData = TestData String !Acquire !Release !Process !(Resource, Either Error Resource)+data TestData = TestData String !Acquire !Release !Process !(Resource, Either Err Resource) bracketTests :: [TestData] bracketTests = [ TestData "1" acquireOk releaseOk processOk (Resource True True True, Right $ Resource True False False)- , TestData "2" acquireEx releaseOk processOk (Resource False False False, Left $ Error { isException = True, message = "acquireEx" })- , TestData "3" acquireEr releaseOk processOk (Resource False False False, Left $ Error { isException = False, message = "acquireEr" })- , TestData "4" acquireOk releaseEx processOk (Resource True False True, Left $ Error { isException = True, message = "releaseEx" })- , TestData "5" acquireOk releaseEr processOk (Resource True False True, Left $ Error { isException = False, message = "releaseEr" })- , TestData "6" acquireOk releaseOk processEx (Resource True True False, Left $ Error { isException = True, message = "processEx" })- , TestData "7" acquireOk releaseOk processEr (Resource True True False, Left $ Error { isException = False, message = "processEr" })- , TestData "8" acquireOk releaseEx processEx (Resource True False False, Left $ Error { isException = True, message = "processEx" })- , TestData "9" acquireOk releaseEr processEx (Resource True False False, Left $ Error { isException = True, message = "processEx" })- , TestData "10" acquireOk releaseEx processEr (Resource True False False, Left $ Error { isException = False, message = "processEr" })- , TestData "11" acquireOk releaseEr processEr (Resource True False False, Left $ Error { isException = False, message = "processEr" })+ , TestData "2" acquireEx releaseOk processOk (Resource False False False, Left $ Err { isException = True, message = "acquireEx" })+ , TestData "3" acquireEr releaseOk processOk (Resource False False False, Left $ Err { isException = False, message = "acquireEr" })+ , TestData "4" acquireOk releaseEx processOk (Resource True False True, Left $ Err { isException = True, message = "releaseEx" })+ , TestData "5" acquireOk releaseEr processOk (Resource True False True, Left $ Err { isException = False, message = "releaseEr" })+ , TestData "6" acquireOk releaseOk processEx (Resource True True False, Left $ Err { isException = True, message = "processEx" })+ , TestData "7" acquireOk releaseOk processEr (Resource True True False, Left $ Err { isException = False, message = "processEr" })+ , TestData "8" acquireOk releaseEx processEx (Resource True False False, Left $ Err { isException = True, message = "processEx" })+ , TestData "9" acquireOk releaseEr processEx (Resource True False False, Left $ Err { isException = True, message = "processEx" })+ , TestData "10" acquireOk releaseEx processEr (Resource True False False, Left $ Err { isException = False, message = "processEr" })+ , TestData "11" acquireOk releaseEr processEr (Resource True False False, Left $ Err { isException = False, message = "processEr" }) ] runBracketTest :: TestData -> Assertion runBracketTest (TestData m a r p e) = do t <- bracketTest a r p assertEqual m e t++data PrevNaturalError = NotNatural Integer | Minimal deriving (Eq, Show)++prevNatural :: (Monad m, Integral i) => ConduitT i i (ExceptT PrevNaturalError m) ()+prevNatural = awaitForever $ \ !n -> do+ if n <= 0 then throwError (NotNatural $ fromIntegral n) else return ()+ if n == 1 then throwError Minimal else return ()+ yield $ n - 1++prevNaturalsFile :: Monad m => ConduitT S.ByteString S.ByteString (ExceptT PrevNaturalError m) ()+prevNaturalsFile = (eitherVoidR <$> runGet (iterateM_ (const $ yield =<< getInt8) (error ""))) .| prevNatural .| awaitForever (runPut . putInt8)++testPrevNaturalsFile :: Assertion+testPrevNaturalsFile = do+ assertEqual "" (Left Minimal, "") $ runConduitPure $ yield "\x01\x02\x03" .| runExceptC prevNaturalsFile `fuseBoth` N.sinkLazy+ assertEqual "" (Right (), "\x02\x07\x08") $ runConduitPure $ yield "\x03\x08\x09" .| runExceptC prevNaturalsFile `fuseBoth` N.sinkLazy