unexceptionalio-0.5.1/0000755000000000000000000000000013656652703013126 5ustar0000000000000000unexceptionalio-0.5.1/UnexceptionalIO.hs0000644000000000000000000002505713656652703016541 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable #-} #endif -- | When you've caught all the exceptions that can be handled safely, -- this is what you're left with. -- -- > runEitherIO . fromIO ≡ id -- -- It is intended that you use qualified imports with this library. -- -- > import UnexceptionalIO (UIO) -- > import qualified UnexceptionalIO as UIO module UnexceptionalIO ( UIO, Unexceptional(..), fromIO, #ifdef __GLASGOW_HASKELL__ fromIO', #endif run, runEitherIO, -- * Unsafe entry points unsafeFromIO, -- * Pseudo exceptions SomeNonPseudoException, #ifdef __GLASGOW_HASKELL__ PseudoException(..), ProgrammerError(..), ExternalError(..), -- * Pseudo exception helpers bracket, #if MIN_VERSION_base(4,7,0) forkFinally, fork, ChildThreadError(..) #endif #endif ) where import Data.Maybe (fromMaybe) import Control.Applicative (Applicative(..), (<|>), (<$>)) import Control.Monad (liftM, ap, (<=<)) import Control.Monad.Fix (MonadFix(..)) #ifdef __GLASGOW_HASKELL__ import System.Exit (ExitCode) import Control.Exception (try) import Data.Typeable (Typeable) import qualified Control.Exception as Ex import qualified Control.Concurrent as Concurrent #if MIN_VERSION_base(4,11,0) import qualified Control.Exception.Base as Ex #endif -- | Not everything handled by the exception system is a run-time error -- you can handle. This is the class of unrecoverable pseudo-exceptions. -- -- Additionally, except for 'ExitCode' any of these pseudo-exceptions -- you could never guarantee to have caught. Since they can come -- from anywhere at any time, we could never guarentee that 'UIO' does -- not contain them. data PseudoException = ProgrammerError ProgrammerError | -- ^ Mistakes programmers make ExternalError ExternalError | -- ^ Errors thrown by the runtime Exit ExitCode -- ^ Process exit requests deriving (Show, Typeable) instance Ex.Exception PseudoException where toException (ProgrammerError e) = Ex.toException e toException (ExternalError e) = Ex.toException e toException (Exit e) = Ex.toException e fromException e = ProgrammerError <$> Ex.fromException e <|> ExternalError <$> Ex.fromException e <|> Exit <$> Ex.fromException e -- | Pseudo-exceptions caused by a programming error -- -- Partial functions, 'error', 'undefined', etc data ProgrammerError = #if MIN_VERSION_base(4,9,0) TypeError Ex.TypeError | #endif ArithException Ex.ArithException | ArrayException Ex.ArrayException | AssertionFailed Ex.AssertionFailed | ErrorCall Ex.ErrorCall | NestedAtomically Ex.NestedAtomically | NoMethodError Ex.NoMethodError | PatternMatchFail Ex.PatternMatchFail | RecConError Ex.RecConError | RecSelError Ex.RecSelError | RecUpdError Ex.RecSelError deriving (Show, Typeable) instance Ex.Exception ProgrammerError where #if MIN_VERSION_base(4,9,0) toException (TypeError e) = Ex.toException e #endif toException (ArithException e) = Ex.toException e toException (ArrayException e) = Ex.toException e toException (AssertionFailed e) = Ex.toException e toException (ErrorCall e) = Ex.toException e toException (NestedAtomically e) = Ex.toException e toException (NoMethodError e) = Ex.toException e toException (PatternMatchFail e) = Ex.toException e toException (RecConError e) = Ex.toException e toException (RecSelError e) = Ex.toException e toException (RecUpdError e) = Ex.toException e fromException e = #if MIN_VERSION_base(4,9,0) TypeError <$> Ex.fromException e <|> #endif ArithException <$> Ex.fromException e <|> ArrayException <$> Ex.fromException e <|> AssertionFailed <$> Ex.fromException e <|> ErrorCall <$> Ex.fromException e <|> NestedAtomically <$> Ex.fromException e <|> NoMethodError <$> Ex.fromException e <|> PatternMatchFail <$> Ex.fromException e <|> RecConError <$> Ex.fromException e <|> RecSelError <$> Ex.fromException e <|> RecUpdError <$> Ex.fromException e -- | Pseudo-exceptions thrown by the runtime environment data ExternalError = #if MIN_VERSION_base(4,10,0) CompactionFailed Ex.CompactionFailed | #endif #if MIN_VERSION_base(4,11,0) FixIOException Ex.FixIOException | #endif #if MIN_VERSION_base(4,7,0) AsyncException Ex.SomeAsyncException | #else AsyncException Ex.AsyncException | #endif BlockedIndefinitelyOnSTM Ex.BlockedIndefinitelyOnSTM | BlockedIndefinitelyOnMVar Ex.BlockedIndefinitelyOnMVar | Deadlock Ex.Deadlock | NonTermination Ex.NonTermination deriving (Show, Typeable) instance Ex.Exception ExternalError where #if MIN_VERSION_base(4,10,0) toException (CompactionFailed e) = Ex.toException e #endif #if MIN_VERSION_base(4,11,0) toException (FixIOException e) = Ex.toException e #endif toException (AsyncException e) = Ex.toException e toException (BlockedIndefinitelyOnMVar e) = Ex.toException e toException (BlockedIndefinitelyOnSTM e) = Ex.toException e toException (Deadlock e) = Ex.toException e toException (NonTermination e) = Ex.toException e fromException e = #if MIN_VERSION_base(4,10,0) CompactionFailed <$> Ex.fromException e <|> #endif #if MIN_VERSION_base(4,11,0) FixIOException <$> Ex.fromException e <|> #endif AsyncException <$> Ex.fromException e <|> BlockedIndefinitelyOnSTM <$> Ex.fromException e <|> BlockedIndefinitelyOnMVar <$> Ex.fromException e <|> Deadlock <$> Ex.fromException e <|> NonTermination <$> Ex.fromException e -- | Every 'Ex.SomeException' but 'PseudoException' newtype SomeNonPseudoException = SomeNonPseudoException Ex.SomeException deriving (Show, Typeable) instance Ex.Exception SomeNonPseudoException where toException (SomeNonPseudoException e) = e fromException e = case Ex.fromException e of Just pseudo -> const Nothing (pseudo :: PseudoException) Nothing -> Just (SomeNonPseudoException e) throwIO :: (Ex.Exception e) => e -> IO a throwIO = Ex.throwIO #else -- Haskell98 import 'IO' instead import System.IO.Error (IOError, ioError, try) type SomeNonPseudoException = IOError throwIO :: SomeNonPseudoException -> IO a throwIO = ioError #endif -- | Like IO, but throws only 'PseudoException' newtype UIO a = UIO (IO a) instance Functor UIO where fmap = liftM instance Applicative UIO where pure = return (<*>) = ap instance Monad UIO where return = UIO . return (UIO x) >>= f = UIO (x >>= run . f) #if !MIN_VERSION_base(4,13,0) fail s = error $ "UnexceptionalIO cannot fail (" ++ s ++ ")" #endif instance MonadFix UIO where mfix f = UIO (mfix $ run . f) -- | Monads in which 'UIO' computations may be embedded class (Monad m) => Unexceptional m where lift :: UIO a -> m a instance Unexceptional UIO where lift = id instance Unexceptional IO where lift = run -- | Catch any exception but 'PseudoException' in an 'IO' action fromIO :: (Unexceptional m) => IO a -> m (Either SomeNonPseudoException a) fromIO = unsafeFromIO . try #ifdef __GLASGOW_HASKELL__ -- | Catch any 'e' in an 'IO' action, with a default mapping for -- unexpected cases fromIO' :: (Ex.Exception e, Unexceptional m) => (SomeNonPseudoException -> e) -- ^ Default if an unexpected exception occurs -> IO a -> m (Either e a) fromIO' f = liftM (either (Left . f) id) . fromIO . try #endif -- | Re-embed 'UIO' into 'IO' run :: UIO a -> IO a run (UIO io) = io -- | Re-embed 'UIO' and possible exception back into 'IO' #ifdef __GLASGOW_HASKELL__ runEitherIO :: (Ex.Exception e) => UIO (Either e a) -> IO a #else runEitherIO :: UIO (Either SomeNonPseudoException a) -> IO a #endif runEitherIO = either throwIO return <=< run -- | You promise there are no exceptions but 'PseudoException' thrown by this 'IO' action unsafeFromIO :: (Unexceptional m) => IO a -> m a unsafeFromIO = lift . UIO #ifdef __GLASGOW_HASKELL__ -- | When you're doing resource handling, 'PseudoException' matters. -- You still need to use the 'Ex.bracket' pattern to handle cleanup. bracket :: (Unexceptional m) => UIO a -> (a -> UIO ()) -> (a -> UIO c) -> m c bracket acquire release body = unsafeFromIO $ Ex.bracket (run acquire) (run . release) (run . body) #if MIN_VERSION_base(4,7,0) -- | Mirrors 'Concurrent.forkFinally', but since the body is 'UIO', -- the thread must terminate successfully or because of 'PseudoException' forkFinally :: (Unexceptional m) => UIO a -> (Either PseudoException a -> UIO ()) -> m Concurrent.ThreadId forkFinally body handler = unsafeFromIO $ Concurrent.forkFinally (run body) $ \result -> case result of Left e -> case Ex.fromException e of Just pseudo -> run $ handler $ Left pseudo Nothing -> error $ "Bug in UnexceptionalIO: forkFinally caught a non-PseudoException: " ++ show e Right x -> run $ handler $ Right x -- | Mirrors 'Concurrent.forkIO', but re-throws errors to the parent thread -- -- * Ignores manual thread kills, since those are on purpose. -- * Re-throws async exceptions ('SomeAsyncException') as is. -- * Re-throws 'ExitCode' as is in an attempt to exit with the requested code. -- * Wraps synchronous 'PseudoException' in async 'ChildThreadError'. fork :: (Unexceptional m) => UIO () -> m Concurrent.ThreadId fork body = do parent <- unsafeFromIO Concurrent.myThreadId forkFinally body $ either (handler parent) (const $ return ()) where handler parent e -- Thread manually killed. I assume on purpose | Just Ex.ThreadKilled <- castException e = return () -- Async exception, nothing to do with this thread, propogate directly | Just (Ex.SomeAsyncException _) <- castException e = unsafeFromIO $ Concurrent.throwTo parent e -- Attempt to manually end the process, -- not an async exception, so a bit dangerous to throw async'ly, but -- you really do want this to reach the top as-is for the exit code to -- work. | Just e <- castException e = unsafeFromIO $ Concurrent.throwTo parent (e :: ExitCode) -- Non-async PseudoException, so wrap in an async wrapper before -- throwing async'ly | otherwise = unsafeFromIO $ Concurrent.throwTo parent (ChildThreadError e) castException :: (Ex.Exception e1, Ex.Exception e2) => e1 -> Maybe e2 castException = Ex.fromException . Ex.toException -- | Async signal that a child thread ended due to non-async PseudoException newtype ChildThreadError = ChildThreadError PseudoException deriving (Show, Typeable) instance Ex.Exception ChildThreadError where toException = Ex.asyncExceptionToException fromException = Ex.asyncExceptionFromException #endif #endif unexceptionalio-0.5.1/Setup.hs0000644000000000000000000000005613656652703014563 0ustar0000000000000000import Distribution.Simple main = defaultMain unexceptionalio-0.5.1/unexceptionalio.cabal0000644000000000000000000000327113656652703017323 0ustar0000000000000000name: unexceptionalio version: 0.5.1 cabal-version: >=1.10 license: OtherLicense license-file: COPYING copyright: © 2013-2018 Stephen Paul Weber category: Control author: Stephen Paul Weber maintainer: Stephen Paul Weber stability: experimental build-type: Simple homepage: https://github.com/singpolyma/unexceptionalio bug-reports: http://github.com/singpolyma/unexceptionalio/issues synopsis: IO without any non-error, synchronous exceptions description: When you've caught all the exceptions that can be handled safely, this is what you're left with. . It is intended that you use qualified imports with this library. . > import UnexceptionalIO (UIO) > import qualified UnexceptionalIO as UIO . You may also wish to investigate unexceptionalio-trans if you like monad transformers. . Blog post: http://sngpl.ma/p4uT0 library default-language: Haskell2010 ghc-options: -fno-warn-tabs exposed-modules: UnexceptionalIO build-depends: base == 4.* test-suite tests type: exitcode-stdio-1.0 main-is: tests/suite.hs ghc-options: -O0 -fno-warn-tabs default-language: Haskell2010 other-modules: UnexceptionalIO build-depends: base == 4.*, HUnit, test-framework, test-framework-hunit source-repository head type: git location: git://github.com/singpolyma/unexceptionalio.git unexceptionalio-0.5.1/COPYING0000644000000000000000000000136613656652703014167 0ustar0000000000000000Copyright © 2013-2018, Stephen Paul Weber Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. unexceptionalio-0.5.1/tests/0000755000000000000000000000000013656652703014270 5ustar0000000000000000unexceptionalio-0.5.1/tests/suite.hs0000644000000000000000000001274113656652703015762 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable #-} import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, assert) import Data.Typeable (Typeable) import Control.Monad import System.Exit import qualified Control.Exception as Ex import qualified Control.Concurrent as Concurrent import qualified UnexceptionalIO as UIO data CustomException = CustomException deriving (Show, Typeable) instance Ex.Exception CustomException class TestClass a where testClassMethod :: a -> () data CantTestClass = CantTestClass instance TestClass CantTestClass data BadRecord = BadRecord { badfld :: String } | OtherBadRecord { otherfld :: String } fromIOCatches :: IO () -> Assertion fromIOCatches io = do caught <- UIO.run $ UIO.fromIO io either (const $ return ()) (\x -> assertFailure $ "fromIO did not catch: " ++ show x) caught fromIOPasses :: IO () -> Assertion fromIOPasses io = do caught <- Ex.try $ UIO.run $ UIO.fromIO io either (\(Ex.SomeException _) -> return ()) (\x -> assertFailure $ "fromIO caught: " ++ show x) caught #if MIN_VERSION_base(4,7,0) threadReturns :: UIO.UIO () -> (Either Ex.SomeException () -> Assertion) -> Assertion threadReturns spawn assertion = do mvar <- Concurrent.newEmptyMVar void $ Concurrent.forkFinally (UIO.run spawn >> Concurrent.yield) (Concurrent.putMVar mvar) result <- Concurrent.takeMVar mvar assertion result assertRightUnit :: (Show e) => Either e () -> Assertion assertRightUnit (Left e) = assertFailure $ "Expected Right () got Left " ++ show e assertRightUnit (Right ()) = return () assertLeft :: (e -> Assertion) -> Either e () -> Assertion assertLeft _ (Right ()) = assertFailure "Expected Left ... got Right ()" assertLeft assertion (Left e) = assertion e assertChildThreadError :: Ex.SomeException -> Assertion assertChildThreadError e = case Ex.fromException e of Just (UIO.ChildThreadError _) -> return () Nothing -> assertFailure $ "Expected ChildThreadError got " ++ show e #endif tests :: [Test] tests = [ #if MIN_VERSION_base(4,7,0) testGroup "fork" [ testCase "ignores success" (threadReturns (void $ UIO.fork $ return ()) assertRightUnit ), testCase "ignores threadKilled" (threadReturns (UIO.fork (forever $ UIO.unsafeFromIO Concurrent.yield) >>= UIO.unsafeFromIO . Concurrent.killThread) assertRightUnit ), testCase "re-throws SomeAsyncException" (threadReturns (void $ UIO.fork (UIO.unsafeFromIO $ Ex.throwIO Ex.UserInterrupt)) (assertLeft ((@?= Just Ex.UserInterrupt) . Ex.fromException)) ), testCase "re-throws ExitCode" (threadReturns (void $ UIO.fork (UIO.unsafeFromIO exitSuccess)) (assertLeft ((@?= Just ExitSuccess) . Ex.fromException)) ), testCase "wraps sync PseudoException in ChildThreadError" (threadReturns (void $ UIO.fork (error "blah")) (assertLeft assertChildThreadError) ) ], #endif testGroup "fromIO catches runtime errors" [ testCase "fail" (fromIOCatches $ fail "boo"), testCase "userError" (fromIOCatches $ Ex.throwIO $ userError "boo"), testCase "CustomException" (fromIOCatches $ Ex.throwIO CustomException) ], testGroup "fromIO passes through programmer errors" [ #if MIN_VERSION_base(4,9,0) testCase "TypeError" (fromIOPasses $ Ex.throwIO $ Ex.TypeError "boo"), #endif testCase "error" (fromIOPasses $ error "boo"), testCase "undefined" (fromIOPasses undefined), testCase "ArithException" (fromIOPasses $ void (return $! (1::Int) `div` 0)), testCase "assert" (fromIOPasses $ Ex.assert False (return ())), testCase "pattern match fail" (fromIOPasses $ (\(Just _) -> return ()) Nothing), testCase "array out of bounds" (fromIOPasses $ Ex.throwIO $ Ex.IndexOutOfBounds "boo"), testCase "array uninitialized" (fromIOPasses $ Ex.throwIO $ Ex.UndefinedElement "boo"), testCase "no method" (fromIOPasses $ print $ testClassMethod CantTestClass), testCase "use uninitialized record field" (fromIOPasses $ print $ badfld BadRecord {}), testCase "use not present record field" (fromIOPasses $ print $ otherfld BadRecord {}), testCase "update not present record field" (fromIOPasses $ void (return $! (BadRecord {} { otherfld = "hai" }))) ], testGroup "fromIO passes through termination" [ #if MIN_VERSION_base(4,8,0) testCase "die" (fromIOPasses $ die "exit time"), #endif testCase "exitSuccess" (fromIOPasses exitSuccess), testCase "exitFailure" (fromIOPasses exitFailure) ], testGroup "fromIO passes through exceptions from the runtime" [ #if MIN_VERSION_base(4,8,0) testCase "AllocationLimitExceeded" (fromIOPasses $ Ex.throwIO Ex.AllocationLimitExceeded), #endif #if MIN_VERSION_base(4,7,0) testCase "ChildThreadError" (fromIOPasses $ Ex.throwIO $ UIO.ChildThreadError $ UIO.ProgrammerError $ UIO.ArithException Ex.DivideByZero), #endif testCase "NonTermination" (fromIOPasses $ Ex.throwIO Ex.NonTermination), testCase "StackOverflow" (fromIOPasses $ Ex.throwIO Ex.StackOverflow), testCase "HeapOverflow" (fromIOPasses $ Ex.throwIO Ex.HeapOverflow), testCase "ThreadKilled" (fromIOPasses $ Ex.throwIO Ex.ThreadKilled), testCase "UserInterrupt" (fromIOPasses $ Ex.throwIO Ex.UserInterrupt), testCase "BlockedIndefinitelyOnMVar" (fromIOPasses $ Ex.throwIO Ex.BlockedIndefinitelyOnMVar), testCase "BlockedIndefinitelyOnSTM" (fromIOPasses $ Ex.throwIO Ex.BlockedIndefinitelyOnSTM), testCase "Deadlock" (fromIOPasses $ Ex.throwIO Ex.Deadlock), testCase "NestedAtomically" (fromIOPasses $ Ex.throwIO Ex.NestedAtomically) ] ] main :: IO () main = defaultMain tests