lifted-base-0.2.3.8/0000755000000000000000000000000012744050754012237 5ustar0000000000000000lifted-base-0.2.3.8/lifted-base.cabal0000644000000000000000000000671012744050754015406 0ustar0000000000000000Name: lifted-base Version: 0.2.3.8 Synopsis: lifted IO operations from the base library License: BSD3 License-file: LICENSE Author: Bas van Dijk, Anders Kaseorg Maintainer: Bas van Dijk 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.8 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 extra-source-files: include/inlinable.h -------------------------------------------------------------------------------- source-repository head type: git location: https://github.com/basvandijk/lifted-base.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 >= 3 && < 5 , transformers-base >= 0.4 && < 0.5 , monad-control >= 0.3 && < 1.1 Include-dirs: include Includes: inlinable.h Ghc-options: -Wall -------------------------------------------------------------------------------- test-suite test-lifted-base type: exitcode-stdio-1.0 main-is: test.hs hs-source-dirs: test build-depends: lifted-base , base >= 3 && < 5 , transformers >= 0.3 && < 0.6 , transformers-base >= 0.4.4 && < 0.5 , transformers-compat >= 0.3 && < 0.6 , monad-control >= 1.0.0.3 && < 1.1 , HUnit >= 1.2.2 && < 1.4 , test-framework >= 0.2.4 && < 0.9 , test-framework-hunit >= 0.2.4 && < 0.4 Include-dirs: include Includes: inlinable.h 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 && < 5 , transformers >= 0.2 && < 0.6 , criterion >= 1 && < 1.2 , monad-control >= 0.3 && < 1.1 , monad-peel >= 0.1 && < 0.3 lifted-base-0.2.3.8/README.markdown0000644000000000000000000000070712744050754014744 0ustar0000000000000000[![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`. lifted-base-0.2.3.8/LICENSE0000644000000000000000000000275112744050754013251 0ustar0000000000000000Copyright © 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. lifted-base-0.2.3.8/Setup.hs0000644000000000000000000000005612744050754013674 0ustar0000000000000000import Distribution.Simple main = defaultMain lifted-base-0.2.3.8/NEWS0000644000000000000000000000000012744050754012724 0ustar0000000000000000lifted-base-0.2.3.8/include/0000755000000000000000000000000012744050754013662 5ustar0000000000000000lifted-base-0.2.3.8/include/inlinable.h0000644000000000000000000000007612744050754015773 0ustar0000000000000000#if __GLASGOW_HASKELL__ < 700 #define INLINABLE INLINE #endif lifted-base-0.2.3.8/bench/0000755000000000000000000000000012744050754013316 5ustar0000000000000000lifted-base-0.2.3.8/bench/bench.hs0000644000000000000000000000722112744050754014733 0ustar0000000000000000{-# 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 lifted-base-0.2.3.8/Data/0000755000000000000000000000000012744050754013110 5ustar0000000000000000lifted-base-0.2.3.8/Data/IORef/0000755000000000000000000000000012744050754014054 5ustar0000000000000000lifted-base-0.2.3.8/Data/IORef/Lifted.hs0000644000000000000000000000617312744050754015626 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif {- | Module : Data.IORef Copyright : Liyang HU, Bas van Dijk License : BSD-style Maintainer : Bas van Dijk 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 Data.IORef ( IORef ) import qualified Data.IORef as R import System.IO ( IO ) import System.Mem.Weak ( Weak ) import Prelude ( (.) ) -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase ) -- from monad-control: import Control.Monad.Trans.Control ( MonadBaseControl, liftBaseDiscard ) #include "inlinable.h" -------------------------------------------------------------------------------- -- * IORefs -------------------------------------------------------------------------------- -- | Generalized version of 'R.newIORef'. newIORef :: MonadBase IO m => a -> m (IORef a) newIORef = liftBase . R.newIORef {-# INLINABLE newIORef #-} -- | Generalized version of 'R.readIORef'. readIORef :: MonadBase IO m => IORef a -> m a readIORef = liftBase . R.readIORef {-# INLINABLE readIORef #-} -- | Generalized version of 'R.writeIORef'. writeIORef :: MonadBase IO m => IORef a -> a -> m () writeIORef r = liftBase . R.writeIORef r {-# INLINABLE writeIORef #-} -- | Generalized version of 'R.modifyIORef'. modifyIORef :: MonadBase IO m => IORef a -> (a -> a) -> m () modifyIORef r = liftBase . R.modifyIORef r {-# INLINABLE modifyIORef #-} -- | Generalized version of 'R.atomicModifyIORef'. atomicModifyIORef :: MonadBase IO m => 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' :: MonadBase IO m => IORef a -> (a -> a) -> m () modifyIORef' r = liftBase . R.modifyIORef' r {-# INLINABLE modifyIORef' #-} -- | Generalized version of 'R.atomicModifyIORef''. atomicModifyIORef' :: MonadBase IO m => IORef a -> (a -> (a, b)) -> m b atomicModifyIORef' r = liftBase . R.atomicModifyIORef' r {-# INLINABLE atomicModifyIORef' #-} -- | Generalized version of 'R.atomicWriteIORef'. atomicWriteIORef :: MonadBase IO m => 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 IO m => IORef a -> m () -> m (Weak (IORef a)) mkWeakIORef = liftBaseDiscard . R.mkWeakIORef {-# INLINABLE mkWeakIORef #-} lifted-base-0.2.3.8/Foreign/0000755000000000000000000000000012744050754013630 5ustar0000000000000000lifted-base-0.2.3.8/Foreign/Marshal/0000755000000000000000000000000012744050754015217 5ustar0000000000000000lifted-base-0.2.3.8/Foreign/Marshal/Utils/0000755000000000000000000000000012744050754016317 5ustar0000000000000000lifted-base-0.2.3.8/Foreign/Marshal/Utils/Lifted.hs0000644000000000000000000000235512744050754020067 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {- | Module : Foreign.Marshal.Utils.Lifted Copyright : Bas van Dijk, Anders Kaseorg, Michael Steele License : BSD-style Maintainer : Bas van Dijk Stability : experimental Portability : non-portable (extended exceptions) This is a wrapped version of "Foreign.Marshal.Utils" with types generalized from 'IO' to all monads in either 'MonadBase' or 'MonadBaseControl'. -} module Foreign.Marshal.Utils.Lifted ( with ) where -- from base: import qualified Foreign as F import System.IO ( IO ) import Prelude ( (.) ) -- from monad-control: import Control.Monad.Trans.Control ( MonadBaseControl , liftBaseOp ) -- |Generalized version of 'F.with'. -- -- Note, when the given function throws an exception any monadic side -- effects in @m@ will be discarded. with :: (MonadBaseControl IO m, F.Storable a) => a -- ^ value to be poked -> (F.Ptr a -> m b) -- ^ computation to run -> m b with = liftBaseOp . F.with {-# INLINEABLE with #-} lifted-base-0.2.3.8/System/0000755000000000000000000000000012744050754013523 5ustar0000000000000000lifted-base-0.2.3.8/System/Timeout/0000755000000000000000000000000012744050754015151 5ustar0000000000000000lifted-base-0.2.3.8/System/Timeout/Lifted.hs0000644000000000000000000000311212744050754016711 0ustar0000000000000000{-# LANGUAGE CPP, NoImplicitPrelude, FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif ------------------------------------------------------------------------------- -- | -- Module : System.Timeout.Lifted -- Copyright : (c) The University of Glasgow 2007 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable -- -- Attach a timeout event to monadic computations -- which are instances of 'MonadBaseControl'. -- ------------------------------------------------------------------------------- module System.Timeout.Lifted ( timeout ) where -- from base: import Prelude ( (.) ) import Data.Int ( Int ) import Data.Maybe ( Maybe(Nothing, Just), maybe ) import Control.Monad ( (>>=), return, liftM ) import System.IO ( IO ) import qualified System.Timeout as T ( timeout ) -- from monad-control: import Control.Monad.Trans.Control ( MonadBaseControl, restoreM, liftBaseWith ) #include "inlinable.h" -- | Generalized version of 'T.timeout'. -- -- Note that when the given computation times out any side effects of @m@ are -- discarded. When the computation completes within the given time the -- side-effects are restored on return. timeout :: MonadBaseControl IO m => Int -> m a -> m (Maybe a) timeout t m = liftBaseWith (\runInIO -> T.timeout t (runInIO m)) >>= maybe (return Nothing) (liftM Just . restoreM) {-# INLINABLE timeout #-} lifted-base-0.2.3.8/test/0000755000000000000000000000000012744050754013216 5ustar0000000000000000lifted-base-0.2.3.8/test/test.hs0000644000000000000000000001107312744050754014533 0ustar0000000000000000{-# 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 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_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] lifted-base-0.2.3.8/Control/0000755000000000000000000000000012744050754013657 5ustar0000000000000000lifted-base-0.2.3.8/Control/Concurrent/0000755000000000000000000000000012744050754016001 5ustar0000000000000000lifted-base-0.2.3.8/Control/Concurrent/Lifted.hs0000644000000000000000000002107012744050754017544 0ustar0000000000000000{-# LANGUAGE CPP, NoImplicitPrelude, FlexibleContexts, RankNTypes #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif {- | Module : Control.Concurrent.Lifted Copyright : Bas van Dijk License : BSD-style Maintainer : Bas van Dijk Stability : experimental 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 ( -- * Concurrent Haskell ThreadId -- * Basic concurrency operations , myThreadId , fork #if MIN_VERSION_base(4,4,0) , forkWithUnmask #endif #if MIN_VERSION_base(4,6,0) , forkFinally #endif , killThread , throwTo #if MIN_VERSION_base(4,4,0) -- ** Threads with affinity , forkOn , forkOnWithUnmask , getNumCapabilities #if MIN_VERSION_base(4,6,0) , setNumCapabilities #endif , threadCapability #endif -- * Scheduling , yield -- ** Blocking -- ** Waiting , threadDelay , threadWaitRead , threadWaitWrite -- * Communication abstractions , module Control.Concurrent.MVar.Lifted , module Control.Concurrent.Chan.Lifted , module Control.Concurrent.QSem.Lifted , module Control.Concurrent.QSemN.Lifted #if !MIN_VERSION_base(4,7,0) , module Control.Concurrent.SampleVar.Lifted #endif #if !MIN_VERSION_base(4,6,0) -- * Merging of streams , merge , nmerge #endif -- * Bound Threads , C.rtsSupportsBoundThreads , forkOS , isCurrentThreadBound , runInBoundThread , runInUnboundThread #if MIN_VERSION_base(4,6,0) -- * Weak references to ThreadIds , mkWeakThreadId #endif ) where -------------------------------------------------------------------------------- -- Imports -------------------------------------------------------------------------------- -- from base: import Prelude ( (.) ) import Data.Bool ( Bool ) import Data.Int ( Int ) import Data.Function ( ($) ) import System.IO ( IO ) import System.Posix.Types ( Fd ) #if MIN_VERSION_base(4,6,0) import Control.Monad ( (>>=) ) import Data.Either ( Either ) import System.Mem.Weak ( Weak ) #endif import Control.Concurrent ( ThreadId ) import qualified Control.Concurrent as C -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase ) -- from monad-control: import Control.Monad.Trans.Control ( MonadBaseControl, liftBaseOp_, liftBaseDiscard ) #if MIN_VERSION_base(4,4,0) import Control.Monad.Trans.Control ( liftBaseWith ) import Control.Monad ( void ) #endif -- 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 #if !MIN_VERSION_base(4,7,0) import Control.Concurrent.SampleVar.Lifted #endif import Control.Exception.Lifted ( throwTo #if MIN_VERSION_base(4,6,0) , SomeException, try, mask #endif ) #include "inlinable.h" -------------------------------------------------------------------------------- -- Control.Concurrent -------------------------------------------------------------------------------- -- | Generalized version of 'C.myThreadId'. myThreadId :: MonadBase IO m => m ThreadId myThreadId = liftBase C.myThreadId {-# INLINABLE myThreadId #-} -- | Generalized version of 'C.forkIO'. -- -- Note that, while the forked computation @m ()@ has access to the captured -- state, all its side-effects in @m@ are discarded. It is run only for its -- side-effects in 'IO'. fork :: MonadBaseControl IO m => m () -> m ThreadId fork = liftBaseDiscard C.forkIO {-# INLINABLE fork #-} #if MIN_VERSION_base(4,4,0) -- | Generalized version of 'C.forkIOWithUnmask'. -- -- Note that, while the forked computation @m ()@ has access to the captured -- state, all its side-effects in @m@ are discarded. It is run only for its -- side-effects in 'IO'. forkWithUnmask :: MonadBaseControl IO m => ((forall a. m a -> m a) -> m ()) -> m ThreadId forkWithUnmask f = liftBaseWith $ \runInIO -> C.forkIOWithUnmask $ \unmask -> void $ runInIO $ f $ liftBaseOp_ unmask {-# INLINABLE forkWithUnmask #-} #endif #if MIN_VERSION_base(4,6,0) -- | Generalized version of 'C.forkFinally'. -- -- Note that in @forkFinally action and_then@, while the forked -- @action@ and the @and_then@ function have access to the captured -- state, all their side-effects in @m@ are discarded. They're run -- only for their side-effects in 'IO'. forkFinally :: MonadBaseControl IO m => m a -> (Either SomeException a -> m ()) -> m ThreadId forkFinally action and_then = mask $ \restore -> fork $ try (restore action) >>= and_then {-# INLINABLE forkFinally #-} #endif -- | Generalized version of 'C.killThread'. killThread :: MonadBase IO m => ThreadId -> m () killThread = liftBase . C.killThread {-# INLINABLE killThread #-} #if MIN_VERSION_base(4,4,0) -- | Generalized version of 'C.forkOn'. -- -- Note that, while the forked computation @m ()@ has access to the captured -- state, all its side-effects in @m@ are discarded. It is run only for its -- side-effects in 'IO'. forkOn :: MonadBaseControl IO m => Int -> m () -> m ThreadId forkOn = liftBaseDiscard . C.forkOn {-# INLINABLE forkOn #-} -- | Generalized version of 'C.forkOnWithUnmask'. -- -- Note that, while the forked computation @m ()@ has access to the captured -- state, all its side-effects in @m@ are discarded. It is run only for its -- side-effects in 'IO'. forkOnWithUnmask :: MonadBaseControl IO m => Int -> ((forall a. m a -> m a) -> m ()) -> m ThreadId forkOnWithUnmask cap f = liftBaseWith $ \runInIO -> C.forkOnWithUnmask cap $ \unmask -> void $ runInIO $ f $ liftBaseOp_ unmask {-# INLINABLE forkOnWithUnmask #-} -- | Generalized version of 'C.getNumCapabilities'. getNumCapabilities :: MonadBase IO m => m Int getNumCapabilities = liftBase C.getNumCapabilities {-# INLINABLE getNumCapabilities #-} #if MIN_VERSION_base(4,6,0) -- | Generalized version of 'C.setNumCapabilities'. setNumCapabilities :: MonadBase IO m => Int -> m () setNumCapabilities = liftBase . C.setNumCapabilities {-# INLINABLE setNumCapabilities #-} #endif -- | Generalized version of 'C.threadCapability'. threadCapability :: MonadBase IO m => ThreadId -> m (Int, Bool) threadCapability = liftBase . C.threadCapability {-# INLINABLE threadCapability #-} #endif -- | Generalized version of 'C.yield'. yield :: MonadBase IO m => m () yield = liftBase C.yield {-# INLINABLE yield #-} -- | Generalized version of 'C.threadDelay'. threadDelay :: MonadBase IO m => Int -> m () threadDelay = liftBase . C.threadDelay {-# INLINABLE threadDelay #-} -- | Generalized version of 'C.threadWaitRead'. threadWaitRead :: MonadBase IO m => Fd -> m () threadWaitRead = liftBase . C.threadWaitRead {-# INLINABLE threadWaitRead #-} -- | Generalized version of 'C.threadWaitWrite'. threadWaitWrite :: MonadBase IO m => Fd -> m () threadWaitWrite = liftBase . C.threadWaitWrite {-# INLINABLE threadWaitWrite #-} #if !MIN_VERSION_base(4,6,0) -- | Generalized version of 'C.mergeIO'. merge :: MonadBase IO m => [a] -> [a] -> m [a] merge xs ys = liftBase $ C.mergeIO xs ys {-# INLINABLE merge #-} -- | Generalized version of 'C.nmergeIO'. nmerge :: MonadBase IO m => [[a]] -> m [a] nmerge = liftBase . C.nmergeIO {-# INLINABLE nmerge #-} #endif -- | Generalized version of 'C.forkOS'. -- -- Note that, while the forked computation @m ()@ has access to the captured -- state, all its side-effects in @m@ are discarded. It is run only for its -- side-effects in 'IO'. forkOS :: MonadBaseControl IO m => m () -> m ThreadId forkOS = liftBaseDiscard C.forkOS {-# INLINABLE forkOS #-} -- | Generalized version of 'C.isCurrentThreadBound'. isCurrentThreadBound :: MonadBase IO m => m Bool isCurrentThreadBound = liftBase C.isCurrentThreadBound {-# INLINABLE isCurrentThreadBound #-} -- | Generalized version of 'C.runInBoundThread'. runInBoundThread :: MonadBaseControl IO m => m a -> m a runInBoundThread = liftBaseOp_ C.runInBoundThread {-# INLINABLE runInBoundThread #-} -- | Generalized version of 'C.runInUnboundThread'. runInUnboundThread :: MonadBaseControl IO m => m a -> m a runInUnboundThread = liftBaseOp_ C.runInUnboundThread {-# INLINABLE runInUnboundThread #-} #if MIN_VERSION_base(4,6,0) -- | Generalized versio of 'C.mkWeakThreadId'. mkWeakThreadId :: MonadBase IO m => ThreadId -> m (Weak ThreadId) mkWeakThreadId = liftBase . C.mkWeakThreadId {-# INLINABLE mkWeakThreadId #-} #endif lifted-base-0.2.3.8/Control/Concurrent/Chan/0000755000000000000000000000000012744050754016652 5ustar0000000000000000lifted-base-0.2.3.8/Control/Concurrent/Chan/Lifted.hs0000644000000000000000000000453612744050754020425 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif {- | Module : Control.Concurrent.Chan.Lifted Copyright : Liyang HU, Bas van Dijk License : BSD-style Maintainer : Bas van Dijk 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 ) import Prelude ( (.) ) -- 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 #-} lifted-base-0.2.3.8/Control/Concurrent/QSem/0000755000000000000000000000000012744050754016646 5ustar0000000000000000lifted-base-0.2.3.8/Control/Concurrent/QSem/Lifted.hs0000644000000000000000000000325312744050754020414 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif {- | Module : Control.Concurrent.QSem.Lifted Copyright : Liyang HU, Bas van Dijk License : BSD-style Maintainer : Bas van Dijk 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 ) import Prelude ( (.) ) -- 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 #-} lifted-base-0.2.3.8/Control/Concurrent/SampleVar/0000755000000000000000000000000012744050754017673 5ustar0000000000000000lifted-base-0.2.3.8/Control/Concurrent/SampleVar/Lifted.hs0000644000000000000000000000476512744050754021452 0ustar0000000000000000{-# 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 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 :: 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 #-} lifted-base-0.2.3.8/Control/Concurrent/MVar/0000755000000000000000000000000012744050754016646 5ustar0000000000000000lifted-base-0.2.3.8/Control/Concurrent/MVar/Lifted.hs0000644000000000000000000001576412744050754020426 0ustar0000000000000000{-# LANGUAGE CPP , NoImplicitPrelude , FlexibleContexts , TupleSections #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif {- | Module : Control.Concurrent.MVar.Lifted Copyright : Bas van Dijk License : BSD-style Maintainer : Bas van Dijk Stability : experimental 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 ( MVar.MVar , newEmptyMVar , newMVar , takeMVar , putMVar , readMVar , swapMVar , tryTakeMVar , tryPutMVar , isEmptyMVar , withMVar , modifyMVar_ , modifyMVar #if MIN_VERSION_base(4,6,0) , modifyMVarMasked_ , modifyMVarMasked #endif #if MIN_VERSION_base(4,6,0) , mkWeakMVar #else , addMVarFinalizer #endif #if MIN_VERSION_base(4,7,0) , withMVarMasked , tryReadMVar #endif ) where -------------------------------------------------------------------------------- -- Imports -------------------------------------------------------------------------------- -- from base: import Prelude ( (.) ) import Data.Bool ( Bool(False, True) ) import Data.Function ( ($) ) import Data.Functor ( fmap ) import Data.IORef ( newIORef, readIORef, writeIORef ) import Data.Maybe ( Maybe ) import Control.Monad ( return, when ) import System.IO ( IO ) import Control.Concurrent.MVar ( MVar ) import qualified Control.Concurrent.MVar as MVar import Control.Exception ( onException #if MIN_VERSION_base(4,3,0) , mask, mask_ #else , block, unblock #endif ) #if MIN_VERSION_base(4,6,0) import System.Mem.Weak ( Weak ) #endif #if __GLASGOW_HASKELL__ < 700 import Control.Monad ( (>>=), (>>), fail ) #endif -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase ) -- from monad-control: import Control.Monad.Trans.Control ( MonadBaseControl , control , liftBaseOp , liftBaseDiscard ) #include "inlinable.h" -------------------------------------------------------------------------------- -- * MVars -------------------------------------------------------------------------------- -- | Generalized version of 'MVar.newEmptyMVar'. newEmptyMVar :: MonadBase IO m => m (MVar a) newEmptyMVar = liftBase MVar.newEmptyMVar {-# INLINABLE newEmptyMVar #-} -- | Generalized version of 'MVar.newMVar'. newMVar :: MonadBase IO m => a -> m (MVar a) newMVar = liftBase . MVar.newMVar {-# INLINABLE newMVar #-} -- | Generalized version of 'MVar.takeMVar'. takeMVar :: MonadBase IO m => MVar a -> m a takeMVar = liftBase . MVar.takeMVar {-# INLINABLE takeMVar #-} -- | Generalized version of 'MVar.putMVar'. putMVar :: MonadBase IO m => MVar a -> a -> m () putMVar mv x = liftBase $ MVar.putMVar mv x {-# INLINABLE putMVar #-} -- | Generalized version of 'MVar.readMVar'. readMVar :: MonadBase IO m => MVar a -> m a readMVar = liftBase . MVar.readMVar {-# INLINABLE readMVar #-} -- | Generalized version of 'MVar.swapMVar'. swapMVar :: MonadBase IO m => MVar a -> a -> m a swapMVar mv x = liftBase $ MVar.swapMVar mv x {-# INLINABLE swapMVar #-} -- | Generalized version of 'MVar.tryTakeMVar'. tryTakeMVar :: MonadBase IO m => MVar a -> m (Maybe a) tryTakeMVar = liftBase . MVar.tryTakeMVar {-# INLINABLE tryTakeMVar #-} -- | Generalized version of 'MVar.tryPutMVar'. tryPutMVar :: MonadBase IO m => MVar a -> a -> m Bool tryPutMVar mv x = liftBase $ MVar.tryPutMVar mv x {-# INLINABLE tryPutMVar #-} -- | Generalized version of 'MVar.isEmptyMVar'. isEmptyMVar :: MonadBase IO m => MVar a -> m Bool isEmptyMVar = liftBase . MVar.isEmptyMVar {-# INLINABLE isEmptyMVar #-} -- | Generalized version of 'MVar.withMVar'. withMVar :: MonadBaseControl IO m => MVar a -> (a -> m b) -> m b withMVar = liftBaseOp . MVar.withMVar {-# INLINABLE withMVar #-} -- | Generalized version of 'MVar.modifyMVar_'. modifyMVar_ :: (MonadBaseControl IO m) => MVar a -> (a -> m a) -> m () modifyMVar_ mv = modifyMVar mv . (fmap (, ()) .) {-# INLINABLE modifyMVar_ #-} -- | Generalized version of 'MVar.modifyMVar'. modifyMVar :: (MonadBaseControl IO m) => MVar a -> (a -> m (a, b)) -> m b #if MIN_VERSION_base(4,3,0) modifyMVar mv f = control $ \runInIO -> mask $ \restore -> do aborted <- newIORef True let f' x = do (x', a) <- f x liftBase $ mask_ $ do writeIORef aborted False MVar.putMVar mv x' return a x <- MVar.takeMVar mv stM <- restore (runInIO (f' x)) `onException` MVar.putMVar mv x abort <- readIORef aborted when abort $ MVar.putMVar mv x return stM #else modifyMVar mv f = control $ \runInIO -> block $ do aborted <- newIORef True let f' x = do (x', a) <- f x liftBase $ block $ do writeIORef aborted False MVar.putMVar mv x' return a x <- MVar.takeMVar mv stM <- unblock (runInIO (f' x)) `onException` MVar.putMVar mv x abort <- readIORef aborted when abort $ MVar.putMVar mv x return stM #endif {-# INLINABLE modifyMVar #-} #if MIN_VERSION_base(4,6,0) -- | Generalized version of 'MVar.modifyMVarMasked_'. modifyMVarMasked_ :: (MonadBaseControl IO m) => MVar a -> (a -> m a) -> m () modifyMVarMasked_ mv = modifyMVarMasked mv . (fmap (, ()) .) {-# INLINABLE modifyMVarMasked_ #-} -- | Generalized version of 'MVar.modifyMVarMasked'. modifyMVarMasked :: (MonadBaseControl IO m) => MVar a -> (a -> m (a, b)) -> m b modifyMVarMasked mv f = control $ \runInIO -> mask_ $ do aborted <- newIORef True let f' x = do (x', a) <- f x liftBase $ do writeIORef aborted False MVar.putMVar mv x' return a x <- MVar.takeMVar mv stM <- runInIO (f' x) `onException` MVar.putMVar mv x abort <- readIORef aborted when abort $ MVar.putMVar mv x return stM {-# INLINABLE modifyMVarMasked #-} #endif #if MIN_VERSION_base(4,6,0) -- | Generalized version of 'MVar.mkWeakMVar'. -- -- Note any monadic side effects in @m@ of the \"finalizer\" computation are -- discarded. mkWeakMVar :: MonadBaseControl IO m => MVar a -> m () -> m (Weak (MVar a)) mkWeakMVar = liftBaseDiscard . MVar.mkWeakMVar {-# INLINABLE mkWeakMVar #-} #else -- | Generalized version of 'MVar.addMVarFinalizer'. -- -- Note any monadic side effects in @m@ of the \"finalizer\" computation are -- discarded. addMVarFinalizer :: MonadBaseControl IO m => MVar a -> m () -> m () addMVarFinalizer = liftBaseDiscard . MVar.addMVarFinalizer {-# INLINABLE addMVarFinalizer #-} #endif #if MIN_VERSION_base (4,7,0) -- | Generalized version of 'MVar.withMVarMasked'. withMVarMasked :: MonadBaseControl IO m => MVar a -> (a -> m b) -> m b withMVarMasked = liftBaseOp . MVar.withMVarMasked -- | Generalized version of 'MVar.tryReadMVar'. tryReadMVar :: MonadBase IO m => MVar a -> m (Maybe a) tryReadMVar = liftBase . MVar.tryReadMVar #endif lifted-base-0.2.3.8/Control/Concurrent/QSemN/0000755000000000000000000000000012744050754016764 5ustar0000000000000000lifted-base-0.2.3.8/Control/Concurrent/QSemN/Lifted.hs0000644000000000000000000000335512744050754020535 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif {- | Module : Control.Concurrent.QSemN.Lifted Copyright : Liyang HU, Bas van Dijk License : BSD-style Maintainer : Bas van Dijk 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 ) import Prelude ( (.) ) -- 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 #-} lifted-base-0.2.3.8/Control/Exception/0000755000000000000000000000000012744050754015615 5ustar0000000000000000lifted-base-0.2.3.8/Control/Exception/Lifted.hs0000644000000000000000000003526212744050754017370 0ustar0000000000000000{-# LANGUAGE CPP , NoImplicitPrelude , ExistentialQuantification , FlexibleContexts #-} #if MIN_VERSION_base(4,3,0) {-# LANGUAGE RankNTypes #-} -- for mask #endif #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif {- | Module : Control.Exception.Lifted Copyright : Bas van Dijk, Anders Kaseorg License : BSD-style Maintainer : Bas van Dijk 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,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 -- * 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 ) #if __GLASGOW_HASKELL__ < 700 import Control.Monad ( fail ) #endif 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 -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase ) -- from monad-control: import Control.Monad.Trans.Control ( MonadBaseControl, StM , liftBaseWith, restoreM , control, liftBaseOp_ ) #if defined (__HADDOCK__) import Control.Monad.Trans.Control ( liftBaseOp ) #endif #include "inlinable.h" -------------------------------------------------------------------------------- -- * Throwing exceptions -------------------------------------------------------------------------------- -- |Generalized version of 'E.throwIO'. throwIO :: (MonadBase IO m, Exception e) => e -> m a throwIO = liftBase . E.throwIO {-# INLINABLE throwIO #-} -- |Generalized version of 'E.ioError'. ioError :: MonadBase IO m => IOError -> m a ioError = liftBase . E.ioError {-# INLINABLE ioError #-} -- | Generalized version of 'C.throwTo'. throwTo :: (MonadBase IO m, 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 IO m, 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 IO m => 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 IO m, 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 IO m, 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 IO m, 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 IO m => 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 IO m, 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 IO m, 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 :: MonadBase IO m => 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 IO m => ((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 IO m => m a -> m a mask_ = liftBaseOp_ E.mask_ {-# INLINABLE mask_ #-} -- |Generalized version of 'E.uninterruptibleMask'. uninterruptibleMask :: MonadBaseControl IO m => ((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 IO m => m a -> m a uninterruptibleMask_ = liftBaseOp_ E.uninterruptibleMask_ {-# INLINABLE uninterruptibleMask_ #-} -- |Generalized version of 'E.getMaskingState'. getMaskingState :: MonadBase IO m => m MaskingState getMaskingState = liftBase E.getMaskingState {-# INLINABLE getMaskingState #-} #if MIN_VERSION_base(4,4,0) -- |Generalized version of 'E.allowInterrupt'. allowInterrupt :: MonadBase IO m => m () allowInterrupt = liftBase E.allowInterrupt {-# INLINABLE allowInterrupt #-} #endif #else -- |Generalized version of 'E.block'. block :: MonadBaseControl IO m => m a -> m a block = liftBaseOp_ E.block {-# INLINABLE block #-} -- |Generalized version of 'E.unblock'. unblock :: MonadBaseControl IO m => 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 :: MonadBase IO m => 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 IO m => 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 IO m => 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 IO m => 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 IO m => 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 IO m => m a -> m b -> m a onException m what = control $ \runInIO -> E.onException (runInIO m) (runInIO what) {-# INLINABLE onException #-}