diff --git a/Control/Concurrent/Lifted.hs b/Control/Concurrent/Lifted.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Lifted.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, FlexibleContexts, RankNTypes #-} + +{- | +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 + , forkWithUnmask + , killThread + , throwTo + + -- ** Threads with affinity + , forkOn + , forkOnWithUnmask + , getNumCapabilities + , threadCapability + + -- * Scheduling + , yield + + -- ** Blocking + -- ** Waiting + , threadDelay + , threadWaitRead + , threadWaitWrite + + -- * Communication abstractions + , module Control.Concurrent.MVar.Lifted + -- TODO: , module Control.Concurrent.Chan.Lifted + -- TODO: , module Control.Concurrent.QSem.Lifted + -- TODO: , module Control.Concurrent.QSemN.Lifted + -- TODO: , module Control.Concurrent.SampleVar.Lifted + + -- * Merging of streams + , merge + , nmerge + + -- * Bound Threads + , forkOS + , isCurrentThreadBound + , runInBoundThread + , runInUnboundThread + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Data.Bool ( Bool ) +import Data.Int ( Int ) +import Data.Function ( ($) ) +import Control.Monad ( void ) +import System.IO ( IO ) +import System.Posix.Types ( Fd ) +import Control.Exception ( Exception ) + +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 ) + +-- from monad-control: +import Control.Monad.Trans.Control + ( MonadBaseControl, liftBaseWith, liftBaseOp_, liftBaseDiscard ) + +-- from lifted-base (this package): +import Control.Concurrent.MVar.Lifted + + +-------------------------------------------------------------------------------- +-- 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 #-} + +-- | 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 ⇒ ((∀ α. m α → m α) → m ()) → m ThreadId +forkWithUnmask f = liftBaseWith $ \runInIO → + C.forkIOWithUnmask $ \unmask → + void $ runInIO $ f $ liftBaseOp_ unmask +{-# INLINABLE forkWithUnmask #-} + +-- | Generalized version of '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 #-} + +-- | 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 → ((∀ α. m α → m α) → 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 #-} + +-- | Generalized version of 'C.threadCapability'. +threadCapability ∷ MonadBase IO m ⇒ ThreadId → m (Int, Bool) +threadCapability = liftBase ∘ C.threadCapability +{-# INLINABLE threadCapability #-} + +-- | 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 #-} + +-- | Generalized version of 'C.mergeIO'. +merge ∷ MonadBase IO m ⇒ [α] → [α] → m [α] +merge xs ys = liftBase $ C.mergeIO xs ys +{-# INLINABLE merge #-} + +-- | Generalized version of 'C.nmergeIO'. +nmerge ∷ MonadBase IO m ⇒ [[α]] → m [α] +nmerge = liftBase ∘ C.nmergeIO +{-# INLINABLE nmerge #-} + +-- | 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 α → m α +runInBoundThread = liftBaseOp_ C.runInBoundThread +{-# INLINABLE runInBoundThread #-} + +-- | Generalized version of 'C.runInUnboundThread'. +runInUnboundThread ∷ MonadBaseControl IO m ⇒ m α → m α +runInUnboundThread = liftBaseOp_ C.runInUnboundThread +{-# INLINABLE runInUnboundThread #-} diff --git a/Control/Concurrent/MVar/Lifted.hs b/Control/Concurrent/MVar/Lifted.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/MVar/Lifted.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, FlexibleContexts #-} + +{- | +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 + , addMVarFinalizer + ) where + + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import Data.Bool ( Bool ) +import Data.Function ( ($) ) +import Data.Maybe ( Maybe ) +import Control.Monad ( return ) +import System.IO ( IO ) +import Control.Concurrent.MVar ( MVar ) +import qualified Control.Concurrent.MVar as MVar + +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) + +-- from transformers-base: +import Control.Monad.Base ( MonadBase, liftBase ) + +-- from monad-control: +import Control.Monad.Trans.Control ( MonadBaseControl, liftBaseOp, liftBaseDiscard ) + +-- from lifted-base (this package): +import Control.Exception.Lifted ( mask, onException ) + + +-------------------------------------------------------------------------------- +-- * MVars +-------------------------------------------------------------------------------- + +-- | Generalized version of 'MVar.newEmptyMVar'. +newEmptyMVar ∷ MonadBase IO m ⇒ m (MVar α) +newEmptyMVar = liftBase MVar.newEmptyMVar +{-# INLINABLE newEmptyMVar #-} + +-- | Generalized version of 'MVar.newMVar'. +newMVar ∷ MonadBase IO m ⇒ α → m (MVar α) +newMVar = liftBase ∘ MVar.newMVar +{-# INLINABLE newMVar #-} + +-- | Generalized version of 'MVar.takeMVar'. +takeMVar ∷ MonadBase IO m ⇒ MVar α → m α +takeMVar = liftBase ∘ MVar.takeMVar +{-# INLINABLE takeMVar #-} + +-- | Generalized version of 'MVar.putMVar'. +putMVar ∷ MonadBase IO m ⇒ MVar α → α → m () +putMVar mv x = liftBase $ MVar.putMVar mv x +{-# INLINABLE putMVar #-} + +-- | Generalized version of 'MVar.readMVar'. +readMVar ∷ MonadBase IO m ⇒ MVar α → m α +readMVar = liftBase ∘ MVar.readMVar +{-# INLINABLE readMVar #-} + +-- | Generalized version of 'MVar.swapMVar'. +swapMVar ∷ MonadBase IO m ⇒ MVar α → α → m α +swapMVar mv x = liftBase $ MVar.swapMVar mv x +{-# INLINABLE swapMVar #-} + +-- | Generalized version of 'MVar.tryTakeMVar'. +tryTakeMVar ∷ MonadBase IO m ⇒ MVar α → m (Maybe α) +tryTakeMVar = liftBase ∘ MVar.tryTakeMVar +{-# INLINABLE tryTakeMVar #-} + +-- | Generalized version of 'MVar.tryPutMVar'. +tryPutMVar ∷ MonadBase IO m ⇒ MVar α → α → m Bool +tryPutMVar mv x = liftBase $ MVar.tryPutMVar mv x +{-# INLINABLE tryPutMVar #-} + +-- | Generalized version of 'MVar.isEmptyMVar'. +isEmptyMVar ∷ MonadBase IO m ⇒ MVar α → m Bool +isEmptyMVar = liftBase ∘ MVar.isEmptyMVar +{-# INLINABLE isEmptyMVar #-} + +-- | Generalized version of 'MVar.withMVar'. +withMVar ∷ MonadBaseControl IO m ⇒ MVar α → (α → m β) → m β +withMVar = liftBaseOp ∘ MVar.withMVar +{-# INLINABLE withMVar #-} + +-- | Generalized version of 'MVar.modifyMVar_'. +modifyMVar_ ∷ (MonadBaseControl IO m, MonadBase IO m) ⇒ MVar α → (α → m α) → m () +modifyMVar_ mv f = mask $ \restore → do + x ← takeMVar mv + x' ← restore (f x) `onException` putMVar mv x + putMVar mv x' +{-# INLINABLE modifyMVar_ #-} + +-- | Generalized version of 'MVar.modifyMVar'. +modifyMVar ∷ (MonadBaseControl IO m, MonadBase IO m) ⇒ MVar α → (α → m (α, β)) → m β +modifyMVar mv f = mask $ \restore → do + x ← takeMVar mv + (x', y) ← restore (f x) `onException` putMVar mv x + putMVar mv x' + return y +{-# INLINABLE modifyMVar #-} + +-- | Generalized version of 'MVar.addMVarFinalizer'. +-- +-- Note any monadic side effects in @m@ of the \"finalizer\" computation are +-- discarded. +addMVarFinalizer ∷ MonadBaseControl IO m ⇒ MVar α → m () → m () +addMVarFinalizer = liftBaseDiscard ∘ MVar.addMVarFinalizer +{-# INLINABLE addMVarFinalizer #-} diff --git a/Control/Exception/Lifted.hs b/Control/Exception/Lifted.hs new file mode 100644 --- /dev/null +++ b/Control/Exception/Lifted.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE CPP + , UnicodeSyntax + , NoImplicitPrelude + , ExistentialQuantification + , FlexibleContexts + #-} + +#if MIN_VERSION_base(4,3,0) +{-# LANGUAGE RankNTypes #-} -- for mask +#endif + +{- | +Module : Control.Exception.Lifted +Copyright : Bas van Dijk, Anders Kaseorg +License : BSD-style + +Maintainer : Bas van Dijk +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 + + -- * 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 +#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 Data.Function ( ($) ) +import Data.Either ( Either(Left, Right), either ) +import Data.Maybe ( Maybe ) +import Control.Monad ( Monad, (>>=), return, liftM ) +import System.IO.Error ( IOError ) + +#if MIN_VERSION_base(4,3,0) || defined (__HADDOCK__) +import System.IO ( IO ) +#endif + +#if __GLASGOW_HASKELL__ < 700 +import Control.Monad ( fail ) +#endif + +import Control.Exception hiding + ( throwIO, ioError + , catch, catches, Handler(..), catchJust + , handle, handleJust + , try, tryJust + , evaluate +#if MIN_VERSION_base(4,3,0) + , mask, mask_ + , uninterruptibleMask, uninterruptibleMask_ + , getMaskingState +#else + , block, unblock +#endif +#if !MIN_VERSION_base(4,4,0) + , blocked +#endif + , bracket, bracket_, bracketOnError + , finally, onException + ) +import qualified Control.Exception as E + +#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 ) + +-- from monad-control: +import Control.Monad.Trans.Control ( MonadBaseControl, StM + , liftBaseWith, restoreM + , control, liftBaseOp_ + ) +#if MIN_VERSION_base(4,3,0) || defined (__HADDOCK__) +import Control.Monad.Trans.Control ( liftBaseOp ) +#endif + + +-------------------------------------------------------------------------------- +-- * Throwing exceptions +-------------------------------------------------------------------------------- + +-- |Generalized version of 'E.throwIO'. +throwIO ∷ (MonadBase IO m, Exception e) ⇒ e → m α +throwIO = liftBase ∘ E.throwIO +{-# INLINABLE throwIO #-} + +-- |Generalized version of 'E.ioError'. +ioError ∷ MonadBase IO m ⇒ IOError → m α +ioError = liftBase ∘ E.ioError +{-# INLINABLE ioError #-} + + +-------------------------------------------------------------------------------- +-- * Catching exceptions +-------------------------------------------------------------------------------- + +-- |Generalized version of 'E.catch'. +catch ∷ (MonadBaseControl IO m, Exception e) + ⇒ m α -- ^ The computation to run + → (e → m α) -- ^ Handler to invoke if an exception is raised + → m α +catch a handler = control $ \runInIO → + E.catch (runInIO a) + (\e → runInIO $ handler e) +{-# INLINABLE catch #-} + +-- |Generalized version of 'E.catches'. +catches ∷ MonadBaseControl IO m ⇒ m α → [Handler m α] → m α +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 α = ∀ e. Exception e ⇒ Handler (e → m α) + +-- |Generalized version of 'E.catchJust'. +catchJust ∷ (MonadBaseControl IO m, Exception e) + ⇒ (e → Maybe β) -- ^ Predicate to select exceptions + → m α -- ^ Computation to run + → (β → m α) -- ^ Handler + → m α +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'. +handle ∷ (MonadBaseControl IO m, Exception e) ⇒ (e → m α) → m α → m α +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 β) → (β → m α) → m α → m α +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 α) → m (Either e α) +sequenceEither = either (return ∘ Left) (liftM Right ∘ restoreM) +{-# INLINE sequenceEither #-} + +-- |Generalized version of 'E.try'. +try ∷ (MonadBaseControl IO m, Exception e) ⇒ m α → m (Either e α) +try m = liftBaseWith (\runInIO → E.try (runInIO m)) >>= sequenceEither +{-# INLINABLE try #-} + +-- |Generalized version of 'E.tryJust'. +tryJust ∷ (MonadBaseControl IO m, Exception e) ⇒ (e → Maybe β) → m α → m (Either β α) +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 ⇒ α → m α +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 ⇒ ((∀ α. m α → m α) → m β) → m β +mask = liftBaseOp E.mask ∘ liftRestore +{-# INLINABLE mask #-} + +liftRestore ∷ MonadBaseControl IO m + ⇒ ((∀ α. m α → m α) → β) + → ((∀ α. IO α → IO α) → β) +liftRestore f r = f $ liftBaseOp_ r +{-# INLINE liftRestore #-} + +-- |Generalized version of 'E.mask_'. +mask_ ∷ MonadBaseControl IO m ⇒ m α → m α +mask_ = liftBaseOp_ E.mask_ +{-# INLINABLE mask_ #-} + +-- |Generalized version of 'E.uninterruptibleMask'. +uninterruptibleMask ∷ MonadBaseControl IO m ⇒ ((∀ α. m α → m α) → m β) → m β +uninterruptibleMask = liftBaseOp E.uninterruptibleMask ∘ liftRestore +{-# INLINABLE uninterruptibleMask #-} + +-- |Generalized version of 'E.uninterruptibleMask_'. +uninterruptibleMask_ ∷ MonadBaseControl IO m ⇒ m α → m α +uninterruptibleMask_ = liftBaseOp_ E.uninterruptibleMask_ +{-# INLINABLE uninterruptibleMask_ #-} + +-- |Generalized version of 'E.getMaskingState'. +getMaskingState ∷ MonadBase IO m ⇒ m MaskingState +getMaskingState = liftBase E.getMaskingState +{-# INLINABLE getMaskingState #-} +#else +-- |Generalized version of 'E.block'. +block ∷ MonadBaseControl IO m ⇒ m α → m α +block = liftBaseOp_ E.block +{-# INLINABLE block #-} + +-- |Generalized version of 'E.unblock'. +unblock ∷ MonadBaseControl IO m ⇒ m α → m α +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, 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 α -- ^ computation to run first (\"acquire resource\") + → (α → m β) -- ^ computation to run last (\"release resource\") + → (α → m γ) -- ^ computation to run in-between + → m γ +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 α -- ^ computation to run first (\"acquire resource\") + → m β -- ^ computation to run last (\"release resource\") + → m γ -- ^ computation to run in-between + → m γ +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. +-- +-- 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 α -- ^ computation to run first (\"acquire resource\") + → (α → m β) -- ^ computation to run last (\"release resource\") + → (α → m γ) -- ^ computation to run in-between + → m γ +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 α -- ^ computation to run first + → m β -- ^ computation to run afterward (even if an exception was raised) + → m α +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 α → m β → m α +onException m what = control $ \runInIO → + E.onException (runInIO m) + (runInIO what) +{-# INLINABLE onException #-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright © 2010, 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 --- /dev/null +++ b/NEWS diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,5 @@ +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 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,44 @@ +#! /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 --------------------------------------------------------------------- diff --git a/System/Timeout/Lifted.hs b/System/Timeout/Lifted.hs new file mode 100644 --- /dev/null +++ b/System/Timeout/Lifted.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, FlexibleContexts #-} + +------------------------------------------------------------------------------- +-- | +-- 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 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 ) + +-- | 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 α → m (Maybe α) +timeout t m = liftBaseWith (\runInIO → T.timeout t (runInIO m)) >>= + maybe (return Nothing) (liftM Just ∘ restoreM) +{-# INLINABLE timeout #-} diff --git a/lifted-base.cabal b/lifted-base.cabal new file mode 100644 --- /dev/null +++ b/lifted-base.cabal @@ -0,0 +1,67 @@ +Name: lifted-base +Version: 0.1 +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 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 +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 + +-- TODO: Remove when http://hackage.haskell.org/trac/hackage/ticket/792 is fixed: +extra-source-files: test.hs + +-------------------------------------------------------------------------------- + +source-repository head + type: git + location: git://github.com/basvandijk/lifted-base.git + +-------------------------------------------------------------------------------- + +Library + Exposed-modules: Control.Exception.Lifted + Control.Concurrent.MVar.Lifted + Control.Concurrent.Lifted + System.Timeout.Lifted + + Build-depends: base >= 3 && < 4.5 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , transformers-base >= 0.4 && < 0.5 + , monad-control >= 0.3 && < 0.4 + + Ghc-options: -Wall + +-------------------------------------------------------------------------------- + +test-suite test-lifted-base + type: exitcode-stdio-1.0 + main-is: test.hs + + ghc-options: -Wall + + build-depends: base >= 3 && < 4.5 + , base-unicode-symbols >= 0.1.1 && < 0.3 + , transformers >= 0.2 && < 0.3 + , transformers-base >= 0.4 && < 0.5 + , monad-control >= 0.3 && < 0.4 + , HUnit >= 1.2.2 && < 1.3 + , test-framework >= 0.2.4 && < 0.5 + , test-framework-hunit >= 0.2.4 && < 0.3 + +-------------------------------------------------------------------------------- diff --git a/test.hs b/test.hs new file mode 100644 --- /dev/null +++ b/test.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} + +-- from base: +import Prelude hiding (catch) +import Data.IORef +import Data.Maybe +import Data.Typeable (Typeable) + +-- from transformers-base: +import Control.Monad.Base (liftBase) + +import Control.Monad.Trans.Identity +import Control.Monad.Trans.List +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer +import Control.Monad.Trans.Error +import Control.Monad.Trans.State +import qualified Control.Monad.Trans.RWS as RWS + +-- from monad-control: +import Control.Monad.Trans.Control (MonadBaseControl) + +-- from lifted-base (this package): +import Control.Exception.Lifted + +-- from test-framework: +import Test.Framework (defaultMain, testGroup, Test) + + -- from test-framework-hunit: +import Test.Framework.Providers.HUnit + +-- from hunit: +import Test.HUnit hiding (Test) + + +main :: IO () +main = defaultMain + [ testSuite "IdentityT" runIdentityT + , testSuite "ListT" $ fmap head . runListT + , testSuite "MaybeT" $ fmap fromJust . runMaybeT + , testSuite "ReaderT" $ flip runReaderT "reader state" + , testSuite "WriterT" runWriterT' + , testSuite "ErrorT" runErrorT' + , testSuite "StateT" $ flip evalStateT "state state" + , testSuite "RWST" $ \m -> runRWST' m "RWS in" "RWS state" + , testCase "ErrorT throwError" case_throwError + , testCase "WriterT tell" case_tell + ] + where + runWriterT' :: Functor m => WriterT [Int] m a -> m a + runWriterT' = fmap fst . runWriterT + runErrorT' :: Functor m => ErrorT String m () -> m () + runErrorT' = fmap (either (const ()) id) . runErrorT + runRWST' :: (Monad m, Functor m) => RWS.RWST r [Int] s m a -> r -> s -> m a + runRWST' m r s = fmap fst $ RWS.evalRWST m r s + +testSuite :: MonadBaseControl IO m => String -> (m () -> IO ()) -> Test +testSuite s run = testGroup s + [ testCase "finally" $ case_finally run + , testCase "catch" $ case_catch run + , testCase "bracket" $ case_bracket run + , testCase "bracket_" $ case_bracket_ run + , testCase "onException" $ case_onException run + ] + +ignore :: IO () -> IO () +ignore x = + catch x go + where + go :: SomeException -> IO () + go _ = return () + +data Exc = Exc + deriving (Show, Typeable) +instance Exception Exc + +one :: Int +one = 1 + +case_finally :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion +case_finally run = do + i <- newIORef one + ignore + (run $ (do + liftBase $ writeIORef i 2 + error "error") `finally` (liftBase $ writeIORef i 3)) + j <- readIORef i + j @?= 3 + +case_catch :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion +case_catch run = do + i <- newIORef one + run $ (do + liftBase $ writeIORef i 2 + throw Exc) `catch` (\Exc -> liftBase $ writeIORef i 3) + j <- readIORef i + j @?= 3 + +case_bracket :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion +case_bracket run = do + i <- newIORef one + ignore $ run $ bracket + (liftBase $ writeIORef i 2) + (\() -> liftBase $ writeIORef i 4) + (\() -> liftBase $ writeIORef i 3) + j <- readIORef i + j @?= 4 + +case_bracket_ :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion +case_bracket_ run = do + i <- newIORef one + ignore $ run $ bracket_ + (liftBase $ writeIORef i 2) + (liftBase $ writeIORef i 4) + (liftBase $ writeIORef i 3) + j <- readIORef i + j @?= 4 + +case_onException :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion +case_onException run = do + i <- newIORef one + ignore $ run $ onException + (liftBase (writeIORef i 2) >> error "ignored") + (liftBase $ writeIORef i 3) + j <- readIORef i + j @?= 3 + ignore $ run $ onException + (liftBase $ writeIORef i 4) + (liftBase $ writeIORef i 5) + k <- readIORef i + k @?= 4 + +case_throwError :: Assertion +case_throwError = do + i <- newIORef one + Left "throwError" <- runErrorT $ + (liftBase (writeIORef i 2) >> throwError "throwError") + `finally` + (liftBase $ writeIORef i 3) + j <- readIORef i + j @?= 3 + +case_tell :: Assertion +case_tell = do + i <- newIORef one + ((), w) <- runWriterT $ bracket_ + (liftBase (writeIORef i 2) >> tell [1 :: Int]) + (liftBase (writeIORef i 4) >> tell [3]) + (liftBase (writeIORef i 3) >> tell [2]) + j <- readIORef i + j @?= 4 + w @?= [2] + + ((), w') <- runWriterT $ bracket + (liftBase (writeIORef i 5) >> tell [5 :: Int]) + (const $ liftBase (writeIORef i 7) >> tell [7]) + (const $ liftBase (writeIORef i 6) >> tell [6]) + j' <- readIORef i + j' @?= 7 + w' @?= [5, 6]