From 1d883e1c73a546eaa4c4e1e66c0495fd86b155e9 Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 25 2020 14:16:56 +0000 Subject: ghc-lifted-base-0.2.3.11 base --- diff --git a/Control/Concurrent/Chan/Lifted.hs b/Control/Concurrent/Chan/Lifted.hs new file mode 100644 index 0000000..ca258ad --- /dev/null +++ b/Control/Concurrent/Chan/Lifted.hs @@ -0,0 +1,81 @@ +{-# 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 #-} diff --git a/Control/Concurrent/Lifted.hs b/Control/Concurrent/Lifted.hs new file mode 100644 index 0000000..433ef45 --- /dev/null +++ b/Control/Concurrent/Lifted.hs @@ -0,0 +1,282 @@ +{-# 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 diff --git a/Control/Concurrent/MVar/Lifted.hs b/Control/Concurrent/MVar/Lifted.hs new file mode 100644 index 0000000..f8c751f --- /dev/null +++ b/Control/Concurrent/MVar/Lifted.hs @@ -0,0 +1,237 @@ +{-# 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 diff --git a/Control/Concurrent/QSem/Lifted.hs b/Control/Concurrent/QSem/Lifted.hs new file mode 100644 index 0000000..0848dcb --- /dev/null +++ b/Control/Concurrent/QSem/Lifted.hs @@ -0,0 +1,62 @@ +{-# 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 #-} diff --git a/Control/Concurrent/QSemN/Lifted.hs b/Control/Concurrent/QSemN/Lifted.hs new file mode 100644 index 0000000..26c460a --- /dev/null +++ b/Control/Concurrent/QSemN/Lifted.hs @@ -0,0 +1,62 @@ +{-# 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 #-} diff --git a/Control/Concurrent/SampleVar/Lifted.hs b/Control/Concurrent/SampleVar/Lifted.hs new file mode 100644 index 0000000..6c0a2d2 --- /dev/null +++ b/Control/Concurrent/SampleVar/Lifted.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} + +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif + +{- | +Module : Control.Concurrent.SampleVar.Lifted +Copyright : Liyang HU, Bas van Dijk +License : BSD-style + +Maintainer : Bas van Dijk +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 #-} diff --git a/Control/Exception/Lifted.hs b/Control/Exception/Lifted.hs new file mode 100644 index 0000000..6bc4e67 --- /dev/null +++ b/Control/Exception/Lifted.hs @@ -0,0 +1,438 @@ +{-# 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 #-} diff --git a/Data/IORef/Lifted.hs b/Data/IORef/Lifted.hs new file mode 100644 index 0000000..945602f --- /dev/null +++ b/Data/IORef/Lifted.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# 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 #-} diff --git a/Foreign/Marshal/Utils/Lifted.hs b/Foreign/Marshal/Utils/Lifted.hs new file mode 100644 index 0000000..1f484ac --- /dev/null +++ b/Foreign/Marshal/Utils/Lifted.hs @@ -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 +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 #-} diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..b8b5ed9 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +• Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +• Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +• Neither the name of the author nor the names of other contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +“AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/NEWS b/NEWS new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/NEWS diff --git a/README.markdown b/README.markdown new file mode 100644 index 0000000..aa04daa --- /dev/null +++ b/README.markdown @@ -0,0 +1,8 @@ +[![Hackage](https://img.shields.io/hackage/v/lifted-base.svg)](https://hackage.haskell.org/package/lifted-base) +[![Build Status](https://travis-ci.org/basvandijk/lifted-base.svg)](https://travis-ci.org/basvandijk/lifted-base) + +IO operations from the base library lifted to any instance of +`MonadBase` or `MonadBaseControl` + +The package includes a copy of the `monad-peel` testsuite written by +Anders Kaseorg The tests can be performed using `cabal test`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Timeout/Lifted.hs b/System/Timeout/Lifted.hs new file mode 100644 index 0000000..5473d24 --- /dev/null +++ b/System/Timeout/Lifted.hs @@ -0,0 +1,45 @@ +{-# 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 #-} diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 index 0000000..7c28456 --- /dev/null +++ b/bench/bench.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE DeriveDataTypeable, RankNTypes #-} + +module Main where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Prelude hiding (catch) +import Control.Exception ( Exception, SomeException, throwIO ) +import qualified Control.Exception as E ( mask, bracket, bracket_ ) +import Data.Typeable +import Control.Monad (join) + +-- from criterion: +import Criterion.Main + +-- from transformers: +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Control.Monad.Trans.Writer + +-- from monad-peel: +import qualified Control.Exception.Peel as MP +import qualified Control.Monad.IO.Peel as MP + +-- from monad-control: +import qualified Control.Monad.Trans.Control as MC + +-- from lifted-base: +import qualified Control.Exception.Lifted as MC + + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain + [ b "bracket" benchBracket MP.bracket MC.bracket + , b "bracket_" benchBracket_ MP.bracket_ MC.bracket_ + , b "catch" benchCatch MP.catch MC.catch + , b "try" benchTry MP.try MC.try + + , bgroup "mask" + [ bench "monad-peel" $ whnfIO $ benchMask mpMask + , bench "monad-control" $ whnfIO $ benchMask MC.mask + ] + + , bgroup "liftIOOp" + [ bench "monad-peel" $ whnfIO $ exe $ MP.liftIOOp (E.bracket nop (\_ -> nop)) + (\_ -> nop) + , bench "monad-control" $ whnfIO $ exe $ MC.liftBaseOp (E.bracket nop (\_ -> nop)) + (\_ -> nop) + ] + + , bgroup "liftIOOp_" + [ bench "monad-peel" $ whnfIO $ exe $ MP.liftIOOp_ (E.bracket_ nop nop) nop + , bench "monad-control" $ whnfIO $ exe $ MC.liftBaseOp_ (E.bracket_ nop nop) nop + ] + ] + +b name bnch peel mndCtrl = bgroup name + [ bench "monad-peel" $ whnfIO $ bnch peel + , bench "monad-control" $ whnfIO $ bnch mndCtrl + ] + +-------------------------------------------------------------------------------- +-- Monad stack +-------------------------------------------------------------------------------- + +type M a = ReaderT Int (StateT Bool (WriterT String (MaybeT IO))) a + +type R a = IO (Maybe ((a, Bool), String)) + +runM :: Int -> Bool -> M a -> R a +runM r s m = runMaybeT (runWriterT (runStateT (runReaderT m r) s)) + +exe :: M a -> R a +exe = runM 0 False + + +-------------------------------------------------------------------------------- +-- Benchmarks +-------------------------------------------------------------------------------- + +benchBracket bracket = exe $ bracket nop (\_ -> nop) (\_ -> nop) +benchBracket_ bracket_ = exe $ bracket_ nop nop nop +benchCatch catch = exe $ catch throwE (\E -> nop) +benchTry try = exe $ try throwE :: R (Either E ()) + +benchMask :: (((forall a. M a -> M a) -> M ()) -> M ()) -> R () +benchMask mask = exe $ mask $ \restore -> nop >> restore nop >> nop + + +-------------------------------------------------------------------------------- +-- Utils +-------------------------------------------------------------------------------- + +nop :: Monad m => m () +nop = return () + +data E = E deriving (Show, Typeable) + +instance Exception E + +throwE :: MonadIO m => m () +throwE = liftIO $ throwIO E + +mpMask :: MP.MonadPeelIO m => ((forall a. m a -> m a) -> m b) -> m b +mpMask f = do + k <- MP.peelIO + join $ liftIO $ E.mask $ \restore -> k $ f $ MP.liftIOOp_ restore diff --git a/include/inlinable.h b/include/inlinable.h new file mode 100644 index 0000000..56e2da7 --- /dev/null +++ b/include/inlinable.h @@ -0,0 +1,3 @@ +#if __GLASGOW_HASKELL__ < 700 +#define INLINABLE INLINE +#endif diff --git a/lifted-base.cabal b/lifted-base.cabal new file mode 100644 index 0000000..f25ed48 --- /dev/null +++ b/lifted-base.cabal @@ -0,0 +1,95 @@ +Name: lifted-base +Version: 0.2.3.11 +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.5 + , 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.3 + , monad-control >= 0.3 && < 1.1 + , monad-peel >= 0.1 && < 0.3 diff --git a/test/test.hs b/test/test.hs new file mode 100644 index 0000000..6de06ab --- /dev/null +++ b/test/test.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-} + +-- from base: +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding (catch) +#endif +import Data.IORef +import Data.Maybe +import Data.Typeable (Typeable) + +-- from transformers-base: +import Control.Monad.Base (liftBase) + +-- from transformers: +import Control.Monad.Trans.Identity +import Control.Monad.Trans.List +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer +import Control.Monad.Trans.Except + +import Control.Monad.Trans.State +import qualified Control.Monad.Trans.RWS as RWS + +-- from monad-control: +import Control.Monad.Trans.Control (MonadBaseControl) + +-- from lifted-base (this package): +import Control.Exception.Lifted + +-- from test-framework: +import Test.Framework (defaultMain, testGroup, Test) + + -- from test-framework-hunit: +import Test.Framework.Providers.HUnit + +-- from hunit: +import Test.HUnit hiding (Test) + + +main :: IO () +main = defaultMain + [ testSuite "IdentityT" runIdentityT + , testSuite "ListT" $ fmap head . runListT + , testSuite "MaybeT" $ fmap fromJust . runMaybeT + , testSuite "ReaderT" $ flip runReaderT "reader state" + , testSuite "WriterT" runWriterT' + , testSuite "ExceptT" runExceptT' + , testSuite "StateT" $ flip evalStateT "state state" + , testSuite "RWST" $ \m -> runRWST' m "RWS in" "RWS state" + , testCase "ExceptT throwE" case_throwE + , testCase "WriterT tell" case_tell + ] + where + runWriterT' :: Functor m => WriterT [Int] m a -> m a + runWriterT' = fmap fst . runWriterT + runExceptT' :: Functor m => ExceptT String m () -> m () + runExceptT' = fmap (either (const ()) id) . runExceptT + runRWST' :: (Monad m, Functor m) => RWS.RWST r [Int] s m a -> r -> s -> m a + runRWST' m r s = fmap fst $ RWS.evalRWST m r s + +testSuite :: MonadBaseControl 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]