lifted-threads (empty) → 1.0

raw patch · 5 files changed

+229/−0 lines, 5 filesdep +basedep +monad-controldep +threadssetup-changed

Dependencies added: base, monad-control, threads, transformers-base

Files

LICENSE +30/−0
Setup.hs +2/−0
lifted-threads.cabal +33/−0
src/Control/Concurrent/Thread/Group/Lifted.hs +90/−0
src/Control/Concurrent/Thread/Lifted.hs +74/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2015, Scrive++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 Andrzej Rybczak 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+OWNER 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ lifted-threads.cabal view

@@ -0,0 +1,33 @@+name:                lifted-threads+version:             1.0+synopsis:            lifted IO operations from the threads library++description:         @lifted-threads@ exports IO operations from the base library lifted to+                     any instance of 'MonadBase' or 'MonadBaseControl'.++homepage:            https://github.com/scrive/lifted-threads++license:             BSD3+license-file:        LICENSE+author:              Scrive+maintainer:          Andrzej Rybczak <andrzej@scrive.com>+category:            Concurrency+build-type:          Simple+cabal-version:       >= 1.10++source-repository head+  type:     git+  location: https://github.com/scrive/lifted-threads.git++library+  exposed-modules:     Control.Concurrent.Thread.Lifted+                     , Control.Concurrent.Thread.Group.Lifted++  build-depends:       base >=4.4 && <5+                     , threads >=0.5 && <0.6+                     , transformers-base >=0.4 && <0.5+                     , monad-control >=0.3 && <1.1++  hs-source-dirs:      src+  ghc-options:         -Wall+  default-language:    Haskell2010

+ src/Control/Concurrent/Thread/Group/Lifted.hs view

@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleContexts, RankNTypes #-}+-- | This is a wrapped version of "Control.Concurrent.Thread.Group"+-- with types generalised from 'IO' to all monads in either 'MonadBase'+-- or 'MonadBaseControl'.+module Control.Concurrent.Thread.Group.Lifted (+    TG.ThreadGroup+  , new+  , TG.nrOfRunning+  , wait+  , waitN++  -- * Forking threads+  , fork+  , forkOS+  , forkOn+  , forkWithUnmask+  , forkOnWithUnmask+  ) where++import Control.Concurrent (ThreadId)+import Control.Concurrent.Thread (Result)+import Control.Monad.Base+import Control.Monad.Trans.Control+import qualified Control.Concurrent.Thread.Group as TG++-- | Generalized version of 'TG.new'.+new :: MonadBase IO m => m TG.ThreadGroup+new = liftBase TG.new++-- | Generalized version of 'TG.wait'.+wait :: MonadBase IO m => TG.ThreadGroup -> m ()+wait = liftBase . TG.wait++-- | Generalized version of 'TG.waitN'.+waitN :: MonadBase IO m => Int -> TG.ThreadGroup -> m ()+waitN i = liftBase . TG.waitN i++-- | Generalized version of 'TG.forkIO'.+fork :: MonadBaseControl IO m+     => TG.ThreadGroup+     -> m a+     -> m (ThreadId, m (Result a))+fork tg action = liftBaseWith $ \runInBase -> fixTypes+  =<< TG.forkIO tg (runInBase action)++-- | Generalized version of 'TG.forkOS'.+forkOS :: MonadBaseControl IO m+       => TG.ThreadGroup+       -> m a+       -> m (ThreadId, m (Result a))+forkOS tg action = liftBaseWith $ \runInBase -> fixTypes+  =<< TG.forkOS tg (runInBase action)++-- | Generalized version of 'TG.forkOn'.+forkOn :: MonadBaseControl IO m+       => Int+       -> TG.ThreadGroup+       -> m a+       -> m (ThreadId, m (Result a))+forkOn i tg action = liftBaseWith $ \runInBase -> fixTypes+  =<< TG.forkOn i tg (runInBase action)++-- | Generalized version of 'TG.forkIOWithUnmask'.+forkWithUnmask :: MonadBaseControl IO m+               => TG.ThreadGroup+               -> ((forall b. m b -> m b) -> m a)+               -> m (ThreadId, m (Result a))+forkWithUnmask tg action = liftBaseWith $ \runInBase -> fixTypes+  =<< TG.forkIOWithUnmask tg (\unmask -> runInBase (action (liftBaseOp_ unmask)))++-- | Generalized version of 'TG.forkOnWithUnmask'.+forkOnWithUnmask :: MonadBaseControl IO m+                 => Int+                 -> TG.ThreadGroup+                 -> ((forall b. m b -> m b) -> m a)+                 -> m (ThreadId, m (Result a))+forkOnWithUnmask i tg action = liftBaseWith $ \runInBase -> fixTypes+  =<< TG.forkOnWithUnmask i tg (\unmask -> runInBase (action (liftBaseOp_ unmask)))++----------------------------------------++fixTypes :: MonadBaseControl IO m+         => (ThreadId, IO (Result (StM m a)))+         -> IO (ThreadId, m (Result a))+fixTypes = return . fmap (\c -> liftBase c >>= mapMEither restoreM)+  where+    -- missing instance of Traversable for Either+    mapMEither :: Monad m => (a -> m b) -> Either c a -> m (Either c b)+    mapMEither f (Right r) = f r >>= \v -> return (Right v)+    mapMEither _ (Left v) = return (Left v)

+ src/Control/Concurrent/Thread/Lifted.hs view

@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleContexts, RankNTypes #-}+-- | This is a wrapped version of "Control.Concurrent.Thread" with+-- types generalised from 'IO' to all monads in either 'MonadBase'+-- or 'MonadBaseControl'.+module Control.Concurrent.Thread.Lifted (+  -- * Forking threads+    fork+  , forkOS+  , forkOn+  , forkWithUnmask+  , forkOnWithUnmask+  -- * Results+  , Result+  , result+  ) where++import Control.Concurrent (ThreadId)+import Control.Concurrent.Thread (Result)+import Control.Monad.Base+import Control.Monad.Trans.Control+import qualified Control.Concurrent.Thread as T++-- | Generalized version of 'T.forkIO'.+fork :: MonadBaseControl IO m+     => m a+     -> m (ThreadId, m (Result a))+fork action = liftBaseWith $ \runInBase -> fixTypes+  =<< T.forkIO (runInBase action)++-- | Generalized version of 'T.forkOS'.+forkOS :: MonadBaseControl IO m+       => m a+       -> m (ThreadId, m (Result a))+forkOS action = liftBaseWith $ \runInBase -> fixTypes+  =<< T.forkOS (runInBase action)++-- | Generalized version of 'T.forkOn'.+forkOn :: MonadBaseControl IO m+       => Int+       -> m a+       -> m (ThreadId, m (Result a))+forkOn i action = liftBaseWith $ \runInBase -> fixTypes+  =<< T.forkOn i (runInBase action)++-- | Generalized version of 'T.forkIOWithUnmask'.+forkWithUnmask :: MonadBaseControl IO m+               => ((forall b. m b -> m b) -> m a)+               -> m (ThreadId, m (Result a))+forkWithUnmask action = liftBaseWith $ \runInBase -> fixTypes+  =<< T.forkIOWithUnmask (\unmask -> runInBase (action (liftBaseOp_ unmask)))++-- | Generalized version of 'T.forkOnWithUnmask'.+forkOnWithUnmask :: MonadBaseControl IO m+                 => Int+                 -> ((forall b. m b -> m b) -> m a)+                 -> m (ThreadId, m (Result a))+forkOnWithUnmask i action = liftBaseWith $ \runInBase -> fixTypes+  =<< T.forkOnWithUnmask i (\unmask -> runInBase (action (liftBaseOp_ unmask)))++-- Generalized version of 'T.result'.+result :: MonadBase IO m => Result a -> m a+result = liftBase . T.result++----------------------------------------++fixTypes :: MonadBaseControl IO m+         => (ThreadId, IO (Result (StM m a)))+         -> IO (ThreadId, m (Result a))+fixTypes = return . fmap (\c -> liftBase c >>= mapMEither restoreM)+  where+    -- missing instance of Traversable for Either+    mapMEither :: Monad m => (a -> m b) -> Either c a -> m (Either c b)+    mapMEither f (Right r) = f r >>= \v -> return (Right v)+    mapMEither _ (Left v) = return (Left v)