lifted-base 0.1.2 → 0.2.3.12
raw patch · 17 files changed
Files
- Control/Concurrent/Chan/Lifted.hs +13/−17
- Control/Concurrent/Lifted.hs +92/−42
- Control/Concurrent/MVar/Lifted.hs +94/−39
- Control/Concurrent/QSem/Lifted.hs +9/−12
- Control/Concurrent/QSemN/Lifted.hs +9/−12
- Control/Concurrent/SampleVar/Lifted.hs +12/−16
- Control/Exception/Lifted.hs +175/−110
- Data/IORef/Lifted.hs +38/−19
- Foreign/Marshal/Utils/Lifted.hs +46/−0
- LICENSE +1/−1
- README.markdown +3/−0
- Setup.hs +2/−44
- System/Timeout/Lifted.hs +6/−8
- bench/bench.hs +13/−9
- include/inlinable.h +2/−2
- lifted-base.cabal +25/−22
- test/test.hs +10/−9
Control/Concurrent/Chan/Lifted.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} #endif {- |@@ -40,9 +39,7 @@ import Control.Concurrent.Chan ( Chan ) import qualified Control.Concurrent.Chan as Chan import System.IO ( IO )---- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )+import Prelude ( (.) ) -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase )@@ -54,32 +51,31 @@ -------------------------------------------------------------------------------- -- | Generalized version of 'Chan.newChan'.-newChan ∷ MonadBase IO m ⇒ m (Chan a)+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+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+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+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+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+writeList2Chan :: MonadBase IO m => Chan a -> [a] -> m ()+writeList2Chan chan = liftBase . Chan.writeList2Chan chan {-# INLINABLE writeList2Chan #-}-
Control/Concurrent/Lifted.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, FlexibleContexts, RankNTypes #-}+{-# LANGUAGE CPP, NoImplicitPrelude, FlexibleContexts, RankNTypes #-} #if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} #endif {- |@@ -26,6 +26,9 @@ #if MIN_VERSION_base(4,4,0) , forkWithUnmask #endif+#if MIN_VERSION_base(4,6,0)+ , forkFinally+#endif , killThread , throwTo @@ -34,6 +37,9 @@ , forkOn , forkOnWithUnmask , getNumCapabilities+#if MIN_VERSION_base(4,6,0)+ , setNumCapabilities+#endif , threadCapability #endif @@ -51,17 +57,27 @@ , 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 @@ -70,19 +86,21 @@ -------------------------------------------------------------------------------- -- from base:+import Prelude ( (.) ) import Data.Bool ( Bool ) import Data.Int ( Int ) import Data.Function ( ($) ) import System.IO ( IO ) import System.Posix.Types ( Fd )-import Control.Exception ( Exception )+#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 base-unicode-symbols:-import Data.Function.Unicode ( (∘) )- -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase ) @@ -99,8 +117,14 @@ 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" @@ -109,7 +133,7 @@ -------------------------------------------------------------------------------- -- | Generalized version of 'C.myThreadId'.-myThreadId ∷ MonadBase IO m ⇒ m ThreadId+myThreadId :: MonadBase IO m => m ThreadId myThreadId = liftBase C.myThreadId {-# INLINABLE myThreadId #-} @@ -118,7 +142,7 @@ -- 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 :: MonadBaseControl IO m => m () -> m ThreadId fork = liftBaseDiscard C.forkIO {-# INLINABLE fork #-} @@ -128,31 +152,41 @@ -- 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 ⇒ ((∀ a. m a → m a) → m ()) → m ThreadId-forkWithUnmask f = liftBaseWith $ \runInIO →- C.forkIOWithUnmask $ \unmask →+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 #-}+{-# 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+killThread :: MonadBase IO m => ThreadId -> m ()+killThread = liftBase . C.killThread {-# INLINABLE killThread #-} --- | Generalized version of 'C.throwTo'.-throwTo ∷ (MonadBase IO m, Exception e) ⇒ ThreadId → e → m ()-throwTo tid e = liftBase $ C.throwTo tid e-{-# INLINABLE throwTo #-}- #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+forkOn :: MonadBaseControl IO m => Int -> m () -> m ThreadId+forkOn = liftBaseDiscard . C.forkOn {-# INLINABLE forkOn #-} -- | Generalized version of 'C.forkOnWithUnmask'.@@ -160,73 +194,89 @@ -- 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 → ((∀ a. m a → m a) → m ()) → m ThreadId-forkOnWithUnmask cap f = liftBaseWith $ \runInIO →- C.forkOnWithUnmask cap $ \unmask →+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 :: 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+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 :: 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+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+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+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 :: 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+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 :: MonadBaseControl IO m => m () -> m ThreadId forkOS = liftBaseDiscard C.forkOS {-# INLINABLE forkOS #-} -- | Generalized version of 'C.isCurrentThreadBound'.-isCurrentThreadBound ∷ MonadBase IO m ⇒ m Bool+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 :: 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 :: 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
Control/Concurrent/MVar/Lifted.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE CPP- , UnicodeSyntax , NoImplicitPrelude , FlexibleContexts- , TupleSections- #-}+ , TupleSections #-} #if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} #endif {- |@@ -35,7 +33,19 @@ , 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 @@ -44,6 +54,7 @@ -------------------------------------------------------------------------------- -- from base:+import Prelude ( (.) ) import Data.Bool ( Bool(False, True) ) import Data.Function ( ($) ) import Data.Functor ( fmap )@@ -60,14 +71,14 @@ , 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 base-unicode-symbols:-import Data.Function.Unicode ( (∘) )- -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase ) @@ -85,98 +96,142 @@ -------------------------------------------------------------------------------- -- | Generalized version of 'MVar.newEmptyMVar'.-newEmptyMVar ∷ MonadBase IO m ⇒ m (MVar a)+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+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+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 :: 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+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 :: 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+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 :: 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+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+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 (, ()) ∘)+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+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+modifyMVar mv f = control $ \runInIO -> mask $ \restore -> do+ aborted <- newIORef True let f' x = do- (x', a) ← f x+ (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+ 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+ aborted <- newIORef True let f' x = do- (x', a) ← f x+ (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+ 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+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
Control/Concurrent/QSem/Lifted.hs view
@@ -1,10 +1,10 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} #endif {- |@@ -35,9 +35,7 @@ import qualified Control.Concurrent.QSem as QSem import Data.Int ( Int ) import System.IO ( IO )---- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )+import Prelude ( (.) ) -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase )@@ -49,17 +47,16 @@ -------------------------------------------------------------------------------- -- | Generalized version of 'QSem.newQSem'.-newQSem ∷ MonadBase IO m ⇒ Int → m QSem-newQSem = liftBase ∘ 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+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+signalQSem :: MonadBase IO m => QSem -> m ()+signalQSem = liftBase . QSem.signalQSem {-# INLINABLE signalQSem #-}-
Control/Concurrent/QSemN/Lifted.hs view
@@ -1,10 +1,10 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} #endif {- |@@ -35,9 +35,7 @@ import qualified Control.Concurrent.QSemN as QSemN import Data.Int ( Int ) import System.IO ( IO )---- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )+import Prelude ( (.) ) -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase )@@ -49,17 +47,16 @@ -------------------------------------------------------------------------------- -- | Generalized version of 'QSemN.newQSemN'.-newQSemN ∷ MonadBase IO m ⇒ Int → m QSemN-newQSemN = liftBase ∘ 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+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+signalQSemN :: MonadBase IO m => QSemN -> Int -> m ()+signalQSemN sem = liftBase . QSemN.signalQSemN sem {-# INLINABLE signalQSemN #-}-
Control/Concurrent/SampleVar/Lifted.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} @@ -38,9 +37,7 @@ import qualified Control.Concurrent.SampleVar as SampleVar import Data.Bool ( Bool ) import System.IO ( IO )---- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )+import Prelude ( (.) ) -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase )@@ -52,32 +49,31 @@ -------------------------------------------------------------------------------- -- | Generalized version of 'SampleVar.newEmptySampleVar'.-newEmptySampleVar ∷ MonadBase IO m ⇒ m (SampleVar a)+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+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+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+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+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+isEmptySampleVar :: MonadBase IO m => SampleVar a -> m Bool+isEmptySampleVar = liftBase . SampleVar.isEmptySampleVar {-# INLINABLE isEmptySampleVar #-}-
Control/Exception/Lifted.hs view
@@ -1,16 +1,14 @@ {-# LANGUAGE CPP- , UnicodeSyntax , NoImplicitPrelude , ExistentialQuantification- , FlexibleContexts- #-}+ , FlexibleContexts #-} #if MIN_VERSION_base(4,3,0) {-# LANGUAGE RankNTypes #-} -- for mask #endif #if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} #endif {- |@@ -30,7 +28,7 @@ ( module Control.Exception -- * Throwing exceptions- , throwIO, ioError+ , throwIO, ioError, throwTo -- * Catching exceptions -- ** The @catch@ functions@@ -53,6 +51,9 @@ , mask, mask_ , uninterruptibleMask, uninterruptibleMask_ , getMaskingState+#if MIN_VERSION_base(4,4,0)+ , allowInterrupt+#endif #else , block, unblock #endif@@ -73,10 +74,11 @@ -------------------------------------------------------------------------------- -- from base:+import Prelude ( (.) ) import Data.Function ( ($) ) import Data.Either ( Either(Left, Right), either ) import Data.Maybe ( Maybe )-import Control.Monad ( Monad, (>>=), return, liftM )+import Control.Monad ( (>>=), return, liftM ) import System.IO.Error ( IOError ) import System.IO ( IO ) @@ -85,7 +87,7 @@ #endif import Control.Exception hiding- ( throwIO, ioError+ ( throwIO, ioError, throwTo , catch, catches, Handler(..), catchJust , handle, handleJust , try, tryJust@@ -94,6 +96,9 @@ , mask, mask_ , uninterruptibleMask, uninterruptibleMask_ , getMaskingState+#if MIN_VERSION_base(4,4,0)+ , allowInterrupt+#endif #else , block, unblock #endif@@ -103,15 +108,14 @@ , bracket, bracket_, bracketOnError , finally, onException )-import qualified Control.Exception as E+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 base-unicode-symbols:-import Data.Function.Unicode ( (∘) )- -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase ) @@ -120,7 +124,7 @@ , liftBaseWith, restoreM , control, liftBaseOp_ )-#if MIN_VERSION_base(4,3,0) || defined (__HADDOCK__)+#if defined (__HADDOCK__) import Control.Monad.Trans.Control ( liftBaseOp ) #endif @@ -131,52 +135,65 @@ -------------------------------------------------------------------------------- -- |Generalized version of 'E.throwIO'.-throwIO ∷ (MonadBase IO m, Exception e) ⇒ e → m a-throwIO = liftBase ∘ 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+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'.-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 →+--+-- 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)+ (\e -> runInIO $ handler e) {-# INLINABLE catch #-} -- |Generalized version of 'E.catches'.-catches ∷ MonadBaseControl IO m ⇒ m a → [Handler m a] → m a-catches a handlers = control $ \runInIO →+--+-- 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+ [ E.Handler $ \e -> runInIO $ handler e+ | Handler handler <- handlers ] {-# INLINABLE catches #-} -- |Generalized version of 'E.Handler'.-data Handler m a = ∀ e. Exception e ⇒ Handler (e → m a)+data Handler m a = forall e. Exception e => Handler (e -> m a) -- |Generalized version of 'E.catchJust'.-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 →+--+-- 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))+ (\e -> runInIO (handler e)) {-# INLINABLE catchJust #-} @@ -185,17 +202,23 @@ -------------------------------------------------------------------------------- -- |Generalized version of 'E.handle'.-handle ∷ (MonadBaseControl IO m, Exception e) ⇒ (e → m a) → m a → m a-handle handler a = control $ \runInIO →- E.handle (\e → runInIO (handler e))+--+-- 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'.-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))+--+-- 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 #-} @@ -203,18 +226,24 @@ -- ** The @try@ functions -------------------------------------------------------------------------------- -sequenceEither ∷ MonadBaseControl IO m ⇒ Either e (StM m a) → m (Either e a)-sequenceEither = either (return ∘ Left) (liftM Right ∘ restoreM)+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'.-try ∷ (MonadBaseControl IO m, Exception e) ⇒ m a → m (Either e a)-try m = liftBaseWith (\runInIO → E.try (runInIO m)) >>= sequenceEither+--+-- 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'.-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+--+-- 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 #-} @@ -223,8 +252,8 @@ -------------------------------------------------------------------------------- -- |Generalized version of 'E.evaluate'.-evaluate ∷ MonadBase IO m ⇒ a → m a-evaluate = liftBase ∘ E.evaluate+evaluate :: MonadBase IO m => a -> m a+evaluate = liftBase . E.evaluate {-# INLINABLE evaluate #-} @@ -234,43 +263,49 @@ #if MIN_VERSION_base(4,3,0) -- |Generalized version of 'E.mask'.-mask ∷ MonadBaseControl IO m ⇒ ((∀ a. m a → m a) → m b) → m b-mask = liftBaseOp E.mask ∘ liftRestore+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 #-} -liftRestore ∷ MonadBaseControl IO m- ⇒ ((∀ a. m a → m a) → b)- → ((∀ a. IO a → IO a) → b)-liftRestore f r = f $ liftBaseOp_ r-{-# INLINE liftRestore #-}- -- |Generalized version of 'E.mask_'.-mask_ ∷ MonadBaseControl IO m ⇒ m a → m a+mask_ :: MonadBaseControl IO m => m a -> m a mask_ = liftBaseOp_ E.mask_ {-# INLINABLE mask_ #-} -- |Generalized version of 'E.uninterruptibleMask'.-uninterruptibleMask ∷ MonadBaseControl IO m ⇒ ((∀ a. m a → m a) → m b) → m b-uninterruptibleMask = liftBaseOp E.uninterruptibleMask ∘ liftRestore+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_ :: 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 :: 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 :: 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 :: MonadBaseControl IO m => m a -> m a unblock = liftBaseOp_ E.unblock {-# INLINABLE unblock #-} #endif@@ -279,7 +314,7 @@ -- | Generalized version of 'E.blocked'. -- returns @True@ if asynchronous exceptions are blocked in the -- current thread.-blocked ∷ MonadBase IO m ⇒ m Bool+blocked :: MonadBase IO m => m Bool blocked = liftBase E.blocked {-# INLINABLE blocked #-} #endif@@ -289,63 +324,89 @@ -- * Brackets -------------------------------------------------------------------------------- --- |Generalized version of 'E.bracket'. Note, any monadic side--- effects in @m@ of the \"release\" computation will be discarded; it--- is run only for its side effects in @IO@.+-- |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 →+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)+ (\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.+-- |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 →+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, any monadic side--- effects in @m@ of the \"release\" computation will be discarded.+-- |Generalized version of 'E.bracketOnError'. ----- Note that when your @acquire@ and @release@ computations are of type 'IO'--- it will be more efficient to write:+-- 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 :: 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 →+ control $ \runInIO -> E.bracketOnError (runInIO before)- (\st → runInIO $ restoreM st >>= after)- (\st → runInIO $ restoreM st >>= thing)+ (\st -> runInIO $ restoreM st >>= after)+ (\st -> runInIO $ restoreM st >>= thing) {-# INLINABLE bracketOnError #-} @@ -353,21 +414,25 @@ -- * 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 →+-- |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 →+-- |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 #-}
Data/IORef/Lifted.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} -#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-} #endif {- |@@ -25,7 +24,14 @@ , 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 @@ -38,9 +44,7 @@ import qualified Data.IORef as R import System.IO ( IO ) import System.Mem.Weak ( Weak )---- from base-unicode-symbols:-import Data.Function.Unicode ( (∘) )+import Prelude ( (.) ) -- from transformers-base: import Control.Monad.Base ( MonadBase, liftBase )@@ -55,35 +59,50 @@ -------------------------------------------------------------------------------- -- | Generalized version of 'R.newIORef'.-newIORef ∷ MonadBase IO m ⇒ a → m (IORef a)-newIORef = liftBase ∘ 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+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+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+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+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+mkWeakIORef :: MonadBaseControl IO m => IORef a -> m () -> m (Weak (IORef a))+mkWeakIORef = liftBaseDiscard . R.mkWeakIORef {-# INLINABLE mkWeakIORef #-}-
+ Foreign/Marshal/Utils/Lifted.hs view
@@ -0,0 +1,46 @@+{-# 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 <v.dijk.bas@gmail.com>+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 #-}
LICENSE view
@@ -1,4 +1,4 @@-Copyright © 2010, Bas van Dijk, Anders Kaseorg+Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg All rights reserved. Redistribution and use in source and binary forms, with or without
README.markdown view
@@ -1,3 +1,6 @@+[](https://hackage.haskell.org/package/lifted-base)+[](https://travis-ci.org/basvandijk/lifted-base)+ IO operations from the base library lifted to any instance of `MonadBase` or `MonadBaseControl`
Setup.hs view
@@ -1,44 +1,2 @@-#! /usr/bin/env runhaskell--{-# LANGUAGE NoImplicitPrelude, UnicodeSyntax #-}--module Main (main) where------------------------------------------------------------------------------------- Imports------------------------------------------------------------------------------------ from base-import System.IO ( IO )---- from cabal-import Distribution.Simple ( defaultMainWithHooks- , simpleUserHooks- , UserHooks(haddockHook)- )--import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )-import Distribution.Simple.Program ( userSpecifyArgs )-import Distribution.Simple.Setup ( HaddockFlags )-import Distribution.PackageDescription ( PackageDescription(..) )------------------------------------------------------------------------------------- Cabal setup program which sets the CPP define '__HADDOCK __' when haddock is run.----------------------------------------------------------------------------------main ∷ IO ()-main = defaultMainWithHooks hooks- where- hooks = simpleUserHooks { haddockHook = haddockHook' }---- Define __HADDOCK__ for CPP when running haddock.-haddockHook' ∷ PackageDescription → LocalBuildInfo → UserHooks → HaddockFlags → IO ()-haddockHook' pkg lbi =- haddockHook simpleUserHooks pkg (lbi { withPrograms = p })- where- p = userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] (withPrograms lbi)----- The End ---------------------------------------------------------------------+import Distribution.Simple+main = defaultMain
System/Timeout/Lifted.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, FlexibleContexts #-}+{-# LANGUAGE CPP, NoImplicitPrelude, FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} #endif -------------------------------------------------------------------------------@@ -22,15 +22,13 @@ 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 base-unicode-symbols:-import Data.Function.Unicode ( (∘) )- -- from monad-control: import Control.Monad.Trans.Control ( MonadBaseControl, restoreM, liftBaseWith ) @@ -41,7 +39,7 @@ -- 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)+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 #-}
bench/bench.hs view
@@ -45,24 +45,28 @@ , b "bracket_" benchBracket_ MP.bracket_ MC.bracket_ , b "catch" benchCatch MP.catch MC.catch , b "try" benchTry MP.try MC.try- , b "mask" benchMask mpMask MC.mask + , bgroup "mask"+ [ bench "monad-peel" $ whnfIO $ benchMask mpMask+ , bench "monad-control" $ whnfIO $ benchMask MC.mask+ ]+ , bgroup "liftIOOp"- [ bench "monad-peel" $ exe $ MP.liftIOOp (E.bracket nop (\_ -> nop))- (\_ -> nop)- , bench "monad-control" $ exe $ MC.liftBaseOp (E.bracket nop (\_ -> nop))- (\_ -> nop)+ [ 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" $ exe $ MP.liftIOOp_ (E.bracket_ nop nop) nop- , bench "monad-control" $ exe $ MC.liftBaseOp_ (E.bracket_ nop nop) nop+ [ 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" $ bnch peel- , bench "monad-control" $ bnch mndCtrl+ [ bench "monad-peel" $ whnfIO $ bnch peel+ , bench "monad-control" $ whnfIO $ bnch mndCtrl ] --------------------------------------------------------------------------------
include/inlinable.h view
@@ -1,3 +1,3 @@-#if __GLASCOW_HASKELL__ < 700-#define INLINABLE INLINE +#if __GLASGOW_HASKELL__ < 700+#define INLINABLE INLINE #endif
lifted-base.cabal view
@@ -1,16 +1,16 @@ Name: lifted-base-Version: 0.1.2+Version: 0.2.3.12 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 Bas van Dijk, Anders Kaseorg+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: Custom-Cabal-version: >= 1.9.2+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'. .@@ -29,7 +29,7 @@ source-repository head type: git- location: git://github.com/basvandijk/lifted-base.git+ location: https://github.com/basvandijk/lifted-base.git -------------------------------------------------------------------------------- @@ -39,15 +39,17 @@ Control.Concurrent.Chan.Lifted Control.Concurrent.QSem.Lifted Control.Concurrent.QSemN.Lifted- Control.Concurrent.SampleVar.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 && < 4.7- , base-unicode-symbols >= 0.1.1 && < 0.3- , transformers-base >= 0.4 && < 0.5- , monad-control >= 0.3 && < 0.4+ Build-depends: base >= 3 && < 5+ , transformers-base >= 0.4+ , monad-control >= 0.3 Include-dirs: include Includes: inlinable.h@@ -62,13 +64,14 @@ hs-source-dirs: test build-depends: lifted-base- , base >= 3 && < 4.7- , transformers >= 0.2 && < 0.4- , transformers-base >= 0.4 && < 0.5- , monad-control >= 0.3 && < 0.4- , HUnit >= 1.2.2 && < 1.3- , test-framework >= 0.2.4 && < 0.7- , test-framework-hunit >= 0.2.4 && < 0.3+ , base >= 3 && < 5+ , transformers >= 0.3+ , transformers-base >= 0.4.4+ , transformers-compat >= 0.3+ , monad-control >= 1.0.0.3+ , HUnit >= 1.2.2+ , test-framework >= 0.2.4+ , test-framework-hunit >= 0.2.4 Include-dirs: include Includes: inlinable.h@@ -85,8 +88,8 @@ ghc-options: -O2 build-depends: lifted-base- , base >= 3 && < 4.7- , transformers >= 0.2 && < 0.4- , criterion >= 0.5 && < 0.7- , monad-control >= 0.3 && < 0.4- , monad-peel >= 0.1 && < 0.2+ , base >= 3 && < 5+ , transformers >= 0.2+ , criterion >= 1+ , monad-control >= 0.3+ , monad-peel >= 0.1
test/test.hs view
@@ -17,7 +17,8 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer-import Control.Monad.Trans.Error+import Control.Monad.Trans.Except+ import Control.Monad.Trans.State import qualified Control.Monad.Trans.RWS as RWS @@ -44,17 +45,17 @@ , testSuite "MaybeT" $ fmap fromJust . runMaybeT , testSuite "ReaderT" $ flip runReaderT "reader state" , testSuite "WriterT" runWriterT'- , testSuite "ErrorT" runErrorT'+ , testSuite "ExceptT" runExceptT' , testSuite "StateT" $ flip evalStateT "state state" , testSuite "RWST" $ \m -> runRWST' m "RWS in" "RWS state"- , testCase "ErrorT throwError" case_throwError+ , testCase "ExceptT throwE" case_throwE , testCase "WriterT tell" case_tell ] where runWriterT' :: Functor m => WriterT [Int] m a -> m a runWriterT' = fmap fst . runWriterT- runErrorT' :: Functor m => ErrorT String m () -> m ()- runErrorT' = fmap (either (const ()) id) . runErrorT+ 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 @@ -134,11 +135,11 @@ k <- readIORef i k @?= 4 -case_throwError :: Assertion-case_throwError = do+case_throwE :: Assertion+case_throwE = do i <- newIORef one- Left "throwError" <- runErrorT $- (liftBase (writeIORef i 2) >> throwError "throwError")+ Left "throwE" <- runExceptT $+ (liftBase (writeIORef i 2) >> throwE "throwE") `finally` (liftBase $ writeIORef i 3) j <- readIORef i