[Pkg-haskell-commits] darcs: haskell-lifted-base: Initial check-in
Joachim Breitner
mail at joachim-breitner.de
Thu Dec 29 20:08:17 UTC 2011
Thu Dec 29 20:07:43 UTC 2011 Joachim Breitner <mail at joachim-breitner.de>
* Initial check-in
Ignore-this: 72a6945a5c3b0cacf120ebe3b774f62
A ./Control/
A ./Control/Concurrent/
A ./Control/Concurrent/Lifted.hs
A ./Control/Concurrent/MVar/
A ./Control/Concurrent/MVar/Lifted.hs
A ./Control/Exception/
A ./Control/Exception/Lifted.hs
A ./LICENSE
A ./NEWS
A ./README.markdown
A ./Setup.hs
A ./System/
A ./System/Timeout/
A ./System/Timeout/Lifted.hs
A ./debian/
A ./debian/changelog
A ./debian/compat
A ./debian/control
A ./debian/copyright
A ./debian/rules
A ./debian/source/
A ./debian/source/format
A ./debian/watch
A ./include/
A ./include/inlinable.h
A ./lifted-base.cabal
A ./test.hs
Thu Dec 29 20:07:43 UTC 2011 Joachim Breitner <mail at joachim-breitner.de>
* Initial check-in
Ignore-this: 72a6945a5c3b0cacf120ebe3b774f62
diff -rN -u old-haskell-lifted-base//Control/Concurrent/Lifted.hs new-haskell-lifted-base//Control/Concurrent/Lifted.hs
--- old-haskell-lifted-base//Control/Concurrent/Lifted.hs 1970-01-01 00:00:00.000000000 +0000
+++ new-haskell-lifted-base//Control/Concurrent/Lifted.hs 2011-12-29 20:08:17.643670813 +0000
@@ -0,0 +1,224 @@
+{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, FlexibleContexts, RankNTypes #-}
+
+{- |
+Module : Control.Concurrent.Lifted
+Copyright : Bas van Dijk
+License : BSD-style
+
+Maintainer : Bas van Dijk <v.dijk.bas at 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
+#if MIN_VERSION_base(4,4,0)
+ , forkWithUnmask
+#endif
+ , killThread
+ , throwTo
+
+#if MIN_VERSION_base(4,4,0)
+ -- ** Threads with affinity
+ , forkOn
+ , forkOnWithUnmask
+ , getNumCapabilities
+ , threadCapability
+#endif
+
+ -- * 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 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, 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
+
+#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 ⇒ ((∀ α. m α → m α) → m ()) → m ThreadId
+forkWithUnmask f = liftBaseWith $ \runInIO →
+ C.forkIOWithUnmask $ \unmask →
+ void $ runInIO $ f $ liftBaseOp_ unmask
+{-# INLINABLE forkWithUnmask #-}
+#endif
+
+-- | 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 #-}
+
+#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 → ((∀ α. 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 #-}
+#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 #-}
+
+-- | 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 -rN -u old-haskell-lifted-base//Control/Concurrent/MVar/Lifted.hs new-haskell-lifted-base//Control/Concurrent/MVar/Lifted.hs
--- old-haskell-lifted-base//Control/Concurrent/MVar/Lifted.hs 1970-01-01 00:00:00.000000000 +0000
+++ new-haskell-lifted-base//Control/Concurrent/MVar/Lifted.hs 2011-12-29 20:08:17.643670813 +0000
@@ -0,0 +1,162 @@
+{-# LANGUAGE CPP, UnicodeSyntax, NoImplicitPrelude, FlexibleContexts #-}
+
+{- |
+Module : Control.Concurrent.MVar.Lifted
+Copyright : Bas van Dijk
+License : BSD-style
+
+Maintainer : Bas van Dijk <v.dijk.bas at 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
+
+#if __GLASGOW_HASKELL__ < 700
+import Control.Monad ( (>>=), (>>), fail )
+#endif
+
+-- from base-unicode-symbols:
+import Data.Function.Unicode ( (∘) )
+
+-- from transformers-base:
+import Control.Monad.Base ( MonadBase, liftBase )
+
+-- from monad-control:
+import Control.Monad.Trans.Control ( MonadBaseControl, liftBaseOp, liftBaseDiscard )
+
+-- from lifted-base (this package):
+import Control.Exception.Lifted ( onException
+#if MIN_VERSION_base(4,3,0)
+ , mask
+#else
+ , block, unblock
+#endif
+ )
+
+#include "inlinable.h"
+
+--------------------------------------------------------------------------------
+-- * 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 ()
+
+-- | Generalized version of 'MVar.modifyMVar'.
+modifyMVar ∷ (MonadBaseControl IO m, MonadBase IO m) ⇒ MVar α → (α → m (α, β)) → m β
+
+#if MIN_VERSION_base(4,3,0)
+modifyMVar_ mv f = mask $ \restore → do
+ x ← takeMVar mv
+ x' ← restore (f x) `onException` putMVar mv x
+ putMVar mv x'
+
+modifyMVar mv f = mask $ \restore → do
+ x ← takeMVar mv
+ (x', y) ← restore (f x) `onException` putMVar mv x
+ putMVar mv x'
+ return y
+#else
+modifyMVar_ mv f = block $ do
+ x ← takeMVar mv
+ x' ← unblock (f x) `onException` putMVar mv x
+ putMVar mv x'
+
+modifyMVar mv f = block $ do
+ x ← takeMVar mv
+ (x', y) ← unblock (f x) `onException` putMVar mv x
+ putMVar mv x'
+ return y
+#endif
+{-# INLINABLE modifyMVar_ #-}
+{-# 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 -rN -u old-haskell-lifted-base//Control/Exception/Lifted.hs new-haskell-lifted-base//Control/Exception/Lifted.hs
--- old-haskell-lifted-base//Control/Exception/Lifted.hs 1970-01-01 00:00:00.000000000 +0000
+++ new-haskell-lifted-base//Control/Exception/Lifted.hs 2011-12-29 20:08:17.643670813 +0000
@@ -0,0 +1,369 @@
+{-# 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 at 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 )
+import System.IO ( IO )
+
+#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
+
+#include "inlinable.h"
+
+--------------------------------------------------------------------------------
+-- * 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 (\[...incomplete...]
More information about the Pkg-haskell-commits
mailing list