lifted-base (empty) → 0.1
raw patch · 10 files changed
+1065/−0 lines, 10 filesdep +HUnitdep +basedep +base-unicode-symbolsbuild-type:Customsetup-changed
Dependencies added: HUnit, base, base-unicode-symbols, monad-control, test-framework, test-framework-hunit, transformers, transformers-base
Files
- Control/Concurrent/Lifted.hs +211/−0
- Control/Concurrent/MVar/Lifted.hs +136/−0
- Control/Exception/Lifted.hs +371/−0
- LICENSE +29/−0
- NEWS +0/−0
- README.markdown +5/−0
- Setup.hs +44/−0
- System/Timeout/Lifted.hs +41/−0
- lifted-base.cabal +67/−0
- test.hs +161/−0
+ Control/Concurrent/Lifted.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, FlexibleContexts, RankNTypes #-}++{- |+Module : Control.Concurrent.Lifted+Copyright : Bas van Dijk+License : BSD-style++Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>+Stability : experimental++This is a wrapped version of 'Control.Concurrent' 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 #-}
+ Control/Concurrent/MVar/Lifted.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, FlexibleContexts #-}++{- |+Module : Control.Concurrent.MVar.Lifted+Copyright : Bas van Dijk+License : BSD-style++Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>+Stability : experimental++This is a wrapped version of 'Control.Concurrent.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 #-}
+ Control/Exception/Lifted.hs view
@@ -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 <v.dijk.bas@gmail.com>+Stability : experimental+Portability : non-portable (extended exceptions)++This is a wrapped version of @Control.Exception@ with types generalized+from @IO@ to all monads in either 'MonadBase' or 'MonadBaseControl'.+-}++module Control.Exception.Lifted+ ( module Control.Exception++ -- * Throwing exceptions+ , throwIO, ioError++ -- * 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 #-}
+ LICENSE view
@@ -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.
+ NEWS view
+ README.markdown view
@@ -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`.
+ Setup.hs view
@@ -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 ---------------------------------------------------------------------
+ System/Timeout/Lifted.hs view
@@ -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 #-}
+ lifted-base.cabal view
@@ -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 <v.dijk.bas@gmail.com>+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++--------------------------------------------------------------------------------
+ test.hs view
@@ -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]