unexceptionalio 0.1.0 → 0.5.1
raw patch · 4 files changed
Files
- COPYING +1/−1
- UnexceptionalIO.hs +281/−37
- tests/suite.hs +138/−0
- unexceptionalio.cabal +28/−5
COPYING view
@@ -1,4 +1,4 @@-Copyright © 2011, Stephen Paul Weber <singpolyma.net>+Copyright © 2013-2018, Stephen Paul Weber <singpolyma.net> Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above
UnexceptionalIO.hs view
@@ -1,65 +1,309 @@+{-# 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 (- UnexceptionalIO,+ UIO,+ Unexceptional(..), fromIO,- runUnexceptionalIO,+#ifdef __GLASGOW_HASKELL__+ fromIO',+#endif+ run, runEitherIO, -- * Unsafe entry points- fromIO',- unsafeFromIO+ 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 Control.Applicative (Applicative(..))+import Data.Maybe (fromMaybe)+import Control.Applicative (Applicative(..), (<|>), (<$>)) import Control.Monad (liftM, ap, (<=<)) import Control.Monad.Fix (MonadFix(..))-import Control.Error (syncIO, mapEitherT, EitherT(..), fmapLT)-import Control.Exception (SomeException, Exception, fromException, throwIO)-import Control.Monad.IO.Class (liftIO, MonadIO)+#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 --- | IO without any non-error, synchronous exceptions-newtype UnexceptionalIO a = UnexceptionalIO (IO a)+-- | 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 Functor UnexceptionalIO where+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 UnexceptionalIO where+instance Applicative UIO where pure = return (<*>) = ap -instance Monad UnexceptionalIO where- return = UnexceptionalIO . return- (UnexceptionalIO x) >>= f = UnexceptionalIO (x >>= runUnexceptionalIO . f)-+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 UnexceptionalIO where- mfix f = UnexceptionalIO (mfix $ runUnexceptionalIO . f)+instance MonadFix UIO where+ mfix f = UIO (mfix $ run . f) --- | Catch any non-error, synchronous exceptions in an 'IO' action-fromIO :: IO a -> EitherT SomeException UnexceptionalIO a-fromIO = mapEitherT unsafeFromIO . syncIO+-- | Monads in which 'UIO' computations may be embedded+class (Monad m) => Unexceptional m where+ lift :: UIO a -> m a --- | Re-embed 'UnexceptionalIO' into 'IO'-runUnexceptionalIO :: (MonadIO m) => UnexceptionalIO a -> m a-runUnexceptionalIO (UnexceptionalIO io) = liftIO io+instance Unexceptional UIO where+ lift = id --- | Re-embed 'UnexceptionalIO' and possible exception back into 'IO'-runEitherIO :: (MonadIO m, Exception e) => EitherT e UnexceptionalIO a -> m a-runEitherIO = either (liftIO . throwIO) return <=< runUnexceptionalIO . runEitherT+instance Unexceptional IO where+ lift = run --- | You promise that 'e' covers all non-error, synchronous exceptions--- thrown by this 'IO' action+-- | 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 ----- This function is partial if you lie-fromIO' :: (Exception e) => IO a -> EitherT e UnexceptionalIO a-fromIO' = fmapLT (maybePartial . fromException) . fromIO+-- * 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- maybePartial (Just x) = x- maybePartial Nothing = error "UnexceptionalIO.fromIO' exception of unspecified type"+ 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) --- | You promise there are no exceptions thrown by this 'IO' action-unsafeFromIO :: IO a -> UnexceptionalIO a-unsafeFromIO = UnexceptionalIO+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
+ tests/suite.hs view
@@ -0,0 +1,138 @@+{-# 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
unexceptionalio.cabal view
@@ -1,9 +1,9 @@ name: unexceptionalio-version: 0.1.0-cabal-version: >=1.8+version: 0.5.1+cabal-version: >=1.10 license: OtherLicense license-file: COPYING-copyright: © 2013 Stephen Paul Weber+copyright: © 2013-2018 Stephen Paul Weber category: Control author: Stephen Paul Weber <singpolyma@singpolyma.net> maintainer: Stephen Paul Weber <singpolyma@singpolyma.net>@@ -15,15 +15,38 @@ 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.*,- errors >= 1.4.2,- transformers+ HUnit,+ test-framework,+ test-framework-hunit source-repository head type: git