unliftio 0.2.8.1 → 0.2.25.1
raw patch · 25 files changed
Files
- ChangeLog.md +111/−0
- README.md +22/−36
- bench/ConcBench.hs +136/−0
- cbits/file-posix.c +34/−0
- cbits/time-osx.c +2/−9
- src/UnliftIO.hs +4/−0
- src/UnliftIO/Async.hs +35/−304
- src/UnliftIO/Concurrent.hs +12/−3
- src/UnliftIO/Directory.hs +57/−0
- src/UnliftIO/Exception.hs +133/−77
- src/UnliftIO/Exception/Lens.hs +105/−0
- src/UnliftIO/IO.hs +8/−1
- src/UnliftIO/IO/File.hs +278/−0
- src/UnliftIO/IO/File/Posix.hs +582/−0
- src/UnliftIO/Internals/Async.hs +1081/−0
- src/UnliftIO/QSem.hs +43/−0
- src/UnliftIO/QSemN.hs +43/−0
- src/UnliftIO/STM.hs +10/−2
- src/UnliftIO/Temporary.hs +36/−0
- test/UnliftIO/AsyncSpec.hs +184/−0
- test/UnliftIO/DirectorySpec.hs +31/−0
- test/UnliftIO/ExceptionSpec.hs +96/−0
- test/UnliftIO/IO/FileSpec.hs +201/−0
- test/UnliftIO/PooledAsyncSpec.hs +203/−0
- unliftio.cabal +91/−34
ChangeLog.md view
@@ -1,5 +1,116 @@ # Changelog for unliftio +## 0.2.25.1++* Forward compatibility with `-Wnoncanonical-monoid-instances` becoming an error++## 0.2.25.0++* Add `UnliftIO.Exception.Lens`++## 0.2.24.0++* Add `UnliftIO.STM.writeTMVar`+* Add `UnliftIO.STM.stateTVar`++## 0.2.23.0++* `UnliftIO.Exception` re-exports the `Handler` and sync/async exception wrappers+ from `safe-exceptions`, instead of redefining them.+ * With this change, you won't be able to distinguish between an asynchronous+ exception from `UnliftIO.Exception.throwTo` and `Control.Exception.Safe.throwTo`.+ * [#103](https://github.com/fpco/unliftio/pull/103)++## 0.2.22.0++* Add `UnliftIO.STM.flushTBQueue`+* Add `UnliftIO.STM.lengthTBQueue`++## 0.2.21.0++* Add `UnliftIO.Directory.createDirectoryLink`+* Add `UnliftIO.Directory.removeDirectoryLink`+* Add `UnliftIO.Directory.getSymbolicLinkTarget`+* Add `UnliftIO.Directory.XdgDirectoryList`+* Add `UnliftIO.Directory.getXdgDirectoryList`++## 0.2.20.1++* Fix time-osx.c for aarch64 mac [#91](https://github.com/fpco/unliftio/pull/91)++## 0.2.20++* Add lifted `System.IO.openFile` (https://github.com/fpco/unliftio/pull/88)++## 0.2.19++* Add `Eq` instance for `StringException` (https://github.com/fpco/unliftio/pull/83)++## 0.2.18++* Reexport `asyncExceptionFromException` and `asyncExceptionToException` [#81](https://github.com/fpco/unliftio/issues/81)++## 0.2.17++* Re-export `AsyncCancelled` in `UnliftIO.Async` [#80](https://github.com/fpco/unliftio/pull/80)+* Add `fromExceptionUnwrap` [#80](https://github.com/fpco/unliftio/pull/80)+* Add `catchSyncOrAsync`, `handleSyncOrAsync`, and `trySyncOrAsync` [#80](https://github.com/fpco/unliftio/pull/80)++## 0.2.16++* Add `createFileLink`++## 0.2.15++* Updated documentation mentioning that `MonadUnliftIO` may be derived using+ the `newtype` strategy [#72](https://github.com/fpco/unliftio/pull/72)+* Add `mapExceptionM` [#75](https://github.com/fpco/unliftio/pull/75)++## 0.2.14++* Add `UnliftIO.QSem`+* Add `UnliftIO.QSemN`++## 0.2.13.1++* Improve `UnliftIO.Exception` documentation++## 0.2.13++* Add `UnliftIO.STM.orElse`+* Re-export all of `SeekMode`++## 0.2.12.1++* Minor doc improvements++## 0.2.12++* Dropped support for ghc-7.8+* Addition of `UnliftIO.IO.File` module and atomic+durable file writes:++ * `writeBinaryFile`+ * `writeBinaryFileAtomic`+ * `writeBinaryFileDurable`+ * `writeBinaryFileDurableAtomic`+ * `withBinaryFileAtomic`+ * `withBinaryFileDurable`+ * `withBinaryFileDurableAtomic`+ * `ensureFileDurable`++## 0.2.11++* Deprecate `forkWithUnmask` in favor of the newly added `forkIOWithUnmask` to+ improve consistency. [https://github.com/fpco/unliftio/issues/44]++## 0.2.10++* Add pooling related functions for unliftio++## 0.2.9.0++* Add the new `Conc` datatype as a more efficient alternative to `Concurrently`+ ## 0.2.8.1 * Support for `stm-2.5.0.0`
README.md view
@@ -1,19 +1,12 @@ # unliftio -[](https://travis-ci.org/fpco/unliftio)-[](https://ci.appveyor.com/project/snoyberg/unliftio)+ Provides the core `MonadUnliftIO` typeclass, a number of common instances, and a collection of common functions working with it. Not sure what the `MonadUnliftIO` typeclass is all about? Read on! -__NOTE__ This library is young, and will likely undergo some serious changes-over time. It's also very lightly tested. That said: the core concept of-`MonadUnliftIO` has been refined for years and is pretty solid, and even though-the code here is lightly tested, the vast majority of it is simply apply-`withUnliftIO` to existing functionality. Caveat emptor and all that.- __NOTE__ The `UnliftIO.Exception` module in this library changes the semantics of asynchronous exceptions to be in the style of the `safe-exceptions` package, which is orthogonal to the "unlifting" concept. While this change is an improvment in most cases, it means that `UnliftIO.Exception` is not always a drop-in replacement for `Control.Exception` in advanced exception handling code. See [Async exception safety](#async-exception-safety) for details. ## Quickstart@@ -27,7 +20,7 @@ * Drop the deps on `monad-control`, `lifted-base`, and `exceptions` * Compilation failures? You may have just avoided subtle runtime bugs -Sound like magic? It's not. Keep reading!+Sounds like magic? It's not. Keep reading! ## Unlifting in 2 minutes @@ -82,7 +75,7 @@ (\h -> runReaderT (inner h) env) ``` -I dare you to try to and accomplish this with `MonadIO` and+I dare you to try and accomplish this with `MonadIO` and `liftIO`. It simply can't be done. (If you're looking for the technical reason, it's because `IO` appears in [negative/argument position](https://www.fpcomplete.com/blog/2016/11/covariance-contravariance)@@ -132,31 +125,33 @@ pre-unlifted versions of functions (like `UnliftIO.Exception.catch`). But ultimately, you'll probably want to use the typeclass directly. The type class has only one method ---`askUnliftIO`:+`withRunInIO`: ```haskell-newtype UnliftIO m = UnliftIO { unliftIO :: forall a. m a -> IO a }- class MonadIO m => MonadUnliftIO m where- askUnliftIO :: m (UnliftIO m)+ withRunInIO :: ((forall a. m a -> IO a) -> IO b) -> m b ``` -`askUnliftIO` gives us a function to run arbitrary computation in `m`+`withRunInIO` provides a function to run arbitrary computations in `m` in `IO`. Thus the "unlift": it's like `liftIO`, but the other way around. Here are some sample typeclass instances: ```haskell instance MonadUnliftIO IO where- askUnliftIO = return (UnliftIO id)-instance MonadUnliftIO m => MonadUnliftIO (IdentityT m) where- askUnliftIO = IdentityT $- withUnliftIO $ \u ->- return (UnliftIO (unliftIO u . runIdentityT))+ withRunInIO inner = inner id+ instance MonadUnliftIO m => MonadUnliftIO (ReaderT r m) where- askUnliftIO = ReaderT $ \r ->- withUnliftIO $ \u ->- return (UnliftIO (unliftIO u . flip runReaderT r))+ withRunInIO inner =+ ReaderT $ \r ->+ withRunInIO $ \run ->+ inner (run . flip runReaderT r)++instance MonadUnliftIO m => MonadUnliftIO (IdentityT m) where+ withRunInIO inner =+ IdentityT $+ withRunInIO $ \run ->+ inner (run . runIdentityT) ``` Note that:@@ -164,21 +159,12 @@ * The `IO` instance does not actually do any lifting or unlifting, and therefore it can use `id` * `IdentityT` is essentially just wrapping/unwrapping its data- constructor, and then recursively calling `withUnliftIO` on the+ constructor, and then recursively calling `withRunInIO` on the underlying monad. * `ReaderT` is just like `IdentityT`, but it captures the reader environment when starting. -We can use `askUnliftIO` to unlift a function:--```haskell-timeout :: MonadUnliftIO m => Int -> m a -> m (Maybe a)-timeout x y = do- u <- askUnliftIO- liftIO $ System.Timeout.timeout x $ unliftIO u y-```--or more concisely using `withRunInIO`:+We can use `withRunInIO` to unlift a function: ```haskell timeout :: MonadUnliftIO m => Int -> m a -> m (Maybe a)@@ -374,7 +360,7 @@ The `unliftio-core` package provides just the typeclass with minimal dependencies (just `base` and `transformers`). If you're writing a library, we recommend depending on that package to provide your-instances. The `unliftio` package is a "batteries loaded" library+instances. The `unliftio` package is a "batteries included" library providing a plethora of pre-unlifted helper functions. It's a good choice for importing, or even for use in a custom prelude. @@ -387,7 +373,7 @@ remove the dependency on them here. If there are other temporary orphans that should be added, please-bring it up in the issue tracker or send a PR, but we'll need to be+bring them up in the issue tracker or send a PR, but we'll need to be selective about adding dependencies. ## Future questions
+ bench/ConcBench.hs view
@@ -0,0 +1,136 @@+import Gauge+import Gauge.Main+import Control.Concurrent (threadDelay)+import UnliftIO+import qualified Control.Concurrent.Async as A+import Data.List (foldl')+import Control.Applicative (liftA2, (<|>), empty)++sizes :: (Int -> [Benchmark]) -> [Benchmark]+sizes f = map+ (\size -> bgroup (show size) (f size))+ [1, 2, 10, 100, 1000, 10000, 100000]++sum' :: [Int] -> Int+sum' = foldl' (+) 0+{-# INLINE sum' #-}++replicateA_ :: Applicative f => Int -> f () -> f ()+replicateA_ cnt0 f =+ let go 1 = f+ go i = f *> go (i - 1)+ in go cnt0+{-# INLINE replicateA_ #-}++main :: IO ()+main = defaultMain+ [ bgroup "concurrently, minimal work" $ sizes $ \size ->+ [ bench "A.replicateConcurrently_" $ whnfIO $ do+ ref <- newIORef (0 :: Int)+ A.replicateConcurrently_ size $ atomicModifyIORef' ref $ \i -> (i + 1, ())+ , bench "replicateConcurrently_" $ whnfIO $ do+ ref <- newIORef (0 :: Int)+ replicateConcurrently_ size $ atomicModifyIORef' ref $ \i -> (i + 1, ())+ , bench "Conc" $ whnfIO $ do+ ref <- newIORef (0 :: Int)+ runConc $ replicateA_ size $ conc $ atomicModifyIORef' ref $ \i -> (i + 1, ())+ ]+ , bgroup "concurrently, no results" $ sizes $ \size ->+ [ bench "A.replicateConcurrently_" $ whnfIO $ A.replicateConcurrently_ size (pure ())+ , bench "replicateConcurrently_" $ whnfIO $ replicateConcurrently_ size (pure ())+ , bench "Conc" $ whnfIO $ runConc $ replicateA_ size $ conc $ pure ()+ , bench "Conc, cheating" $ whnfIO $ runConc $ replicateA_ size $ pure ()+ ]+ , bgroup "concurrently, with results" $ sizes $ \size ->+ [ bench "A.mapConcurrently" $ whnfIO $ fmap sum' $ A.mapConcurrently pure [1..size]+ , bench "mapConcurrently" $ whnfIO $ fmap sum' $ mapConcurrently pure [1..size]+ , bench "Conc" $ whnfIO $ runConc $+ let go i+ | i == size = conc (pure i)+ | otherwise = liftA2 (+) (conc (pure i)) (go (i + 1))+ in go 1+ -- This is cheating, since it's using our Pure data constructor+ , bench "Conc, cheating" $ whnfIO $ runConc $+ let go i+ | i == size = pure i+ | otherwise = liftA2 (+) (pure i) (go (i + 1))+ in go 1+ ]+ , bgroup "race" $ sizes $ \size ->+ [ bench "A.Concurrently" $ whnfIO $+ A.runConcurrently $+ foldr (<|>) empty (replicate size (pure ()))+ , bench "Concurrently" $ whnfIO $+ runConcurrently $+ foldr (<|>) empty (replicate size (pure ()))+ , bench "Conc" $ whnfIO $+ runConc $+ foldr (<|>) empty (replicate size (conc (pure ())))+ -- This is cheating, since it's using our Pure data constructor+ , bench "Conc, cheating" $ whnfIO $+ runConc $+ foldr (<|>) empty (replicate size (pure ()))+ ]+ , bgroup "race (with result)" $+ sizes $ \size ->+ [ bench "Concurrently" $+ whnfIO $+ runConcurrently $+ let go i+ | i == size = Concurrently (pure i)+ | otherwise = liftA2 (+) (Concurrently (pure i)) (go (i + 1))+ in (Concurrently $ threadDelay maxBound >> return 0) <|> (go 1) <|>+ (Concurrently $ threadDelay maxBound >> return 0)+ , bench "Conc" $+ whnfIO $+ runConc $+ let go i+ | i == size = conc (pure i)+ | otherwise = liftA2 (+) (conc (pure i)) (go (i + 1))+ in (conc $ threadDelay maxBound >> return 0) <|> (go 1) <|>+ (conc $ threadDelay maxBound >> return 0)+ , bench "Conc, cheating" $+ whnfIO $+ runConc $+ let go i+ | i == size = conc (pure i)+ | otherwise = liftA2 (+) (pure i) (go (i + 1))+ in (conc $ threadDelay maxBound >> return 0) <|> (go 1) <|>+ (conc $ threadDelay maxBound >> return 0)+ ]+ , let size = 10+ in bgroup+ "race (nested)"+ [ bench "Concurrently" $+ whnfIO $+ runConcurrently $+ let go i+ | i == size = Concurrently (pure i)+ | i `mod` 2 == 0 =+ (liftA2 (+) (Concurrently (pure i)) (go (i + 1))) <|>+ (liftA2 (+) (Concurrently (pure i)) (go (i + 2)))+ | otherwise =+ liftA2 (+) (Concurrently (pure i)) (go (i + 1))+ in go 1+ , bench "Conc" $+ whnfIO $+ runConc $+ let go i+ | i == size = conc (pure i)+ | i `mod` 2 == 0 =+ (liftA2 (+) (conc (pure i)) (go (i + 1))) <|>+ (liftA2 (+) (conc (pure i)) (go (i + 2)))+ | otherwise = liftA2 (+) (conc (pure i)) (go (i + 1))+ in go 1+ , bench "Conc, cheating" $+ whnfIO $+ runConc $+ let go i+ | i == size = conc (pure i)+ | i `mod` 2 == 0 =+ (liftA2 (+) (pure i) (go (i + 1))) <|>+ (liftA2 (+) (pure i) (go (i + 2)))+ | otherwise = liftA2 (+) (pure i) (go (i + 1))+ in go 1+ ]+ ]
+ cbits/file-posix.c view
@@ -0,0 +1,34 @@+#include <fcntl.h>+#include <unistd.h>+#include <sys/stat.h>++int unliftio_o_tmpfile( void )+{+#ifdef __O_TMPFILE+ return __O_TMPFILE;+#else+ return 0;+#endif+}++int unliftio_at_fdcwd( void )+{+ return AT_FDCWD;+}++int unliftio_at_symlink_follow( void )+{+ return AT_SYMLINK_FOLLOW;+}+++int unliftio_s_irusr( void )+{+ return S_IRUSR;+}++int unliftio_s_iwusr( void )+{+ return S_IWUSR;+}+
cbits/time-osx.c view
@@ -1,20 +1,13 @@ /* From https://github.com/bos/criterion */ #include <mach/mach.h>-#include <mach/mach_time.h>--static mach_timebase_info_data_t timebase_info;-static double timebase_recip;+#include <time.h> void unliftio_inittime(void) {- if (timebase_recip == 0) {- mach_timebase_info(&timebase_info);- timebase_recip = (timebase_info.denom / timebase_info.numer) / 1e9;- } } double unliftio_gettime(void) {- return mach_absolute_time() * timebase_recip;+ return clock_gettime_nsec_np(CLOCK_UPTIME_RAW); }
src/UnliftIO.hs view
@@ -9,6 +9,8 @@ , module UnliftIO.IORef , module UnliftIO.Memoize , module UnliftIO.MVar+ , module UnliftIO.QSem+ , module UnliftIO.QSemN , module UnliftIO.STM , module UnliftIO.Temporary , module UnliftIO.Timeout@@ -22,6 +24,8 @@ import UnliftIO.IORef import UnliftIO.Memoize import UnliftIO.MVar+import UnliftIO.QSem+import UnliftIO.QSemN import UnliftIO.STM import UnliftIO.Temporary import UnliftIO.Timeout
src/UnliftIO/Async.hs view
@@ -1,5 +1,12 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} -- | Unlifted "Control.Concurrent.Async". -- -- @since 0.1.0.0@@ -36,315 +43,39 @@ -- ** Linking link, link2, + -- ** Pooled concurrency+ pooledMapConcurrentlyN,+ pooledMapConcurrently,+ pooledMapConcurrentlyN_,+ pooledMapConcurrently_,+ pooledForConcurrentlyN,+ pooledForConcurrently,+ pooledForConcurrentlyN_,+ pooledForConcurrently_,+ pooledReplicateConcurrentlyN,+ pooledReplicateConcurrently,+ pooledReplicateConcurrentlyN_,+ pooledReplicateConcurrently_,+ -- * Convenient utilities race, race_, concurrently, concurrently_, mapConcurrently, forConcurrently, mapConcurrently_, forConcurrently_, replicateConcurrently, replicateConcurrently_,- Concurrently(..),- ) where--import Control.Applicative-import Control.Concurrent.Async (Async)-import Control.Exception (SomeException, Exception)-import qualified UnliftIO.Exception as E-import qualified Control.Concurrent.Async as A-import Control.Concurrent (threadDelay)-import Control.Monad (forever, liftM)-import Control.Monad.IO.Unlift+ Concurrently (..), -#if MIN_VERSION_base(4,9,0)-import Data.Semigroup-#else-import Data.Monoid-import Data.Foldable (Foldable)-import Data.Traversable (Traversable)+#if MIN_VERSION_base(4,8,0)+ Conc, conc, runConc,+ ConcException (..), #endif --- | Unlifted 'A.async'.------ @since 0.1.0.0-async :: MonadUnliftIO m => m a -> m (Async a)-async m = withRunInIO $ \run -> A.async $ run m---- | Unlifted 'A.asyncBound'.------ @since 0.1.0.0-asyncBound :: MonadUnliftIO m => m a -> m (Async a)-asyncBound m = withRunInIO $ \run -> A.asyncBound $ run m---- | Unlifted 'A.asyncOn'.------ @since 0.1.0.0-asyncOn :: MonadUnliftIO m => Int -> m a -> m (Async a)-asyncOn i m = withRunInIO $ \run -> A.asyncOn i $ run m---- | Unlifted 'A.asyncWithUnmask'.------ @since 0.1.0.0-asyncWithUnmask :: MonadUnliftIO m => ((forall b. m b -> m b) -> m a) -> m (Async a)-asyncWithUnmask m =- withRunInIO $ \run -> A.asyncWithUnmask $ \unmask -> run $ m $ liftIO . unmask . run---- | Unlifted 'A.asyncOnWithUnmask'.------ @since 0.1.0.0-asyncOnWithUnmask :: MonadUnliftIO m => Int -> ((forall b. m b -> m b) -> m a) -> m (Async a)-asyncOnWithUnmask i m =- withRunInIO $ \run -> A.asyncOnWithUnmask i $ \unmask -> run $ m $ liftIO . unmask . run---- | Unlifted 'A.withAsync'.------ @since 0.1.0.0-withAsync :: MonadUnliftIO m => m a -> (Async a -> m b) -> m b-withAsync a b = withRunInIO $ \run -> A.withAsync (run a) (run . b)---- | Unlifted 'A.withAsyncBound'.------ @since 0.1.0.0-withAsyncBound :: MonadUnliftIO m => m a -> (Async a -> m b) -> m b-withAsyncBound a b = withRunInIO $ \run -> A.withAsyncBound (run a) (run . b)---- | Unlifted 'A.withAsyncOn'.------ @since 0.1.0.0-withAsyncOn :: MonadUnliftIO m => Int -> m a -> (Async a -> m b) -> m b-withAsyncOn i a b = withRunInIO $ \run -> A.withAsyncOn i (run a) (run . b)---- | Unlifted 'A.withAsyncWithUnmask'.------ @since 0.1.0.0-withAsyncWithUnmask- :: MonadUnliftIO m- => ((forall c. m c -> m c) -> m a)- -> (Async a -> m b)- -> m b-withAsyncWithUnmask a b =- withRunInIO $ \run -> A.withAsyncWithUnmask- (\unmask -> run $ a $ liftIO . unmask . run)- (run . b)---- | Unlifted 'A.withAsyncOnWithMask'.------ @since 0.1.0.0-withAsyncOnWithUnmask- :: MonadUnliftIO m- => Int- -> ((forall c. m c -> m c) -> m a)- -> (Async a -> m b)- -> m b-withAsyncOnWithUnmask i a b =- withRunInIO $ \run -> A.withAsyncOnWithUnmask i- (\unmask -> run $ a $ liftIO . unmask . run)- (run . b)---- | Lifted 'A.wait'.------ @since 0.1.0.0-wait :: MonadIO m => Async a -> m a-wait = liftIO . A.wait---- | Lifted 'A.poll'.------ @since 0.1.0.0-poll :: MonadIO m => Async a -> m (Maybe (Either SomeException a))-poll = liftIO . A.poll---- | Lifted 'A.waitCatch'.------ @since 0.1.0.0-waitCatch :: MonadIO m => Async a -> m (Either SomeException a)-waitCatch = liftIO . A.waitCatch---- | Lifted 'A.cancel'.------ @since 0.1.0.0-cancel :: MonadIO m => Async a -> m ()-cancel = liftIO . A.cancel---- | Lifted 'A.uninterruptibleCancel'.------ @since 0.1.0.0-uninterruptibleCancel :: MonadIO m => Async a -> m ()-uninterruptibleCancel = liftIO . A.uninterruptibleCancel---- | Lifted 'A.cancelWith'. Additionally uses 'E.toAsyncException' to--- ensure async exception safety.------ @since 0.1.0.0-cancelWith :: (Exception e, MonadIO m) => Async a -> e -> m ()-cancelWith a e = liftIO (A.cancelWith a (E.toAsyncException e))---- | Lifted 'A.waitAny'.------ @since 0.1.0.0-waitAny :: MonadIO m => [Async a] -> m (Async a, a)-waitAny = liftIO . A.waitAny---- | Lifted 'A.waitAnyCatch'.------ @since 0.1.0.0-waitAnyCatch :: MonadIO m => [Async a] -> m (Async a, Either SomeException a)-waitAnyCatch = liftIO . A.waitAnyCatch---- | Lifted 'A.waitAnyCancel'.------ @since 0.1.0.0-waitAnyCancel :: MonadIO m => [Async a] -> m (Async a, a)-waitAnyCancel = liftIO . A.waitAnyCancel---- | Lifted 'A.waitAnyCatchCancel'.------ @since 0.1.0.0-waitAnyCatchCancel :: MonadIO m => [Async a] -> m (Async a, Either SomeException a)-waitAnyCatchCancel = liftIO . A.waitAnyCatchCancel---- | Lifted 'A.waitEither'.------ @since 0.1.0.0-waitEither :: MonadIO m => Async a -> Async b -> m (Either a b)-waitEither a b = liftIO (A.waitEither a b)---- | Lifted 'A.waitEitherCatch'.------ @since 0.1.0.0-waitEitherCatch :: MonadIO m => Async a -> Async b -> m (Either (Either SomeException a) (Either SomeException b))-waitEitherCatch a b = liftIO (A.waitEitherCatch a b)---- | Lifted 'A.waitEitherCancel'.------ @since 0.1.0.0-waitEitherCancel :: MonadIO m => Async a -> Async b -> m (Either a b)-waitEitherCancel a b = liftIO (A.waitEitherCancel a b)---- | Lifted 'A.waitEitherCatchCancel'.------ @since 0.1.0.0-waitEitherCatchCancel :: MonadIO m => Async a -> Async b -> m (Either (Either SomeException a) (Either SomeException b))-waitEitherCatchCancel a b = liftIO (A.waitEitherCatchCancel a b)---- | Lifted 'A.waitEither_'.------ @since 0.1.0.0-waitEither_ :: MonadIO m => Async a -> Async b -> m ()-waitEither_ a b = liftIO (A.waitEither_ a b)---- | Lifted 'A.waitBoth'.------ @since 0.1.0.0-waitBoth :: MonadIO m => Async a -> Async b -> m (a, b)-waitBoth a b = liftIO (A.waitBoth a b)---- | Lifted 'A.link'.------ @since 0.1.0.0-link :: MonadIO m => Async a -> m ()-link = liftIO . A.link---- | Lifted 'A.link2'.------ @since 0.1.0.0-link2 :: MonadIO m => Async a -> Async b -> m ()-link2 a b = liftIO (A.link2 a b)---- | Unlifted 'A.race'.------ @since 0.1.0.0-race :: MonadUnliftIO m => m a -> m b -> m (Either a b)-race a b = withRunInIO $ \run -> A.race (run a) (run b)---- | Unlifted 'A.race_'.------ @since 0.1.0.0-race_ :: MonadUnliftIO m => m a -> m b -> m ()-race_ a b = withRunInIO $ \run -> A.race_ (run a) (run b)---- | Unlifted 'A.concurrently'.------ @since 0.1.0.0-concurrently :: MonadUnliftIO m => m a -> m b -> m (a, b)-concurrently a b = withRunInIO $ \run -> A.concurrently (run a) (run b)---- | Unlifted 'A.concurrently_'.------ @since 0.1.0.0-concurrently_ :: MonadUnliftIO m => m a -> m b -> m ()-concurrently_ a b = withRunInIO $ \run -> A.concurrently_ (run a) (run b)---- | Unlifted 'A.mapConcurrently'.------ @since 0.1.0.0-mapConcurrently :: MonadUnliftIO m => Traversable t => (a -> m b) -> t a -> m (t b)-mapConcurrently f t = withRunInIO $ \run -> A.mapConcurrently (run . f) t---- | Unlifted 'A.forConcurrently'.------ @since 0.1.0.0-forConcurrently :: MonadUnliftIO m => Traversable t => t a -> (a -> m b) -> m (t b)-forConcurrently t f = withRunInIO $ \run -> A.forConcurrently t (run . f)---- | Unlifted 'A.mapConcurrently_'.------ @since 0.1.0.0-mapConcurrently_ :: MonadUnliftIO m => Foldable f => (a -> m b) -> f a -> m ()-mapConcurrently_ f t = withRunInIO $ \run -> A.mapConcurrently_ (run . f) t---- | Unlifted 'A.forConcurrently_'.------ @since 0.1.0.0-forConcurrently_ :: MonadUnliftIO m => Foldable f => f a -> (a -> m b) -> m ()-forConcurrently_ t f = withRunInIO $ \run -> A.forConcurrently_ t (run . f)---- | Unlifted 'A.replicateConcurrently'.------ @since 0.1.0.0-replicateConcurrently :: MonadUnliftIO m => Int -> m a -> m [a]-replicateConcurrently i m = withRunInIO $ \run -> A.replicateConcurrently i (run m)---- | Unlifted 'A.replicateConcurrently_'.------ @since 0.1.0.0-replicateConcurrently_ :: MonadUnliftIO m => Int -> m a -> m ()-replicateConcurrently_ i m = withRunInIO $ \run -> A.replicateConcurrently_ i (run m)---- | Unlifted 'A.Concurrently'.------ @since 0.1.0.0-newtype Concurrently m a = Concurrently- { runConcurrently :: m a- }---- | @since 0.1.0.0-instance Monad m => Functor (Concurrently m) where- fmap f (Concurrently a) = Concurrently $ liftM f a---- | @since 0.1.0.0-instance MonadUnliftIO m => Applicative (Concurrently m) where- pure = Concurrently . return- Concurrently fs <*> Concurrently as =- Concurrently $ liftM (\(f, a) -> f a) (concurrently fs as)---- | @since 0.1.0.0-instance MonadUnliftIO m => Alternative (Concurrently m) where- empty = Concurrently $ liftIO (forever (threadDelay maxBound))- Concurrently as <|> Concurrently bs =- Concurrently $ liftM (either id id) (race as bs)--#if MIN_VERSION_base(4,9,0)--- | Only defined by @async@ for @base >= 4.9@.------ @since 0.1.0.0-instance (MonadUnliftIO m, Semigroup a) => Semigroup (Concurrently m a) where- (<>) = liftA2 (<>)---- | @since 0.1.0.0-instance (Semigroup a, Monoid a, MonadUnliftIO m) => Monoid (Concurrently m a) where- mempty = pure mempty- mappend = (<>)-#else--- | @since 0.1.0.0-instance (Monoid a, MonadUnliftIO m) => Monoid (Concurrently m a) where- mempty = pure mempty- mappend = liftA2 mappend+ -- * Re-exports+#if MIN_VERSION_async(2,2,0)+ A.AsyncCancelled (..), #endif+ ) where++import Control.Concurrent.Async (Async)+import qualified Control.Concurrent.Async as A+import UnliftIO.Internals.Async
src/UnliftIO/Concurrent.hs view
@@ -11,7 +11,7 @@ ThreadId, -- * Basic concurrency operations- myThreadId, forkIO, forkWithUnmask, forkFinally, killThread, throwTo,+ myThreadId, forkIO, forkWithUnmask, forkIOWithUnmask, forkFinally, killThread, throwTo, -- ** Threads with affinity forkOn, forkOnWithUnmask, getNumCapabilities, setNumCapabilities,@@ -60,11 +60,20 @@ -- | Unlifted version of 'C.forkIOWithUnmask'. --+-- @since 0.2.11+forkIOWithUnmask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m ()) -> m ThreadId+forkIOWithUnmask m =+ withRunInIO $ \run -> C.forkIOWithUnmask $ \unmask -> run $ m $ liftIO . unmask . run+{-# INLINABLE forkIOWithUnmask #-}++-- | Please use 'forkIOWithUnmask' instead. This function has been deprecated+-- in release 0.2.11 and will be removed in the next major release.+-- -- @since 0.1.1.0 forkWithUnmask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m ()) -> m ThreadId-forkWithUnmask m =- withRunInIO $ \run -> C.forkIOWithUnmask $ \unmask -> run $ m $ liftIO . unmask . run+forkWithUnmask = forkIOWithUnmask {-# INLINABLE forkWithUnmask #-}+{-# DEPRECATED forkWithUnmask "forkWithUnmask has been renamed to forkIOWithUnmask" #-} -- | Unlifted version of 'C.forkFinally'. --
src/UnliftIO/Directory.hs view
@@ -7,6 +7,12 @@ -- * Actions on directories createDirectory , createDirectoryIfMissing+#if MIN_VERSION_directory(1,3,1)+ , createFileLink+ , createDirectoryLink+ , removeDirectoryLink+ , getSymbolicLinkTarget+#endif , removeDirectory , removeDirectoryRecursive #if MIN_VERSION_directory(1,2,7)@@ -31,6 +37,10 @@ , XdgDirectory(..) , getXdgDirectory #endif+#if MIN_VERSION_directory(1,3,2)+ , XdgDirectoryList(..)+ , getXdgDirectoryList+#endif , getAppUserDataDirectory , getUserDocumentsDirectory , getTemporaryDirectory@@ -120,6 +130,9 @@ #if MIN_VERSION_directory(1,2,3) , XdgDirectory(..) #endif+#if MIN_VERSION_directory(1,3,2)+ , XdgDirectoryList(..)+#endif , emptyPermissions #if MIN_VERSION_directory(1,2,4) , exeExtension@@ -149,6 +162,41 @@ createDirectoryIfMissing create_parents path0 = liftIO (D.createDirectoryIfMissing create_parents path0) +#if MIN_VERSION_directory(1,3,1)+-- | Lifted 'D.createFileLink'.+-- directory package version should be >= 1.3.1.+-- @since 0.2.16.0+{-# INLINE createFileLink #-}+createFileLink+ :: MonadIO m+ => FilePath -- ^ path to the target file+ -> FilePath -- ^ path of the link to be created+ -> m ()+createFileLink targetPath linkPath =+ liftIO (D.createFileLink targetPath linkPath)++-- | Lifted 'D.createDirectoryLink'.+--+-- @since 0.2.21.0+createDirectoryLink :: MonadIO m => FilePath -> FilePath -> m ()+createDirectoryLink targetPath linkPath =+ liftIO (D.createDirectoryLink targetPath linkPath)++-- | Lifted 'D.removeDirectoryLink'.+--+-- @since 0.2.21.0+removeDirectoryLink :: MonadIO m => FilePath -> m ()+removeDirectoryLink linkPath =+ liftIO (D.removeDirectoryLink linkPath)++-- | Lifted 'D.getSymbolicLinkTarget'.+--+-- @since 0.2.21.0+getSymbolicLinkTarget :: MonadIO m => FilePath -> m FilePath+getSymbolicLinkTarget linkPath =+ liftIO (D.getSymbolicLinkTarget linkPath)+#endif+ -- | Lifted 'D.removeDirectory'. -- -- @since 0.2.6.0@@ -233,6 +281,15 @@ {-# INLINE getXdgDirectory #-} getXdgDirectory :: MonadIO m => XdgDirectory -> FilePath -> m FilePath getXdgDirectory xdgDir suffix = liftIO (D.getXdgDirectory xdgDir suffix)+#endif++#if MIN_VERSION_directory(1,3,2)+-- | Lifted 'D.getXdgDirectoryList'.+--+-- @since 0.2.21.0+getXdgDirectoryList :: MonadIO m => XdgDirectoryList -> m [FilePath]+getXdgDirectoryList xdgDirectoryList =+ liftIO (D.getXdgDirectoryList xdgDirectoryList) #endif -- | Lifted 'D.getAppUserDataDirectory'.
src/UnliftIO/Exception.hs view
@@ -6,6 +6,10 @@ {-# LANGUAGE ImplicitParams #-} -- | Unlifted "Control.Exception", with extra async exception safety -- and more helper functions.+--+-- This module works best when your cleanup functions adhere to certain+-- expectations around exception safety and interruptible actions.+-- For more details, see [this exception safety tutorial](https://www.fpcomplete.com/haskell/tutorial/exceptions/). module UnliftIO.Exception ( -- * Throwing throwIO@@ -17,6 +21,8 @@ , fromEither , fromEitherIO , fromEitherM+ , mapExceptionM+ -- * Catching (with recovery) , catch , catchIO@@ -41,10 +47,15 @@ , pureTry , pureTryDeep - , Handler(..)+ , ESafe.Handler (..) , catches , catchesDeep + -- * Catching async exceptions (with recovery)+ , catchSyncOrAsync+ , handleSyncOrAsync+ , trySyncOrAsync+ -- * Cleanup (no recovery) , onException , bracket@@ -55,10 +66,13 @@ , bracketOnError_ -- * Coercion to sync and async- , SyncExceptionWrapper (..)+ -- | In version /0.2.23.0/, these were changed with aliases to the values+ -- from "Control.Exception.Safe" in the @safe-exceptions@ package.+ , ESafe.SyncExceptionWrapper(..) , toSyncException- , AsyncExceptionWrapper (..)+ , ESafe.AsyncExceptionWrapper(..) , toAsyncException+ , fromExceptionUnwrap -- * Check exception type , isSyncException@@ -78,6 +92,8 @@ , SomeAsyncException (..) , IOException , EUnsafe.assert+ , EUnsafe.asyncExceptionToException+ , EUnsafe.asyncExceptionFromException #if !MIN_VERSION_base(4,8,0) , displayException #endif@@ -91,16 +107,25 @@ import Control.DeepSeq (NFData (..), ($!!)) import Data.Typeable (Typeable, cast) import System.IO.Unsafe (unsafePerformIO)+import qualified Control.Exception.Safe as ESafe+import Control.Exception.Safe (Handler(..)) #if MIN_VERSION_base(4,9,0) import GHC.Stack (prettySrcLoc) import GHC.Stack.Types (HasCallStack, CallStack, getCallStack) #endif --- | Unlifted 'EUnsafe.catch', but will not catch asynchronous exceptions.+-- | Catch a synchronous (but not asynchronous) exception and recover from it. --+-- This is parameterized on the exception type. To catch all synchronous exceptions,+-- use 'catchAny'.+-- -- @since 0.1.0.0-catch :: (MonadUnliftIO m, Exception e) => m a -> (e -> m a) -> m a+catch+ :: (MonadUnliftIO m, Exception e)+ => m a -- ^ action+ -> (e -> m a) -- ^ handler+ -> m a catch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> if isSyncException e then run (g e)@@ -114,7 +139,7 @@ catchIO :: MonadUnliftIO m => m a -> (IOException -> m a) -> m a catchIO = catch --- | 'catch' specialized to catch all synchronous exception.+-- | 'catch' specialized to catch all synchronous exceptions. -- -- @since 0.1.0.0 catchAny :: MonadUnliftIO m => m a -> (SomeException -> m a) -> m a@@ -142,6 +167,19 @@ catchJust :: (MonadUnliftIO m, Exception e) => (e -> Maybe b) -> m a -> (b -> m a) -> m a catchJust f a b = a `catch` \e -> maybe (liftIO (throwIO e)) b $ f e +-- | A variant of 'catch' that catches both synchronous and asynchronous exceptions.+--+-- WARNING: This function (and other @*SyncOrAsync@ functions) is for advanced users. Most of the+-- time, you probably want to use the non-@SyncOrAsync@ versions.+--+-- Before attempting to use this function, be familiar with the "Rules for async safe handling"+-- section in+-- [this blog post](https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/).+--+-- @since 0.2.17+catchSyncOrAsync :: (MonadUnliftIO m, Exception e) => m a -> (e -> m a) -> m a+catchSyncOrAsync f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> run (g e)+ -- | Flipped version of 'catch'. -- -- @since 0.1.0.0@@ -178,8 +216,19 @@ handleJust :: (MonadUnliftIO m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a handleJust f = flip (catchJust f) --- | Unlifted 'EUnsafe.try', but will not catch asynchronous exceptions.+-- | A variant of 'handle' that catches both synchronous and asynchronous exceptions. --+-- See 'catchSyncOrAsync'.+--+-- @since 0.2.17+handleSyncOrAsync :: (MonadUnliftIO m, Exception e) => (e -> m a) -> m a -> m a+handleSyncOrAsync = flip catchSyncOrAsync++-- | Run the given action and catch any synchronous exceptions as a 'Left' value.+--+-- This is parameterized on the exception type. To catch all synchronous exceptions,+-- use 'tryAny'.+-- -- @since 0.1.0.0 try :: (MonadUnliftIO m, Exception e) => m a -> m (Either e a) try f = catch (liftM Right f) (return . Left)@@ -216,6 +265,14 @@ tryJust :: (MonadUnliftIO m, Exception e) => (e -> Maybe b) -> m a -> m (Either b a) tryJust f a = catch (Right `liftM` a) (\e -> maybe (throwIO e) (return . Left) (f e)) +-- | A variant of 'try' that catches both synchronous and asynchronous exceptions.+--+-- See 'catchSyncOrAsync'.+--+-- @since 0.2.17+trySyncOrAsync :: (MonadUnliftIO m, Exception e) => m a -> m (Either e a)+trySyncOrAsync f = catchSyncOrAsync (liftM Right f) (return . Left)+ -- | Evaluate the value to WHNF and catch any synchronous exceptions. -- -- The expression may still have bottom values within it; you may@@ -231,22 +288,19 @@ pureTryDeep :: NFData a => a -> Either SomeException a pureTryDeep = unsafePerformIO . tryAnyDeep . return --- | Generalized version of 'EUnsafe.Handler'.------ @since 0.1.0.0-data Handler m a = forall e . Exception e => Handler (e -> m a)- -- | Internal. catchesHandler :: MonadIO m => [Handler m a] -> SomeException -> m a catchesHandler handlers e = foldr tryHandler (liftIO (EUnsafe.throwIO e)) handlers- where tryHandler (Handler handler) res+ where tryHandler (ESafe.Handler handler) res = case fromException e of Just e' -> handler e' Nothing -> res --- | Same as upstream 'EUnsafe.catches', but will not catch--- asynchronous exceptions.+-- | Similar to 'catch', but provides multiple different handler functions. --+-- For more information on motivation, see @base@'s 'EUnsafe.catches'. Note that,+-- unlike that function, this function will not catch asynchronous exceptions.+-- -- @since 0.1.0.0 catches :: MonadUnliftIO m => m a -> [Handler m a] -> m a catches io handlers = io `catch` catchesHandler handlers@@ -270,8 +324,21 @@ evaluateDeep :: (MonadIO m, NFData a) => a -> m a evaluateDeep = (evaluate $!!) --- | Async safe version of 'EUnsafe.bracket'.+-- | Allocate and clean up a resource safely. --+-- For more information on motivation and usage of this function, see @base@'s+-- 'EUnsafe.bracket'. This function has two differences from the one in @base@.+-- The first, and more obvious, is that it works on any @MonadUnliftIO@+-- instance, not just @IO@.+--+-- The more subtle difference is that this function will use uninterruptible+-- masking for its cleanup handler. This is a subtle distinction, but at a+-- high level, means that resource cleanup has more guarantees to complete.+-- This comes at the cost that an incorrectly written cleanup function+-- cannot be interrupted.+--+-- For more information, please see <https://github.com/fpco/safe-exceptions/issues/3>.+-- -- @since 0.1.0.0 bracket :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m c) -> m c bracket before after thing = withRunInIO $ \run -> EUnsafe.mask $ \restore -> do@@ -291,13 +358,15 @@ _ <- EUnsafe.uninterruptibleMask_ $ run $ after x return y --- | Async safe version of 'EUnsafe.bracket_'.+-- | Same as 'bracket', but does not pass the acquired resource to cleanup and use functions. --+-- For more information, see @base@'s 'EUnsafe.bracket_'.+-- -- @since 0.1.0.0 bracket_ :: MonadUnliftIO m => m a -> m b -> m c -> m c bracket_ before after thing = bracket before (const after) (const thing) --- | Async safe version of 'EUnsafe.bracketOnError'.+-- | Same as 'bracket', but only perform the cleanup if an exception is thrown. -- -- @since 0.1.0.0 bracketOnError :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m c) -> m c@@ -319,10 +388,17 @@ bracketOnError_ :: MonadUnliftIO m => m a -> m b -> m c -> m c bracketOnError_ before after thing = bracketOnError before (const after) (const thing) --- | Async safe version of 'EUnsafe.finally'.+-- | Perform @thing@, guaranteeing that @after@ will run after, even if an exception occurs. --+-- Same interruptible vs uninterrupible points apply as with 'bracket'. See @base@'s+-- 'EUnsafe.finally' for more information.+-- -- @since 0.1.0.0-finally :: MonadUnliftIO m => m a -> m b -> m a+finally+ :: MonadUnliftIO m+ => m a -- ^ thing+ -> m b -- ^ after+ -> m a finally thing after = withRunInIO $ \run -> EUnsafe.uninterruptibleMask $ \restore -> do res1 <- EUnsafe.try $ restore $ run thing case res1 of@@ -349,7 +425,7 @@ EUnsafe.throwIO e1 Right x -> return x --- | Async safe version of 'EUnsafe.onException'.+-- | Like 'finally', but only call @after@ if an exception occurs. -- -- @since 0.1.0.0 onException :: MonadUnliftIO m => m a -> m b -> m a@@ -357,27 +433,13 @@ -- | Synchronously throw the given exception. --+-- Note that, if you provide an exception value which is of an asynchronous+-- type, it will be wrapped up in 'SyncExceptionWrapper'. See 'toSyncException'.+-- -- @since 0.1.0.0 throwIO :: (MonadIO m, Exception e) => e -> m a throwIO = liftIO . EUnsafe.throwIO . toSyncException --- | Wrap up an asynchronous exception to be treated as a synchronous--- exception.------ This is intended to be created via 'toSyncException'.------ @since 0.1.0.0-data SyncExceptionWrapper = forall e. Exception e => SyncExceptionWrapper e- deriving Typeable--- | @since 0.1.0.0-instance Show SyncExceptionWrapper where- show (SyncExceptionWrapper e) = show e--- | @since 0.1.0.0-instance Exception SyncExceptionWrapper where-#if MIN_VERSION_base(4,8,0)- displayException (SyncExceptionWrapper e) = displayException e-#endif- -- | Convert an exception into a synchronous exception. -- -- For synchronous exceptions, this is the same as 'toException'.@@ -386,33 +448,8 @@ -- -- @since 0.1.0.0 toSyncException :: Exception e => e -> SomeException-toSyncException e =- case fromException se of- Just (SomeAsyncException _) -> toException (SyncExceptionWrapper e)- Nothing -> se- where- se = toException e---- | Wrap up a synchronous exception to be treated as an asynchronous--- exception.------ This is intended to be created via 'toAsyncException'.------ @since 0.1.0.0-data AsyncExceptionWrapper = forall e. Exception e => AsyncExceptionWrapper e- deriving Typeable--- | @since 0.1.0.0-instance Show AsyncExceptionWrapper where- show (AsyncExceptionWrapper e) = show e--- | @since 0.1.0.0-instance Exception AsyncExceptionWrapper where- toException = toException . SomeAsyncException- fromException se = do- SomeAsyncException e <- fromException se- cast e-#if MIN_VERSION_base(4,8,0)- displayException (AsyncExceptionWrapper e) = displayException e-#endif+toSyncException =+ ESafe.toSyncException -- | Convert an exception into an asynchronous exception. --@@ -422,21 +459,29 @@ -- -- @since 0.1.0.0 toAsyncException :: Exception e => e -> SomeException-toAsyncException e =- case fromException se of- Just (SomeAsyncException _) -> se- Nothing -> toException (AsyncExceptionWrapper e)- where- se = toException e+toAsyncException =+ ESafe.toAsyncException +-- | Convert from a possibly wrapped exception.+--+-- The inverse of 'toAsyncException' and 'toSyncException'. When using those+-- functions (or functions that use them, like 'throwTo' or 'throwIO'),+-- 'fromException' might not be sufficient because the exception might be+-- wrapped within 'SyncExceptionWrapper' or 'AsyncExceptionWrapper'.+--+-- @since 0.2.17+fromExceptionUnwrap :: Exception e => SomeException -> Maybe e+fromExceptionUnwrap se+ | Just (ESafe.AsyncExceptionWrapper e) <- fromException se = cast e+ | Just (ESafe.SyncExceptionWrapper e) <- fromException se = cast e+ | otherwise = fromException se+ -- | Check if the given exception is synchronous. -- -- @since 0.1.0.0 isSyncException :: Exception e => e -> Bool-isSyncException e =- case fromException (toException e) of- Just (SomeAsyncException _) -> False- Nothing -> True+isSyncException =+ ESafe.isSyncException -- | Check if the given exception is asynchronous. --@@ -529,7 +574,7 @@ -- | @since 0.1.0.0 instance Show StringException where show (StringException s cs) = concat- $ "Control.Exception.Safe.throwString called with:\n\n"+ $ "UnliftIO.Exception.throwString called with:\n\n" : s : "\nCalled from:\n" : map go (getCallStack cs)@@ -547,9 +592,13 @@ -- | @since 0.1.0.0 instance Show StringException where- show (StringException s _) = "Control.Exception.Safe.throwString called with:\n\n" ++ s+ show (StringException s _) = "UnliftIO.Exception.throwString called with:\n\n" ++ s #endif +-- | @since 0.2.19+instance Eq StringException where+ StringException msg1 _ == StringException msg2 _ = msg1 == msg2+ -- | @since 0.1.0.0 instance Exception StringException @@ -594,3 +643,10 @@ -- @since 0.1.0.0 fromEitherM :: (Exception e, MonadIO m) => m (Either e a) -> m a fromEitherM = (>>= fromEither)++-- | Same as 'Control.Exception.mapException', except works in+-- a monadic context.+--+-- @since 0.2.15+mapExceptionM :: (Exception e1, Exception e2, MonadUnliftIO m) => (e1 -> e2) -> m a -> m a+mapExceptionM f = handle (throwIO . f)
+ src/UnliftIO/Exception/Lens.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Functions from "Control.Exception.Lens", but using 'MonadUnliftIO', not+-- 'MonadCatch'+module UnliftIO.Exception.Lens+ ( catching+ , catching_+ , handling+ , handling_+ , trying+ , trying_+ ) where++import Prelude++import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad (liftM)+import Data.Monoid (First)+import UnliftIO.Exception (SomeException, catchJust, tryJust)+import Control.Applicative (Const(..))+import Data.Monoid (First(..))++#if __GLASGOW_HASKELL__ >= 708+import Data.Coerce+#else+import Unsafe.Coerce+#endif++-- | 'Control.Exception.Lens.catching' using 'MonadUnliftIO'+--+-- @since 0.2.25.0+catching :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> (a -> m r) -> m r+catching l = catchJust (preview l)+{-# INLINE catching #-}++-- | 'Control.Exception.Lens.catching_' using 'MonadUnliftIO'+--+-- @since 0.2.25.0+catching_ :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m r -> m r+catching_ l a b = catchJust (preview l) a (const b)+{-# INLINE catching_ #-}++-- | 'Control.Exception.Lens.handling' using 'MonadUnliftIO'+--+-- @since 0.2.25.0+handling :: MonadUnliftIO m => Getting (First a) SomeException a -> (a -> m r) -> m r -> m r+handling l = flip (catching l)+{-# INLINE handling #-}++-- | 'Control.Exception.Lens.handling_' using 'MonadUnliftIO'+--+-- @since 0.2.25.0+handling_ :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m r -> m r+handling_ l = flip (catching_ l)+{-# INLINE handling_ #-}++-- | 'Control.Exception.Lens.trying' using 'MonadUnliftIO'+--+-- @since 0.2.25.0+trying :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m (Either a r)+trying l = tryJust (preview l)+{-# INLINE trying #-}++-- | 'Control.Exception.Lens.trying_' using 'MonadUnliftIO'+--+-- @since 0.2.25.0+trying_ :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m (Maybe r)+trying_ l m = preview _Right `liftM` trying l m+{-# INLINE trying_ #-}++--------------------------------------------------------------------------------+-- Enough of (micro)lens to accomplish this mondule without any dependencies+--+-- TODO: code review note: should we just bring in microlens?+--------------------------------------------------------------------------------+type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t++_Right :: Traversal (Either a b) (Either a b') b b'+_Right f (Right b) = Right <$> f b+_Right _ (Left a) = pure (Left a)+{-# INLINE _Right #-}++type Getting r s a = (a -> Const r a) -> s -> Const r s++preview :: Getting (First a) s a -> s -> Maybe a+preview l = getFirst #. foldMapOf l (First #. Just)+{-# INLINE preview #-}++foldMapOf :: Getting r s a -> (a -> r) -> s -> r+foldMapOf l f = getConst #. l (Const #. f)+{-# INLINE foldMapOf #-}++#if __GLASGOW_HASKELL__ >= 708+( #. ) :: Coercible c b => (b -> c) -> (a -> b) -> (a -> c)+( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b+#else+( #. ) :: (b -> c) -> (a -> b) -> (a -> c)+( #. ) _ = unsafeCoerce+#endif++{-# INLINE ( #. ) #-}++infixr 9 #.
src/UnliftIO/IO.hs view
@@ -9,6 +9,7 @@ , IO.stderr , withFile , withBinaryFile+ , openFile , hClose , hFlush , hFileSize@@ -18,7 +19,7 @@ , hSetBuffering , hGetBuffering , hSeek- , IO.SeekMode+ , IO.SeekMode (..) , hTell , hIsOpen , hIsClosed@@ -50,6 +51,12 @@ -- @since 0.1.0.0 withBinaryFile :: MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m a) -> m a withBinaryFile fp mode inner = withRunInIO $ \run -> IO.withBinaryFile fp mode $ run . inner++-- | Lifted version of 'IO.openFile'+--+-- @since 0.2.20+openFile :: MonadIO m => FilePath -> IOMode -> m Handle+openFile fp = liftIO . IO.openFile fp -- | Lifted version of 'IO.hClose' --
+ src/UnliftIO/IO/File.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE CPP #-}+{-|++== Rationale++This module offers functions to handle files that offer better durability and/or+atomicity.++== When to use functions in this module?++Given the usage of this functions comes at a cost in performance, it is important to+consider what are the use cases that are ideal for each of the functions.++=== Not Durable and not Atomic++For this use case, you want to use the regular functions:++* 'withBinaryFile'+* 'writeBinaryFile'++The regular use case for this scenario happens when your program is dealing with outputs+that are never going to be consumed again by your program. For example, imagine you have a+program that generates sales reports for the last month, this is a report that can be+generated quickly; you don't really care if the output file gets corrupted or lost at one+particular execution of your program given that is cheap to execute the data export+program a second time. In other words, your program doesn't /rely/ on the data contained+in this file in order to work.++=== Atomic but not Durable++ Imagine a scenario where your program builds a temporary file that serves as an+intermediate step to a bigger task, like Object files (@.o@) in a compilation process. The+program will use an existing @.o@ file if it is present, or it will build one from scratch+if it is not. The file is not really required, but if it is present, it *must* be valid+and consistent. In this situation, you care about atomicity, but not durability. You can+use the functions for such scenario:++* 'withBinaryFileAtomic'+* 'writeBinaryFileAtomic'++__Note__ - there is a peculiar difference between regular file writing functionality and+the one that is done atomically. Even if the orignal file is removed while it is being+modified, because of atomicity, it will be restored with all modifications, if any. The+reason for this is because a copy of the file was made prior to modifications and at the+end the existing is atomically replaced. An important consequence of this fact is that+whenever the folder containing the file which is being modified is removed, all bets are+off and all atomic functions will result in an exception.++=== Durable but not Atomic++For this use case, you want to use the functions:++* 'withBinaryFileDurable'+* 'writeBinaryFileDurable'++The regular use case for this scenario happens when your program deals with file+modifications that must be guaranteed to be durable, but you don't care that changes are+consistent. If you use this function, more than likely your program is ensuring+consistency guarantees through other means, for example, SQLite uses the Write Ahead Log+(WAL) algorithm to ensure changes are atomic at an application level.++=== Durable and Atomic++For this use case, you can use the functions:++* 'withBinaryFileDurableAtomic'+* 'writeBinaryFileDurableAtomic'++The regular use case for this scenario happens when you want to ensure that after a+program is executed, the modifications done to a file are guaranteed to be saved, and also+that changes are rolled-back in case there is a failure (e.g. hard reboot, shutdown,+etc).++-}+module UnliftIO.IO.File+ ( writeBinaryFile+ , writeBinaryFileAtomic+ , writeBinaryFileDurable+ , writeBinaryFileDurableAtomic+ , withBinaryFile+ , withBinaryFileAtomic+ , withBinaryFileDurable+ , withBinaryFileDurableAtomic+ , ensureFileDurable+ )+ where++import Data.ByteString as B (ByteString, writeFile)+import Control.Monad.IO.Unlift+import UnliftIO.IO (Handle, IOMode(..), withBinaryFile)++#if WINDOWS+++ensureFileDurable = (`seq` pure ())++writeBinaryFileDurable = writeBinaryFile+writeBinaryFileDurableAtomic = writeBinaryFile+writeBinaryFileAtomic = writeBinaryFile++withBinaryFileDurable = withBinaryFile+withBinaryFileDurableAtomic = withBinaryFile+withBinaryFileAtomic = withBinaryFile++#else++import qualified Data.ByteString as B (hPut)+import qualified UnliftIO.IO.File.Posix as Posix++ensureFileDurable = Posix.ensureFileDurable++writeBinaryFileDurable fp bytes =+ liftIO $ withBinaryFileDurable fp WriteMode (`B.hPut` bytes)+writeBinaryFileDurableAtomic fp bytes =+ liftIO $ withBinaryFileDurableAtomic fp WriteMode (`B.hPut` bytes)+writeBinaryFileAtomic fp bytes =+ liftIO $ withBinaryFileAtomic fp WriteMode (`B.hPut` bytes)++withBinaryFileDurable = Posix.withBinaryFileDurable+withBinaryFileDurableAtomic = Posix.withBinaryFileDurableAtomic+withBinaryFileAtomic = Posix.withBinaryFileAtomic+#endif++-- | After a file is closed, this function opens it again and executes @fsync()@+-- internally on both the file and the directory that contains it. Note that this function+-- is intended to work around the non-durability of existing file APIs, as opposed to+-- being necessary for the API functions provided in this module.+--+-- [The effectiveness of calling this function is+-- debatable](https://stackoverflow.com/questions/37288453/calling-fsync2-after-close2/50158433#50158433),+-- as it relies on internal implementation details at the Kernel level that might+-- change. We argue that, despite this fact, calling this function may bring benefits in+-- terms of durability.+--+-- This function does not provide the same guarantee as if you would open and modify a+-- file using `withBinaryFileDurable` or `writeBinaryFileDurable`, since they ensure that+-- the @fsync()@ is called before the file is closed, so if possible use those instead.+--+-- === Cross-Platform support+--+-- This function is a noop on Windows platforms.+--+-- @since 0.2.12+ensureFileDurable :: MonadIO m => FilePath -> m ()+-- Implementation is at the top of the module+++-- | Similar to 'writeBinaryFile', but it also ensures that changes executed to the file+-- are guaranteed to be durable. It internally uses @fsync()@ and makes sure it+-- synchronizes the file on disk.+--+-- === Cross-Platform support+--+-- This function behaves the same as 'RIO.writeBinaryFile' on Windows platforms.+--+-- @since 0.2.12+writeBinaryFileDurable :: MonadIO m => FilePath -> ByteString -> m ()+-- Implementation is at the top of the module++-- | Similar to 'writeBinaryFile', but it also guarantes that changes executed to the file+-- are durable, also, in case of failure, the modified file is never going to get+-- corrupted. It internally uses @fsync()@ and makes sure it synchronizes the file on+-- disk.+--+-- === Cross-Platform support+--+-- This function behaves the same as 'writeBinaryFile' on Windows platforms.+--+-- @since 0.2.12+writeBinaryFileDurableAtomic :: MonadIO m => FilePath -> ByteString -> m ()+-- Implementation is at the top of the module++-- | Same as 'writeBinaryFileDurableAtomic', except it does not guarantee durability.+--+-- === Cross-Platform support+--+-- This function behaves the same as 'writeBinaryFile' on Windows platforms.+--+-- @since 0.2.12+writeBinaryFileAtomic :: MonadIO m => FilePath -> ByteString -> m ()+-- Implementation is at the top of the module++-- | Opens a file with the following guarantees:+--+-- * It successfully closes the file in case of an asynchronous exception+--+-- * It reliably saves the file in the correct directory; including edge case situations+-- like a different device being mounted to the current directory, or the current+-- directory being renamed to some other name while the file is being used.+--+-- * It ensures durability by executing an @fsync()@ call before closing the file handle+--+-- === Cross-Platform support+--+-- This function behaves the same as 'System.IO.withBinaryFile' on Windows platforms.+--+-- @since 0.2.12+withBinaryFileDurable ::+ MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r+-- Implementation is at the top of the module++-- | Opens a file with the following guarantees:+--+-- * It successfully closes the file in case of an asynchronous exception+--+-- * It reliably saves the file in the correct directory; including edge case situations+-- like a different device being mounted to the current directory, or the current+-- directory being renamed to some other name while the file is being used.+--+-- * It ensures durability by executing an @fsync()@ call before closing the file handle+--+-- * It keeps all changes in a temporary file, and after it is closed it atomically moves+-- the temporary file to the original filepath, in case of catastrophic failure, the+-- original file stays unaffected.+--+-- If you do not need durability but only atomicity, use `withBinaryFileAtomic` instead,+-- which is faster as it does not perform @fsync()@.+--+-- __Important__ - Make sure not to close the `Handle`, it will be closed for you,+-- otherwise it will result in @invalid argument (Bad file descriptor)@ exception.+--+-- === Performance Considerations+--+-- When using a writable but non-truncating 'IOMode' (i.e. 'ReadWriteMode' and+-- 'AppendMode'), this function performs a copy operation of the specified input file to+-- guarantee the original file is intact in case of a catastrophic failure (no partial+-- writes). This approach may be prohibitive in scenarios where the input file is expected+-- to be large in size.+--+-- === Cross-Platform support+--+-- This function behaves the same as 'System.IO.withBinaryFile' on Windows platforms.+--+-- @since 0.2.12+withBinaryFileDurableAtomic ::+ MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r+-- Implementation is at the top of the module+++-- | Perform an action on a new or existing file at the destination file path. If+-- previously the file existed at the supplied file path then:+--+-- * in case of `WriteMode` it will be overwritten+--+-- * upon `ReadWriteMode` or `AppendMode` files contents will be copied over into a+-- temporary file, thus making sure no corruption can happen to an existing file upon any+-- failures, even catastrophic one, yet its contents are availble for modification.+--+-- * There is nothing atomic about `ReadMode`, so no special treatment there.+--+-- It is similar to `withBinaryFileDurableAtomic`, but without the durability part. It+-- means that all modification can still disappear after it has been succesfully written+-- due to some extreme event like an abrupt power loss, but the contents will not be+-- corrupted in case when the file write did not end successfully.+--+-- The same performance caveats apply as for `withBinaryFileDurableAtomic` due to making a+-- copy of the content of existing files during non-truncating writes.+--+-- __Important__ - Do not close the handle, otherwise it will result in @invalid argument+-- (Bad file descriptor)@ exception+--+-- __Note__ - on Linux operating system and only with supported file systems an anonymous+-- temporary file will be used while working on the file (see @O_TMPFILE@ in @man+-- openat@). In case when such feature is not available or not supported a temporary file+-- ".target-file-nameXXX.ext.tmp", where XXX is some random number, will be created+-- alongside the target file in the same directory+--+-- @since 0.2.12+withBinaryFileAtomic ::+ MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r+-- Implementation is at the top of the module+++-- | Lifted version of `B.writeFile`+--+-- @since 0.2.12+writeBinaryFile :: MonadIO m => FilePath -> ByteString -> m ()+writeBinaryFile fp = liftIO . B.writeFile fp
+ src/UnliftIO/IO/File/Posix.hs view
@@ -0,0 +1,582 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+module UnliftIO.IO.File.Posix+ ( withBinaryFileDurable+ , withBinaryFileDurableAtomic+ , withBinaryFileAtomic+ , ensureFileDurable+ )+ where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad (forM_, guard, unless, void, when)+import Control.Monad.IO.Unlift+import Data.Bits (Bits, (.|.))+import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import Data.Typeable (cast)+import Foreign (allocaBytes)+import Foreign.C (CInt(..), throwErrnoIfMinus1, throwErrnoIfMinus1Retry,+ throwErrnoIfMinus1Retry_)+import GHC.IO.Device (IODeviceType(RegularFile))+import qualified GHC.IO.Device as Device+import GHC.IO.Exception (IOErrorType(UnsupportedOperation))+import qualified GHC.IO.FD as FD+import qualified GHC.IO.Handle.FD as HandleFD+import qualified GHC.IO.Handle.Types as HandleFD (Handle(..), Handle__(..))+import System.Directory (removeFile)+import System.FilePath (takeDirectory, takeFileName)+import System.IO (Handle, IOMode(..), SeekMode(..), hGetBuf, hPutBuf,+ openBinaryTempFile)+import System.IO.Error (ioeGetErrorType, isAlreadyExistsError,+ isDoesNotExistError)+import qualified System.Posix.Files as Posix+import System.Posix.Internals (CFilePath, c_close, c_safe_open, withFilePath)+import System.Posix.Types (CMode(..), Fd(..), FileMode)+import UnliftIO.Exception+import UnliftIO.IO+import UnliftIO.MVar++-- NOTE: System.Posix.Internal doesn't re-export this constants so we have to+-- recreate-them here++newtype CFlag =+ CFlag CInt+ deriving (Eq, Show, Bits)++foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CFlag+foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CFlag+foreign import ccall unsafe "HsBase.h __hscore_o_rdwr" o_RDWR :: CFlag+foreign import ccall unsafe "HsBase.h __hscore_o_append" o_APPEND :: CFlag+foreign import ccall unsafe "HsBase.h __hscore_o_creat" o_CREAT :: CFlag+foreign import ccall unsafe "HsBase.h __hscore_o_noctty" o_NOCTTY :: CFlag++-- After here, we have our own imports++-- On non-Linux operating systems that do not support `O_TMPFILE` the value of+-- `o_TMPFILE` will be 0, which is then used to fallback onto a different+-- implementation of temporary files.+foreign import ccall unsafe "file-posix.c unliftio_o_tmpfile" o_TMPFILE :: CFlag+++-- | Whenever Operating System does not support @O_TMPFILE@ flag and anonymous+-- temporary files then `o_TMPFILE` flag will be set to @0@+o_TMPFILE_not_supported :: CFlag+o_TMPFILE_not_supported = CFlag 0++newtype CAt = CAt+ { unCAt :: CInt+ } deriving (Eq, Show, Bits)++foreign import ccall unsafe "file-posix.c unliftio_at_fdcwd" at_FDCWD :: CAt+foreign import ccall unsafe "file-posix.c unliftio_at_symlink_follow" at_SYMLINK_FOLLOW :: CAt+foreign import ccall unsafe "file-posix.c unliftio_s_irusr" s_IRUSR :: CMode+foreign import ccall unsafe "file-posix.c unliftio_s_iwusr" s_IWUSR :: CMode++c_open :: CFilePath -> CFlag -> CMode -> IO CInt+c_open fp (CFlag flags) = c_safe_open fp flags++foreign import ccall safe "fcntl.h openat"+ c_safe_openat :: CInt -> CFilePath -> CInt -> CMode -> IO CInt++c_openat :: DirFd -> CFilePath -> CFlag -> CMode -> IO CInt+c_openat (DirFd (Fd fd)) fp (CFlag flags) = c_safe_openat fd fp flags++foreign import ccall safe "fcntl.h renameat"+ c_safe_renameat :: CInt -> CFilePath -> CInt -> CFilePath -> IO CInt++c_renameat :: DirFd -> CFilePath -> DirFd -> CFilePath -> IO CInt+c_renameat (DirFd (Fd fdFrom)) cFpFrom (DirFd (Fd fdTo)) cFpTo =+ c_safe_renameat fdFrom cFpFrom fdTo cFpTo++foreign import ccall safe "unistd.h fsync"+ c_safe_fsync :: CInt -> IO CInt++c_fsync :: Fd -> IO CInt+c_fsync (Fd fd) = c_safe_fsync fd++foreign import ccall safe "unistd.h linkat"+ c_safe_linkat :: CInt -> CFilePath -> CInt -> CFilePath -> CInt -> IO CInt++c_linkat :: CAt -> CFilePath -> Either DirFd CAt -> CFilePath -> CAt -> IO CInt+c_linkat cat oldPath eNewDir newPath (CAt flags) =+ c_safe_linkat (unCAt cat) oldPath newDir newPath flags+ where+ unFd (Fd fd) = fd+ newDir = either (unFd . unDirFd) unCAt eNewDir++std_flags, output_flags, read_flags, write_flags, rw_flags,+ append_flags :: CFlag+std_flags = o_NOCTTY+output_flags = std_flags .|. o_CREAT+read_flags = std_flags .|. o_RDONLY+write_flags = output_flags .|. o_WRONLY+rw_flags = output_flags .|. o_RDWR+append_flags = write_flags .|. o_APPEND++ioModeToFlags :: IOMode -> CFlag+ioModeToFlags iomode =+ case iomode of+ ReadMode -> read_flags+ WriteMode -> write_flags+ ReadWriteMode -> rw_flags+ AppendMode -> append_flags++newtype DirFd = DirFd+ { unDirFd :: Fd+ }++-- | Returns a low-level file descriptor for a directory path. This function+-- exists given the fact that 'openFile' does not work with directories.+--+-- If you use this function, make sure you are working on a masked state,+-- otherwise async exceptions may leave file descriptors open.+openDir :: MonadIO m => FilePath -> m Fd+openDir fp+ -- TODO: Investigate what is the situation with Windows FS in regards to non_blocking+ -- NOTE: File operations _do not support_ non_blocking on various kernels, more+ -- info can be found here: https://ghc.haskell.org/trac/ghc/ticket/15153+ =+ liftIO $+ withFilePath fp $ \cFp ->+ Fd <$>+ throwErrnoIfMinus1Retry+ "openDir"+ (c_open cFp (ioModeToFlags ReadMode) 0o660)++-- | Closes a 'Fd' that points to a Directory.+closeDirectory :: MonadIO m => DirFd -> m ()+closeDirectory (DirFd (Fd dirFd)) =+ liftIO $+ throwErrnoIfMinus1Retry_ "closeDirectory" $ c_close dirFd++-- | Executes the low-level C function fsync on a C file descriptor+fsyncFileDescriptor+ :: MonadIO m+ => String -- ^ Meta-description for error messages+ -> Fd -- ^ C File Descriptor+ -> m ()+fsyncFileDescriptor name fd =+ liftIO $ void $ throwErrnoIfMinus1 ("fsync - " ++ name) $ c_fsync fd++-- | Call @fsync@ on the file handle. Accepts an arbitary string for error reporting.+fsyncFileHandle :: String -> Handle -> IO ()+fsyncFileHandle fname hdl = withHandleFd hdl (fsyncFileDescriptor (fname ++ "/File"))+++-- | Call @fsync@ on the opened directory file descriptor. Accepts an arbitary+-- string for error reporting.+fsyncDirectoryFd :: String -> DirFd -> IO ()+fsyncDirectoryFd fname = fsyncFileDescriptor (fname ++ "/Directory") . unDirFd+++-- | Opens a file from a directory, using this function in favour of a regular+-- 'openFile' guarantees that any file modifications are kept in the same+-- directory where the file was opened. An edge case scenario is a mount+-- happening in the directory where the file was opened while your program is+-- running.+--+-- If you use this function, make sure you are working on an masked state,+-- otherwise async exceptions may leave file descriptors open.+--+openFileFromDir :: MonadIO m => DirFd -> FilePath -> IOMode -> m Handle+openFileFromDir dirFd filePath@(takeFileName -> fileName) iomode =+ liftIO $+ withFilePath fileName $ \cFileName ->+ bracketOnError+ (do fileFd <-+ throwErrnoIfMinus1Retry "openFileFromDir" $+ c_openat dirFd cFileName (ioModeToFlags iomode) 0o666+ {- Can open directory with read only -}+ FD.mkFD+ fileFd+ iomode+ Nothing {- no stat -}+ False {- not a socket -}+ False {- non_blocking -}+ `onException`+ c_close fileFd)+ (liftIO . Device.close . fst)+ (\(fD, fd_type)+ -- we want to truncate() if this is an open in WriteMode, but only if the+ -- target is a RegularFile. ftruncate() fails on special files like+ -- /dev/null.+ -> do+ when (iomode == WriteMode && fd_type == RegularFile) $+ Device.setSize fD 0+ HandleFD.mkHandleFromFD fD fd_type filePath iomode False Nothing)+++-- | Similar to `openFileFromDir`, but will open an anonymous (nameless)+-- temporary file in the supplied directory+openAnonymousTempFileFromDir ::+ MonadIO m =>+ Maybe DirFd+ -- ^ If a file descriptor is given for the directory where the target file is/will be+ -- located in, then it will be used for opening an anonymous file. Otherwise+ -- anonymous will be opened unattached to any file path.+ -> FilePath+ -- ^ File path of the target file that we are working on.+ -> IOMode+ -> m Handle+openAnonymousTempFileFromDir mDirFd filePath iomode =+ liftIO $+ case mDirFd of+ Just dirFd -> withFilePath "." (openAnonymousWith . c_openat dirFd)+ Nothing ->+ withFilePath (takeDirectory filePath) (openAnonymousWith . c_open)+ where+ fdName = "openAnonymousTempFileFromDir - " ++ filePath+ ioModeToTmpFlags :: IOMode -> CFlag+ ioModeToTmpFlags =+ \case+ ReadMode -> o_RDWR -- It is an error to create a O_TMPFILE with O_RDONLY+ ReadWriteMode -> o_RDWR+ _ -> o_WRONLY+ openAnonymousWith fopen =+ bracketOnError+ (do fileFd <-+ throwErrnoIfMinus1Retry "openAnonymousTempFileFromDir" $+ fopen (o_TMPFILE .|. ioModeToTmpFlags iomode) (s_IRUSR .|. s_IWUSR)+ FD.mkFD+ fileFd+ iomode+ Nothing {- no stat -}+ False {- not a socket -}+ False {- non_blocking -}+ `onException`+ c_close fileFd)+ (liftIO . Device.close . fst)+ (\(fD, fd_type) ->+ HandleFD.mkHandleFromFD fD fd_type fdName iomode False Nothing)+++atomicDurableTempFileRename ::+ DirFd -> Maybe FileMode -> Handle -> Maybe FilePath -> FilePath -> IO ()+atomicDurableTempFileRename dirFd mFileMode tmpFileHandle mTmpFilePath filePath = do+ fsyncFileHandle "atomicDurableTempFileCreate" tmpFileHandle+ -- at this point we know that the content has been persisted to the storage it+ -- is safe to do the atomic move/replace+ let eTmpFile = maybe (Left tmpFileHandle) Right mTmpFilePath+ atomicTempFileRename (Just dirFd) mFileMode eTmpFile filePath+ -- Important to close the handle, so the we can fsync the directory+ hClose tmpFileHandle+ -- file path is updated, now we can fsync the directory+ fsyncDirectoryFd "atomicDurableTempFileCreate" dirFd+++-- | There will be an attempt to atomically convert an invisible temporary file+-- into a target file at the supplied file path. In case when there is already a+-- file at that file path, a new visible temporary file will be created in the+-- same folder and then atomically renamed into the target file path, replacing+-- any existing file. This is necessary since `c_safe_linkat` cannot replace+-- files atomically and we have to fall back onto `c_safe_renameat`. This should+-- not be a problem in practice, since lifetime of such visible file is+-- extremely short and it will be cleaned up regardless of the outcome of the+-- rename.+--+-- It is important to note, that whenever a file descriptor for the containing+-- directory is supplied, renaming and linking will be done in its context,+-- thus allowing to do proper fsyncing if durability is necessary.+--+-- __NOTE__: this function will work only on Linux.+--+atomicTempFileCreate ::+ Maybe DirFd+ -- ^ Possible handle for the directory where the target file is located. Which+ -- means that the file is already in that directory, just without a name. In other+ -- words it was opened before with `openAnonymousTempFileFromDir`+ -> Maybe FileMode+ -- ^ If file permissions are supplied they will be set on the new file prior+ -- to atomic rename.+ -> Handle+ -- ^ Handle to the anonymous temporary file created with `c_openat` and+ -- `o_TMPFILE`+ -> FilePath+ -- ^ File path for the target file.+ -> IO ()+atomicTempFileCreate mDirFd mFileMode tmpFileHandle filePath =+ withHandleFd tmpFileHandle $ \fd@(Fd cFd) ->+ withFilePath ("/proc/self/fd/" ++ show cFd) $ \cFromFilePath ->+ withFilePath filePathName $ \cToFilePath -> do+ let fileMode = fromMaybe Posix.stdFileMode mFileMode+ -- work around for the glibc bug: https://sourceware.org/bugzilla/show_bug.cgi?id=17523+ Posix.setFdMode fd fileMode+ let safeLink which to =+ throwErrnoIfMinus1Retry_+ ("atomicFileCreate - c_safe_linkat - " ++ which) $+ -- see `man linkat` and `man openat` for more info+ c_linkat at_FDCWD cFromFilePath cDirFd to at_SYMLINK_FOLLOW+ eExc <-+ tryJust (guard . isAlreadyExistsError) $+ safeLink "anonymous" cToFilePath+ case eExc of+ Right () -> pure ()+ Left () ->+ withBinaryTempFileFor filePath $ \visTmpFileName visTmpFileHandle -> do+ hClose visTmpFileHandle+ removeFile visTmpFileName+ case mDirFd of+ Nothing -> do+ withFilePath visTmpFileName (safeLink "visible")+ Posix.rename visTmpFileName filePath+ Just dirFd ->+ withFilePath (takeFileName visTmpFileName) $ \cVisTmpFile -> do+ safeLink "visible" cVisTmpFile+ throwErrnoIfMinus1Retry_+ "atomicFileCreate - c_safe_renameat" $+ c_renameat dirFd cVisTmpFile dirFd cToFilePath+ where+ (cDirFd, filePathName) =+ case mDirFd of+ Nothing -> (Right at_FDCWD, filePath)+ Just dirFd -> (Left dirFd, takeFileName filePath)++atomicTempFileRename ::+ Maybe DirFd+ -- ^ Possible handle for the directory where the target file is located.+ -> Maybe FileMode+ -- ^ If file permissions are supplied they will be set on the new file prior+ -- to atomic rename.+ -> Either Handle FilePath+ -- ^ Temporary file. If a handle is supplied, it means it was opened with+ -- @O_TMPFILE@ flag and thus we are on the Linux OS and can safely call+ -- `atomicTempFileCreate`+ -> FilePath+ -- ^ File path for the target file. Whenever `DirFd` is supplied, it must be+ -- the containgin directory fo this file, but that invariant is not enforced+ -- within this function.+ -> IO ()+atomicTempFileRename mDirFd mFileMode eTmpFile filePath =+ case eTmpFile of+ Left tmpFileHandle ->+ atomicTempFileCreate mDirFd mFileMode tmpFileHandle filePath+ Right tmpFilePath -> do+ forM_ mFileMode $ \fileMode -> Posix.setFileMode tmpFilePath fileMode+ case mDirFd of+ Nothing -> Posix.rename tmpFilePath filePath+ Just dirFd ->+ withFilePath (takeFileName filePath) $ \cToFilePath ->+ withFilePath (takeFileName tmpFilePath) $ \cTmpFilePath ->+ throwErrnoIfMinus1Retry_ "atomicFileCreate - c_safe_renameat" $+ c_renameat dirFd cTmpFilePath dirFd cToFilePath+++withDirectory :: MonadUnliftIO m => FilePath -> (DirFd -> m a) -> m a+withDirectory dirPath = bracket (DirFd <$> openDir dirPath) closeDirectory++withFileInDirectory ::+ MonadUnliftIO m => DirFd -> FilePath -> IOMode -> (Handle -> m a) -> m a+withFileInDirectory dirFd filePath iomode =+ bracket (openFileFromDir dirFd filePath iomode) hClose+++-- | Create a temporary file for a matching possibly exiting target file that+-- will be replaced in the future. Temporary file is meant to be renamed+-- afterwards, thus it is only deleted upon error.+--+-- __Important__: Temporary file is not removed and file handle is not closed if+-- there was no exception thrown by the supplied action.+withBinaryTempFileFor ::+ MonadUnliftIO m+ => FilePath+ -- ^ "For" file. It may exist or may not.+ -> (FilePath -> Handle -> m a)+ -> m a+withBinaryTempFileFor filePath action =+ bracketOnError+ (liftIO (openBinaryTempFile dirPath tmpFileName))+ (\(tmpFilePath, tmpFileHandle) ->+ hClose tmpFileHandle >> liftIO (tryIO (removeFile tmpFilePath)))+ (uncurry action)+ where+ dirPath = takeDirectory filePath+ fileName = takeFileName filePath+ tmpFileName = "." ++ fileName ++ ".tmp"++-- | Returns `Nothing` if anonymous temporary file is not supported by the OS or+-- the underlying file system can't handle that feature.+withAnonymousBinaryTempFileFor ::+ MonadUnliftIO m+ => Maybe DirFd+ -- ^ It is possible to open the temporary file in the context of a directory,+ -- in such case supply its file descriptor. i.e. @openat@ will be used instead+ -- of @open@+ -> FilePath+ -- ^ "For" file. The file may exist or may not.+ -> IOMode+ -> (Handle -> m a)+ -> m (Maybe a)+withAnonymousBinaryTempFileFor mDirFd filePath iomode action+ | o_TMPFILE == o_TMPFILE_not_supported = pure Nothing+ | otherwise =+ trySupported $+ bracket (openAnonymousTempFileFromDir mDirFd filePath iomode) hClose action+ where+ trySupported m =+ tryIO m >>= \case+ Right res -> pure $ Just res+ Left exc+ | ioeGetErrorType exc == UnsupportedOperation -> pure Nothing+ Left exc -> throwIO exc++withNonAnonymousBinaryTempFileFor ::+ MonadUnliftIO m+ => Maybe DirFd+ -- ^ It is possible to open the temporary file in the context of a directory,+ -- in such case supply its file descriptor. i.e. @openat@ will be used instead+ -- of @open@+ -> FilePath+ -- ^ "For" file. The file may exist or may not.+ -> IOMode+ -> (FilePath -> Handle -> m a)+ -> m a+withNonAnonymousBinaryTempFileFor mDirFd filePath iomode action =+ withBinaryTempFileFor filePath $ \tmpFilePath tmpFileHandle -> do+ hClose tmpFileHandle+ case mDirFd of+ Nothing -> withBinaryFile tmpFilePath iomode (action tmpFilePath)+ Just dirFd -> withFileInDirectory dirFd tmpFilePath iomode (action tmpFilePath)++-- | Copy the contents of the file into the handle, but only if that file exists+-- and either `ReadWriteMode` or `AppendMode` is specified. Returned are the+-- file permissions of the original file so it can be set later when original+-- gets overwritten atomically.+copyFileHandle ::+ MonadUnliftIO f => IOMode -> FilePath -> Handle -> f (Maybe FileMode)+copyFileHandle iomode fromFilePath toHandle =+ either (const Nothing) Just <$>+ tryJust+ (guard . isDoesNotExistError)+ (do fileStatus <- liftIO $ Posix.getFileStatus fromFilePath+ -- Whenever we are not overwriting an existing file, we also need a+ -- copy of the file's contents+ unless (iomode == WriteMode) $ do+ withBinaryFile fromFilePath ReadMode (`copyHandleData` toHandle)+ unless (iomode == AppendMode) $ hSeek toHandle AbsoluteSeek 0+ -- Get the copy of source file permissions, but only whenever it exists+ pure $ Posix.fileMode fileStatus)+++-- This is a copy of the internal function from `directory-1.3.3.2`. It became+-- available only in directory-1.3.3.0 and is still internal, hence the+-- duplication.+copyHandleData :: MonadIO m => Handle -> Handle -> m ()+copyHandleData hFrom hTo = liftIO $ allocaBytes bufferSize go+ where+ bufferSize = 131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h)+ go buffer = do+ count <- hGetBuf hFrom buffer bufferSize+ when (count > 0) $ do+ hPutBuf hTo buffer count+ go buffer++-- | Thread safe access to the file descriptor in the file handle+withHandleFd :: Handle -> (Fd -> IO a) -> IO a+withHandleFd h cb =+ case h of+ HandleFD.FileHandle _ mv ->+ withMVar mv $ \HandleFD.Handle__{HandleFD.haDevice = dev} ->+ case cast dev of+ Just fd -> cb $ Fd $ FD.fdFD fd+ Nothing -> error "withHandleFd: not a file handle"+ HandleFD.DuplexHandle {} -> error "withHandleFd: not a file handle"++-- | See `ensureFileDurable`+ensureFileDurable :: MonadIO m => FilePath -> m ()+ensureFileDurable filePath =+ liftIO $+ withDirectory (takeDirectory filePath) $ \dirFd ->+ withFileInDirectory dirFd filePath ReadMode $ \fileHandle ->+ liftIO $ do+ fsyncFileHandle "ensureFileDurablePosix" fileHandle+ -- NOTE: Here we are purposefully not fsyncing the directory if the file fails to fsync+ fsyncDirectoryFd "ensureFileDurablePosix" dirFd++++-- | See `withBinaryFileDurable`+withBinaryFileDurable ::+ MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r+withBinaryFileDurable filePath iomode action =+ case iomode of+ ReadMode+ -- We do not need to consider durable operations when we are in a+ -- 'ReadMode', so we can use a regular `withBinaryFile`+ -> withBinaryFile filePath iomode action+ _ {- WriteMode, ReadWriteMode, AppendMode -}+ ->+ withDirectory (takeDirectory filePath) $ \dirFd ->+ withFileInDirectory dirFd filePath iomode $ \tmpFileHandle -> do+ res <- action tmpFileHandle+ liftIO $ do+ fsyncFileHandle "withBinaryFileDurablePosix" tmpFileHandle+ -- NOTE: Here we are purposefully not fsyncing the directory if the file fails to fsync+ fsyncDirectoryFd "withBinaryFileDurablePosix" dirFd+ pure res++-- | See `withBinaryFileDurableAtomic`+withBinaryFileDurableAtomic ::+ MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r+withBinaryFileDurableAtomic filePath iomode action =+ case iomode of+ ReadMode+ -- We do not need to consider an atomic operation when we are in a+ -- 'ReadMode', so we can use a regular `withBinaryFile`+ -> withBinaryFile filePath iomode action+ _ {- WriteMode, ReadWriteMode, AppendMode -}+ ->+ withDirectory (takeDirectory filePath) $ \dirFd -> do+ mRes <- withAnonymousBinaryTempFileFor (Just dirFd) filePath iomode $+ durableAtomicAction dirFd Nothing+ case mRes of+ Just res -> pure res+ Nothing ->+ withNonAnonymousBinaryTempFileFor (Just dirFd) filePath iomode $ \tmpFilePath ->+ durableAtomicAction dirFd (Just tmpFilePath)+ where+ durableAtomicAction dirFd mTmpFilePath tmpFileHandle = do+ mFileMode <- copyFileHandle iomode filePath tmpFileHandle+ res <- action tmpFileHandle+ liftIO $+ atomicDurableTempFileRename+ dirFd+ mFileMode+ tmpFileHandle+ mTmpFilePath+ filePath+ pure res++-- | See `withBinaryFileAtomic`+withBinaryFileAtomic ::+ MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r+withBinaryFileAtomic filePath iomode action =+ case iomode of+ ReadMode+ -- We do not need to consider an atomic operation when we are in a+ -- 'ReadMode', so we can use a regular `withBinaryFile`+ -> withBinaryFile filePath iomode action+ _ {- WriteMode, ReadWriteMode, AppendMode -}+ -> do+ mRes <-+ withAnonymousBinaryTempFileFor Nothing filePath iomode $+ atomicAction Nothing+ case mRes of+ Just res -> pure res+ Nothing ->+ withNonAnonymousBinaryTempFileFor Nothing filePath iomode $ \tmpFilePath ->+ atomicAction (Just tmpFilePath)+ where+ atomicAction mTmpFilePath tmpFileHandle = do+ let eTmpFile = maybe (Left tmpFileHandle) Right mTmpFilePath+ mFileMode <- copyFileHandle iomode filePath tmpFileHandle+ res <- action tmpFileHandle+ liftIO $ atomicTempFileRename Nothing mFileMode eTmpFile filePath+ pure res+
+ src/UnliftIO/Internals/Async.hs view
@@ -0,0 +1,1081 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+module UnliftIO.Internals.Async where++import Control.Applicative+import Control.Concurrent (threadDelay, getNumCapabilities)+import qualified Control.Concurrent as C+import Control.Concurrent.Async (Async)+import qualified Control.Concurrent.Async as A+import Control.Concurrent.STM+import Control.Exception (Exception, SomeException)+import Control.Monad (forever, liftM, unless, void, (>=>))+import Control.Monad.IO.Unlift+import Data.Foldable (for_, traverse_)+import Data.Typeable (Typeable)+import Data.IORef (IORef, readIORef, atomicWriteIORef, newIORef, atomicModifyIORef')+import qualified UnliftIO.Exception as UE++-- For the implementation of Conc below, we do not want any of the+-- smart async exception handling logic from UnliftIO.Exception, since+-- (eg) we're low-level enough to need to explicit be throwing async+-- exceptions synchronously.+import qualified Control.Exception as E+import GHC.Generics (Generic)++#if MIN_VERSION_base(4,9,0)+import Data.Semigroup+#else+import Data.Monoid hiding (Alt)+#endif+import Data.Foldable (Foldable, toList)+import Data.Traversable (Traversable, for, traverse)++-- | Unlifted 'A.async'.+--+-- @since 0.1.0.0+async :: MonadUnliftIO m => m a -> m (Async a)+async m = withRunInIO $ \run -> A.async $ run m++-- | Unlifted 'A.asyncBound'.+--+-- @since 0.1.0.0+asyncBound :: MonadUnliftIO m => m a -> m (Async a)+asyncBound m = withRunInIO $ \run -> A.asyncBound $ run m++-- | Unlifted 'A.asyncOn'.+--+-- @since 0.1.0.0+asyncOn :: MonadUnliftIO m => Int -> m a -> m (Async a)+asyncOn i m = withRunInIO $ \run -> A.asyncOn i $ run m++-- | Unlifted 'A.asyncWithUnmask'.+--+-- @since 0.1.0.0+asyncWithUnmask :: MonadUnliftIO m => ((forall b. m b -> m b) -> m a) -> m (Async a)+asyncWithUnmask m =+ withRunInIO $ \run -> A.asyncWithUnmask $ \unmask -> run $ m $ liftIO . unmask . run++-- | Unlifted 'A.asyncOnWithUnmask'.+--+-- @since 0.1.0.0+asyncOnWithUnmask :: MonadUnliftIO m => Int -> ((forall b. m b -> m b) -> m a) -> m (Async a)+asyncOnWithUnmask i m =+ withRunInIO $ \run -> A.asyncOnWithUnmask i $ \unmask -> run $ m $ liftIO . unmask . run++-- | Unlifted 'A.withAsync'.+--+-- @since 0.1.0.0+withAsync :: MonadUnliftIO m => m a -> (Async a -> m b) -> m b+withAsync a b = withRunInIO $ \run -> A.withAsync (run a) (run . b)++-- | Unlifted 'A.withAsyncBound'.+--+-- @since 0.1.0.0+withAsyncBound :: MonadUnliftIO m => m a -> (Async a -> m b) -> m b+withAsyncBound a b = withRunInIO $ \run -> A.withAsyncBound (run a) (run . b)++-- | Unlifted 'A.withAsyncOn'.+--+-- @since 0.1.0.0+withAsyncOn :: MonadUnliftIO m => Int -> m a -> (Async a -> m b) -> m b+withAsyncOn i a b = withRunInIO $ \run -> A.withAsyncOn i (run a) (run . b)++-- | Unlifted 'A.withAsyncWithUnmask'.+--+-- @since 0.1.0.0+withAsyncWithUnmask+ :: MonadUnliftIO m+ => ((forall c. m c -> m c) -> m a)+ -> (Async a -> m b)+ -> m b+withAsyncWithUnmask a b =+ withRunInIO $ \run -> A.withAsyncWithUnmask+ (\unmask -> run $ a $ liftIO . unmask . run)+ (run . b)++-- | Unlifted 'A.withAsyncOnWithMask'.+--+-- @since 0.1.0.0+withAsyncOnWithUnmask+ :: MonadUnliftIO m+ => Int+ -> ((forall c. m c -> m c) -> m a)+ -> (Async a -> m b)+ -> m b+withAsyncOnWithUnmask i a b =+ withRunInIO $ \run -> A.withAsyncOnWithUnmask i+ (\unmask -> run $ a $ liftIO . unmask . run)+ (run . b)++-- | Lifted 'A.wait'.+--+-- @since 0.1.0.0+wait :: MonadIO m => Async a -> m a+wait = liftIO . A.wait++-- | Lifted 'A.poll'.+--+-- @since 0.1.0.0+poll :: MonadIO m => Async a -> m (Maybe (Either SomeException a))+poll = liftIO . A.poll++-- | Lifted 'A.waitCatch'.+--+-- @since 0.1.0.0+waitCatch :: MonadIO m => Async a -> m (Either SomeException a)+waitCatch = liftIO . A.waitCatch++-- | Lifted 'A.cancel'.+--+-- @since 0.1.0.0+cancel :: MonadIO m => Async a -> m ()+cancel = liftIO . A.cancel++-- | Lifted 'A.uninterruptibleCancel'.+--+-- @since 0.1.0.0+uninterruptibleCancel :: MonadIO m => Async a -> m ()+uninterruptibleCancel = liftIO . A.uninterruptibleCancel++-- | Lifted 'A.cancelWith'. Additionally uses 'UE.toAsyncException' to+-- ensure async exception safety.+--+-- @since 0.1.0.0+cancelWith :: (Exception e, MonadIO m) => Async a -> e -> m ()+cancelWith a e = liftIO (A.cancelWith a (UE.toAsyncException e))++-- | Lifted 'A.waitAny'.+--+-- @since 0.1.0.0+waitAny :: MonadIO m => [Async a] -> m (Async a, a)+waitAny = liftIO . A.waitAny++-- | Lifted 'A.waitAnyCatch'.+--+-- @since 0.1.0.0+waitAnyCatch :: MonadIO m => [Async a] -> m (Async a, Either SomeException a)+waitAnyCatch = liftIO . A.waitAnyCatch++-- | Lifted 'A.waitAnyCancel'.+--+-- @since 0.1.0.0+waitAnyCancel :: MonadIO m => [Async a] -> m (Async a, a)+waitAnyCancel = liftIO . A.waitAnyCancel++-- | Lifted 'A.waitAnyCatchCancel'.+--+-- @since 0.1.0.0+waitAnyCatchCancel :: MonadIO m => [Async a] -> m (Async a, Either SomeException a)+waitAnyCatchCancel = liftIO . A.waitAnyCatchCancel++-- | Lifted 'A.waitEither'.+--+-- @since 0.1.0.0+waitEither :: MonadIO m => Async a -> Async b -> m (Either a b)+waitEither a b = liftIO (A.waitEither a b)++-- | Lifted 'A.waitEitherCatch'.+--+-- @since 0.1.0.0+waitEitherCatch :: MonadIO m => Async a -> Async b -> m (Either (Either SomeException a) (Either SomeException b))+waitEitherCatch a b = liftIO (A.waitEitherCatch a b)++-- | Lifted 'A.waitEitherCancel'.+--+-- @since 0.1.0.0+waitEitherCancel :: MonadIO m => Async a -> Async b -> m (Either a b)+waitEitherCancel a b = liftIO (A.waitEitherCancel a b)++-- | Lifted 'A.waitEitherCatchCancel'.+--+-- @since 0.1.0.0+waitEitherCatchCancel :: MonadIO m => Async a -> Async b -> m (Either (Either SomeException a) (Either SomeException b))+waitEitherCatchCancel a b = liftIO (A.waitEitherCatchCancel a b)++-- | Lifted 'A.waitEither_'.+--+-- @since 0.1.0.0+waitEither_ :: MonadIO m => Async a -> Async b -> m ()+waitEither_ a b = liftIO (A.waitEither_ a b)++-- | Lifted 'A.waitBoth'.+--+-- @since 0.1.0.0+waitBoth :: MonadIO m => Async a -> Async b -> m (a, b)+waitBoth a b = liftIO (A.waitBoth a b)++-- | Lifted 'A.link'.+--+-- @since 0.1.0.0+link :: MonadIO m => Async a -> m ()+link = liftIO . A.link++-- | Lifted 'A.link2'.+--+-- @since 0.1.0.0+link2 :: MonadIO m => Async a -> Async b -> m ()+link2 a b = liftIO (A.link2 a b)++-- | Unlifted 'A.race'.+--+-- @since 0.1.0.0+race :: MonadUnliftIO m => m a -> m b -> m (Either a b)+race a b = withRunInIO $ \run -> A.race (run a) (run b)++-- | Unlifted 'A.race_'.+--+-- @since 0.1.0.0+race_ :: MonadUnliftIO m => m a -> m b -> m ()+race_ a b = withRunInIO $ \run -> A.race_ (run a) (run b)++-- | Unlifted 'A.concurrently'.+--+-- @since 0.1.0.0+concurrently :: MonadUnliftIO m => m a -> m b -> m (a, b)+concurrently a b = withRunInIO $ \run -> A.concurrently (run a) (run b)++-- | Unlifted 'A.concurrently_'.+--+-- @since 0.1.0.0+concurrently_ :: MonadUnliftIO m => m a -> m b -> m ()+concurrently_ a b = withRunInIO $ \run -> A.concurrently_ (run a) (run b)++-- | Unlifted 'A.Concurrently'.+--+-- @since 0.1.0.0+newtype Concurrently m a = Concurrently+ { runConcurrently :: m a+ }++-- | @since 0.1.0.0+instance Monad m => Functor (Concurrently m) where+ fmap f (Concurrently a) = Concurrently $ liftM f a++-- | @since 0.1.0.0+instance MonadUnliftIO m => Applicative (Concurrently m) where+ pure = Concurrently . return+ Concurrently fs <*> Concurrently as =+ Concurrently $ liftM (\(f, a) -> f a) (concurrently fs as)++-- | Composing two unlifted 'Concurrently' values using 'Alternative' is the+-- equivalent to using a 'race' combinator, the asynchrounous sub-routine that+-- returns a value first is the one that gets it's value returned, the slowest+-- sub-routine gets cancelled and it's thread is killed.+--+-- @since 0.1.0.0+instance MonadUnliftIO m => Alternative (Concurrently m) where+ -- | Care should be taken when using the 'empty' value of the 'Alternative'+ -- interface, as it will create a thread that delays for a long period of+ -- time. The reason behind this implementation is that any other computation+ -- will finish first than the 'empty' value. This implementation is less than+ -- ideal, and in a perfect world, we would have a typeclass family that allows+ -- '(<|>)' but not 'empty'.+ --+ -- @since 0.1.0.0+ empty = Concurrently $ liftIO (forever (threadDelay maxBound))+ Concurrently as <|> Concurrently bs =+ Concurrently $ liftM (either id id) (race as bs)++--------------------------------------------------------------------------------+#if MIN_VERSION_base(4,9,0)+--------------------------------------------------------------------------------+-- | Only defined by @async@ for @base >= 4.9@.+--+-- @since 0.1.0.0+instance (MonadUnliftIO m, Semigroup a) => Semigroup (Concurrently m a) where+ (<>) = liftA2 (<>)++-- | @since 0.1.0.0+instance (Semigroup a, Monoid a, MonadUnliftIO m) => Monoid (Concurrently m a) where+ mempty = pure mempty+ mappend = (<>)+--------------------------------------------------------------------------------+#else+--------------------------------------------------------------------------------+-- | @since 0.1.0.0+instance (Monoid a, MonadUnliftIO m) => Monoid (Concurrently m a) where+ mempty = pure mempty+ mappend = liftA2 mappend+--------------------------------------------------------------------------------+#endif+--------------------------------------------------------------------------------++-- | Similar to 'mapConcurrently' but with arguments flipped+--+-- @since 0.1.0.0+forConcurrently :: MonadUnliftIO m => Traversable t => t a -> (a -> m b) -> m (t b)+forConcurrently = flip mapConcurrently+{-# INLINE forConcurrently #-}++-- | Similar to 'mapConcurrently_' but with arguments flipped+--+-- @since 0.1.0.0+forConcurrently_ :: MonadUnliftIO m => Foldable f => f a -> (a -> m b) -> m ()+forConcurrently_ = flip mapConcurrently_+{-# INLINE forConcurrently_ #-}++-- | Unlifted 'A.replicateConcurrently'.+--+-- @since 0.1.0.0+#if MIN_VERSION_base(4,7,0)+#else+replicateConcurrently :: (Functor m, MonadUnliftIO m) => Int -> m a -> m [a]+#endif+replicateConcurrently cnt m =+ case compare cnt 1 of+ LT -> pure []+ EQ -> (:[]) <$> m+ GT -> mapConcurrently id (replicate cnt m)+{-# INLINE replicateConcurrently #-}++-- | Unlifted 'A.replicateConcurrently_'.+--+-- @since 0.1.0.0+#if MIN_VERSION_base(4,7,0)+replicateConcurrently_ :: (Applicative m, MonadUnliftIO m) => Int -> m a -> m ()+#else+replicateConcurrently_ :: (MonadUnliftIO m) => Int -> m a -> m ()+#endif+replicateConcurrently_ cnt m =+ case compare cnt 1 of+ LT -> pure ()+ EQ -> void m+ GT -> mapConcurrently_ id (replicate cnt m)+{-# INLINE replicateConcurrently_ #-}++-- Conc uses GHC features that are not supported in versions <= to ghc-7.10+-- so we are going to export/use it when we have a higher version only.+--------------------------------------------------------------------------------+#if MIN_VERSION_base(4,8,0)+--------------------------------------------------------------------------------++-- | Executes a 'Traversable' container of items concurrently, it uses the 'Flat'+-- type internally.+--+-- @since 0.1.0.0+mapConcurrently :: MonadUnliftIO m => Traversable t => (a -> m b) -> t a -> m (t b)+mapConcurrently f t = withRunInIO $ \run -> runFlat $ traverse+ (FlatApp . FlatAction . run . f)+ t+{-# INLINE mapConcurrently #-}++-- | Executes a 'Traversable' container of items concurrently, it uses the 'Flat'+-- type internally. This function ignores the results.+--+-- @since 0.1.0.0+mapConcurrently_ :: MonadUnliftIO m => Foldable f => (a -> m b) -> f a -> m ()+mapConcurrently_ f t = withRunInIO $ \run -> runFlat $ traverse_+ (FlatApp . FlatAction . run . f)+ t+{-# INLINE mapConcurrently_ #-}+++-- More efficient Conc implementation++-- | A more efficient alternative to 'Concurrently', which reduces the+-- number of threads that need to be forked. For more information, see+-- [this blog post](https://www.fpcomplete.com/blog/transformations-on-applicative-concurrent-computations/).+-- This is provided as a separate type to @Concurrently@ as it has a slightly different API.+--+-- Use the 'conc' function to construct values of type 'Conc', and+-- 'runConc' to execute the composed actions. You can use the+-- @Applicative@ instance to run different actions and wait for all of+-- them to complete, or the @Alternative@ instance to wait for the+-- first thread to complete.+--+-- In the event of a runtime exception thrown by any of the children+-- threads, or an asynchronous exception received in the parent+-- thread, all threads will be killed with an 'A.AsyncCancelled'+-- exception and the original exception rethrown. If multiple+-- exceptions are generated by different threads, there are no+-- guarantees on which exception will end up getting rethrown.+--+-- For many common use cases, you may prefer using helper functions in+-- this module like 'mapConcurrently'.+--+-- There are some intentional differences in behavior to+-- @Concurrently@:+--+-- * Children threads are always launched in an unmasked state, not+-- the inherited state of the parent thread.+--+-- Note that it is a programmer error to use the @Alternative@+-- instance in such a way that there are no alternatives to an empty,+-- e.g. @runConc (empty <|> empty)@. In such a case, a 'ConcException'+-- will be thrown. If there was an @Alternative@ in the standard+-- libraries without @empty@, this library would use it instead.+--+-- @since 0.2.9.0+data Conc m a where+ Action :: m a -> Conc m a+ Apply :: Conc m (v -> a) -> Conc m v -> Conc m a+ LiftA2 :: (x -> y -> a) -> Conc m x -> Conc m y -> Conc m a++ -- Just an optimization to avoid spawning extra threads+ Pure :: a -> Conc m a++ -- I thought there would be an optimization available from having a+ -- data constructor that explicit doesn't care about the first+ -- result. Turns out it doesn't help much: we still need to keep a+ -- TMVar below to know when the thread completes.+ --+ -- Then :: Conc m a -> Conc m b -> Conc m b++ Alt :: Conc m a -> Conc m a -> Conc m a+ Empty :: Conc m a++deriving instance Functor m => Functor (Conc m)+-- fmap f (Action routine) = Action (fmap f routine)+-- fmap f (LiftA2 g x y) = LiftA2 (fmap f g) x y+-- fmap f (Pure val) = Pure (f val)+-- fmap f (Alt a b) = Alt (fmap f a) (fmap f b)+-- fmap f Empty = Empty++-- | Construct a value of type 'Conc' from an action. Compose these+-- values using the typeclass instances (most commonly 'Applicative'+-- and 'Alternative') and then run with 'runConc'.+--+-- @since 0.2.9.0+conc :: m a -> Conc m a+conc = Action+{-# INLINE conc #-}++-- | Run a 'Conc' value on multiple threads.+--+-- @since 0.2.9.0+runConc :: MonadUnliftIO m => Conc m a -> m a+runConc = flatten >=> (liftIO . runFlat)+{-# INLINE runConc #-}++-- | @since 0.2.9.0+instance MonadUnliftIO m => Applicative (Conc m) where+ pure = Pure+ {-# INLINE pure #-}+ -- | Following is an example of how an 'Applicative' expands to a Tree+ --+ -- @@@+ -- downloadA :: IO String+ -- downloadB :: IO String+ --+ -- (f <$> conc downloadA <*> conc downloadB <*> pure 123)+ --+ -- (((f <$> a) <*> b) <*> c))+ -- (1) (2) (3)+ --+ -- (1)+ -- Action (fmap f downloadA)+ -- (2)+ -- Apply (Action (fmap f downloadA)) (Action downloadB)+ -- (3)+ -- Apply (Apply (Action (fmap f downloadA)) (Action downloadB))+ -- (Pure 123)+ -- @@@+ --+ (<*>) = Apply+ {-# INLINE (<*>) #-}+ -- See comment above on Then+ -- (*>) = Then+#if MIN_VERSION_base(4,11,0)+ liftA2 = LiftA2+ {-# INLINE liftA2 #-}+#endif++ a *> b = LiftA2 (\_ x -> x) a b+ {-# INLINE (*>) #-}++-- | @since 0.2.9.0+instance MonadUnliftIO m => Alternative (Conc m) where+ empty = Empty -- this is so ugly, we don't actually want to provide it!+ {-# INLINE empty #-}+ (<|>) = Alt+ {-# INLINE (<|>) #-}++#if MIN_VERSION_base(4, 11, 0)+-- | @since 0.2.9.0+instance (MonadUnliftIO m, Semigroup a) => Semigroup (Conc m a) where+ (<>) = liftA2 (<>)+ {-# INLINE (<>) #-}+#endif++-- | @since 0.2.9.0+instance (Monoid a, MonadUnliftIO m) => Monoid (Conc m a) where+ mempty = pure mempty+ {-# INLINE mempty #-}+#if !MIN_VERSION_base(4,11,0)+ mappend = liftA2 mappend+ {-# INLINE mappend #-}+#endif++-------------------------+-- Conc implementation --+-------------------------++-- Data types for flattening out the original @Conc@ into a simplified+-- view. Goals:+--+-- * We want to get rid of the Empty data constructor. We don't want+-- it anyway, it's only there because of the Alternative typeclass.+--+-- * We want to ensure that there is no nesting of Alt data+-- constructors. There is a bookkeeping overhead to each time we+-- need to track raced threads, and we want to minimize that+-- bookkeeping.+--+-- * We want to ensure that, when racing, we're always racing at least+-- two threads.+--+-- * We want to simplify down to IO.++-- | Flattened structure, either Applicative or Alternative+data Flat a+ = FlatApp !(FlatApp a)+ -- | Flattened Alternative. Has at least 2 entries, which must be+ -- FlatApp (no nesting of FlatAlts).+ | FlatAlt !(FlatApp a) !(FlatApp a) ![FlatApp a]++deriving instance Functor Flat+-- fmap f (FlatApp a) =+-- FlatApp (fmap f a)+-- fmap f (FlatAlt (FlatApp a) (FlatApp b) xs) =+-- FlatAlt (FlatApp (fmap f a)) (FlatApp (fmap f b)) (map (fmap f) xs)+instance Applicative Flat where+ pure = FlatApp . pure+ (<*>) f a = FlatApp (FlatLiftA2 id f a)+#if MIN_VERSION_base(4,11,0)+ liftA2 f a b = FlatApp (FlatLiftA2 f a b)+#endif++-- | Flattened Applicative. No Alternative stuff directly in here, but may be in+-- the children. Notice this type doesn't have a type parameter for monadic+-- contexts, it hardwires the base monad to IO given concurrency relies+-- eventually on that.+--+-- @since 0.2.9.0+data FlatApp a where+ FlatPure :: a -> FlatApp a+ FlatAction :: IO a -> FlatApp a+ FlatApply :: Flat (v -> a) -> Flat v -> FlatApp a+ FlatLiftA2 :: (x -> y -> a) -> Flat x -> Flat y -> FlatApp a++deriving instance Functor FlatApp+instance Applicative FlatApp where+ pure = FlatPure+ (<*>) mf ma = FlatApply (FlatApp mf) (FlatApp ma)+#if MIN_VERSION_base(4,11,0)+ liftA2 f a b = FlatLiftA2 f (FlatApp a) (FlatApp b)+#endif++-- | Things that can go wrong in the structure of a 'Conc'. These are+-- /programmer errors/.+--+-- @since 0.2.9.0+data ConcException+ = EmptyWithNoAlternative+ deriving (Generic, Show, Typeable, Eq, Ord)+instance E.Exception ConcException++-- | Simple difference list, for nicer types below+type DList a = [a] -> [a]++dlistConcat :: DList a -> DList a -> DList a+dlistConcat = (.)+{-# INLINE dlistConcat #-}++dlistCons :: a -> DList a -> DList a+dlistCons a as = dlistSingleton a `dlistConcat` as+{-# INLINE dlistCons #-}++dlistConcatAll :: [DList a] -> DList a+dlistConcatAll = foldr (.) id+{-# INLINE dlistConcatAll #-}++dlistToList :: DList a -> [a]+dlistToList = ($ [])+{-# INLINE dlistToList #-}++dlistSingleton :: a -> DList a+dlistSingleton a = (a:)+{-# INLINE dlistSingleton #-}++dlistEmpty :: DList a+dlistEmpty = id+{-# INLINE dlistEmpty #-}++-- | Turn a 'Conc' into a 'Flat'. Note that thanks to the ugliness of+-- 'empty', this may fail, e.g. @flatten Empty@.+--+-- @since 0.2.9.0+flatten :: forall m a. MonadUnliftIO m => Conc m a -> m (Flat a)+flatten c0 = withRunInIO $ \run -> do++ -- why not app?+ let both :: forall k. Conc m k -> IO (Flat k)+ both Empty = E.throwIO EmptyWithNoAlternative+ both (Action m) = pure $ FlatApp $ FlatAction $ run m+ both (Apply cf ca) = do+ f <- both cf+ a <- both ca+ pure $ FlatApp $ FlatApply f a+ both (LiftA2 f ca cb) = do+ a <- both ca+ b <- both cb+ pure $ FlatApp $ FlatLiftA2 f a b+ both (Alt ca cb) = do+ a <- alt ca+ b <- alt cb+ case dlistToList (a `dlistConcat` b) of+ [] -> E.throwIO EmptyWithNoAlternative+ [x] -> pure $ FlatApp x+ x:y:z -> pure $ FlatAlt x y z+ both (Pure a) = pure $ FlatApp $ FlatPure a++ -- Returns a difference list for cheaper concatenation+ alt :: forall k. Conc m k -> IO (DList (FlatApp k))+ alt Empty = pure dlistEmpty+ alt (Apply cf ca) = do+ f <- both cf+ a <- both ca+ pure (dlistSingleton $ FlatApply f a)+ alt (Alt ca cb) = do+ a <- alt ca+ b <- alt cb+ pure $ a `dlistConcat` b+ alt (Action m) = pure (dlistSingleton $ FlatAction (run m))+ alt (LiftA2 f ca cb) = do+ a <- both ca+ b <- both cb+ pure (dlistSingleton $ FlatLiftA2 f a b)+ alt (Pure a) = pure (dlistSingleton $ FlatPure a)++ both c0++-- | Run a @Flat a@ on multiple threads.+runFlat :: Flat a -> IO a++-- Silly, simple optimizations+runFlat (FlatApp (FlatAction io)) = io+runFlat (FlatApp (FlatPure x)) = pure x++-- Start off with all exceptions masked so we can install proper cleanup.+runFlat f0 = E.uninterruptibleMask $ \restore -> do+ -- How many threads have been spawned and finished their task? We need to+ -- ensure we kill all child threads and wait for them to die.+ resultCountVar <- newTVarIO 0++ -- Forks off as many threads as necessary to run the given Flat a,+ -- and returns:+ --+ -- + An STM action that will block until completion and return the+ -- result.+ --+ -- + The IDs of all forked threads. These need to be tracked so they+ -- can be killed (either when an exception is thrown, or when one+ -- of the alternatives completes first).+ --+ -- It would be nice to have the returned STM action return an Either+ -- and keep the SomeException values somewhat explicit, but in all+ -- my testing this absolutely kills performance. Instead, we're+ -- going to use a hack of providing a TMVar to fill up with a+ -- SomeException when things fail.+ --+ -- TODO: Investigate why performance degradation on Either+ let go :: forall a.+ TMVar E.SomeException+ -> Flat a+ -> IO (STM a, DList C.ThreadId)+ go _excVar (FlatApp (FlatPure x)) = pure (pure x, dlistEmpty)+ go excVar (FlatApp (FlatAction io)) = do+ resVar <- newEmptyTMVarIO+ tid <- C.forkIOWithUnmask $ \restore1 -> do+ res <- E.try $ restore1 io+ atomically $ do+ modifyTVar' resultCountVar (+ 1)+ case res of+ Left e -> void $ tryPutTMVar excVar e+ Right x -> putTMVar resVar x+ pure (readTMVar resVar, dlistSingleton tid)+ go excVar (FlatApp (FlatApply cf ca)) = do+ (f, tidsf) <- go excVar cf+ (a, tidsa) <- go excVar ca+ pure (f <*> a, tidsf `dlistConcat` tidsa)+ go excVar (FlatApp (FlatLiftA2 f a b)) = do+ (a', tidsa) <- go excVar a+ (b', tidsb) <- go excVar b+ pure (liftA2 f a' b', tidsa `dlistConcat` tidsb)++ go excVar0 (FlatAlt x y z) = do+ -- As soon as one of the children finishes, we need to kill the siblings,+ -- we're going to create our own excVar here to pass to the children, so+ -- we can prevent the ThreadKilled exceptions we throw to the children+ -- here from propagating and taking down the whole system.+ excVar <- newEmptyTMVarIO+ resVar <- newEmptyTMVarIO+ pairs <- traverse (go excVar . FlatApp) (x:y:z)+ let (blockers, workerTids) = unzip pairs++ -- Fork a helper thread to wait for the first child to+ -- complete, or for one of them to die with an exception so we+ -- can propagate it to excVar0.+ helperTid <- C.forkIOWithUnmask $ \restore1 -> do+ eres <- E.try $ restore1 $ atomically $ foldr+ (\blocker rest -> (Right <$> blocker) <|> rest)+ (Left <$> readTMVar excVar)+ blockers+ atomically $ do+ modifyTVar' resultCountVar (+ 1)+ case eres of+ -- NOTE: The child threads are spawned from @traverse go@ call above, they+ -- are _not_ children of this helper thread, and helper thread doesn't throw+ -- synchronous exceptions, so, any exception that the try above would catch+ -- must be an async exception.+ -- We were killed by an async exception, do nothing.+ Left (_ :: E.SomeException) -> pure ()+ -- Child thread died, propagate it+ Right (Left e) -> void $ tryPutTMVar excVar0 e+ -- Successful result from one of the children+ Right (Right res) -> putTMVar resVar res++ -- And kill all of the threads+ for_ workerTids $ \tids' ->+ -- NOTE: Replacing A.AsyncCancelled with KillThread as the+ -- 'A.AsyncCancelled' constructor is not exported in older versions+ -- of the async package+ -- for_ (tids' []) $ \workerTid -> E.throwTo workerTid A.AsyncCancelled+ for_ (dlistToList tids') $ \workerTid -> C.killThread workerTid++ pure ( readTMVar resVar+ , helperTid `dlistCons` dlistConcatAll workerTids+ )++ excVar <- newEmptyTMVarIO+ (getRes, tids0) <- go excVar f0+ let tids = dlistToList tids0+ tidCount = length tids+ allDone count =+ if count > tidCount+ then error ("allDone: count ("+ <> show count+ <> ") should never be greater than tidCount ("+ <> show tidCount+ <> ")")+ else count == tidCount++ -- Automatically retry if we get killed by a+ -- BlockedIndefinitelyOnSTM. For more information, see:+ --+ -- + https:\/\/github.com\/simonmar\/async\/issues\/14+ -- + https:\/\/github.com\/simonmar\/async\/pull\/15+ --+ let autoRetry action =+ action `E.catch`+ \E.BlockedIndefinitelyOnSTM -> autoRetry action++ -- Restore the original masking state while blocking and catch+ -- exceptions to allow the parent thread to be killed early.+ res <- E.try $ restore $ autoRetry $ atomically $+ (Left <$> readTMVar excVar) <|>+ (Right <$> getRes)++ count0 <- atomically $ readTVar resultCountVar+ unless (allDone count0) $ do+ -- Kill all of the threads+ -- NOTE: Replacing A.AsyncCancelled with KillThread as the+ -- 'A.AsyncCancelled' constructor is not exported in older versions+ -- of the async package+ -- for_ tids $ \tid -> E.throwTo tid A.AsyncCancelled+ for_ tids $ \tid -> C.killThread tid++ -- Wait for all of the threads to die. We're going to restore the original+ -- masking state here, just in case there's a bug in the cleanup code of a+ -- child thread, so that we can be killed by an async exception. We decided+ -- this is a better behavior than hanging indefinitely and wait for a SIGKILL.+ restore $ atomically $ do+ count <- readTVar resultCountVar+ -- retries until resultCountVar has increased to the threadId count returned by go+ check $ allDone count++ -- Return the result or throw an exception. Yes, we could use+ -- either or join, but explicit pattern matching is nicer here.+ case res of+ -- Parent thread was killed with an async exception+ Left e -> E.throwIO (e :: E.SomeException)+ -- Some child thread died+ Right (Left e) -> E.throwIO e+ -- Everything worked!+ Right (Right x) -> pure x+{-# INLINEABLE runFlat #-}++--------------------------------------------------------------------------------+#else+--------------------------------------------------------------------------------++-- | Unlifted 'A.mapConcurrently'.+--+-- @since 0.1.0.0+mapConcurrently :: MonadUnliftIO m => Traversable t => (a -> m b) -> t a -> m (t b)+mapConcurrently f t = withRunInIO $ \run -> A.mapConcurrently (run . f) t+{-# INLINE mapConcurrently #-}++-- | Unlifted 'A.mapConcurrently_'.+--+-- @since 0.1.0.0+mapConcurrently_ :: MonadUnliftIO m => Foldable f => (a -> m b) -> f a -> m ()+mapConcurrently_ f t = withRunInIO $ \run -> A.mapConcurrently_ (run . f) t+{-# INLINE mapConcurrently_ #-}++--------------------------------------------------------------------------------+#endif+--------------------------------------------------------------------------------++-- | Like 'mapConcurrently' from async, but instead of one thread per+-- element, it does pooling from a set of threads. This is useful in+-- scenarios where resource consumption is bounded and for use cases+-- where too many concurrent tasks aren't allowed.+--+-- === __Example usage__+--+-- @+-- import Say+--+-- action :: Int -> IO Int+-- action n = do+-- tid <- myThreadId+-- sayString $ show tid+-- threadDelay (2 * 10^6) -- 2 seconds+-- return n+--+-- main :: IO ()+-- main = do+-- yx \<- pooledMapConcurrentlyN 5 (\\x -\> action x) [1..5]+-- print yx+-- @+--+-- On executing you can see that five threads have been spawned:+--+-- @+-- \$ ./pool+-- ThreadId 36+-- ThreadId 38+-- ThreadId 40+-- ThreadId 42+-- ThreadId 44+-- [1,2,3,4,5]+-- @+--+--+-- Let's modify the above program such that there are less threads+-- than the number of items in the list:+--+-- @+-- import Say+--+-- action :: Int -> IO Int+-- action n = do+-- tid <- myThreadId+-- sayString $ show tid+-- threadDelay (2 * 10^6) -- 2 seconds+-- return n+--+-- main :: IO ()+-- main = do+-- yx \<- pooledMapConcurrentlyN 3 (\\x -\> action x) [1..5]+-- print yx+-- @+-- On executing you can see that only three threads are active totally:+--+-- @+-- \$ ./pool+-- ThreadId 35+-- ThreadId 37+-- ThreadId 39+-- ThreadId 35+-- ThreadId 39+-- [1,2,3,4,5]+-- @+--+-- @since 0.2.10+pooledMapConcurrentlyN :: (MonadUnliftIO m, Traversable t)+ => Int -- ^ Max. number of threads. Should not be less than 1.+ -> (a -> m b) -> t a -> m (t b)+pooledMapConcurrentlyN numProcs f xs =+ withRunInIO $ \run -> pooledMapConcurrentlyIO numProcs (run . f) xs++-- | Similar to 'pooledMapConcurrentlyN' but with number of threads+-- set from 'getNumCapabilities'. Usually this is useful for CPU bound+-- tasks.+--+-- @since 0.2.10+pooledMapConcurrently :: (MonadUnliftIO m, Traversable t) => (a -> m b) -> t a -> m (t b)+pooledMapConcurrently f xs = do+ withRunInIO $ \run -> do+ numProcs <- getNumCapabilities+ pooledMapConcurrentlyIO numProcs (run . f) xs++-- | Similar to 'pooledMapConcurrentlyN' but with flipped arguments.+--+-- @since 0.2.10+pooledForConcurrentlyN :: (MonadUnliftIO m, Traversable t)+ => Int -- ^ Max. number of threads. Should not be less than 1.+ -> t a -> (a -> m b) -> m (t b)+pooledForConcurrentlyN numProcs = flip (pooledMapConcurrentlyN numProcs)++-- | Similar to 'pooledForConcurrentlyN' but with number of threads+-- set from 'getNumCapabilities'. Usually this is useful for CPU bound+-- tasks.+--+-- @since 0.2.10+pooledForConcurrently :: (MonadUnliftIO m, Traversable t) => t a -> (a -> m b) -> m (t b)+pooledForConcurrently = flip pooledMapConcurrently++pooledMapConcurrentlyIO :: Traversable t => Int -> (a -> IO b) -> t a -> IO (t b)+pooledMapConcurrentlyIO numProcs f xs =+ if (numProcs < 1)+ then error "pooledMapconcurrentlyIO: number of threads < 1"+ else pooledMapConcurrentlyIO' numProcs f xs++-- | Performs the actual pooling for the tasks. This function will+-- continue execution until the task queue becomes empty. When one of+-- the pooled thread finishes it's task, it will pickup the next task+-- from the queue if an job is available.+pooledConcurrently+ :: Int -- ^ Max. number of threads. Should not be less than 1.+ -> IORef [a] -- ^ Task queue. These are required as inputs for the jobs.+ -> (a -> IO ()) -- ^ The task which will be run concurrently (but+ -- will be pooled properly).+ -> IO ()+pooledConcurrently numProcs jobsVar f = do+ replicateConcurrently_ numProcs $ do+ let loop = do+ mbJob :: Maybe a <- atomicModifyIORef' jobsVar $ \x -> case x of+ [] -> ([], Nothing)+ var : vars -> (vars, Just var)+ case mbJob of+ Nothing -> return ()+ Just x -> do+ f x+ loop+ in loop++pooledMapConcurrentlyIO' ::+ Traversable t => Int -- ^ Max. number of threads. Should not be less than 1.+ -> (a -> IO b)+ -> t a+ -> IO (t b)+pooledMapConcurrentlyIO' numProcs f xs = do+ -- prepare one IORef per result...+ jobs :: t (a, IORef b) <-+ for xs (\x -> (x, ) <$> newIORef (error "pooledMapConcurrentlyIO': empty IORef"))+ -- ...put all the inputs in a queue..+ jobsVar :: IORef [(a, IORef b)] <- newIORef (toList jobs)+ -- ...run `numProcs` threads in parallel, each+ -- of them consuming the queue and filling in+ -- the respective IORefs.+ pooledConcurrently numProcs jobsVar $ \ (x, outRef) -> f x >>= atomicWriteIORef outRef -- Read all the IORefs+ for jobs (\(_, outputRef) -> readIORef outputRef)++pooledMapConcurrentlyIO_' ::+ Foldable t => Int -> (a -> IO ()) -> t a -> IO ()+pooledMapConcurrentlyIO_' numProcs f jobs = do+ jobsVar :: IORef [a] <- newIORef (toList jobs)+ pooledConcurrently numProcs jobsVar f++pooledMapConcurrentlyIO_ :: Foldable t => Int -> (a -> IO b) -> t a -> IO ()+pooledMapConcurrentlyIO_ numProcs f xs =+ if (numProcs < 1)+ then error "pooledMapconcurrentlyIO_: number of threads < 1"+ else pooledMapConcurrentlyIO_' numProcs (\x -> f x >> return ()) xs++-- | Like 'pooledMapConcurrentlyN' but with the return value+-- discarded.+--+-- @since 0.2.10+pooledMapConcurrentlyN_ :: (MonadUnliftIO m, Foldable f)+ => Int -- ^ Max. number of threads. Should not be less than 1.+ -> (a -> m b) -> f a -> m ()+pooledMapConcurrentlyN_ numProcs f t =+ withRunInIO $ \run -> pooledMapConcurrentlyIO_ numProcs (run . f) t++-- | Like 'pooledMapConcurrently' but with the return value discarded.+--+-- @since 0.2.10+pooledMapConcurrently_ :: (MonadUnliftIO m, Foldable f) => (a -> m b) -> f a -> m ()+pooledMapConcurrently_ f t =+ withRunInIO $ \run -> do+ numProcs <- getNumCapabilities+ pooledMapConcurrentlyIO_ numProcs (run . f) t++-- | Like 'pooledMapConcurrently_' but with flipped arguments.+--+-- @since 0.2.10+pooledForConcurrently_ :: (MonadUnliftIO m, Foldable f) => f a -> (a -> m b) -> m ()+pooledForConcurrently_ = flip pooledMapConcurrently_++-- | Like 'pooledMapConcurrentlyN_' but with flipped arguments.+--+-- @since 0.2.10+pooledForConcurrentlyN_ :: (MonadUnliftIO m, Foldable t)+ => Int -- ^ Max. number of threads. Should not be less than 1.+ -> t a -> (a -> m b) -> m ()+pooledForConcurrentlyN_ numProcs = flip (pooledMapConcurrentlyN_ numProcs)+++-- | Pooled version of 'replicateConcurrently'. Performs the action in+-- the pooled threads.+--+-- @since 0.2.10+pooledReplicateConcurrentlyN :: (MonadUnliftIO m)+ => Int -- ^ Max. number of threads. Should not be less than 1.+ -> Int -- ^ Number of times to perform the action.+ -> m a -> m [a]+pooledReplicateConcurrentlyN numProcs cnt task =+ if cnt < 1+ then return []+ else pooledMapConcurrentlyN numProcs (\_ -> task) [1..cnt]++-- | Similar to 'pooledReplicateConcurrentlyN' but with number of+-- threads set from 'getNumCapabilities'. Usually this is useful for+-- CPU bound tasks.+--+-- @since 0.2.10+pooledReplicateConcurrently :: (MonadUnliftIO m)+ => Int -- ^ Number of times to perform the action.+ -> m a -> m [a]+pooledReplicateConcurrently cnt task =+ if cnt < 1+ then return []+ else pooledMapConcurrently (\_ -> task) [1..cnt]++-- | Pooled version of 'replicateConcurrently_'. Performs the action in+-- the pooled threads.+--+-- @since 0.2.10+pooledReplicateConcurrentlyN_ :: (MonadUnliftIO m)+ => Int -- ^ Max. number of threads. Should not be less than 1.+ -> Int -- ^ Number of times to perform the action.+ -> m a -> m ()+pooledReplicateConcurrentlyN_ numProcs cnt task =+ if cnt < 1+ then return ()+ else pooledMapConcurrentlyN_ numProcs (\_ -> task) [1..cnt]++-- | Similar to 'pooledReplicateConcurrently_' but with number of+-- threads set from 'getNumCapabilities'. Usually this is useful for+-- CPU bound tasks.+--+-- @since 0.2.10+pooledReplicateConcurrently_ :: (MonadUnliftIO m)+ => Int -- ^ Number of times to perform the action.+ -> m a -> m ()+pooledReplicateConcurrently_ cnt task =+ if cnt < 1+ then return ()+ else pooledMapConcurrently_ (\_ -> task) [1..cnt]
+ src/UnliftIO/QSem.hs view
@@ -0,0 +1,43 @@+-- | Unlifted "Control.Concurrent.QSem".+--+-- @since 0.2.14+module UnliftIO.QSem+ ( QSem+ , newQSem+ , waitQSem+ , signalQSem+ , withQSem+ ) where++import Control.Concurrent.QSem (QSem)+import Control.Monad.IO.Unlift+import UnliftIO.Exception+import qualified Control.Concurrent.QSem as Q++-- | Lifted 'Q.newQSem'.+--+-- @since 0.2.14+newQSem :: MonadIO m => Int -> m QSem+newQSem = liftIO . Q.newQSem++-- | Lifted 'Q.waitQSem'.+--+-- @since 0.2.14+waitQSem :: MonadIO m => QSem -> m ()+waitQSem = liftIO . Q.waitQSem++-- | Lifted 'Q.signalQSem'.+--+-- @since 0.2.14+signalQSem :: MonadIO m => QSem -> m ()+signalQSem = liftIO . Q.signalQSem++-- | 'withQSem' is an exception-safe wrapper for performing the+-- provided operation while holding a unit of value from the semaphore.+-- It ensures the semaphore cannot be leaked if there are exceptions.+--+-- @since 0.2.14+{-# INLINE withQSem #-}+withQSem :: MonadUnliftIO m => QSem -> m a -> m a+withQSem x io = withRunInIO $ \run ->+ bracket_ (waitQSem x) (signalQSem x) (run io)
+ src/UnliftIO/QSemN.hs view
@@ -0,0 +1,43 @@+-- | Unlifted "Control.Concurrent.QSemN".+--+-- @since 0.2.14+module UnliftIO.QSemN+ ( QSemN+ , newQSemN+ , waitQSemN+ , signalQSemN+ , withQSemN+ ) where++import Control.Concurrent.QSemN (QSemN)+import Control.Monad.IO.Unlift+import UnliftIO.Exception+import qualified Control.Concurrent.QSemN as Q++-- | Lifted 'Q.newQSemN'.+--+-- @since 0.2.14+newQSemN :: MonadIO m => Int -> m QSemN+newQSemN = liftIO . Q.newQSemN++-- | Lifted 'Q.waitQSemN'.+--+-- @since 0.2.14+waitQSemN :: MonadIO m => QSemN -> Int -> m ()+waitQSemN x = liftIO . Q.waitQSemN x++-- | Lifted 'Q.signalQSemN'.+--+-- @since 0.2.14+signalQSemN :: MonadIO m => QSemN -> Int -> m ()+signalQSemN x = liftIO . Q.signalQSemN x++-- | 'withQSemN' is an exception-safe wrapper for performing the+-- provided operation while holding N unit of value from the semaphore.+-- It ensures the semaphore cannot be leaked if there are exceptions.+--+-- @since 0.2.14+{-# INLINE withQSemN #-}+withQSemN :: MonadUnliftIO m => QSemN -> Int -> m a -> m a+withQSemN x n io = withRunInIO $ \run ->+ bracket_ (waitQSemN x n) (signalQSemN x n) (run io)
src/UnliftIO/STM.hs view
@@ -8,6 +8,7 @@ , atomically , retrySTM , checkSTM+ , STM.orElse -- * TVar , STM.TVar@@ -18,6 +19,7 @@ , STM.writeTVar , STM.modifyTVar , STM.modifyTVar'+ , STM.stateTVar , STM.swapTVar , registerDelay , mkWeakTVar@@ -31,6 +33,9 @@ , STM.takeTMVar , STM.putTMVar , STM.readTMVar+#if MIN_VERSION_stm(2, 5, 1)+ , STM.writeTMVar+#endif , STM.tryReadTMVar , STM.swapTMVar , STM.tryTakeTMVar@@ -72,10 +77,12 @@ , newTBQueueIO , STM.readTBQueue , STM.tryReadTBQueue+ , STM.flushTBQueue , STM.peekTBQueue , STM.tryPeekTBQueue , STM.writeTBQueue , STM.unGetTBQueue+ , STM.lengthTBQueue , STM.isEmptyTBQueue , STM.isFullTBQueue ) where@@ -84,9 +91,10 @@ import qualified Control.Concurrent.STM as STM import Control.Monad.IO.Unlift import System.Mem.Weak (Weak)--#if MIN_VERSION_stm(2, 5, 0)+#if MIN_VERSION_base(4, 8, 0) import GHC.Natural (Natural)+#else+import Numeric.Natural (Natural) #endif -- | Lifted version of 'STM.atomically'
src/UnliftIO/Temporary.hs view
@@ -4,6 +4,42 @@ -- Strongly inspired by\/stolen from the <https://github.com/feuerbach/temporary> package. -- -- @since 0.1.0.0+--+-- === __Copyright notice:__+--+-- The following copyright notice is taken from <https://github.com/feuerbach/temporary>+-- and is reproduced here as part of license terms of that package, of which this module is+-- a derivate work.+--+-- @+-- Copyright+-- (c) 2003-2006, Isaac Jones+-- (c) 2005-2009, Duncan Coutts+-- (c) 2008, Maximilian Bolingbroke+-- ... and other contributors+--+-- 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 Maximilian Bolingbroke 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.+-- @ module UnliftIO.Temporary ( withSystemTempFile , withSystemTempDirectory
+ test/UnliftIO/AsyncSpec.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+module UnliftIO.AsyncSpec (spec) where++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import UnliftIO+import UnliftIO.Internals.Async+import Data.List (nub)+import Control.Applicative+import Control.Concurrent (myThreadId, threadDelay)+import qualified Control.Exception as CE (ErrorCall(..), try)+import GHC.Conc.Sync (ThreadStatus(..), threadStatus)+import Control.Concurrent.STM (throwSTM)+import Control.Exception (getMaskingState, MaskingState (Unmasked))++data MyExc = MyExc+ deriving (Show, Eq, Typeable)+instance Exception MyExc++spec :: Spec+spec = do+ describe "replicateConcurrently_" $ do+ prop "works" $ \(NonNegative cnt) -> do+ ref <- newIORef (0 :: Int)+ replicateConcurrently_ cnt $ atomicModifyIORef' ref $ \i -> (i + 1, ())+ readIORef ref `shouldReturn` cnt++ it "uses a different thread per replicated action" $+ forAllShrink ((+ 1) . abs <$> arbitrary) (filter (>= 1) . shrink) $ \n -> do+ threadIdsRef <- newIORef []+ let action = myThreadId >>= \tid -> atomicModifyIORef' threadIdsRef (\acc -> (tid:acc, ()))+ replicateConcurrently_ n action+ tids <- readIORef threadIdsRef+ tids `shouldBe` (nub tids)++#if MIN_VERSION_base(4,8,0)+ describe "flatten" $ do+ -- NOTE: cannot make this test a property test given+ -- Flat and Conc cannot have an Eq property+ it "flattens all alternative trees" $ do+ let+ concValue :: Conc IO Int+ concValue =+ conc (pure 1) <|> conc (pure 2) <|> pure 3+ -- Alt (Alt (Action (pure 1)) (Action (pure 2)))+ -- (Pure 3)+ flatConc <- flatten concValue+ case flatConc of+ FlatAlt (FlatAction action1)+ (FlatAction action2)+ [(FlatPure 3)] -> do+ action1 `shouldReturn` 1+ action2 `shouldReturn` 2+ _ -> expectationFailure "expecting flatten to work but didn't"++ describe "conc" $ do+ it "handles sync exceptions" $ do+ runConc (conc (pure ()) *> conc (throwIO MyExc))+ `shouldThrow` (== MyExc)++ it "handles async exceptions" $ do+ tidVar <- newEmptyMVar+ result <- CE.try $ runConc (conc (pure ())+ *> conc (takeMVar tidVar >>= (`throwTo` (CE.ErrorCall "having error")))+ *> conc (myThreadId+ >>= putMVar tidVar+ >> threadDelay 1000100))+ case result of+ Right _ ->+ expectationFailure "Expecting an error, got none"+ Left (SomeAsyncException err) ->+ displayException err `shouldBe` "having error"++ it "has an Unmasked masking state for given subroutines" $+ uninterruptibleMask_ $+ runConc $ conc (threadDelay maxBound) <|>+ conc (getMaskingState `shouldReturn` Unmasked)++-- NOTE: Older versions of GHC have a timeout function that doesn't+-- work on Windows+#if !WINDOWS+ it "allows to kill parent via timeout" $ do+ ref <- newIORef (0 :: Int)+ mres <- timeout 20 $ runConc $+ conc (pure ()) *>+ conc ((writeIORef ref 1 >> threadDelay maxBound >> writeIORef ref 2)+ `finally` writeIORef ref 3)+ mres `shouldBe` Nothing+ res <- readIORef ref+ case res of+ 0 -> putStrLn "make timeout longer"+ 1 -> error "it's 1"+ 2 -> error "it's 2"+ 3 -> pure ()+ _ -> error $ "what? " ++ show res+#endif++ it "throws right exception on empty" $+ runConc empty `shouldThrow` (== EmptyWithNoAlternative)++ describe "Conc Applicative instance" $ do+ prop "doesn't fork a new thread on a pure call" $ \i ->+ runConc (pure (i :: Int)) `shouldReturn` i++ it "evaluates all needed sub-routines " $ do+ runConc (conc (pure ()) *> conc (throwIO MyExc))+ `shouldThrow` (== MyExc)++ it "cleanup on brackets work" $ do+ var <- newTVarIO (0 :: Int)+ let worker = conc $ bracket_+ (atomically $ modifyTVar' var (+ 1))+ (atomically $ modifyTVar' var (subtract 1))+ (threadDelay 10000000 >> error "this should never happen")+ count = 10+ killer = conc $ atomically $ do+ count' <- readTVar var+ checkSTM $ count == count'+ throwSTM MyExc+ composed = foldr (*>) killer (replicate count worker)+ runConc composed `shouldThrow` (== MyExc)+ atomically (readTVar var) `shouldReturn` 0++ it "re-throws exception that happened first" $ do+ let composed = conc (throwIO MyExc) *> conc (threadDelay 1000000 >> error "foo")+ runConc composed `shouldThrow` (== MyExc)++ describe "Conc Alternative instance" $ do+ it "is left associative" $ do+ let+ concValue :: Conc IO Int+ concValue =+ conc (pure 1) <|> conc (pure 2) <|> conc (pure 3)+ case concValue of+ Alt (Alt (Action action1) (Action action2)) (Action action3) -> do+ action1 `shouldReturn` 1+ action2 `shouldReturn` 2+ action3 `shouldReturn` 3++ _ -> expectationFailure "expecting Conc Alternative to be left associative, but it wasn't"++ it "executes body of all alternative blocks" $ do+ var <- newEmptyMVar+ runConc $+ conc (takeMVar var) <|>+ conc (threadDelay maxBound) <|>+ conc (threadDelay 100 >> pure ())+ -- if a GC runs at the right time, it's possible that both `takeMVar` and+ -- `runConc` itself will be in a "blocked indefinitely on MVar" situation,+ -- adding line bellow to avoid that+ putMVar var ()++ it "finishes all threads that didn't finish first" $ do+ ref <- newIORef []+ runConc $+ conc (do tid <- myThreadId+ atomicModifyIORef' ref (\acc -> (tid:acc, ()))+ -- it is never going to finish+ threadDelay maxBound) <|>+ conc (do tid <- myThreadId+ -- it finishes after registering thread id+ atomicModifyIORef' ref (\acc -> (tid:acc, ()))+ threadDelay 500) <|>+ conc (do tid <- myThreadId+ atomicModifyIORef' ref (\acc -> (tid:acc, ()))+ -- it is never going to finish+ threadDelay maxBound)+ threads <- readIORef ref+ statusList <- mapM threadStatus threads+ length (filter (== ThreadFinished) statusList) `shouldBe` 3++ it "nesting works" $ do+ var <- newEmptyMVar+ let sillyAlts :: Conc IO a -> Conc IO a+ sillyAlts c = c <|> conc (takeMVar var >> error "shouldn't happen")+ res <- runConc $ sillyAlts $ (+)+ <$> sillyAlts (conc (pure 1))+ <*> sillyAlts (conc (pure 2))+ res `shouldBe` 3+ putMVar var ()++#endif
+ test/UnliftIO/DirectorySpec.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE CPP #-}+module UnliftIO.DirectorySpec (spec) where++import Test.Hspec+#if MIN_VERSION_directory(1,3,1)+import System.FilePath+import UnliftIO.IO+import UnliftIO.Directory+import UnliftIO.Temporary+++spec :: Spec+spec = do+ describe "createFileLink" $ do+ it "mirror" $ do+ withSystemTempDirectory "createFileLink.mirror" $ \fp -> do+ let fileContent = "i am the same"+ fileContent' = "I AM THE SAME"+ origin = fp </> "origin.txt"+ link = fp </> "link.txt"+ writeFile origin fileContent+ createFileLink origin link+ linkContent <- readFile link+ linkContent `shouldBe`fileContent+ writeFile origin fileContent'+ linkContent' <- readFile link+ linkContent' `shouldBe`fileContent'+#else+spec :: Spec+spec = pure ()+#endif
test/UnliftIO/ExceptionSpec.hs view
@@ -1,10 +1,92 @@+{-# LANGUAGE CPP #-}+ module UnliftIO.ExceptionSpec (spec) where +import qualified Control.Exception+import Control.Monad (void, (<=<))+import Data.Bifunctor (first) import Test.Hspec import UnliftIO+import UnliftIO.Concurrent (threadDelay) +#if MIN_VERSION_async(2,2,0)+cancelled :: AsyncCancelled+cancelled = AsyncCancelled+#else+cancelled :: Control.Exception.AsyncException+cancelled = Control.Exception.ThreadKilled+#endif+ spec :: Spec spec = do+ let -- The callback will run in a thread that gets cancelled immediately,+ -- then get Exception2 thrown synchronously after 1 second.+ withAsyncExceptionThrown :: (IO a -> IO b) -> IO b+ withAsyncExceptionThrown f = do+ var <- newEmptyMVar+ a <- async $ f $ do+ putMVar var ()+ threadDelay 1000000+ throwIO Exception2+ -- wait until thread is running, then cancel+ takeMVar var+ cancel a+ -- check result+ wait a+ -- The callback will run in a thread that gets Exception1 thrown as+ -- an async exception immediately, then get Exception2 thrown+ -- synchronously after 1 second.+ withWrappedAsyncExceptionThrown :: (IO a -> IO b) -> IO b+ withWrappedAsyncExceptionThrown f = do+ var <- newEmptyMVar+ a <- async $ f $ do+ putMVar var ()+ threadDelay 1000000+ throwIO Exception2+ -- wait until thread is running, then cancel+ takeMVar var+ throwTo (asyncThreadId a) Exception1+ -- check result+ wait a+ describe "catchSyncOrAsync" $ do+ it "should catch sync exceptions" $ do+ result <- (`catchSyncOrAsync` return) $ throwIO Exception1+ result `shouldBe` Exception1+ it "should catch async exceptions" $ do+ result <- withAsyncExceptionThrown $ \m -> m `catchSyncOrAsync` return+ result `shouldBe` cancelled+ it "should catch unliftio-wrapped async exceptions" $ do+ result <- withWrappedAsyncExceptionThrown $ \m -> m `catchSyncOrAsync` return+ fromExceptionUnwrap result `shouldBe` Just Exception1+ describe "handleSyncOrAsync" $ do+ it "should catch sync exceptions" $ do+ result <- handleSyncOrAsync return $ throwIO Exception1+ result `shouldBe` Exception1+ it "should catch async exceptions" $ do+ result <- withAsyncExceptionThrown $ \m -> handleSyncOrAsync return m+ result `shouldBe` cancelled+ it "should catch unliftio-wrapped async exceptions" $ do+ result <- withWrappedAsyncExceptionThrown $ \m -> handleSyncOrAsync return m+ fromExceptionUnwrap result `shouldBe` Just Exception1+ describe "trySyncOrAsync" $ do+ it "should catch sync exceptions" $ do+ result <- trySyncOrAsync $ void $ throwIO Exception1+ result `shouldBe` Left Exception1+ it "should catch async exceptions" $ do+ result <- withAsyncExceptionThrown $ \m -> trySyncOrAsync (void m)+ result `shouldBe` Left cancelled+ it "should catch unliftio-wrapped async exceptions" $ do+ result <- withWrappedAsyncExceptionThrown $ \m -> trySyncOrAsync (void m)+ first fromExceptionUnwrap result `shouldBe` Left (Just Exception1)++ describe "fromExceptionUnwrap" $ do+ it "should be the inverse of toAsyncException" $ do+ fromExceptionUnwrap (toAsyncException Exception1) `shouldBe` Just Exception1+ it "should be the inverse of toSyncException" $ do+ let toAsyncToSync = toSyncException . toAsyncException+ fromSyncFromAsyc = fromExceptionUnwrap <=< fromExceptionUnwrap+ fromSyncFromAsyc (toAsyncToSync Exception1) `shouldBe` Just Exception1+ let shouldLeft x = either (const Nothing) Just x `shouldBe` Nothing shouldRight x = either (Just . show) (const Nothing) x `shouldBe` Nothing describe "pureTry" $ do@@ -15,3 +97,17 @@ it "Right for defined values" $ shouldRight $ pureTryDeep () it "Left for bottom" $ shouldLeft $ pureTryDeep (undefined :: ()) it "Left for wrapped bottom" $ shouldLeft $ pureTryDeep $ Just (undefined :: ())++ describe "mapExceptionM" $ do+ it "should convert an exception" $ do+ result <- try $ mapExceptionM (\Exception1 -> Exception2) (throwIO Exception1)+ result `shouldBe` (Left Exception2 :: Either Exception2 ())+ it "should not convert unrelated exceptions" $ do+ result <- try $ mapExceptionM (\Exception1 -> Exception2) (throwIO Exception2)+ result `shouldBe` (Left Exception2 :: Either Exception2 ())++data Exception1 = Exception1 deriving (Show, Eq)+instance Exception Exception1++data Exception2 = Exception2 deriving (Show, Eq)+instance Exception Exception2
+ test/UnliftIO/IO/FileSpec.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module UnliftIO.IO.FileSpec where++import Test.Hspec+-- Atomic/durable file writing is not supported on Windows.+#ifndef WINDOWS+import Control.Monad (forM_)+import Data.Bool (bool)+import System.FilePath ((</>))+import Test.QuickCheck+import UnliftIO.Directory+import UnliftIO.Exception+import UnliftIO.IO+import UnliftIO.IO.File as File+import UnliftIO.Temporary (withSystemTempDirectory)+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+#if __GLASGOW_HASKELL__ < 820+import Data.Monoid+#endif++data ExpectedException =+ ExpectedException+ deriving (Show)++instance Exception ExpectedException++spec :: Spec+spec = do+ describe "ensureFileDurable" $+ it "ensures a file is durable with an fsync" $+ withSystemTempDirectory "rio" $ \dir -> do+ let fp = dir </> "ensure_file_durable"+ writeFile fp "Hello World"+ File.ensureFileDurable fp+ contents <- B.readFile fp+ contents `shouldBe` "Hello World"+ withBinaryFileSpec False "withBinaryFile" withBinaryFile+ writeBinaryFileSpec "writeBinaryFile" writeBinaryFile+ -- Above two specs are validating the specs behavior by applying to+ -- known good implementations+ withBinaryFileSpec True "withBinaryFileAtomic" File.withBinaryFileAtomic+ writeBinaryFileSpec "writeBinaryFileAtomic" File.writeBinaryFileAtomic+ withBinaryFileSpec False "withBinaryFileDurable" File.withBinaryFileDurable+ writeBinaryFileSpec "writeBinaryFileDurable" File.writeBinaryFileDurable+ withBinaryFileSpec True "withBinaryFileDurableAtomic" File.withBinaryFileDurableAtomic+ writeBinaryFileSpec "writeBinaryFileDurableAtomic" File.writeBinaryFileDurableAtomic++writeFileUtf8 fp str = withBinaryFile fp WriteMode (`BB.hPutBuilder` BB.stringUtf8 str)++withBinaryFileSpec ::+ Bool -- ^ Should we test atomicity+ -> String+ -> (forall a. FilePath -> IOMode -> (Handle -> IO a) -> IO a)+ -> Spec+withBinaryFileSpec atomic fname withFileTestable = do+ let hello = "Hello World"+ helloString = "Hello World"+ writeHello fp = writeFileUtf8 fp helloString+ -- Create a file, write "Hello World" into it and apply the action.+ withHelloFileTestable fp iomode action = do+ writeHello fp+ withFileTestable fp iomode action+ goodbye = "Goodbye yall"+ modifiedPermissions =+ setOwnerExecutable True $+ setOwnerReadable True $ setOwnerWritable True emptyPermissions+ describe fname $ do+ it "read" $+ withSystemTempDirectory "rio" $ \dir -> do+ let fp = dir </> fname ++ "-read"+ withHelloFileTestable fp ReadWriteMode (`B.hGet` B.length hello) `shouldReturn`+ hello+ it "write" $+ withSystemTempDirectory "rio" $ \dir -> do+ let fp = dir </> fname ++ "-write"+ withHelloFileTestable fp WriteMode (`B.hPut` goodbye)+ B.readFile fp `shouldReturn` goodbye+ it "read/write" $+ withSystemTempDirectory "rio" $ \dir -> do+ let fp = dir </> fname ++ "-read-write"+ withHelloFileTestable fp ReadWriteMode $ \h -> do+ B.hGetLine h `shouldReturn` hello+ B.hPut h goodbye+ B.readFile fp `shouldReturn` (hello <> goodbye)+ it "append" $+ withSystemTempDirectory "rio" $ \dir -> do+ let fp = dir </> fname ++ "-append"+ privet = "Привет Мир" -- some unicode won't hurt+ encodeUtf8 = BL.toStrict . BB.toLazyByteString . BB.stringUtf8+ writeFileUtf8 fp privet+ setPermissions fp modifiedPermissions+ withFileTestable fp AppendMode $ \h -> B.hPut h goodbye+ B.readFile fp `shouldReturn` (encodeUtf8 privet <> goodbye)+ it "sub-directory" $+ withSystemTempDirectory "rio" $ \dir -> do+ let subDir = dir </> fname ++ "-sub-directory"+ fp = subDir </> "test.file"+ createDirectoryIfMissing True subDir+ withHelloFileTestable fp ReadWriteMode $ \h -> do+ B.hGetLine h `shouldReturn` hello+ B.hPut h goodbye+ B.readFile fp `shouldReturn` (hello <> goodbye)+ it "relative-directory" $+ withSystemTempDirectory "rio" $ \dir -> do+ let relDir = fname ++ "-relative-directory"+ subDir = dir </> relDir+ fp = relDir </> "test.file"+ createDirectoryIfMissing True subDir+ withCurrentDirectoryCompat dir $ do+ withHelloFileTestable fp ReadWriteMode $ \h -> do+ B.hGetLine h `shouldReturn` hello+ B.hPut h goodbye+ B.readFile fp `shouldReturn` (hello <> goodbye)+ it "modified-permissions" $+ forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->+ withSystemTempDirectory "rio" $ \dir -> do+ let fp = dir </> fname ++ "-modified-permissions"+ writeHello fp+ setPermissions fp modifiedPermissions+ withFileTestable fp iomode $ \h -> B.hPut h goodbye+ getPermissions fp `shouldReturn` modifiedPermissions+ it "exception - Does not corrupt files" $+ bool expectFailure property atomic $ -- should fail for non-atomic+ forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->+ withSystemTempDirectory "rio" $ \dir -> do+ let fp = dir </> fname ++ "-exception"+ _ :: Either ExpectedException () <-+ try $+ withHelloFileTestable fp iomode $ \h -> do+ B.hPut h goodbye+ throwIO ExpectedException+ B.readFile fp `shouldReturn` hello+ it "exception - Does not leave files behind" $+ bool expectFailure property atomic $ -- should fail for non-atomic+ forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->+ withSystemTempDirectory "rio" $ \dir -> do+ let fp = dir </> fname ++ "-exception"+ _ :: Either ExpectedException () <-+ try $+ withFileTestable fp iomode $ \h -> do+ B.hPut h goodbye+ throwIO ExpectedException+ doesFileExist fp `shouldReturn` False+ listDirectoryCompat dir `shouldReturn` []+ it "delete - file" $+ bool expectFailure property atomic $ -- should fail for non-atomic+ forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode ->+ withSystemTempDirectory "rio" $ \dir -> do+ let fp = dir </> fname ++ "-delete"+ withHelloFileTestable fp iomode $ \h -> do+ removeFile fp+ B.hPut h goodbye+ doesFileExist fp `shouldReturn` True++writeBinaryFileSpec :: String -> (FilePath -> B.ByteString -> IO ()) -> SpecWith ()+writeBinaryFileSpec fname writeFileTestable = do+ let hello = "Hello World"+ describe fname $ do+ it "write" $+ withSystemTempDirectory "rio" $ \dir -> do+ let fp = dir </> fname ++ "-write"+ writeFileTestable fp hello+ B.readFile fp `shouldReturn` hello+ it "default-permissions" $+ withSystemTempDirectory "rio" $ \dir -> do+ let fp = dir </> fname ++ "-default-permissions"+ defaultPermissions =+ setOwnerReadable True $ setOwnerWritable True emptyPermissions+ writeFileTestable fp hello+ getPermissions fp `shouldReturn` defaultPermissions+++listDirectoryCompat :: FilePath -> IO [FilePath]+#if MIN_VERSION_directory(1,2,5)+listDirectoryCompat = listDirectory+#else+listDirectoryCompat path =+ filter f <$> getDirectoryContents path+ where f filename = filename /= "." && filename /= ".."+#endif++withCurrentDirectoryCompat :: FilePath -> IO a -> IO a+#if MIN_VERSION_directory(1,2,3)+withCurrentDirectoryCompat = withCurrentDirectory+#else+withCurrentDirectoryCompat dir action =+ bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do+ setCurrentDirectory dir+ action+#endif++#else+spec :: Spec+spec = pure ()+#endif
+ test/UnliftIO/PooledAsyncSpec.hs view
@@ -0,0 +1,203 @@+{-#LANGUAGE DeriveDataTypeable#-}+{-#LANGUAGE BangPatterns#-}++module UnliftIO.PooledAsyncSpec (spec) where++import Test.Hspec+import Control.Concurrent+import Data.List (sort)+import Test.QuickCheck+import qualified Data.Set as Set+import Data.Functor ((<$>))+import UnliftIO++data MyPooledException = PoolHellException+ deriving (Show, Typeable)++instance Exception MyPooledException++-- | Strip out duplicates. (Taken from rio)+nubOrd :: Ord a => [a] -> [a]+nubOrd =+ loop Set.empty+ where+ loop _ [] = []+ loop !s (a:as)+ | a `Set.member` s = loop s as+ | otherwise = a : loop (Set.insert a s) as++spec :: Spec+spec = do+ let exAction :: Int -> IO Int+ exAction x = do+ if (x == 2) then throwIO PoolHellException else return ()+ return x++ action :: Int -> IO ThreadId+ action x = do+ threadDelay (2 * 10^5)+ myThreadId++ myVar :: IO (TVar Int)+ myVar = atomically $ newTVar 0++ maxTVar :: Int -> TVar Int -> IO ()+ maxTVar cval tvar = do+ atomically $ do+ v <- readTVar tvar+ if cval >= v+ then writeTVar tvar cval+ else return ()++ poolException :: Selector MyPooledException+ poolException = const True++ describe "pooled mapConcurrencyN" $ do+ it "Throws exception properly" $ do+ (pooledMapConcurrentlyN 5 exAction [1..5]) `shouldThrow` poolException++ it "total thread should be >= 1" $ do+ (pooledMapConcurrentlyN 0 action [1..5]) `shouldThrow` anyErrorCall++ it "should not spawn more than five threads for five concurrent tasks" $ do+ xs <- (pooledMapConcurrentlyN 5 action [1..5])+ (length $ nubOrd xs) `shouldSatisfy` (<= (5 :: Int))++ it "should not spawn more than three threads for five concurrent tasks" $ do+ xs <- (pooledMapConcurrentlyN 3 action [1..5])+ (length $ nubOrd xs) `shouldSatisfy` (<= (3 :: Int))++ it "should spawn only one thread" $ do+ xs <- (pooledMapConcurrentlyN 1 action [1..5])+ (length $ nubOrd xs) `shouldBe` 1++ it "never uses more than the given number of pools and doesn't miss any return values" $+ forAllShrink ((+ 1) . abs <$> arbitrary) (filter (>= 1) . shrink) $ \threads ->+ property $ \list -> do+ threadIdsVar <- newTVarIO []+ let go :: Int -> IO Int+ go i = do+ tid <- myThreadId+ atomically $ modifyTVar threadIdsVar (tid :)+ return i+ list' <- pooledMapConcurrentlyN threads go list+ sort list' `shouldBe` sort list+ tids <- readTVarIO threadIdsVar+ length (nubOrd tids) `shouldSatisfy` (<= threads)++ describe "pooled mapConcurrencyN_" $ do+ it "Throws exception properly" $ do+ (pooledMapConcurrentlyN_ 5 exAction [1..5]) `shouldThrow` poolException++ it "total thread should be >= 1" $ do+ (pooledMapConcurrentlyN_ 0 action [1..5]) `shouldThrow` anyErrorCall++ it "find proper maximum value" $ do+ var <- myVar+ xs <- (pooledMapConcurrentlyN_ 5 (\x -> maxTVar x var) [1..5])+ newVar <- atomically $ readTVar var+ atomically $ writeTVar var 0+ newVar `shouldBe` 5++ it "find proper maximum value with 2 threads" $ do+ var <- myVar+ xs <- (pooledMapConcurrentlyN_ 2 (\x -> maxTVar x var) [1..5])+ newVar <- atomically $ readTVar var+ atomically $ writeTVar var 0+ newVar `shouldBe` 5++ it "find proper maximum value with 1 threads" $ do+ var <- myVar+ xs <- (pooledMapConcurrentlyN_ 1 (\x -> maxTVar x var) [1..5])+ newVar <- atomically $ readTVar var+ atomically $ writeTVar var 0+ newVar `shouldBe` 5++ it "make sure activity is happening in different threads" $ do+ let myThreads :: IO (TVar [ThreadId])+ myThreads = atomically $ newTVar []++ collectThreads :: TVar [ThreadId] -> IO ()+ collectThreads threadVar = do+ tid <- myThreadId+ atomically $ do+ tvar <- readTVar threadVar+ writeTVar threadVar (tid:tvar)+ threadDelay $ 2 * 10^5++ tid <- myThreads+ xs <- pooledMapConcurrentlyN_ 5 (\_ -> collectThreads tid) [1..5]+ tids <- atomically $ readTVar tid+ (length $ nubOrd tids) `shouldSatisfy` (<= 5)++ it "Not more than 5 threads will be spawned even if pooling is set to 8 " $ do+ let myThreads :: IO (TVar [ThreadId])+ myThreads = atomically $ newTVar []++ collectThreads :: TVar [ThreadId] -> IO ()+ collectThreads threadVar = do+ tid <- myThreadId+ atomically $ do+ tvar <- readTVar threadVar+ writeTVar threadVar (tid:tvar)+ threadDelay $ 2 * 10^5++ tid <- myThreads+ xs <- pooledMapConcurrentlyN_ 8 (\_ -> collectThreads tid) [1..5]+ tids <- atomically $ readTVar tid+ (length $ nubOrd tids) `shouldSatisfy` (<= 5)++ describe "replicate concurrencyN" $ do+ it "Throws exception properly" $ do+ (pooledReplicateConcurrentlyN 5 1 (exAction 2)) `shouldThrow` poolException++ it "total thread should be >= 1" $ do+ (pooledReplicateConcurrentlyN 0 1 (action 1)) `shouldThrow` anyErrorCall++ it "Read tvar value should be 100" $ do+ var <- myVar+ xs <- (pooledReplicateConcurrentlyN 5 5 (maxTVar 100 var))+ newVar <- atomically $ readTVar var+ atomically $ writeTVar var 0+ newVar `shouldBe` 100++ it "should not spawn more than five threads for five concurrent tasks" $ do+ xs <- (pooledReplicateConcurrentlyN 5 5 (action 1))+ (length $ nubOrd xs) `shouldSatisfy` (<= (5 :: Int))++ it "should not spawn more than three threads for five concurrent tasks" $ do+ xs <- (pooledReplicateConcurrentlyN 3 5 (action 1))+ (length $ nubOrd xs) `shouldSatisfy` (<= (3 :: Int))++ it "should spawn only one thread" $ do+ xs <- (pooledReplicateConcurrentlyN 1 5 (action 1))+ (length $ nubOrd xs) `shouldBe` 1++ it "should give empty list" $ do+ xs <- (pooledReplicateConcurrentlyN 3 0 (action 1))+ xs `shouldBe` []++ it "should give empty list for -ve count" $ do+ xs <- (pooledReplicateConcurrentlyN 3 (-3) (action 1))+ xs `shouldBe` []++ describe "pooled replicateConcurrencyN_" $ do+ it "Throws exception properly" $ do+ (pooledReplicateConcurrentlyN_ 5 1 (exAction 2)) `shouldThrow` poolException++ it "total thread should be >= 1" $ do+ (pooledReplicateConcurrentlyN_ 0 2 (action 1)) `shouldThrow` anyErrorCall++ it "find proper maximum value" $ do+ var <- myVar+ pooledReplicateConcurrentlyN_ 5 3 (maxTVar 200 var)+ newVar <- atomically $ readTVar var+ atomically $ writeTVar var 0+ newVar `shouldBe` 200++ it "Should be initial value" $ do+ var <- myVar+ pooledReplicateConcurrentlyN_ 5 (-2) (maxTVar 200 var)+ newVar <- atomically $ readTVar var+ atomically $ writeTVar var 0+ newVar `shouldBe` 0
unliftio.cabal view
@@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.30.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack------ hash: b929fccb27c59fc9bc0f46c3f81f101436a852090cd8bc99591e2a71d53e65f1 name: unliftio-version: 0.2.8.1+version: 0.2.25.1 synopsis: The MonadUnliftIO typeclass for unlifting monads to IO (batteries included) description: Please see the documentation and README at <https://www.stackage.org/package/unliftio> category: Control@@ -23,77 +21,136 @@ ChangeLog.md library+ exposed-modules:+ UnliftIO+ UnliftIO.Async+ UnliftIO.Chan+ UnliftIO.Concurrent+ UnliftIO.Directory+ UnliftIO.Environment+ UnliftIO.Exception+ UnliftIO.Exception.Lens+ UnliftIO.Foreign+ UnliftIO.Internals.Async+ UnliftIO.IO+ UnliftIO.IO.File+ UnliftIO.IORef+ UnliftIO.Memoize+ UnliftIO.MVar+ UnliftIO.Process+ UnliftIO.QSem+ UnliftIO.QSemN+ UnliftIO.STM+ UnliftIO.Temporary+ UnliftIO.Timeout+ other-modules:+ Paths_unliftio hs-source-dirs: src+ ghc-options: -fwarn-incomplete-uni-patterns build-depends: async >2.1.1- , base >=4.7 && <5+ , base >=4.9 && <5+ , bytestring , deepseq , directory , filepath , process >=1.2.0.0- , stm >=2.4.3+ , safe-exceptions+ , stm >=2.5 , time , transformers , unliftio-core >=0.1.1.0- if !os(Windows)+ default-language: Haskell2010+ if os(windows)+ cpp-options: -DWINDOWS+ else build-depends: unix+ if impl(ghc <= 7.10)+ build-depends:+ nats if os(darwin)+ other-modules:+ UnliftIO.IO.File.Posix c-sources: cbits/time-osx.c+ cbits/file-posix.c else if os(windows) c-sources: cbits/time-windows.c else+ other-modules:+ UnliftIO.IO.File.Posix c-sources:+ cbits/file-posix.c cbits/time-posix.c- exposed-modules:- UnliftIO- UnliftIO.Async- UnliftIO.Chan- UnliftIO.Concurrent- UnliftIO.Directory- UnliftIO.Environment- UnliftIO.Exception- UnliftIO.Foreign- UnliftIO.IO- UnliftIO.IORef- UnliftIO.Memoize- UnliftIO.MVar- UnliftIO.Process- UnliftIO.STM- UnliftIO.Temporary- UnliftIO.Timeout- other-modules:- Paths_unliftio- default-language: Haskell2010 test-suite unliftio-spec type: exitcode-stdio-1.0 main-is: Spec.hs+ other-modules:+ UnliftIO.AsyncSpec+ UnliftIO.DirectorySpec+ UnliftIO.ExceptionSpec+ UnliftIO.IO.FileSpec+ UnliftIO.IOSpec+ UnliftIO.MemoizeSpec+ UnliftIO.PooledAsyncSpec+ Paths_unliftio hs-source-dirs: test build-depends:- async >2.1.1- , base >=4.7 && <5+ QuickCheck+ , async >2.1.1+ , base >=4.9 && <5+ , bytestring+ , containers , deepseq , directory , filepath , hspec , process >=1.2.0.0- , stm >=2.4.3+ , safe-exceptions+ , stm >=2.5 , time , transformers , unliftio , unliftio-core >=0.1.1.0- if !os(Windows)+ default-language: Haskell2010+ if os(windows)+ cpp-options: -DWINDOWS+ else build-depends: unix++benchmark conc-bench+ type: exitcode-stdio-1.0+ main-is: ConcBench.hs other-modules:- UnliftIO.ExceptionSpec- UnliftIO.IOSpec- UnliftIO.MemoizeSpec Paths_unliftio+ hs-source-dirs:+ bench+ ghc-options: -O2 -threaded -rtsopts+ build-depends:+ async >2.1.1+ , base >=4.9 && <5+ , bytestring+ , deepseq+ , directory+ , filepath+ , gauge+ , process >=1.2.0.0+ , safe-exceptions+ , stm >=2.5+ , time+ , transformers+ , unliftio+ , unliftio-core >=0.1.1.0 default-language: Haskell2010+ if os(windows)+ cpp-options: -DWINDOWS+ else+ build-depends:+ unix