lifted-base 0.1.0.4 → 0.1.1

raw patch · 12 files changed

+628/−180 lines, 12 filesdep +criteriondep +lifted-basedep +monad-peeldep ~test-frameworkPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, lifted-base, monad-peel

Dependency ranges changed: test-framework

API changes (from Hackage documentation)

Files

• Control/Concurrent/Chan/Lifted.hs +85/−0
• Control/Concurrent/Lifted.hs +14/−6
• Control/Concurrent/MVar/Lifted.hs +6/−2
• Control/Concurrent/QSem/Lifted.hs +65/−0
• Control/Concurrent/QSemN/Lifted.hs +65/−0
• Control/Concurrent/SampleVar/Lifted.hs +83/−0
• Control/Exception/Lifted.hs +6/−2
• System/Timeout/Lifted.hs +4/−0
• bench/bench.hs +113/−0
• lifted-base.cabal +25/−9
• test.hs +0/−161
• test/test.hs +162/−0

@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++{- |+Module      :  Control.Concurrent.Chan.Lifted+Copyright   :  Liyang HU, Bas van Dijk+License     :  BSD-style++Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com>+Stability   :  experimental++This is a wrapped version of "Control.Concurrent.Chan" with types+generalised from 'IO' to all monads in 'MonadBase'.++'Chan.unGetChan' and 'Chan.isEmptyChan' are deprecated in @base@, therefore+they are not included here. Use 'Control.Concurrent.STM.TVar' instead.+-}++module Control.Concurrent.Chan.Lifted+    ( Chan+    , newChan+    , writeChan+    , readChan+    , dupChan+    , getChanContents+    , writeList2Chan+    ) where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+import Control.Concurrent.Chan ( Chan )+import qualified Control.Concurrent.Chan as Chan+import System.IO ( IO )++-- from base-unicode-symbols:+import Data.Function.Unicode ( (∘) )++-- from transformers-base:+import Control.Monad.Base ( MonadBase, liftBase )++#include "inlinable.h"++--------------------------------------------------------------------------------+-- * Chans+--------------------------------------------------------------------------------++-- | Generalized version of 'Chan.newChan'.+newChan ∷ MonadBase IO m ⇒ m (Chan a)+newChan = liftBase Chan.newChan+{-# INLINABLE newChan #-}++-- | Generalized version of 'Chan.writeChan'.+writeChan ∷ MonadBase IO m ⇒ Chan a → a → m ()+writeChan chan = liftBase ∘ Chan.writeChan chan+{-# INLINABLE writeChan #-}++-- | Generalized version of 'Chan.readChan'.+readChan ∷ MonadBase IO m ⇒ Chan a → m a+readChan = liftBase ∘ Chan.readChan+{-# INLINABLE readChan #-}++-- | Generalized version of 'Chan.dupChan'.+dupChan ∷ MonadBase IO m ⇒ Chan a → m (Chan a)+dupChan = liftBase ∘ Chan.dupChan+{-# INLINABLE dupChan #-}++-- | Generalized version of 'Chan.getChanContents'.+getChanContents ∷ MonadBase IO m ⇒ Chan a → m [a]+getChanContents = liftBase ∘ Chan.getChanContents+{-# INLINABLE getChanContents #-}++-- | Generalized version of 'Chan.writeList2Chan'.+writeList2Chan ∷ MonadBase IO m ⇒ Chan a → [a] → m ()+writeList2Chan chan = liftBase ∘ Chan.writeList2Chan chan+{-# INLINABLE writeList2Chan #-}+

@@ -1,5 +1,9 @@ {-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, FlexibleContexts, RankNTypes #-} +#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+ {- | Module      :  Control.Concurrent.Lifted Copyright   :  Bas van Dijk@@ -8,8 +12,8 @@ Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com> Stability   :  experimental -This is a wrapped version of 'Control.Concurrent' with types generalized-from @IO@ to all monads in either 'MonadBase' or 'MonadBaseControl'.+This is a wrapped version of "Control.Concurrent" with types generalized+from 'IO' to all monads in either 'MonadBase' or 'MonadBaseControl'. -}  module Control.Concurrent.Lifted@@ -44,10 +48,10 @@        -- * Communication abstractions     , module Control.Concurrent.MVar.Lifted-    -- TODO: , module Control.Concurrent.Chan.Lifted-    -- TODO: , module Control.Concurrent.QSem.Lifted-    -- TODO: , module Control.Concurrent.QSemN.Lifted-    -- TODO: , module Control.Concurrent.SampleVar.Lifted+    , module Control.Concurrent.Chan.Lifted+    , module Control.Concurrent.QSem.Lifted+    , module Control.Concurrent.QSemN.Lifted+    , module Control.Concurrent.SampleVar.Lifted        -- * Merging of streams     , merge@@ -92,6 +96,10 @@  -- from lifted-base (this package): import Control.Concurrent.MVar.Lifted+import Control.Concurrent.Chan.Lifted+import Control.Concurrent.QSem.Lifted+import Control.Concurrent.QSemN.Lifted+import Control.Concurrent.SampleVar.Lifted  #include "inlinable.h" 

@@ -5,6 +5,10 @@            , TupleSections   #-} +#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+ {- | Module      :  Control.Concurrent.MVar.Lifted Copyright   :  Bas van Dijk@@ -13,8 +17,8 @@ Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com> Stability   :  experimental -This is a wrapped version of 'Control.Concurrent.MVar' with types generalized-from @IO@ to all monads in either 'MonadBase' or 'MonadBaseControl'.+This is a wrapped version of "Control.Concurrent.MVar" with types generalized+from 'IO' to all monads in either 'MonadBase' or 'MonadBaseControl'. -}  module Control.Concurrent.MVar.Lifted

@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++{- |+Module      :  Control.Concurrent.QSem.Lifted+Copyright   :  Liyang HU, Bas van Dijk+License     :  BSD-style++Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com>+Stability   :  experimental++This is a wrapped version of "Control.Concurrent.QSem" with types+generalised from 'IO' to all monads in 'MonadBase'.+-}++module Control.Concurrent.QSem.Lifted+    ( QSem+    , newQSem+    , waitQSem+    , signalQSem+    ) where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+import Control.Concurrent.QSem ( QSem )+import qualified Control.Concurrent.QSem as QSem+import Data.Int ( Int )+import System.IO ( IO )++-- from base-unicode-symbols:+import Data.Function.Unicode ( (∘) )++-- from transformers-base:+import Control.Monad.Base ( MonadBase, liftBase )++#include "inlinable.h"++--------------------------------------------------------------------------------+-- * QSems+--------------------------------------------------------------------------------++-- | Generalized version of 'QSem.newQSem'.+newQSem ∷ MonadBase IO m ⇒ Int → m QSem+newQSem = liftBase ∘ QSem.newQSem+{-# INLINABLE newQSem #-}++-- | Generalized version of 'QSem.waitQSem'.+waitQSem ∷ MonadBase IO m ⇒ QSem → m ()+waitQSem = liftBase ∘ QSem.waitQSem+{-# INLINABLE waitQSem #-}++-- | Generalized version of 'QSem.signalQSem'.+signalQSem ∷ MonadBase IO m ⇒ QSem → m ()+signalQSem = liftBase ∘ QSem.signalQSem+{-# INLINABLE signalQSem #-}+

@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++{- |+Module      :  Control.Concurrent.QSemN.Lifted+Copyright   :  Liyang HU, Bas van Dijk+License     :  BSD-style++Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com>+Stability   :  experimental++This is a wrapped version of "Control.Concurrent.QSemN" with types+generalised from 'IO' to all monads in 'MonadBase'.+-}++module Control.Concurrent.QSemN.Lifted+    ( QSemN+    , newQSemN+    , waitQSemN+    , signalQSemN+    ) where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+import Control.Concurrent.QSemN ( QSemN )+import qualified Control.Concurrent.QSemN as QSemN+import Data.Int ( Int )+import System.IO ( IO )++-- from base-unicode-symbols:+import Data.Function.Unicode ( (∘) )++-- from transformers-base:+import Control.Monad.Base ( MonadBase, liftBase )++#include "inlinable.h"++--------------------------------------------------------------------------------+-- * QSemNs+--------------------------------------------------------------------------------++-- | Generalized version of 'QSemN.newQSemN'.+newQSemN ∷ MonadBase IO m ⇒ Int → m QSemN+newQSemN = liftBase ∘ QSemN.newQSemN+{-# INLINABLE newQSemN #-}++-- | Generalized version of 'QSemN.waitQSemN'.+waitQSemN ∷ MonadBase IO m ⇒ QSemN → Int → m ()+waitQSemN sem = liftBase ∘ QSemN.waitQSemN sem+{-# INLINABLE waitQSemN #-}++-- | Generalized version of 'QSemN.signalQSemN'.+signalQSemN ∷ MonadBase IO m ⇒ QSemN → Int → m ()+signalQSemN sem = liftBase ∘ QSemN.signalQSemN sem+{-# INLINABLE signalQSemN #-}+

@@ -0,0 +1,83 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}++#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++{- |+Module      :  Control.Concurrent.SampleVar.Lifted+Copyright   :  Liyang HU, Bas van Dijk+License     :  BSD-style++Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com>+Stability   :  experimental++This is a wrapped version of "Control.Concurrent.SampleVar" with types+generalised from 'IO' to all monads in 'MonadBase'.+-}++module Control.Concurrent.SampleVar.Lifted+    ( SampleVar+    , newEmptySampleVar+    , newSampleVar+    , emptySampleVar+    , readSampleVar+    , writeSampleVar+    , isEmptySampleVar+    ) where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+import Control.Concurrent.SampleVar ( SampleVar )+import qualified Control.Concurrent.SampleVar as SampleVar+import Data.Bool ( Bool )+import System.IO ( IO )++-- from base-unicode-symbols:+import Data.Function.Unicode ( (∘) )++-- from transformers-base:+import Control.Monad.Base ( MonadBase, liftBase )++#include "inlinable.h"++--------------------------------------------------------------------------------+-- * SampleVars+--------------------------------------------------------------------------------++-- | Generalized version of 'SampleVar.newEmptySampleVar'.+newEmptySampleVar ∷ MonadBase IO m ⇒ m (SampleVar a)+newEmptySampleVar = liftBase SampleVar.newEmptySampleVar+{-# INLINABLE newEmptySampleVar #-}++-- | Generalized version of 'SampleVar.newSampleVar'.+newSampleVar ∷ MonadBase IO m ⇒ a → m (SampleVar a)+newSampleVar = liftBase ∘ SampleVar.newSampleVar+{-# INLINABLE newSampleVar #-}++-- | Generalized version of 'SampleVar.emptySampleVar'.+emptySampleVar ∷ MonadBase IO m ⇒ SampleVar a → m ()+emptySampleVar = liftBase ∘ SampleVar.emptySampleVar+{-# INLINABLE emptySampleVar #-}++-- | Generalized version of 'SampleVar.readSampleVar'.+readSampleVar ∷ MonadBase IO m ⇒ SampleVar a → m a+readSampleVar = liftBase ∘ SampleVar.readSampleVar+{-# INLINABLE readSampleVar #-}++-- | Generalized version of 'SampleVar.writeSampleVar'.+writeSampleVar ∷ MonadBase IO m ⇒ SampleVar a → a → m ()+writeSampleVar sv = liftBase ∘ SampleVar.writeSampleVar sv+{-# INLINABLE writeSampleVar #-}++-- | Generalized version of 'SampleVar.isEmptySampleVar'.+isEmptySampleVar ∷ MonadBase IO m ⇒ SampleVar a → m Bool+isEmptySampleVar = liftBase ∘ SampleVar.isEmptySampleVar+{-# INLINABLE isEmptySampleVar #-}+

@@ -9,6 +9,10 @@ {-# LANGUAGE RankNTypes #-} -- for mask #endif +#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+ {- | Module      :  Control.Exception.Lifted Copyright   :  Bas van Dijk, Anders Kaseorg@@ -18,8 +22,8 @@ Stability   :  experimental Portability :  non-portable (extended exceptions) -This is a wrapped version of @Control.Exception@ with types generalized-from @IO@ to all monads in either 'MonadBase' or 'MonadBaseControl'.+This is a wrapped version of "Control.Exception" with types generalized+from 'IO' to all monads in either 'MonadBase' or 'MonadBaseControl'. -}  module Control.Exception.Lifted

@@ -1,5 +1,9 @@ {-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, FlexibleContexts #-} +#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+ ------------------------------------------------------------------------------- -- | -- Module      :  System.Timeout.Lifted

@@ -0,0 +1,113 @@+{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}++module Main where+++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+import Prelude hiding (catch)+import Control.Exception ( Exception, SomeException, throwIO )+import qualified Control.Exception as E ( mask, bracket, bracket_ )+import Data.Typeable+import Control.Monad (join)++-- from criterion:+import Criterion.Main++-- from transformers:+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import Control.Monad.Trans.Writer++-- from monad-peel:+import qualified Control.Exception.Peel as MP+import qualified Control.Monad.IO.Peel  as MP++-- from monad-control:+import qualified Control.Monad.Trans.Control as MC++-- from lifted-base:+import qualified Control.Exception.Lifted as MC+++--------------------------------------------------------------------------------+-- Main+--------------------------------------------------------------------------------++main :: IO ()+main = defaultMain+  [ b "bracket"   benchBracket  MP.bracket   MC.bracket+  , b "bracket_"  benchBracket_ MP.bracket_  MC.bracket_+  , b "catch"     benchCatch    MP.catch     MC.catch+  , b "try"       benchTry      MP.try       MC.try+  , b "mask"      benchMask     mpMask       MC.mask++  , bgroup "liftIOOp"+    [ bench "monad-peel"    $ exe $ MP.liftIOOp   (E.bracket nop (\_ -> nop))+                                                  (\_ -> nop)+    , bench "monad-control" $ exe $ MC.liftBaseOp (E.bracket nop (\_ -> nop))+                                                  (\_ -> nop)+    ]++  , bgroup "liftIOOp_"+    [ bench "monad-peel"    $ exe $ MP.liftIOOp_   (E.bracket_ nop nop) nop+    , bench "monad-control" $ exe $ MC.liftBaseOp_ (E.bracket_ nop nop) nop+    ]+  ]++b name bnch peel mndCtrl = bgroup name+  [ bench "monad-peel"    $ bnch peel+  , bench "monad-control" $ bnch mndCtrl+  ]++--------------------------------------------------------------------------------+-- Monad stack+--------------------------------------------------------------------------------++type M a = ReaderT Int (StateT Bool (WriterT String (MaybeT IO))) a++type R a = IO (Maybe ((a, Bool), String))++runM :: Int -> Bool -> M a -> R a+runM r s m = runMaybeT (runWriterT (runStateT (runReaderT m r) s))++exe :: M a -> R a+exe = runM 0 False+++--------------------------------------------------------------------------------+-- Benchmarks+--------------------------------------------------------------------------------++benchBracket   bracket   = exe $              bracket  nop (\_ -> nop)  (\_ -> nop)+benchBracket_  bracket_  = exe $              bracket_ nop nop          nop+benchCatch     catch     = exe $ catch throwE (\E -> nop)+benchTry       try       = exe $ try throwE :: R (Either E ())++benchMask :: (((forall a. M a -> M a) -> M ()) -> M ()) -> R ()+benchMask mask = exe $ mask $ \restore -> nop >> restore nop >> nop+++--------------------------------------------------------------------------------+-- Utils+--------------------------------------------------------------------------------++nop :: Monad m => m ()+nop = return ()++data E = E deriving (Show, Typeable)++instance Exception E++throwE :: MonadIO m => m ()+throwE = liftIO $ throwIO E++mpMask :: MP.MonadPeelIO m => ((forall a. m a -> m a) -> m b) -> m b+mpMask f = do+  k <- MP.peelIO+  join $ liftIO $ E.mask $ \restore -> k $ f $ MP.liftIOOp_ restore

@@ -1,5 +1,5 @@ Name:                lifted-base-Version:             0.1.0.4+Version:             0.1.1 Synopsis:            lifted IO operations from the base library License:             BSD3 License-file:        LICENSE@@ -23,9 +23,6 @@  extra-source-files:  README.markdown, NEWS --- TODO: Remove when http://hackage.haskell.org/trac/hackage/ticket/792 is fixed:-extra-source-files:  test.hs- extra-source-files: include/inlinable.h  --------------------------------------------------------------------------------@@ -39,6 +36,10 @@ Library   Exposed-modules: Control.Exception.Lifted                    Control.Concurrent.MVar.Lifted+                   Control.Concurrent.Chan.Lifted+                   Control.Concurrent.QSem.Lifted+                   Control.Concurrent.QSemN.Lifted+                   Control.Concurrent.SampleVar.Lifted                    Control.Concurrent.Lifted                    System.Timeout.Lifted @@ -55,16 +56,17 @@ --------------------------------------------------------------------------------  test-suite test-lifted-base-  type:    exitcode-stdio-1.0-  main-is: test.hs+  type:           exitcode-stdio-1.0+  main-is:        test.hs+  hs-source-dirs: test -  build-depends: base                 >= 3     && < 4.6-               , base-unicode-symbols >= 0.1.1 && < 0.3+  build-depends: lifted-base+               , base                 >= 3     && < 4.6                , transformers         >= 0.2   && < 0.4                , transformers-base    >= 0.4   && < 0.5                , monad-control        >= 0.3   && < 0.4                , HUnit                >= 1.2.2 && < 1.3-               , test-framework       >= 0.2.4 && < 0.5+               , test-framework       >= 0.2.4 && < 0.7                , test-framework-hunit >= 0.2.4 && < 0.3    Include-dirs: include@@ -73,3 +75,17 @@   ghc-options: -Wall  --------------------------------------------------------------------------------++benchmark bench-lifted-base+  type:           exitcode-stdio-1.0+  main-is:        bench.hs+  hs-source-dirs: bench++  ghc-options:    -O2++  build-depends: lifted-base+               , base          >= 3   && < 4.6+               , transformers  >= 0.2 && < 0.4+               , criterion     >= 0.5 && < 0.7+               , monad-control >= 0.3 && < 0.4+               , monad-peel    >= 0.1 && < 0.2

@@ -1,161 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}---- from base:-import Prelude hiding (catch)-import Data.IORef-import Data.Maybe-import Data.Typeable (Typeable)---- from transformers-base:-import Control.Monad.Base (liftBase)--import Control.Monad.Trans.Identity-import Control.Monad.Trans.List-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer-import Control.Monad.Trans.Error-import Control.Monad.Trans.State-import qualified Control.Monad.Trans.RWS as RWS---- from monad-control:-import Control.Monad.Trans.Control (MonadBaseControl)---- from lifted-base (this package):-import Control.Exception.Lifted---- from test-framework:-import Test.Framework (defaultMain, testGroup, Test)-- -- from test-framework-hunit:-import Test.Framework.Providers.HUnit---- from hunit:-import Test.HUnit hiding (Test)---main :: IO ()-main = defaultMain-    [ testSuite "IdentityT" runIdentityT-    , testSuite "ListT" $ fmap head . runListT-    , testSuite "MaybeT" $ fmap fromJust . runMaybeT-    , testSuite "ReaderT" $ flip runReaderT "reader state"-    , testSuite "WriterT" runWriterT'-    , testSuite "ErrorT" runErrorT'-    , testSuite "StateT" $ flip evalStateT "state state"-    , testSuite "RWST" $ \m -> runRWST' m "RWS in" "RWS state"-    , testCase "ErrorT throwError" case_throwError-    , testCase "WriterT tell" case_tell-    ]-  where-    runWriterT' :: Functor m => WriterT [Int] m a -> m a-    runWriterT' = fmap fst . runWriterT-    runErrorT' :: Functor m => ErrorT String m () -> m ()-    runErrorT' = fmap (either (const ()) id) . runErrorT-    runRWST' :: (Monad m, Functor m) => RWS.RWST r [Int] s m a -> r -> s -> m a-    runRWST' m r s = fmap fst $ RWS.evalRWST m r s--testSuite :: MonadBaseControl IO m => String -> (m () -> IO ()) -> Test-testSuite s run = testGroup s-    [ testCase "finally" $ case_finally run-    , testCase "catch" $ case_catch run-    , testCase "bracket" $ case_bracket run-    , testCase "bracket_" $ case_bracket_ run-    , testCase "onException" $ case_onException run-    ]--ignore :: IO () -> IO ()-ignore x =-    catch x go-  where-    go :: SomeException -> IO ()-    go _ = return ()--data Exc = Exc-    deriving (Show, Typeable)-instance Exception Exc--one :: Int-one = 1--case_finally :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion-case_finally run = do-    i <- newIORef one-    ignore-        (run $ (do-            liftBase $ writeIORef i 2-            error "error") `finally` (liftBase $ writeIORef i 3))-    j <- readIORef i-    j @?= 3--case_catch :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion-case_catch run = do-    i <- newIORef one-    run $ (do-        liftBase $ writeIORef i 2-        throw Exc) `catch` (\Exc -> liftBase $ writeIORef i 3)-    j <- readIORef i-    j @?= 3--case_bracket :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion-case_bracket run = do-    i <- newIORef one-    ignore $ run $ bracket-        (liftBase $ writeIORef i 2)-        (\() -> liftBase $ writeIORef i 4)-        (\() -> liftBase $ writeIORef i 3)-    j <- readIORef i-    j @?= 4--case_bracket_ :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion-case_bracket_ run = do-    i <- newIORef one-    ignore $ run $ bracket_-        (liftBase $ writeIORef i 2)-        (liftBase $ writeIORef i 4)-        (liftBase $ writeIORef i 3)-    j <- readIORef i-    j @?= 4--case_onException :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion-case_onException run = do-    i <- newIORef one-    ignore $ run $ onException-        (liftBase (writeIORef i 2) >> error "ignored")-        (liftBase $ writeIORef i 3)-    j <- readIORef i-    j @?= 3-    ignore $ run $ onException-        (liftBase $ writeIORef i 4)-        (liftBase $ writeIORef i 5)-    k <- readIORef i-    k @?= 4--case_throwError :: Assertion-case_throwError = do-    i <- newIORef one-    Left "throwError" <- runErrorT $-        (liftBase (writeIORef i 2) >> throwError "throwError")-        `finally`-        (liftBase $ writeIORef i 3)-    j <- readIORef i-    j @?= 3--case_tell :: Assertion-case_tell = do-    i <- newIORef one-    ((), w) <- runWriterT $ bracket_-        (liftBase (writeIORef i 2) >> tell [1 :: Int])-        (liftBase (writeIORef i 4) >> tell [3])-        (liftBase (writeIORef i 3) >> tell [2])-    j <- readIORef i-    j @?= 4-    w @?= [2]--    ((), w') <- runWriterT $ bracket-        (liftBase (writeIORef i 5) >> tell [5 :: Int])-        (const $ liftBase (writeIORef i 7) >> tell [7])-        (const $ liftBase (writeIORef i 6) >> tell [6])-    j' <- readIORef i-    j' @?= 7-    w' @?= [5, 6]

@@ -0,0 +1,162 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}++-- from base:+import Prelude hiding (catch)+import Data.IORef+import Data.Maybe+import Data.Typeable (Typeable)++-- from transformers-base:+import Control.Monad.Base (liftBase)++-- from transformers:+import Control.Monad.Trans.Identity+import Control.Monad.Trans.List+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer+import Control.Monad.Trans.Error+import Control.Monad.Trans.State+import qualified Control.Monad.Trans.RWS as RWS++-- from monad-control:+import Control.Monad.Trans.Control (MonadBaseControl)++-- from lifted-base (this package):+import Control.Exception.Lifted++-- from test-framework:+import Test.Framework (defaultMain, testGroup, Test)++ -- from test-framework-hunit:+import Test.Framework.Providers.HUnit++-- from hunit:+import Test.HUnit hiding (Test)+++main :: IO ()+main = defaultMain+    [ testSuite "IdentityT" runIdentityT+    , testSuite "ListT" $ fmap head . runListT+    , testSuite "MaybeT" $ fmap fromJust . runMaybeT+    , testSuite "ReaderT" $ flip runReaderT "reader state"+    , testSuite "WriterT" runWriterT'+    , testSuite "ErrorT" runErrorT'+    , testSuite "StateT" $ flip evalStateT "state state"+    , testSuite "RWST" $ \m -> runRWST' m "RWS in" "RWS state"+    , testCase "ErrorT throwError" case_throwError+    , testCase "WriterT tell" case_tell+    ]+  where+    runWriterT' :: Functor m => WriterT [Int] m a -> m a+    runWriterT' = fmap fst . runWriterT+    runErrorT' :: Functor m => ErrorT String m () -> m ()+    runErrorT' = fmap (either (const ()) id) . runErrorT+    runRWST' :: (Monad m, Functor m) => RWS.RWST r [Int] s m a -> r -> s -> m a+    runRWST' m r s = fmap fst $ RWS.evalRWST m r s++testSuite :: MonadBaseControl IO m => String -> (m () -> IO ()) -> Test+testSuite s run = testGroup s+    [ testCase "finally" $ case_finally run+    , testCase "catch" $ case_catch run+    , testCase "bracket" $ case_bracket run+    , testCase "bracket_" $ case_bracket_ run+    , testCase "onException" $ case_onException run+    ]++ignore :: IO () -> IO ()+ignore x =+    catch x go+  where+    go :: SomeException -> IO ()+    go _ = return ()++data Exc = Exc+    deriving (Show, Typeable)+instance Exception Exc++one :: Int+one = 1++case_finally :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion+case_finally run = do+    i <- newIORef one+    ignore+        (run $ (do+            liftBase $ writeIORef i 2+            error "error") `finally` (liftBase $ writeIORef i 3))+    j <- readIORef i+    j @?= 3++case_catch :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion+case_catch run = do+    i <- newIORef one+    run $ (do+        liftBase $ writeIORef i 2+        throw Exc) `catch` (\Exc -> liftBase $ writeIORef i 3)+    j <- readIORef i+    j @?= 3++case_bracket :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion+case_bracket run = do+    i <- newIORef one+    ignore $ run $ bracket+        (liftBase $ writeIORef i 2)+        (\() -> liftBase $ writeIORef i 4)+        (\() -> liftBase $ writeIORef i 3)+    j <- readIORef i+    j @?= 4++case_bracket_ :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion+case_bracket_ run = do+    i <- newIORef one+    ignore $ run $ bracket_+        (liftBase $ writeIORef i 2)+        (liftBase $ writeIORef i 4)+        (liftBase $ writeIORef i 3)+    j <- readIORef i+    j @?= 4++case_onException :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion+case_onException run = do+    i <- newIORef one+    ignore $ run $ onException+        (liftBase (writeIORef i 2) >> error "ignored")+        (liftBase $ writeIORef i 3)+    j <- readIORef i+    j @?= 3+    ignore $ run $ onException+        (liftBase $ writeIORef i 4)+        (liftBase $ writeIORef i 5)+    k <- readIORef i+    k @?= 4++case_throwError :: Assertion+case_throwError = do+    i <- newIORef one+    Left "throwError" <- runErrorT $+        (liftBase (writeIORef i 2) >> throwError "throwError")+        `finally`+        (liftBase $ writeIORef i 3)+    j <- readIORef i+    j @?= 3++case_tell :: Assertion+case_tell = do+    i <- newIORef one+    ((), w) <- runWriterT $ bracket_+        (liftBase (writeIORef i 2) >> tell [1 :: Int])+        (liftBase (writeIORef i 4) >> tell [3])+        (liftBase (writeIORef i 3) >> tell [2])+    j <- readIORef i+    j @?= 4+    w @?= [2]++    ((), w') <- runWriterT $ bracket+        (liftBase (writeIORef i 5) >> tell [5 :: Int])+        (const $ liftBase (writeIORef i 7) >> tell [7])+        (const $ liftBase (writeIORef i 6) >> tell [6])+    j' <- readIORef i+    j' @?= 7+    w' @?= [5, 6]