packages feed

lifted-base-tf (empty) → 0.1.0.0

raw patch · 11 files changed

+1016/−0 lines, 11 filesdep +HUnitdep +basedep +basicsetup-changed

Dependencies added: HUnit, base, basic, control, criterion, lifted-base, monad-control, monad-peel, test-framework, test-framework-hunit, transformers, transformers-compat

Files

+ Control/Concurrent/SampleVar/Lifted.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE CPP #-}+{-# 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 )+import Prelude ( (.) )++-- from transformers-base:+import Control.Monad.Base ( MonadBase, liftBase )++#include "inlinable.h"++--------------------------------------------------------------------------------+-- * SampleVars+--------------------------------------------------------------------------------++-- | Generalized version of 'SampleVar.newEmptySampleVar'.+newEmptySampleVar :: Basic1 m => m (SampleVar a)+newEmptySampleVar = liftBase SampleVar.newEmptySampleVar+{-# INLINABLE newEmptySampleVar #-}++-- | Generalized version of 'SampleVar.newSampleVar'.+newSampleVar :: Basic1 m => a -> m (SampleVar a)+newSampleVar = liftBase . SampleVar.newSampleVar+{-# INLINABLE newSampleVar #-}++-- | Generalized version of 'SampleVar.emptySampleVar'.+emptySampleVar :: Basic1 m => SampleVar a -> m ()+emptySampleVar = liftBase . SampleVar.emptySampleVar+{-# INLINABLE emptySampleVar #-}++-- | Generalized version of 'SampleVar.readSampleVar'.+readSampleVar :: Basic1 m => SampleVar a -> m a+readSampleVar = liftBase . SampleVar.readSampleVar+{-# INLINABLE readSampleVar #-}++-- | Generalized version of 'SampleVar.writeSampleVar'.+writeSampleVar :: Basic1 m => SampleVar a -> a -> m ()+writeSampleVar sv = liftBase . SampleVar.writeSampleVar sv+{-# INLINABLE writeSampleVar #-}++-- | Generalized version of 'SampleVar.isEmptySampleVar'.+isEmptySampleVar :: Basic1 m => SampleVar a -> m Bool+isEmptySampleVar = liftBase . SampleVar.isEmptySampleVar+{-# INLINABLE isEmptySampleVar #-}
+ Control/Exception/Lifted.hs view
@@ -0,0 +1,417 @@+{-# LANGUAGE CPP+           , ExistentialQuantification+           , FlexibleContexts #-}++#if MIN_VERSION_base(4,3,0)+{-# LANGUAGE RankNTypes #-} -- for mask+#endif++{- |+Module      :  Control.Exception.Lifted+Copyright   :  Bas van Dijk, Anders Kaseorg+License     :  BSD-style++Maintainer  :  Bas van Dijk <v.dijk.bas@gmail.com>+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'.+-}++module Control.Exception.Lifted+    ( module Control.Exception++      -- * Throwing exceptions+    , throwIO, ioError, throwTo++      -- * Catching exceptions+      -- ** The @catch@ functions+    , catch, catches, Handler(..), catchJust++      -- ** The @handle@ functions+    , handle, handleJust++      -- ** The @try@ functions+    , try, tryJust++      -- ** The @evaluate@ function+    , evaluate++      -- * Asynchronous Exceptions+      -- ** Asynchronous exception control+      -- |The following functions allow a thread to control delivery of+      -- asynchronous exceptions during a critical region.+#if MIN_VERSION_base(4,4,0)+    , allowInterrupt+#else+    , blocked+#endif+      -- * Brackets+    , bracket, bracket_, bracketOnError++      -- * Utilities+    , finally, onException+    ) where+++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+import Prelude         ( (.) )+import Data.Function   ( ($) )+import Data.Either     ( Either(Left, Right), either )+import Data.Maybe      ( Maybe )+import Control.Monad   ( (>>=), return, liftM )+import System.IO.Error ( IOError )+import System.IO       ( IO )++import Control.Exception hiding+    ( throwIO, ioError, throwTo+    , catch, catches, Handler(..), catchJust+    , handle, handleJust+    , try, tryJust+    , evaluate+#if MIN_VERSION_base(4,3,0)+    , mask, mask_+    , uninterruptibleMask, uninterruptibleMask_+    , getMaskingState+#if MIN_VERSION_base(4,4,0)+    , allowInterrupt+#endif+#else+    , block, unblock+#endif+#if !MIN_VERSION_base(4,4,0)+    , blocked+#endif+    , bracket, bracket_, bracketOnError+    , finally, onException+    )+import qualified Control.Exception  as E+import qualified Control.Concurrent as C+import           Control.Concurrent ( ThreadId )++#if !MIN_VERSION_base(4,4,0)+import Data.Bool ( Bool )+#endif++import Data.Basic ( Basic1 (..) )+import Control.Monad.Base.Control ( MonadBaseControl, StM+                                  , liftBaseWith, restoreM+                                  , control, liftBaseOp_+                                  )+#if defined (__HADDOCK__)+import Control.Monad.Base.Control ( liftBaseOp )+#endif++#include "inlinable.h"++--------------------------------------------------------------------------------+-- * Throwing exceptions+--------------------------------------------------------------------------------++-- |Generalized version of 'E.throwIO'.+throwIO :: (Basic1 m, Base m ~ IO, Exception e) => e -> m a+throwIO = liftBase . E.throwIO+{-# INLINABLE throwIO #-}++-- |Generalized version of 'E.ioError'.+ioError :: (Basic1 m, Base m ~ IO) => IOError -> m a+ioError = liftBase . E.ioError+{-# INLINABLE ioError #-}++-- | Generalized version of 'C.throwTo'.+throwTo :: (Basic1 m, Base m ~ IO, Exception e) => ThreadId -> e -> m ()+throwTo tid e = liftBase $ C.throwTo tid e+{-# INLINABLE throwTo #-}++--------------------------------------------------------------------------------+-- * Catching exceptions+--------------------------------------------------------------------------------++-- |Generalized version of 'E.catch'.+--+-- Note, when the given computation throws an exception any monadic+-- side effects in @m@ will be discarded.+catch :: (MonadBaseControl m, Base m ~ IO, Exception e)+      => m a       -- ^ The computation to run+      -> (e -> m a) -- ^ Handler to invoke if an exception is raised+      -> m a+catch a handler = control $ \runInIO ->+                    E.catch (runInIO a)+                            (\e -> runInIO $ handler e)+{-# INLINABLE catch #-}++-- |Generalized version of 'E.catches'.+--+-- Note, when the given computation throws an exception any monadic+-- side effects in @m@ will be discarded.+catches :: (MonadBaseControl m, Base m ~ IO) => m a -> [Handler m a] -> m a+catches a handlers = control $ \runInIO ->+                       E.catches (runInIO a)+                                 [ E.Handler $ \e -> runInIO $ handler e+                                 | Handler handler <- handlers+                                 ]+{-# INLINABLE catches #-}++-- |Generalized version of 'E.Handler'.+data Handler m a = forall e. Exception e => Handler (e -> m a)++-- |Generalized version of 'E.catchJust'.+--+-- Note, when the given computation throws an exception any monadic+-- side effects in @m@ will be discarded.+catchJust :: (MonadBaseControl m, Base m ~ IO, Exception e)+          => (e -> Maybe b) -- ^ Predicate to select exceptions+          -> m a           -- ^ Computation to run+          -> (b -> m a)     -- ^ Handler+          -> m a+catchJust p a handler = control $ \runInIO ->+                          E.catchJust p+                                      (runInIO a)+                                      (\e -> runInIO (handler e))+{-# INLINABLE catchJust #-}+++--------------------------------------------------------------------------------+--  ** The @handle@ functions+--------------------------------------------------------------------------------++-- |Generalized version of 'E.handle'.+--+-- Note, when the given computation throws an exception any monadic+-- side effects in @m@ will be discarded.+handle :: (MonadBaseControl m, Base m ~ IO, Exception e) => (e -> m a) -> m a -> m a+handle handler a = control $ \runInIO ->+                     E.handle (\e -> runInIO (handler e))+                              (runInIO a)+{-# INLINABLE handle #-}++-- |Generalized version of 'E.handleJust'.+--+-- Note, when the given computation throws an exception any monadic+-- side effects in @m@ will be discarded.+handleJust :: (MonadBaseControl m, Base m ~ IO, Exception e)+           => (e -> Maybe b) -> (b -> m a) -> m a -> m a+handleJust p handler a = control $ \runInIO ->+                           E.handleJust p (\e -> runInIO (handler e))+                                          (runInIO a)+{-# INLINABLE handleJust #-}++--------------------------------------------------------------------------------+-- ** The @try@ functions+--------------------------------------------------------------------------------++sequenceEither :: (MonadBaseControl m, Base m ~ IO) => Either e (StM m a) -> m (Either e a)+sequenceEither = either (return . Left) (liftM Right . restoreM)+{-# INLINE sequenceEither #-}++-- |Generalized version of 'E.try'.+--+-- Note, when the given computation throws an exception any monadic+-- side effects in @m@ will be discarded.+try :: (MonadBaseControl m, Base m ~ IO, Exception e) => m a -> m (Either e a)+try m = liftBaseWith (\runInIO -> E.try (runInIO m)) >>= sequenceEither+{-# INLINABLE try #-}++-- |Generalized version of 'E.tryJust'.+--+-- Note, when the given computation throws an exception any monadic+-- side effects in @m@ will be discarded.+tryJust :: (MonadBaseControl m, Base m ~ IO, Exception e) => (e -> Maybe b) -> m a -> m (Either b a)+tryJust p m = liftBaseWith (\runInIO -> E.tryJust p (runInIO m)) >>= sequenceEither+{-# INLINABLE tryJust #-}+++--------------------------------------------------------------------------------+-- ** The @evaluate@ function+--------------------------------------------------------------------------------++-- |Generalized version of 'E.evaluate'.+evaluate :: (Basic1 m, Base m ~ IO) => a -> m a+evaluate = liftBase . E.evaluate+{-# INLINABLE evaluate #-}+++--------------------------------------------------------------------------------+-- ** Asynchronous exception control+--------------------------------------------------------------------------------++#if MIN_VERSION_base(4,3,0)+-- |Generalized version of 'E.mask'.+mask :: (MonadBaseControl m, Base m ~ IO) => ((forall a. m a -> m a) -> m b) -> m b+mask f = control $ \runInBase ->+           E.mask $ \g -> runInBase $ f $ liftBaseOp_ g+{-# INLINABLE mask #-}++-- |Generalized version of 'E.mask_'.+mask_ :: (MonadBaseControl m, Base m ~ IO) => m a -> m a+mask_ = liftBaseOp_ E.mask_+{-# INLINABLE mask_ #-}++-- |Generalized version of 'E.uninterruptibleMask'.+uninterruptibleMask+    :: (MonadBaseControl m, Base m ~ IO) => ((forall a. m a -> m a) -> m b) -> m b+uninterruptibleMask f =+    control $ \runInBase ->+        E.uninterruptibleMask $ \g -> runInBase $ f $ liftBaseOp_ g++{-# INLINABLE uninterruptibleMask #-}++-- |Generalized version of 'E.uninterruptibleMask_'.+uninterruptibleMask_ :: (MonadBaseControl m, Base m ~ IO) => m a -> m a+uninterruptibleMask_ = liftBaseOp_ E.uninterruptibleMask_+{-# INLINABLE uninterruptibleMask_ #-}++-- |Generalized version of 'E.getMaskingState'.+getMaskingState :: (Basic1 m, Base m ~ IO) => m MaskingState+getMaskingState = liftBase E.getMaskingState+{-# INLINABLE getMaskingState #-}++#if MIN_VERSION_base(4,4,0)+-- |Generalized version of 'E.allowInterrupt'.+allowInterrupt :: (Basic1 m, Base m ~ IO) => m ()+allowInterrupt = liftBase E.allowInterrupt+{-# INLINABLE allowInterrupt #-}+#endif+#else+-- |Generalized version of 'E.block'.+block :: (MonadBaseControl m, Base m ~ IO) => m a -> m a+block = liftBaseOp_ E.block+{-# INLINABLE block #-}++-- |Generalized version of 'E.unblock'.+unblock :: (MonadBaseControl m, Base m ~ IO) => m a -> m a+unblock = liftBaseOp_ E.unblock+{-# INLINABLE unblock #-}+#endif++#if !MIN_VERSION_base(4,4,0)+-- | Generalized version of 'E.blocked'.+-- returns @True@ if asynchronous exceptions are blocked in the+-- current thread.+blocked :: (Basic1 m, Base m ~ IO) => m Bool+blocked = liftBase E.blocked+{-# INLINABLE blocked #-}+#endif+++--------------------------------------------------------------------------------+-- * Brackets+--------------------------------------------------------------------------------++-- |Generalized version of 'E.bracket'.+--+-- Note:+--+-- * When the \"acquire\" or \"release\" computations throw exceptions+--   any monadic side effects in @m@ will be discarded.+--+-- * When the \"in-between\" computation throws an exception any+--   monadic side effects in @m@ produced by that computation will be+--   discarded but the side effects of the \"acquire\" or \"release\"+--   computations will be retained.+--+-- * Also, any monadic side effects in @m@ of the \"release\"+--   computation will be discarded; it is run only for its side+--   effects in @IO@.+--+-- Note that when your @acquire@ and @release@ computations are of type 'IO'+-- it will be more efficient to write:+--+-- @'liftBaseOp' ('E.bracket' acquire release)@+bracket :: (MonadBaseControl m, Base m ~ IO)+        => m a       -- ^ computation to run first (\"acquire resource\")+        -> (a -> m b) -- ^ computation to run last (\"release resource\")+        -> (a -> m c) -- ^ computation to run in-between+        -> m c+bracket before after thing = control $ \runInIO ->+                               E.bracket (runInIO before)+                                         (\st -> runInIO $ restoreM st >>= after)+                                         (\st -> runInIO $ restoreM st >>= thing)+{-# INLINABLE bracket #-}++-- |Generalized version of 'E.bracket_'.+--+-- Note any monadic side effects in @m@ of /both/ the \"acquire\" and+-- \"release\" computations will be discarded. To keep the monadic+-- side effects of the \"acquire\" computation, use 'bracket' with+-- constant functions instead.+--+-- Note that when your @acquire@ and @release@ computations are of type 'IO'+-- it will be more efficient to write:+--+-- @'liftBaseOp_' ('E.bracket_' acquire release)@+bracket_ :: (MonadBaseControl m, Base m ~ IO)+         => m a -- ^ computation to run first (\"acquire resource\")+         -> m b -- ^ computation to run last (\"release resource\")+         -> m c -- ^ computation to run in-between+         -> m c+bracket_ before after thing = control $ \runInIO ->+                                E.bracket_ (runInIO before)+                                           (runInIO after)+                                           (runInIO thing)+{-# INLINABLE bracket_ #-}++-- |Generalized version of 'E.bracketOnError'.+--+-- Note:+--+-- * When the \"acquire\" or \"release\" computations throw exceptions+--   any monadic side effects in @m@ will be discarded.+--+-- * When the \"in-between\" computation throws an exception any+--   monadic side effects in @m@ produced by that computation will be+--   discarded but the side effects of the \"acquire\" computation+--   will be retained.+--+-- * Also, any monadic side effects in @m@ of the \"release\"+--   computation will be discarded; it is run only for its side+--   effects in @IO@.+--+-- Note that when your @acquire@ and @release@ computations are of+-- type 'IO' it will be more efficient to write:+--+-- @'liftBaseOp' ('E.bracketOnError' acquire release)@+bracketOnError :: (MonadBaseControl m, Base m ~ IO)+               => m a       -- ^ computation to run first (\"acquire resource\")+               -> (a -> m b) -- ^ computation to run last (\"release resource\")+               -> (a -> m c) -- ^ computation to run in-between+               -> m c+bracketOnError before after thing =+    control $ \runInIO ->+      E.bracketOnError (runInIO before)+                       (\st -> runInIO $ restoreM st >>= after)+                       (\st -> runInIO $ restoreM st >>= thing)+{-# INLINABLE bracketOnError #-}+++--------------------------------------------------------------------------------+-- * Utilities+--------------------------------------------------------------------------------++-- |Generalized version of 'E.finally'.+--+-- Note, any monadic side effects in @m@ of the \"afterward\"+-- computation will be discarded.+finally :: (MonadBaseControl m, Base m ~ IO)+        => m a -- ^ computation to run first+        -> m b -- ^ computation to run afterward (even if an exception was raised)+        -> m a+finally a sequel = control $ \runInIO ->+                     E.finally (runInIO a)+                               (runInIO sequel)+{-# INLINABLE finally #-}++-- |Generalized version of 'E.onException'.+--+-- Note, any monadic side effects in @m@ of the \"afterward\"+-- computation will be discarded.+onException :: (MonadBaseControl m, Base m ~ IO) => m a -> m b -> m a+onException m what = control $ \runInIO ->+                       E.onException (runInIO m)+                                     (runInIO what)+{-# INLINABLE onException #-}
+ Data/IORef/Lifted.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}++{- |+Module      :  Data.IORef+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 "Data.IORef" with types+generalised from 'IO' to all monads in 'MonadBase'.+-}++module Data.IORef.Lifted+    ( IORef+    , newIORef+    , readIORef+    , writeIORef+    , modifyIORef+#if MIN_VERSION_base(4,6,0)+    , modifyIORef'+#endif+    , atomicModifyIORef+#if MIN_VERSION_base(4,6,0)+    , atomicModifyIORef'+    , atomicWriteIORef+#endif+    , mkWeakIORef+    ) where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++-- from base:+import Control.Monad.Base.Control ( MonadBaseControl, liftBaseDiscard )+import Data.Basic ( Basic1 (..) )+import Data.IORef ( IORef )+import qualified Data.IORef as R+import System.IO ( IO )+import System.Mem.Weak ( Weak )+import Prelude ( (.) )++#include "inlinable.h"++--------------------------------------------------------------------------------+-- * IORefs+--------------------------------------------------------------------------------++-- | Generalized version of 'R.newIORef'.+newIORef :: (Basic1 m, Base m ~ IO) => a -> m (IORef a)+newIORef = liftBase . R.newIORef+{-# INLINABLE newIORef #-}++-- | Generalized version of 'R.readIORef'.+readIORef :: (Basic1 m, Base m ~ IO) => IORef a -> m a+readIORef = liftBase . R.readIORef+{-# INLINABLE readIORef #-}++-- | Generalized version of 'R.writeIORef'.+writeIORef :: (Basic1 m, Base m ~ IO) => IORef a -> a -> m ()+writeIORef r = liftBase . R.writeIORef r+{-# INLINABLE writeIORef #-}++-- | Generalized version of 'R.modifyIORef'.+modifyIORef :: (Basic1 m, Base m ~ IO) => IORef a -> (a -> a) -> m ()+modifyIORef r = liftBase . R.modifyIORef r+{-# INLINABLE modifyIORef #-}++-- | Generalized version of 'R.atomicModifyIORef'.+atomicModifyIORef :: (Basic1 m, Base m ~ IO) => IORef a -> (a -> (a, b)) -> m b+atomicModifyIORef r = liftBase . R.atomicModifyIORef r+{-# INLINABLE atomicModifyIORef #-}++#if MIN_VERSION_base(4,6,0)+-- | Generalized version of 'R.modifyIORef''.+modifyIORef' :: (Basic1 m, Base m ~ IO) => IORef a -> (a -> a) -> m ()+modifyIORef' r = liftBase . R.modifyIORef' r+{-# INLINABLE modifyIORef' #-}++-- | Generalized version of 'R.atomicModifyIORef''.+atomicModifyIORef' :: (Basic1 m, Base m ~ IO) => IORef a -> (a -> (a, b)) -> m b+atomicModifyIORef' r = liftBase . R.atomicModifyIORef' r+{-# INLINABLE atomicModifyIORef' #-}++-- | Generalized version of 'R.atomicWriteIORef'.+atomicWriteIORef :: (Basic1 m, Base m ~ IO) => IORef a -> a -> m ()+atomicWriteIORef r = liftBase . R.atomicWriteIORef r+#endif++-- | Generalized version of 'R.mkWeakIORef'.+--+-- Note any monadic side effects in @m@ of the \"finalizer\" computation+-- are discarded.+mkWeakIORef :: (MonadBaseControl m, Base m ~ IO) => IORef a -> m () -> m (Weak (IORef a))+mkWeakIORef = liftBaseDiscard . R.mkWeakIORef+{-# INLINABLE mkWeakIORef #-}
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++• Redistributions of source code must retain the above copyright+  notice, this list of conditions and the following disclaimer.++• Redistributions in binary form must reproduce the above copyright+  notice, this list of conditions and the following disclaimer in the+  documentation and/or other materials provided with the distribution.++• Neither the name of the author nor the names of other contributors+  may be used to endorse or promote products derived from this+  software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+“AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ NEWS view
+ README.markdown view
@@ -0,0 +1,8 @@+[![Hackage](https://img.shields.io/hackage/v/lifted-base.svg)](https://hackage.haskell.org/package/lifted-base)+[![Build Status](https://travis-ci.org/basvandijk/lifted-base.svg)](https://travis-ci.org/basvandijk/lifted-base)++IO operations from the base library lifted to any instance of+`MonadBase` or `MonadBaseControl`++The package includes a copy of the `monad-peel` testsuite written by+Anders Kaseorg The tests can be performed using `cabal test`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/bench.hs view
@@ -0,0 +1,117 @@+{-# 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++  , bgroup "mask"+    [ bench "monad-peel"    $ whnfIO $ benchMask mpMask+    , bench "monad-control" $ whnfIO $ benchMask MC.mask+    ]++  , bgroup "liftIOOp"+    [ bench "monad-peel"    $ whnfIO $ exe $ MP.liftIOOp   (E.bracket nop (\_ -> nop))+                                                           (\_ -> nop)+    , bench "monad-control" $ whnfIO $ exe $ MC.liftBaseOp (E.bracket nop (\_ -> nop))+                                                           (\_ -> nop)+    ]++  , bgroup "liftIOOp_"+    [ bench "monad-peel"    $ whnfIO $ exe $ MP.liftIOOp_   (E.bracket_ nop nop) nop+    , bench "monad-control" $ whnfIO $ exe $ MC.liftBaseOp_ (E.bracket_ nop nop) nop+    ]+  ]++b name bnch peel mndCtrl = bgroup name+  [ bench "monad-peel"    $ whnfIO $ bnch peel+  , bench "monad-control" $ whnfIO $ 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
+ include/inlinable.h view
@@ -0,0 +1,3 @@+#if __GLASGOW_HASKELL__ < 700+#define INLINABLE INLINE+#endif
+ lifted-base-tf.cabal view
@@ -0,0 +1,96 @@+Name:                lifted-base-tf+Version:             0.1.0.0+Synopsis:            lifted IO operations from the base library+License:             BSD3+License-file:        LICENSE+Author:              Bas van Dijk, Anders Kaseorg+Maintainer:          Bas van Dijk <v.dijk.bas@gmail.com>+Copyright:           (c) 2011-2012 Bas van Dijk, Anders Kaseorg+Homepage:            https://github.com/basvandijk/lifted-base+Bug-reports:         https://github.com/basvandijk/lifted-base/issues+Category:            Control+Build-type:          Simple+Cabal-version:       >= 1.10+Description:         @lifted-base@ exports IO operations from the base library lifted to+                     any instance of 'MonadBase' or 'MonadBaseControl'.+                     .+                     Note that not all modules from @base@ are converted yet. If+                     you need a lifted version of a function from @base@, just+                     ask me to add it or send me a patch.+                     .+                     The package includes a copy of the @monad-peel@ testsuite written+                     by Anders Kaseorg The tests can be performed using @cabal test@.++extra-source-files:  README.markdown, NEWS, include/inlinable.h++--------------------------------------------------------------------------------++source-repository head+  type:     git+  location: https://github.com/strake/lifted-base-tf.git++--------------------------------------------------------------------------------++Library+  Exposed-modules: Control.Exception.Lifted+--                   Control.Concurrent.MVar.Lifted+--                   Control.Concurrent.Chan.Lifted+--                   Control.Concurrent.QSem.Lifted+--                   Control.Concurrent.QSemN.Lifted+--                   Control.Concurrent.Lifted+                   Data.IORef.Lifted+--                   Foreign.Marshal.Utils.Lifted+--                   System.Timeout.Lifted+  if impl(ghc < 7.8)+    Exposed-modules:+                   Control.Concurrent.SampleVar.Lifted++  Build-depends: base              >= 4.3 && < 5+               , basic             >= 0.1 && < 0.2+               , control           >= 0.1.1 && < 0.2++  Ghc-options: -Wall+  Include-dirs: include++  Default-language: Haskell2010+  Default-extensions: NoImplicitPrelude+                    , TypeFamilies++--------------------------------------------------------------------------------++test-suite test-lifted-base+  type:           exitcode-stdio-1.0+  main-is:        test.hs+  hs-source-dirs: test++  build-depends: lifted-base+               , base                 >= 4.3 && < 5+               , basic             >= 0.1 && < 0.2+               , control           >= 0.1 && < 0.2+               , transformers         >= 0.3+               , transformers-compat  >= 0.3+               , HUnit                >= 1.2.2+               , test-framework       >= 0.2.4+               , test-framework-hunit >= 0.2.4++  ghc-options: -Wall++  Default-language: Haskell2010++--------------------------------------------------------------------------------++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          >= 4.3 && < 5+               , transformers  >= 0.2+               , criterion     >= 1+               , monad-control >= 0.3+               , monad-peel    >= 0.1++  Default-language: Haskell2010
+ test/test.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-}++-- from base:+#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif+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.Except++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 "ExceptT" runExceptT'+    , testSuite "StateT" $ flip evalStateT "state state"+    , testSuite "RWST" $ \m -> runRWST' m "RWS in" "RWS state"+    , testCase "ExceptT throwE" case_throwE+    , testCase "WriterT tell" case_tell+    ]+  where+    runWriterT' :: Functor m => WriterT [Int] m a -> m a+    runWriterT' = fmap fst . runWriterT+    runExceptT' :: Functor m => ExceptT String m () -> m ()+    runExceptT' = fmap (either (const ()) id) . runExceptT+    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 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 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 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 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 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 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_throwE :: Assertion+case_throwE = do+    i <- newIORef one+    Left "throwE" <- runExceptT $+        (liftBase (writeIORef i 2) >> throwE "throwE")+        `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]