exceptions 0.3.2 → 0.3.3

raw patch · 2 files changed

+95/−2 lines, 2 filesdep ~QuickCheck

Dependency ranges changed: QuickCheck

Files

• exceptions.cabal +3/−2
• tests/Control/Monad/Catch/Tests.hs +92/−0

@@ -1,6 +1,6 @@ name:          exceptions category:      Control, Exceptions, Monad-version:       0.3.2+version:       0.3.3 cabal-version: >= 1.8 license:       OtherLicense license-file:  LICENSE@@ -46,6 +46,7 @@  test-suite exceptions-tests   main-is: Tests.hs+  other-modules: Control.Monad.Catch.Tests   hs-source-dirs: src, tests   ghc-options: -Wall -fwarn-tabs   type: exitcode-stdio-1.0@@ -56,4 +57,4 @@      test-framework             >= 0.8      && < 0.9,     test-framework-quickcheck2 >= 0.3      && < 0.4,-    QuickCheck                 >= 2.5      && < 2.6+    QuickCheck                 >= 2.5      && < 2.7

@@ -0,0 +1,92 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE CPP #-}++module Control.Monad.Catch.Tests (tests) where++#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706)+import Prelude hiding (catch)+#endif++import Control.Applicative ((<*>))+import Data.Data (Data, Typeable)++import Control.Monad.Trans.Identity (IdentityT(..))+import Control.Monad.Reader (ReaderT(..))+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Property, once)+import Test.QuickCheck.Monadic (monadic, run, assert)+import Test.QuickCheck.Property (morallyDubiousIOProperty)+import qualified Control.Monad.State.Lazy as LazyState+import qualified Control.Monad.State.Strict as StrictState+import qualified Control.Monad.Writer.Lazy as LazyWriter+import qualified Control.Monad.Writer.Strict as StrictWriter+import qualified Control.Monad.RWS.Lazy as LazyRWS+import qualified Control.Monad.RWS.Strict as StrictRWS++import Control.Monad.Catch+import Control.Monad.Catch.Pure++data TestException = TestException String+    deriving (Show, Eq, Data, Typeable)++instance Exception TestException++data MSpec = forall m. (MonadCatch m) => MSpec+    { mspecName :: String+    , mspecRunner :: (m Property -> Property)+    }++testMonadCatch :: MSpec -> Property+testMonadCatch MSpec { mspecRunner } = monadic mspecRunner $+    run $ catch failure handler+  where+    failure = throwM (TestException "foo") >> error "testMonadCatch"+    handler (_ :: TestException) = return ()++testCatchJust :: MSpec -> Property+testCatchJust MSpec { mspecRunner } = monadic mspecRunner $ do+    nice <- run $ catchJust testException posFailure posHandler+    assert $ nice == ("pos", True)+    bad <- run $ catch (catchJust testException negFailure posHandler) negHandler+    assert $ bad == ("neg", True)+  where+    testException (TestException s) = if s == "pos" then Just True else Nothing+    posHandler x = return ("pos", x)+    negHandler (_ :: TestException) = return ("neg", True)+    posFailure = throwM (TestException "pos") >> error "testCatchJust pos"+    negFailure = throwM (TestException "neg") >> error "testCatchJust neg"++tests :: Test+tests = testGroup "Control.Monad.Catch.Tests" $+    [ mkMonadCatch+    , mkCatchJust+    ] <*> mspecs+  where+    mspecs =+        [ MSpec "IO" io+        , MSpec "IdentityT IO" $ io . runIdentityT+        , MSpec "LazyState.StateT IO" $ io . flip LazyState.evalStateT ()+        , MSpec "StrictState.StateT IO" $ io . flip StrictState.evalStateT ()+        , MSpec "ReaderT IO" $ io . flip runReaderT ()+        , MSpec "LazyWriter.WriterT IO" $ io . fmap tfst . LazyWriter.runWriterT+        , MSpec "StrictWriter.WriterT IO" $ io . fmap tfst . StrictWriter.runWriterT+        , MSpec "LazyRWS.RWST IO" $ \m -> io $ fmap tfst $ LazyRWS.evalRWST m () ()+        , MSpec "StrictRWS.RWST IO" $ \m -> io $ fmap tfst $ StrictRWS.evalRWST m () ()++        , MSpec "CatchT Indentity" $ fromRight . runCatch+        ]++    tfst :: (Property, ()) -> Property = fst+    fromRight (Left _) = error "fromRight"+    fromRight (Right a) = a+    io = morallyDubiousIOProperty++    mkMonadCatch = mkTestType "MonadCatch" testMonadCatch+    mkCatchJust = mkTestType "catchJust" testCatchJust++    mkTestType name test = \spec ->+        testProperty (name ++ " " ++ mspecName spec) $ once $ test spec