unliftio-0.2.11/bench/0000755000000000000000000000000013403661532012674 5ustar0000000000000000unliftio-0.2.11/cbits/0000755000000000000000000000000013251722173012721 5ustar0000000000000000unliftio-0.2.11/src/0000755000000000000000000000000013352702215012401 5ustar0000000000000000unliftio-0.2.11/src/UnliftIO/0000755000000000000000000000000013476437166014113 5ustar0000000000000000unliftio-0.2.11/src/UnliftIO/Internals/0000755000000000000000000000000013412137046016032 5ustar0000000000000000unliftio-0.2.11/test/0000755000000000000000000000000013221441450012565 5ustar0000000000000000unliftio-0.2.11/test/UnliftIO/0000755000000000000000000000000013412137046014263 5ustar0000000000000000unliftio-0.2.11/src/UnliftIO.hs0000644000000000000000000000130313343444703014430 0ustar0000000000000000-- | Please see the README.md file for information on using this -- package at . module UnliftIO ( module Control.Monad.IO.Unlift , module UnliftIO.Async , module UnliftIO.Chan , module UnliftIO.Exception , module UnliftIO.IO , module UnliftIO.IORef , module UnliftIO.Memoize , module UnliftIO.MVar , module UnliftIO.STM , module UnliftIO.Temporary , module UnliftIO.Timeout ) where import Control.Monad.IO.Unlift import UnliftIO.Async import UnliftIO.Chan import UnliftIO.Exception import UnliftIO.IO import UnliftIO.IORef import UnliftIO.Memoize import UnliftIO.MVar import UnliftIO.STM import UnliftIO.Temporary import UnliftIO.Timeout unliftio-0.2.11/src/UnliftIO/Async.hs0000644000000000000000000000413313412137046015505 0ustar0000000000000000{-# 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 module UnliftIO.Async ( -- * Asynchronous actions Async, -- ** Spawning async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask, -- ** Spawning with automatic 'cancel'ation withAsync, withAsyncBound, withAsyncOn, withAsyncWithUnmask, withAsyncOnWithUnmask, -- ** Querying 'Async's wait, poll, waitCatch, cancel, uninterruptibleCancel, cancelWith, A.asyncThreadId, -- ** STM operations A.waitSTM, A.pollSTM, A.waitCatchSTM, -- ** Waiting for multiple 'Async's waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel, waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel, waitEither_, waitBoth, -- ** Waiting for multiple 'Async's in STM A.waitAnySTM, A.waitAnyCatchSTM, A.waitEitherSTM, A.waitEitherCatchSTM, A.waitEitherSTM_, A.waitBothSTM, -- ** 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 (..), #if MIN_VERSION_base(4,8,0) Conc, conc, runConc, ConcException (..) #endif ) where import Control.Concurrent.Async (Async) import qualified Control.Concurrent.Async as A import UnliftIO.Internals.Async unliftio-0.2.11/src/UnliftIO/Chan.hs0000644000000000000000000000210013207246422015272 0ustar0000000000000000-- | Lifted "Control.Concurrent.Chan". -- -- @since 0.1.0.0 module UnliftIO.Chan ( Chan , newChan , writeChan , readChan , dupChan , getChanContents , writeList2Chan ) where import Control.Monad.IO.Unlift import Control.Concurrent.Chan (Chan) import qualified Control.Concurrent.Chan as C -- | Lifted 'C.newChan'. -- -- @since 0.1.0.0 newChan :: MonadIO m => m (Chan a) newChan = liftIO C.newChan -- | Lifted 'C.writeChan'. -- -- @since 0.1.0.0 writeChan :: MonadIO m => Chan a -> a -> m () writeChan c = liftIO . C.writeChan c -- | Lifted 'C.readChan'. -- -- @since 0.1.0.0 readChan :: MonadIO m => Chan a -> m a readChan = liftIO . C.readChan -- | Lifted 'C.dupChan'. -- -- @since 0.1.0.0 dupChan :: MonadIO m => Chan a -> m (Chan a) dupChan = liftIO . C.dupChan -- | Lifted 'C.getChanContents'. -- -- @since 0.1.0.0 getChanContents :: MonadIO m => Chan a -> m [a] getChanContents = liftIO . C.getChanContents -- | Lifted 'C.writeList2Chan'. -- -- @since 0.1.0.0 writeList2Chan :: MonadIO m => Chan a -> [a] -> m () writeList2Chan c = liftIO . C.writeList2Chan c unliftio-0.2.11/src/UnliftIO/Concurrent.hs0000644000000000000000000001261513476437166016576 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} -- | Unlifted "Control.Concurrent". -- -- This module is not reexported by "UnliftIO", -- use it only if "UnliftIO.Async" is not enough. -- -- @since 0.1.1.0 module UnliftIO.Concurrent ( -- * Concurrent Haskell ThreadId, -- * Basic concurrency operations myThreadId, forkIO, forkWithUnmask, forkIOWithUnmask, forkFinally, killThread, throwTo, -- ** Threads with affinity forkOn, forkOnWithUnmask, getNumCapabilities, setNumCapabilities, threadCapability, -- * Scheduling yield, -- ** Waiting threadDelay, threadWaitRead, threadWaitWrite, -- * Communication abstractions module UnliftIO.MVar, module UnliftIO.Chan, -- * Bound Threads C.rtsSupportsBoundThreads, forkOS, isCurrentThreadBound, runInBoundThread, runInUnboundThread, -- * Weak references to ThreadIds mkWeakThreadId ) where import Control.Monad.IO.Class (MonadIO, liftIO) import System.Posix.Types (Fd) import System.Mem.Weak (Weak) import Control.Concurrent (ThreadId) import qualified Control.Concurrent as C import Control.Monad.IO.Unlift import UnliftIO.MVar import UnliftIO.Chan import UnliftIO.Exception (throwTo, SomeException) -- | Lifted version of 'C.myThreadId'. -- -- @since 0.1.1.0 myThreadId :: MonadIO m => m ThreadId myThreadId = liftIO C.myThreadId {-# INLINABLE myThreadId #-} -- | Unlifted version of 'C.forkIO'. -- -- @since 0.1.1.0 forkIO :: MonadUnliftIO m => m () -> m ThreadId forkIO m = withRunInIO $ \run -> C.forkIO $ run m {-# INLINABLE forkIO #-} -- | 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 = forkIOWithUnmask {-# INLINABLE forkWithUnmask #-} {-# DEPRECATED forkWithUnmask "forkWithUnmask has been renamed to forkIOWithUnmask" #-} -- | Unlifted version of 'C.forkFinally'. -- -- @since 0.1.1.0 forkFinally :: MonadUnliftIO m => m a -> (Either SomeException a -> m ()) -> m ThreadId forkFinally m1 m2 = withRunInIO $ \run -> C.forkFinally (run m1) $ run . m2 {-# INLINABLE forkFinally #-} -- | Lifted version of 'C.killThread'. -- -- @since 0.1.1.0 killThread :: MonadIO m => ThreadId -> m () killThread = liftIO . C.killThread {-# INLINABLE killThread #-} -- | Unlifted version of 'C.forkOn'. -- -- @since 0.1.1.0 forkOn :: MonadUnliftIO m => Int -> m () -> m ThreadId forkOn i m = withRunInIO $ \run -> C.forkOn i $ run m {-# INLINABLE forkOn #-} -- | Unlifted version of 'C.forkOnWithUnmask'. -- -- @since 0.1.1.0 forkOnWithUnmask :: MonadUnliftIO m => Int -> ((forall a. m a -> m a) -> m ()) -> m ThreadId forkOnWithUnmask i m = withRunInIO $ \run -> C.forkOnWithUnmask i $ \unmask -> run $ m $ liftIO . unmask . run {-# INLINABLE forkOnWithUnmask #-} -- | Lifted version of 'C.getNumCapabilities'. -- -- @since 0.1.1.0 getNumCapabilities :: MonadIO m => m Int getNumCapabilities = liftIO C.getNumCapabilities {-# INLINABLE getNumCapabilities #-} -- | Lifted version of 'C.setNumCapabilities'. -- -- @since 0.1.1.0 setNumCapabilities :: MonadIO m => Int -> m () setNumCapabilities = liftIO . C.setNumCapabilities {-# INLINABLE setNumCapabilities #-} -- | Lifted version of 'C.threadCapability'. -- -- @since 0.1.1.0 threadCapability :: MonadIO m => ThreadId -> m (Int, Bool) threadCapability = liftIO . C.threadCapability {-# INLINABLE threadCapability #-} -- | Lifted version of 'C.yield'. -- -- @since 0.1.1.0 yield :: MonadIO m => m () yield = liftIO C.yield {-# INLINABLE yield #-} -- | Lifted version of 'C.threadDelay'. -- -- @since 0.1.1.0 threadDelay :: MonadIO m => Int -> m () threadDelay = liftIO . C.threadDelay {-# INLINABLE threadDelay #-} -- | Lifted version of 'C.threadWaitRead'. -- -- @since 0.1.1.0 threadWaitRead :: MonadIO m => Fd -> m () threadWaitRead = liftIO . C.threadWaitRead {-# INLINABLE threadWaitRead #-} -- | Lifted version of 'C.threadWaitWrite'. -- -- @since 0.1.1.0 threadWaitWrite :: MonadIO m => Fd -> m () threadWaitWrite = liftIO . C.threadWaitWrite {-# INLINABLE threadWaitWrite #-} -- | Unflifted version of 'C.forkOS'. -- -- @since 0.1.1.0 forkOS :: MonadUnliftIO m => m () -> m ThreadId forkOS m = withRunInIO $ \run -> C.forkOS $ run m {-# INLINABLE forkOS #-} -- | Lifted version of 'C.isCurrentThreadBound'. -- -- @since 0.1.1.0 isCurrentThreadBound :: MonadIO m => m Bool isCurrentThreadBound = liftIO C.isCurrentThreadBound {-# INLINABLE isCurrentThreadBound #-} -- | Unlifted version of 'C.runInBoundThread'. -- -- @since 0.1.1.0 runInBoundThread :: MonadUnliftIO m => m a -> m a runInBoundThread m = withRunInIO $ \run -> C.runInBoundThread $ run m {-# INLINABLE runInBoundThread #-} -- | Unlifted version of 'C.runInUnboundThread'. -- -- @since 0.1.1.0 runInUnboundThread :: MonadUnliftIO m => m a -> m a runInUnboundThread m = withRunInIO $ \run -> C.runInUnboundThread $ run m {-# INLINABLE runInUnboundThread #-} -- | Lifted version of 'C.mkWeakThreadId'. -- -- @since 0.1.1.0 mkWeakThreadId :: MonadIO m => ThreadId -> m (Weak ThreadId) mkWeakThreadId = liftIO . C.mkWeakThreadId {-# INLINABLE mkWeakThreadId #-} unliftio-0.2.11/src/UnliftIO/Directory.hs0000644000000000000000000002751513253417272016412 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Unlifted "System.Directory". -- -- @since 0.2.6.0 module UnliftIO.Directory ( -- * Actions on directories createDirectory , createDirectoryIfMissing , removeDirectory , removeDirectoryRecursive #if MIN_VERSION_directory(1,2,7) , removePathForcibly #endif , renameDirectory #if MIN_VERSION_directory(1,2,5) , listDirectory #endif , getDirectoryContents -- ** Current working directory , getCurrentDirectory , setCurrentDirectory #if MIN_VERSION_directory(1,2,3) , withCurrentDirectory #endif -- * Pre-defined directories , getHomeDirectory #if MIN_VERSION_directory(1,2,3) , XdgDirectory(..) , getXdgDirectory #endif , getAppUserDataDirectory , getUserDocumentsDirectory , getTemporaryDirectory -- * Actions on files , removeFile , renameFile #if MIN_VERSION_directory(1,2,7) , renamePath #endif , copyFile #if MIN_VERSION_directory(1,2,6) , copyFileWithMetadata #endif , canonicalizePath #if MIN_VERSION_directory(1,2,2) , makeAbsolute #endif , makeRelativeToCurrentDirectory , findExecutable #if MIN_VERSION_directory(1,2,2) , findExecutables #endif #if MIN_VERSION_directory(1,2,4) , findExecutablesInDirectories #endif , findFile #if MIN_VERSION_directory(1,2,1) , findFiles #endif #if MIN_VERSION_directory(1,2,6) , findFileWith #endif #if MIN_VERSION_directory(1,2,1) , findFilesWith #endif #if MIN_VERSION_directory(1,2,4) , exeExtension #endif #if MIN_VERSION_directory(1,2,7) , getFileSize #endif -- * Existence tests #if MIN_VERSION_directory(1,2,7) , doesPathExist #endif , doesFileExist , doesDirectoryExist #if MIN_VERSION_directory(1,3,0) -- * Symbolic links , pathIsSymbolicLink #endif -- * Permissions , Permissions , emptyPermissions , readable , writable , executable , searchable , setOwnerReadable , setOwnerWritable , setOwnerExecutable , setOwnerSearchable , getPermissions , setPermissions , copyPermissions -- * Timestamps #if MIN_VERSION_directory(1,2,3) , getAccessTime #endif , getModificationTime #if MIN_VERSION_directory(1,2,3) , setAccessTime , setModificationTime #endif ) where import Control.Monad.IO.Unlift import Data.Time.Clock import qualified System.Directory as D import System.Directory ( Permissions #if MIN_VERSION_directory(1,2,3) , XdgDirectory(..) #endif , emptyPermissions #if MIN_VERSION_directory(1,2,4) , exeExtension #endif , executable , readable , searchable , setOwnerExecutable , setOwnerReadable , setOwnerSearchable , setOwnerWritable , writable ) -- | Lifted 'D.createDirectory'. -- -- @since 0.2.6.0 {-# INLINE createDirectory #-} createDirectory :: MonadIO m => FilePath -> m () createDirectory = liftIO . D.createDirectory -- | Lifted 'D.createDirectoryIfMissing'. -- -- @since 0.2.6.0 {-# INLINE createDirectoryIfMissing #-} createDirectoryIfMissing :: MonadIO m => Bool -> FilePath -> m () createDirectoryIfMissing create_parents path0 = liftIO (D.createDirectoryIfMissing create_parents path0) -- | Lifted 'D.removeDirectory'. -- -- @since 0.2.6.0 {-# INLINE removeDirectory #-} removeDirectory :: MonadIO m => FilePath -> m () removeDirectory = liftIO . D.removeDirectory -- | Lifted 'D.removeDirectoryRecursive'. -- -- @since 0.2.6.0 {-# INLINE removeDirectoryRecursive #-} removeDirectoryRecursive :: MonadIO m => FilePath -> m () removeDirectoryRecursive = liftIO . D.removeDirectoryRecursive #if MIN_VERSION_directory(1,2,7) -- | Lifted 'D.removePathForcibly'. -- -- @since 0.2.6.0 {-# INLINE removePathForcibly #-} removePathForcibly :: MonadIO m => FilePath -> m () removePathForcibly = liftIO . D.removePathForcibly #endif -- | Lifted 'D.renameDirectory'. -- -- @since 0.2.6.0 {-# INLINE renameDirectory #-} renameDirectory :: MonadIO m => FilePath -> FilePath -> m () renameDirectory opath npath = liftIO (D.renameDirectory opath npath) #if MIN_VERSION_directory(1,2,5) -- | Lifted 'D.listDirectory'. -- -- @since 0.2.6.0 {-# INLINE listDirectory #-} listDirectory :: MonadIO m => FilePath -> m [FilePath] listDirectory = liftIO . D.listDirectory #endif -- | Lifted 'D.getDirectoryContents'. -- -- @since 0.2.6.0 {-# INLINE getDirectoryContents #-} getDirectoryContents :: MonadIO m => FilePath -> m [FilePath] getDirectoryContents = liftIO . D.getDirectoryContents -- | Lifted 'D.getCurrentDirectory'. -- -- @since 0.2.6.0 {-# INLINE getCurrentDirectory #-} getCurrentDirectory :: MonadIO m => m FilePath getCurrentDirectory = liftIO D.getCurrentDirectory -- | Lifted 'D.setCurrentDirectory'. -- -- @since 0.2.6.0 {-# INLINE setCurrentDirectory #-} setCurrentDirectory :: MonadIO m => FilePath -> m () setCurrentDirectory = liftIO . D.setCurrentDirectory #if MIN_VERSION_directory(1,2,3) -- | Unlifted 'D.withCurrentDirectory'. -- -- @since 0.2.6.0 {-# INLINE withCurrentDirectory #-} withCurrentDirectory :: MonadUnliftIO m => FilePath -> m a -> m a withCurrentDirectory dir action = withRunInIO (\u -> D.withCurrentDirectory dir (u action)) #endif -- | Lifted 'D.getHomeDirectory'. -- -- @since 0.2.6.0 {-# INLINE getHomeDirectory #-} getHomeDirectory :: MonadIO m => m FilePath getHomeDirectory = liftIO D.getHomeDirectory #if MIN_VERSION_directory(1,2,3) -- | Lifted 'D.getXdgDirectory'. -- -- @since 0.2.6.0 {-# INLINE getXdgDirectory #-} getXdgDirectory :: MonadIO m => XdgDirectory -> FilePath -> m FilePath getXdgDirectory xdgDir suffix = liftIO (D.getXdgDirectory xdgDir suffix) #endif -- | Lifted 'D.getAppUserDataDirectory'. -- -- @since 0.2.6.0 {-# INLINE getAppUserDataDirectory #-} getAppUserDataDirectory :: MonadIO m => FilePath -> m FilePath getAppUserDataDirectory = liftIO . D.getAppUserDataDirectory -- | Lifted 'D.getUserDocumentsDirectory'. -- -- @since 0.2.6.0 {-# INLINE getUserDocumentsDirectory #-} getUserDocumentsDirectory :: MonadIO m => m FilePath getUserDocumentsDirectory = liftIO D.getUserDocumentsDirectory -- | Lifted 'D.getTemporaryDirectory'. -- -- @since 0.2.6.0 {-# INLINE getTemporaryDirectory #-} getTemporaryDirectory :: MonadIO m => m FilePath getTemporaryDirectory = liftIO D.getTemporaryDirectory -- | Lifted 'D.removeFile'. -- -- @since 0.2.6.0 {-# INLINE removeFile #-} removeFile :: MonadIO m => FilePath -> m () removeFile = liftIO . D.removeFile -- | Lifted 'D.renameFile'. -- -- @since 0.2.6.0 {-# INLINE renameFile #-} renameFile :: MonadIO m => FilePath -> FilePath -> m () renameFile opath npath = liftIO (D.renameFile opath npath) #if MIN_VERSION_directory(1,2,7) -- | Lifted 'D.renamePath'. -- -- @since 0.2.6.0 {-# INLINE renamePath #-} renamePath :: MonadIO m => FilePath -> FilePath -> m () renamePath opath npath = liftIO (D.renamePath opath npath) #endif -- | Lifted 'D.copyFile'. -- -- @since 0.2.6.0 {-# INLINE copyFile #-} copyFile :: MonadIO m => FilePath -> FilePath -> m () copyFile fromFPath toFPath = liftIO (D.copyFile fromFPath toFPath) #if MIN_VERSION_directory(1,2,6) -- | Lifted 'D.copyFileWithMetadata'. -- -- @since 0.2.6.0 {-# INLINE copyFileWithMetadata #-} copyFileWithMetadata :: MonadIO m => FilePath -> FilePath -> m () copyFileWithMetadata src dst = liftIO (D.copyFileWithMetadata src dst) #endif -- | Lifted 'D.canonicalizePath'. -- -- @since 0.2.6.0 {-# INLINE canonicalizePath #-} canonicalizePath :: MonadIO m => FilePath -> m FilePath canonicalizePath = liftIO . D.canonicalizePath #if MIN_VERSION_directory(1,2,2) -- | Lifted 'D.makeAbsolute'. -- -- @since 0.2.6.0 {-# INLINE makeAbsolute #-} makeAbsolute :: MonadIO m => FilePath -> m FilePath makeAbsolute = liftIO . D.makeAbsolute #endif -- | Lifted 'D.makeRelativeToCurrentDirectory'. -- -- @since 0.2.6.0 {-# INLINE makeRelativeToCurrentDirectory #-} makeRelativeToCurrentDirectory :: MonadIO m => FilePath -> m FilePath makeRelativeToCurrentDirectory = liftIO . D.makeRelativeToCurrentDirectory -- | Lifted 'D.findExecutable'. -- -- @since 0.2.6.0 {-# INLINE findExecutable #-} findExecutable :: MonadIO m => String -> m (Maybe FilePath) findExecutable = liftIO . D.findExecutable #if MIN_VERSION_directory(1,2,2) -- | Lifted 'D.findExecutables'. -- -- @since 0.2.6.0 {-# INLINE findExecutables #-} findExecutables :: MonadIO m => String -> m [FilePath] findExecutables = liftIO . D.findExecutables #endif #if MIN_VERSION_directory(1,2,4) -- | Lifted 'D.findExecutablesInDirectories'. -- -- @since 0.2.6.0 {-# INLINE findExecutablesInDirectories #-} findExecutablesInDirectories :: MonadIO m => [FilePath] -> String -> m [FilePath] findExecutablesInDirectories path binary = liftIO (D.findExecutablesInDirectories path binary) #endif -- | Lifted 'D.findFile'. -- -- @since 0.2.6.0 {-# INLINE findFile #-} findFile :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath) findFile ds name = liftIO (D.findFile ds name) #if MIN_VERSION_directory(1,2,1) -- | Lifted 'D.findFiles'. -- -- @since 0.2.6.0 {-# INLINE findFiles #-} findFiles :: MonadIO m => [FilePath] -> String -> m [FilePath] findFiles ds name = liftIO (D.findFiles ds name) #endif #if MIN_VERSION_directory(1,2,6) -- | Unlifted 'D.findFileWith'. -- -- @since 0.2.6.0 {-# INLINE findFileWith #-} findFileWith :: MonadUnliftIO m => (FilePath -> m Bool) -> [FilePath] -> String -> m (Maybe FilePath) findFileWith f ds name = withRunInIO (\u -> D.findFileWith (u . f) ds name) #endif #if MIN_VERSION_directory(1,2,1) -- | Unlifted 'D.findFilesWith'. -- -- @since 0.2.6.0 {-# INLINE findFilesWith #-} findFilesWith :: MonadUnliftIO m => (FilePath -> m Bool) -> [FilePath] -> String -> m [FilePath] findFilesWith f ds name = withRunInIO (\u -> D.findFilesWith (u . f) ds name) #endif #if MIN_VERSION_directory(1,2,7) -- | Lifted 'D.getFileSize'. -- -- @since 0.2.6.0 {-# INLINE getFileSize #-} getFileSize :: MonadIO m => FilePath -> m Integer getFileSize = liftIO . D.getFileSize #endif #if MIN_VERSION_directory(1,2,7) -- | Lifted 'D.doesPathExist'. -- -- @since 0.2.6.0 {-# INLINE doesPathExist #-} doesPathExist :: MonadIO m => FilePath -> m Bool doesPathExist = liftIO . D.doesPathExist #endif -- | Lifted 'D.doesFileExist'. -- -- @since 0.2.6.0 {-# INLINE doesFileExist #-} doesFileExist :: MonadIO m => FilePath -> m Bool doesFileExist = liftIO . D.doesFileExist -- | Lifted 'D.doesDirectoryExist'. -- -- @since 0.2.6.0 {-# INLINE doesDirectoryExist #-} doesDirectoryExist :: MonadIO m => FilePath -> m Bool doesDirectoryExist = liftIO . D.doesDirectoryExist #if MIN_VERSION_directory(1,3,0) -- | Lifted 'D.pathIsSymbolicLink'. -- -- @since 0.2.6.0 {-# INLINE pathIsSymbolicLink #-} pathIsSymbolicLink :: MonadIO m => FilePath -> m Bool pathIsSymbolicLink = liftIO . D.pathIsSymbolicLink #endif -- | Lifted 'D.getPermissions'. -- -- @since 0.2.6.0 {-# INLINE getPermissions #-} getPermissions :: MonadIO m => FilePath -> m Permissions getPermissions = liftIO . D.getPermissions -- | Lifted 'D.setPermissions'. -- -- @since 0.2.6.0 {-# INLINE setPermissions #-} setPermissions :: MonadIO m => FilePath -> Permissions -> m () setPermissions name p = liftIO (D.setPermissions name p) -- | Lifted 'D.copyPermissions'. -- -- @since 0.2.6.0 {-# INLINE copyPermissions #-} copyPermissions :: MonadIO m => FilePath -> FilePath -> m () copyPermissions source dest = liftIO (D.copyPermissions source dest) #if MIN_VERSION_directory(1,2,3) -- | Lifted 'D.getAccessTime'. -- -- @since 0.2.6.0 {-# INLINE getAccessTime #-} getAccessTime :: MonadIO m => FilePath -> m UTCTime getAccessTime = liftIO . D.getAccessTime #endif -- | Lifted 'D.getModificationTime'. -- -- @since 0.2.6.0 {-# INLINE getModificationTime #-} getModificationTime :: MonadIO m => FilePath -> m UTCTime getModificationTime = liftIO . D.getModificationTime #if MIN_VERSION_directory(1,2,3) -- | Lifted 'D.setAccessTime'. -- -- @since 0.2.6.0 {-# INLINE setAccessTime #-} setAccessTime :: MonadIO m => FilePath -> UTCTime -> m () setAccessTime path atime = liftIO (D.setAccessTime path atime) -- | Lifted 'D.setModificationTime'. -- -- @since 0.2.6.0 setModificationTime :: MonadIO m => FilePath -> UTCTime -> m () setModificationTime path mtime = liftIO (D.setModificationTime path mtime) #endif unliftio-0.2.11/src/UnliftIO/Environment.hs0000644000000000000000000000364613251722574016753 0ustar0000000000000000-- | Unlifted "System.Environment". -- -- @since 0.2.5.0 module UnliftIO.Environment ( getArgs , getProgName , getExecutablePath , getEnv , lookupEnv , setEnv , unsetEnv , withArgs , withProgName , getEnvironment ) where import Control.Monad.IO.Unlift import qualified System.Environment as E -- | Lifted 'E.getArgs'. -- -- @since 0.2.5.0 {-# INLINE getArgs #-} getArgs :: MonadIO m => m [String] getArgs = liftIO E.getArgs -- | Lifted 'E.getProgName'. -- -- @since 0.2.5.0 {-# INLINE getProgName #-} getProgName :: MonadIO m => m String getProgName = liftIO E.getProgName -- | Lifted 'E.getExecutablePath'. -- -- @since 0.2.5.0 {-# INLINE getExecutablePath #-} getExecutablePath :: MonadIO m => m FilePath getExecutablePath = liftIO E.getExecutablePath -- | Lifted 'E.getEnv'. -- -- @since 0.2.5.0 {-# INLINE getEnv #-} getEnv :: MonadIO m => String -> m String getEnv = liftIO . E.getEnv -- | Lifted 'E.lookupEnv'. -- -- @since 0.2.5.0 {-# INLINE lookupEnv #-} lookupEnv :: MonadIO m => String -> m (Maybe String) lookupEnv = liftIO . E.lookupEnv -- | Lifted 'E.setEnv'. -- -- @since 0.2.5.0 {-# INLINE setEnv #-} setEnv :: MonadIO m => String -> String -> m () setEnv key_ value_ = liftIO (E.setEnv key_ value_) -- | Lifted 'E.unsetEnv'. -- -- @since 0.2.5.0 {-# INLINE unsetEnv #-} unsetEnv :: MonadIO m => String -> m () unsetEnv = liftIO . E.unsetEnv -- | Unlifted 'E.withArgs'. -- -- @since 0.2.5.0 {-# INLINE withArgs #-} withArgs :: MonadUnliftIO m => [String] -> m a -> m a withArgs xs act = withRunInIO (\u -> E.withArgs xs (u act)) -- | Unlifted 'E.withProgName'. -- -- @since 0.2.5.0 {-# INLINE withProgName #-} withProgName :: MonadUnliftIO m => String -> m a -> m a withProgName nm act = withRunInIO (\u -> E.withProgName nm (u act)) -- | Lifted 'E.getEnvironment'. -- -- @since 0.2.5.0 {-# INLINE getEnvironment #-} getEnvironment :: MonadIO m => m [(String, String)] getEnvironment = liftIO E.getEnvironment unliftio-0.2.11/src/UnliftIO/Exception.hs0000644000000000000000000004420113403661532016370 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# 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://haskell-lang.org/tutorial/exception-safety). module UnliftIO.Exception ( -- * Throwing throwIO , throwString , StringException (..) , stringException , throwTo , impureThrow , fromEither , fromEitherIO , fromEitherM -- * Catching (with recovery) , catch , catchIO , catchAny , catchDeep , catchAnyDeep , catchJust , handle , handleIO , handleAny , handleDeep , handleAnyDeep , handleJust , try , tryIO , tryAny , tryDeep , tryAnyDeep , tryJust , pureTry , pureTryDeep , Handler(..) , catches , catchesDeep -- * Cleanup (no recovery) , onException , bracket , bracket_ , finally , withException , bracketOnError , bracketOnError_ -- * Coercion to sync and async , SyncExceptionWrapper (..) , toSyncException , AsyncExceptionWrapper (..) , toAsyncException -- * Check exception type , isSyncException , isAsyncException -- * Masking , mask , uninterruptibleMask , mask_ , uninterruptibleMask_ -- * Evaluation , evaluate , evaluateDeep -- * Reexports , Exception (..) , Typeable , SomeException (..) , SomeAsyncException (..) , IOException , EUnsafe.assert #if !MIN_VERSION_base(4,8,0) , displayException #endif ) where import Control.Concurrent (ThreadId) import Control.Monad (liftM) import Control.Monad.IO.Unlift import Control.Exception (Exception (..), SomeException (..), IOException, SomeAsyncException (..)) import qualified Control.Exception as EUnsafe import Control.DeepSeq (NFData (..), ($!!)) import Data.Typeable (Typeable, cast) import System.IO.Unsafe (unsafePerformIO) #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. -- -- @since 0.1.0.0 catch :: (MonadUnliftIO m, Exception e) => m a -> (e -> m a) -> m a catch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> if isSyncException e then run (g e) -- intentionally rethrowing an async exception synchronously, -- since we want to preserve async behavior else EUnsafe.throwIO e -- | 'catch' specialized to only catching 'IOException's. -- -- @since 0.1.0.0 catchIO :: MonadUnliftIO m => m a -> (IOException -> m a) -> m a catchIO = catch -- | 'catch' specialized to catch all synchronous exception. -- -- @since 0.1.0.0 catchAny :: MonadUnliftIO m => m a -> (SomeException -> m a) -> m a catchAny = catch -- | Same as 'catch', but fully force evaluation of the result value -- to find all impure exceptions. -- -- @since 0.1.0.0 catchDeep :: (MonadUnliftIO m, Exception e, NFData a) => m a -> (e -> m a) -> m a catchDeep m = catch (m >>= evaluateDeep) -- | 'catchDeep' specialized to catch all synchronous exception. -- -- @since 0.1.0.0 catchAnyDeep :: (NFData a, MonadUnliftIO m) => m a -> (SomeException -> m a) -> m a catchAnyDeep = catchDeep -- | 'catchJust' is like 'catch' but it takes an extra argument which -- is an exception predicate, a function which selects which type of -- exceptions we're interested in. -- -- @since 0.1.0.0 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 -- | Flipped version of 'catch'. -- -- @since 0.1.0.0 handle :: (MonadUnliftIO m, Exception e) => (e -> m a) -> m a -> m a handle = flip catch -- | 'handle' specialized to only catching 'IOException's. -- -- @since 0.1.0.0 handleIO :: MonadUnliftIO m => (IOException -> m a) -> m a -> m a handleIO = handle -- | Flipped version of 'catchAny'. -- -- @since 0.1.0.0 handleAny :: MonadUnliftIO m => (SomeException -> m a) -> m a -> m a handleAny = handle -- | Flipped version of 'catchDeep'. -- -- @since 0.1.0.0 handleDeep :: (MonadUnliftIO m, Exception e, NFData a) => (e -> m a) -> m a -> m a handleDeep = flip catchDeep -- | Flipped version of 'catchAnyDeep'. -- -- @since 0.1.0.0 handleAnyDeep :: (MonadUnliftIO m, NFData a) => (SomeException -> m a) -> m a -> m a handleAnyDeep = flip catchAnyDeep -- | Flipped 'catchJust'. -- -- @since 0.1.0.0 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. -- -- @since 0.1.0.0 try :: (MonadUnliftIO m, Exception e) => m a -> m (Either e a) try f = catch (liftM Right f) (return . Left) -- | 'try' specialized to only catching 'IOException's. -- -- @since 0.1.0.0 tryIO :: MonadUnliftIO m => m a -> m (Either IOException a) tryIO = try -- | 'try' specialized to catch all synchronous exceptions. -- -- @since 0.1.0.0 tryAny :: MonadUnliftIO m => m a -> m (Either SomeException a) tryAny = try -- | Same as 'try', but fully force evaluation of the result value -- to find all impure exceptions. -- -- @since 0.1.0.0 tryDeep :: (MonadUnliftIO m, Exception e, NFData a) => m a -> m (Either e a) tryDeep f = catch (liftM Right (f >>= evaluateDeep)) (return . Left) -- | 'tryDeep' specialized to catch all synchronous exceptions. -- -- @since 0.1.0.0 tryAnyDeep :: (MonadUnliftIO m, NFData a) => m a -> m (Either SomeException a) tryAnyDeep = tryDeep -- | A variant of 'try' that takes an exception predicate to select -- which exceptions are caught. -- -- @since 0.1.0.0 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)) -- | Evaluate the value to WHNF and catch any synchronous exceptions. -- -- The expression may still have bottom values within it; you may -- instead want to use 'pureTryDeep'. -- -- @since 0.2.2.0 pureTry :: a -> Either SomeException a pureTry a = unsafePerformIO $ (return $! Right $! a) `catchAny` (return . Left) -- | Evaluate the value to NF and catch any synchronous exceptions. -- -- @since 0.2.2.0 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 = case fromException e of Just e' -> handler e' Nothing -> res -- | Same as upstream 'EUnsafe.catches', but 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 -- | Same as 'catches', but fully force evaluation of the result value -- to find all impure exceptions. -- -- @since 0.1.0.0 catchesDeep :: (MonadUnliftIO m, NFData a) => m a -> [Handler m a] -> m a catchesDeep io handlers = (io >>= evaluateDeep) `catch` catchesHandler handlers -- | Lifted version of 'EUnsafe.evaluate'. -- -- @since 0.1.0.0 evaluate :: MonadIO m => a -> m a evaluate = liftIO . EUnsafe.evaluate -- | Deeply evaluate a value using 'evaluate' and 'NFData'. -- -- @since 0.1.0.0 evaluateDeep :: (MonadIO m, NFData a) => a -> m a evaluateDeep = (evaluate $!!) -- | Async safe version of 'EUnsafe.bracket'. -- -- @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 x <- run before res1 <- EUnsafe.try $ restore $ run $ thing x case res1 of Left (e1 :: SomeException) -> do -- explicitly ignore exceptions from after. We know that -- no async exceptions were thrown there, so therefore -- the stronger exception must come from thing -- -- https://github.com/fpco/safe-exceptions/issues/2 _ :: Either SomeException b <- EUnsafe.try $ EUnsafe.uninterruptibleMask_ $ run $ after x EUnsafe.throwIO e1 Right y -> do _ <- EUnsafe.uninterruptibleMask_ $ run $ after x return y -- | Async safe version of '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'. -- -- @since 0.1.0.0 bracketOnError :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m c) -> m c bracketOnError before after thing = withRunInIO $ \run -> EUnsafe.mask $ \restore -> do x <- run before res1 <- EUnsafe.try $ restore $ run $ thing x case res1 of Left (e1 :: SomeException) -> do -- ignore the exception, see bracket for explanation _ :: Either SomeException b <- EUnsafe.try $ EUnsafe.uninterruptibleMask_ $ run $ after x EUnsafe.throwIO e1 Right y -> return y -- | A variant of 'bracketOnError' where the return value from the first -- computation is not required. -- -- @since 0.1.0.0 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'. -- -- @since 0.1.0.0 finally :: MonadUnliftIO m => m a -> m b -> m a finally thing after = withRunInIO $ \run -> EUnsafe.uninterruptibleMask $ \restore -> do res1 <- EUnsafe.try $ restore $ run thing case res1 of Left (e1 :: SomeException) -> do -- see bracket for explanation _ :: Either SomeException b <- EUnsafe.try $ run after EUnsafe.throwIO e1 Right x -> do _ <- run after return x -- | Like 'onException', but provides the handler the thrown -- exception. -- -- @since 0.1.0.0 withException :: (MonadUnliftIO m, Exception e) => m a -> (e -> m b) -> m a withException thing after = withRunInIO $ \run -> EUnsafe.uninterruptibleMask $ \restore -> do res1 <- EUnsafe.try $ restore $ run thing case res1 of Left e1 -> do -- see explanation in bracket _ :: Either SomeException b <- EUnsafe.try $ run $ after e1 EUnsafe.throwIO e1 Right x -> return x -- | Async safe version of 'EUnsafe.onException'. -- -- @since 0.1.0.0 onException :: MonadUnliftIO m => m a -> m b -> m a onException thing after = withException thing (\(_ :: SomeException) -> after) -- | Synchronously throw the given exception. -- -- @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'. -- For asynchronous exceptions, this will wrap up the exception with -- 'SyncExceptionWrapper'. -- -- @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 -- | Convert an exception into an asynchronous exception. -- -- For asynchronous exceptions, this is the same as 'toException'. -- For synchronous exceptions, this will wrap up the exception with -- 'AsyncExceptionWrapper'. -- -- @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 -- | 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 -- | Check if the given exception is asynchronous. -- -- @since 0.1.0.0 isAsyncException :: Exception e => e -> Bool isAsyncException = not . isSyncException {-# INLINE isAsyncException #-} #if !MIN_VERSION_base(4,8,0) -- | A synonym for 'show', specialized to 'Exception' instances. -- -- Starting with base 4.8, the 'Exception' typeclass has a method -- @displayException@, used for user-friendly display of exceptions. -- This function provides backwards compatibility for users on base 4.7 and earlier, -- so that anyone importing this module can simply use @displayException@. -- -- @since 0.1.0.0 displayException :: Exception e => e -> String displayException = show #endif -- | Unlifted version of 'EUnsafe.mask'. -- -- @since 0.1.0.0 mask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m b) -> m b mask f = withRunInIO $ \run -> EUnsafe.mask $ \unmask -> run $ f $ liftIO . unmask . run -- | Unlifted version of 'EUnsafe.uninterruptibleMask'. -- -- @since 0.1.0.0 uninterruptibleMask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m b) -> m b uninterruptibleMask f = withRunInIO $ \run -> EUnsafe.uninterruptibleMask $ \unmask -> run $ f $ liftIO . unmask . run -- | Unlifted version of 'EUnsafe.mask_'. -- -- @since 0.1.0.0 mask_ :: MonadUnliftIO m => m a -> m a mask_ f = withRunInIO $ \run -> EUnsafe.mask_ (run f) -- | Unlifted version of 'EUnsafe.uninterruptibleMask_'. -- -- @since 0.1.0.0 uninterruptibleMask_ :: MonadUnliftIO m => m a -> m a uninterruptibleMask_ f = withRunInIO $ \run -> EUnsafe.uninterruptibleMask_ (run f) -- | A convenience function for throwing a user error. This is useful -- for cases where it would be too high a burden to define your own -- exception type. -- -- This throws an exception of type 'StringException'. When GHC -- supports it (base 4.9 and GHC 8.0 and onward), it includes a call -- stack. -- -- @since 0.1.0.0 #if MIN_VERSION_base(4,9,0) throwString :: (MonadIO m, HasCallStack) => String -> m a throwString s = throwIO (StringException s ?callStack) #else throwString :: MonadIO m => String -> m a throwString s = throwIO (StringException s ()) #endif -- | Smart constructor for a 'StringException' that deals with the -- call stack. -- -- @since 0.1.0.0 #if MIN_VERSION_base(4,9,0) stringException :: HasCallStack => String -> StringException stringException s = StringException s ?callStack #else stringException :: String -> StringException stringException s = StringException s () #endif -- | Exception type thrown by 'throwString'. -- -- Note that the second field of the data constructor depends on -- GHC/base version. For base 4.9 and GHC 8.0 and later, the second -- field is a call stack. Previous versions of GHC and base do not -- support call stacks, and the field is simply unit (provided to make -- pattern matching across GHC versions easier). -- -- @since 0.1.0.0 #if MIN_VERSION_base(4,9,0) data StringException = StringException String CallStack deriving Typeable -- | @since 0.1.0.0 instance Show StringException where show (StringException s cs) = concat $ "Control.Exception.Safe.throwString called with:\n\n" : s : "\nCalled from:\n" : map go (getCallStack cs) where go (x, y) = concat [ " " , x , " (" , prettySrcLoc y , ")\n" ] #else data StringException = StringException String () deriving Typeable -- | @since 0.1.0.0 instance Show StringException where show (StringException s _) = "Control.Exception.Safe.throwString called with:\n\n" ++ s #endif -- | @since 0.1.0.0 instance Exception StringException -- | Throw an asynchronous exception to another thread. -- -- Synchronously typed exceptions will be wrapped into an -- `AsyncExceptionWrapper`, see -- . -- -- It's usually a better idea to use the "UnliftIO.Async" module, see -- . -- -- @since 0.1.0.0 throwTo :: (Exception e, MonadIO m) => ThreadId -> e -> m () throwTo tid = liftIO . EUnsafe.throwTo tid . toAsyncException -- | Generate a pure value which, when forced, will synchronously -- throw the given exception. -- -- Generally it's better to avoid using this function and instead use 'throwIO', -- see . -- -- @since 0.1.0.0 impureThrow :: Exception e => e -> a impureThrow = EUnsafe.throw . toSyncException -- | Unwrap an 'Either' value, throwing its 'Left' value as a runtime -- exception via 'throwIO' if present. -- -- @since 0.1.0.0 fromEither :: (Exception e, MonadIO m) => Either e a -> m a fromEither = either throwIO return -- | Same as 'fromEither', but works on an 'IO'-wrapped 'Either'. -- -- @since 0.1.0.0 fromEitherIO :: (Exception e, MonadIO m) => IO (Either e a) -> m a fromEitherIO = fromEitherM . liftIO -- | Same as 'fromEither', but works on an 'm'-wrapped 'Either'. -- -- @since 0.1.0.0 fromEitherM :: (Exception e, MonadIO m) => m (Either e a) -> m a fromEitherM = (>>= fromEither) unliftio-0.2.11/src/UnliftIO/Foreign.hs0000644000000000000000000010023513251722614016023 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Unlifted "Foreign". -- -- @since 0.2.5.0 module UnliftIO.Foreign ( -- * Re-exported modules module Data.Bits , module Data.Int , module Data.Word , module Foreign.C.Types -- * Unlifted "Foreign.C.String" , CString , CStringLen , peekCString , peekCStringLen , newCString , newCStringLen , withCString , withCStringLen , charIsRepresentable , castCharToCChar , castCCharToChar , castCharToCUChar , castCUCharToChar , castCharToCSChar , castCSCharToChar , peekCAString , peekCAStringLen , newCAString , newCAStringLen , withCAString , withCAStringLen , CWString , CWStringLen , peekCWString , peekCWStringLen , newCWString , newCWStringLen , withCWString , withCWStringLen -- * Unlifted "Foreign.C.Error" , Errno(..) , eOK , e2BIG , eACCES , eADDRINUSE , eADDRNOTAVAIL , eADV , eAFNOSUPPORT , eAGAIN , eALREADY , eBADF , eBADMSG , eBADRPC , eBUSY , eCHILD , eCOMM , eCONNABORTED , eCONNREFUSED , eCONNRESET , eDEADLK , eDESTADDRREQ , eDIRTY , eDOM , eDQUOT , eEXIST , eFAULT , eFBIG , eFTYPE , eHOSTDOWN , eHOSTUNREACH , eIDRM , eILSEQ , eINPROGRESS , eINTR , eINVAL , eIO , eISCONN , eISDIR , eLOOP , eMFILE , eMLINK , eMSGSIZE , eMULTIHOP , eNAMETOOLONG , eNETDOWN , eNETRESET , eNETUNREACH , eNFILE , eNOBUFS , eNODATA , eNODEV , eNOENT , eNOEXEC , eNOLCK , eNOLINK , eNOMEM , eNOMSG , eNONET , eNOPROTOOPT , eNOSPC , eNOSR , eNOSTR , eNOSYS , eNOTBLK , eNOTCONN , eNOTDIR , eNOTEMPTY , eNOTSOCK , eNOTSUP , eNOTTY , eNXIO , eOPNOTSUPP , ePERM , ePFNOSUPPORT , ePIPE , ePROCLIM , ePROCUNAVAIL , ePROGMISMATCH , ePROGUNAVAIL , ePROTO , ePROTONOSUPPORT , ePROTOTYPE , eRANGE , eREMCHG , eREMOTE , eROFS , eRPCMISMATCH , eRREMOTE , eSHUTDOWN , eSOCKTNOSUPPORT , eSPIPE , eSRCH , eSRMNT , eSTALE , eTIME , eTIMEDOUT , eTOOMANYREFS , eTXTBSY , eUSERS , eWOULDBLOCK , eXDEV , isValidErrno , getErrno , resetErrno , errnoToIOError , throwErrno , throwErrnoIf , throwErrnoIf_ , throwErrnoIfRetry , throwErrnoIfRetry_ , throwErrnoIfMinus1 , throwErrnoIfMinus1_ , throwErrnoIfMinus1Retry , throwErrnoIfMinus1Retry_ , throwErrnoIfNull , throwErrnoIfNullRetry , throwErrnoIfRetryMayBlock , throwErrnoIfRetryMayBlock_ , throwErrnoIfMinus1RetryMayBlock , throwErrnoIfMinus1RetryMayBlock_ , throwErrnoIfNullRetryMayBlock , throwErrnoPath , throwErrnoPathIf , throwErrnoPathIf_ , throwErrnoPathIfNull , throwErrnoPathIfMinus1 , throwErrnoPathIfMinus1_ -- * Unlifted "Foreign.Ptr" , Ptr , nullPtr , castPtr , plusPtr , alignPtr , minusPtr , FunPtr , nullFunPtr , castFunPtr , castFunPtrToPtr , castPtrToFunPtr , freeHaskellFunPtr , IntPtr(..) , ptrToIntPtr , intPtrToPtr , WordPtr(..) , ptrToWordPtr , wordPtrToPtr -- * Unlifted "Foreign.ForeignPtr" , ForeignPtr , FinalizerPtr , FinalizerEnvPtr , newForeignPtr , newForeignPtr_ , addForeignPtrFinalizer , newForeignPtrEnv , addForeignPtrFinalizerEnv , withForeignPtr , finalizeForeignPtr , touchForeignPtr , castForeignPtr #if MIN_VERSION_base(4,10,0) , plusForeignPtr #endif , mallocForeignPtr , mallocForeignPtrBytes , mallocForeignPtrArray , mallocForeignPtrArray0 , newGHCForeignPtr , addGHCForeignPtrFinalizer , unsafeForeignPtrToPtr -- * Unlifted "Foreign.StablePtr" , StablePtr , newStablePtr , deRefStablePtr , freeStablePtr , castStablePtrToPtr , castPtrToStablePtr -- * Unlifted "Foreign.Storable" , Storable(..) -- * Unlifted "Foreign.Marshal.Alloc" , alloca , allocaBytes , allocaBytesAligned , malloc , mallocBytes #if MIN_VERSION_base(4,8,0) , calloc , callocBytes #endif , realloc , reallocBytes , free , finalizerFree -- * Unlifted "Foreign.Marshal.Array" , mallocArray , mallocArray0 , allocaArray , allocaArray0 , reallocArray , reallocArray0 #if MIN_VERSION_base(4,8,0) , callocArray , callocArray0 #endif , peekArray , peekArray0 , pokeArray , pokeArray0 , newArray , newArray0 , withArray , withArray0 , withArrayLen , withArrayLen0 , copyArray , moveArray , lengthArray0 , advancePtr -- * Unlifted "Foreign.Marshal.Error" , throwIf , throwIf_ , throwIfNeg , throwIfNeg_ , throwIfNull -- * Unlifted "Foreign.Marshal.Pool" , Pool , newPool , freePool , withPool , pooledMalloc , pooledMallocBytes , pooledRealloc , pooledReallocBytes , pooledMallocArray , pooledMallocArray0 , pooledReallocArray , pooledReallocArray0 , pooledNew , pooledNewArray , pooledNewArray0 -- * Unlifted "Foreign.Marshal.Utils" , with , new , fromBool , toBool , maybeNew , maybeWith , maybePeek , withMany , copyBytes , moveBytes #if MIN_VERSION_base(4,8,0) , fillBytes #endif ) where import Control.Monad.IO.Unlift import Data.Bits import Data.Int import Data.Word import qualified Foreign as F import Foreign ( FinalizerEnvPtr , FinalizerPtr , ForeignPtr , FunPtr , IntPtr(..) , Pool , Ptr , StablePtr , Storable(..) , WordPtr(..) , advancePtr , alignPtr , castForeignPtr , castFunPtr , castFunPtrToPtr , castPtr , castPtrToFunPtr , castPtrToStablePtr , castStablePtrToPtr , finalizerFree , fromBool , intPtrToPtr , minusPtr , nullFunPtr , nullPtr #if MIN_VERSION_base(4,10,0) , plusForeignPtr #endif , plusPtr , ptrToIntPtr , ptrToWordPtr , toBool , withMany , wordPtrToPtr ) import qualified Foreign.C as F import Foreign.C ( CString , CStringLen , CWString , CWStringLen , Errno(..) , castCCharToChar , castCSCharToChar , castCUCharToChar , castCharToCChar , castCharToCSChar , castCharToCSChar , castCharToCUChar , charIsRepresentable , e2BIG , eACCES , eADDRINUSE , eADDRNOTAVAIL , eADV , eAFNOSUPPORT , eAGAIN , eALREADY , eBADF , eBADMSG , eBADRPC , eBUSY , eCHILD , eCOMM , eCONNABORTED , eCONNREFUSED , eCONNRESET , eDEADLK , eDESTADDRREQ , eDIRTY , eDOM , eDQUOT , eEXIST , eFAULT , eFBIG , eFTYPE , eHOSTDOWN , eHOSTUNREACH , eIDRM , eILSEQ , eINPROGRESS , eINTR , eINVAL , eIO , eISCONN , eISDIR , eLOOP , eMFILE , eMLINK , eMSGSIZE , eMULTIHOP , eNAMETOOLONG , eNETDOWN , eNETRESET , eNETUNREACH , eNFILE , eNOBUFS , eNODATA , eNODEV , eNOENT , eNOEXEC , eNOLCK , eNOLINK , eNOMEM , eNOMSG , eNONET , eNOPROTOOPT , eNOSPC , eNOSR , eNOSTR , eNOSYS , eNOTBLK , eNOTCONN , eNOTDIR , eNOTEMPTY , eNOTSOCK , eNOTSUP , eNOTTY , eNXIO , eOK , eOPNOTSUPP , ePERM , ePFNOSUPPORT , ePIPE , ePROCLIM , ePROCUNAVAIL , ePROGMISMATCH , ePROGUNAVAIL , ePROTO , ePROTONOSUPPORT , ePROTOTYPE , eRANGE , eREMCHG , eREMOTE , eROFS , eRPCMISMATCH , eRREMOTE , eSHUTDOWN , eSOCKTNOSUPPORT , eSPIPE , eSRCH , eSRMNT , eSTALE , eTIME , eTIMEDOUT , eTOOMANYREFS , eTXTBSY , eUSERS , eWOULDBLOCK , eXDEV , errnoToIOError , isValidErrno ) import Foreign.C.Types import qualified Foreign.Concurrent as FC import Foreign.ForeignPtr.Unsafe -- | Lifted 'F.peekCString'. -- -- @since 0.2.5.0 {-# INLINE peekCString #-} peekCString :: MonadIO m => CString -> m String peekCString = liftIO . F.peekCString -- | Lifted 'F.peekCStringLen'. -- -- @since 0.2.5.0 {-# INLINE peekCStringLen #-} peekCStringLen :: MonadIO m => CStringLen -> m String peekCStringLen = liftIO . F.peekCStringLen -- | Lifted 'F.newCString'. -- -- @since 0.2.5.0 {-# INLINE newCString #-} newCString :: MonadIO m => String -> m CString newCString = liftIO . F.newCString -- | Lifted 'F.newCStringLen'. -- -- @since 0.2.5.0 {-# INLINE newCStringLen #-} newCStringLen :: MonadIO m => String -> m CStringLen newCStringLen = liftIO . F.newCStringLen -- | Unlifted 'F.withCString'. -- -- @since 0.2.5.0 {-# INLINE withCString #-} withCString :: MonadUnliftIO m => String -> (CString -> m a) -> m a withCString s f = withRunInIO (\u -> F.withCString s (u . f)) -- | Unlifted 'F.withCStringLen'. -- -- @since 0.2.5.0 {-# INLINE withCStringLen #-} withCStringLen :: MonadUnliftIO m => String -> (CStringLen -> m a) -> m a withCStringLen s f = withRunInIO (\u -> F.withCStringLen s (u . f)) -- | Lifted 'F.peekCAString'. -- -- @since 0.2.5.0 {-# INLINE peekCAString #-} peekCAString :: MonadIO m => CString -> m String peekCAString = liftIO . F.peekCAString -- | Lifted 'F.peekCAStringLen'. -- -- @since 0.2.5.0 {-# INLINE peekCAStringLen #-} peekCAStringLen :: MonadIO m => CStringLen -> m String peekCAStringLen = liftIO . F.peekCAStringLen -- | Lifted 'F.newCAString'. -- -- @since 0.2.5.0 {-# INLINE newCAString #-} newCAString :: MonadIO m => String -> m CString newCAString = liftIO . F.newCAString -- | Lifted 'F.newCAStringLen'. -- -- @since 0.2.5.0 {-# INLINE newCAStringLen #-} newCAStringLen :: MonadIO m => String -> m CStringLen newCAStringLen = liftIO . F.newCAStringLen -- | Unlifted 'F.withCAString'. -- -- @since 0.2.5.0 {-# INLINE withCAString #-} withCAString :: MonadUnliftIO m => String -> (CString -> m a) -> m a withCAString str f = withRunInIO (\u -> F.withCAString str (u . f)) -- | Unlifted 'F.withCAStringLen'. -- -- @since 0.2.5.0 {-# INLINE withCAStringLen #-} withCAStringLen :: MonadUnliftIO m => String -> (CStringLen -> m a) -> m a withCAStringLen str f = withRunInIO (\u -> F.withCAStringLen str (u . f)) -- | Lifted 'F.peekCWString'. -- -- @since 0.2.5.0 {-# INLINE peekCWString #-} peekCWString :: MonadIO m => CWString -> m String peekCWString = liftIO . F.peekCWString -- | Lifted 'F.peekCWStringLen'. -- -- @since 0.2.5.0 {-# INLINE peekCWStringLen #-} peekCWStringLen :: MonadIO m => CWStringLen -> m String peekCWStringLen = liftIO . F.peekCWStringLen -- | Lifted 'F.newCWString'. -- -- @since 0.2.5.0 {-# INLINE newCWString #-} newCWString :: MonadIO m => String -> m CWString newCWString = liftIO . F.newCWString -- | Lifted 'F.newCWStringLen'. -- -- @since 0.2.5.0 {-# INLINE newCWStringLen #-} newCWStringLen :: MonadIO m => String -> m CWStringLen newCWStringLen = liftIO . F.newCWStringLen -- | Unlifted 'F.withCWString'. -- -- @since 0.2.5.0 {-# INLINE withCWString #-} withCWString :: MonadUnliftIO m => String -> (CWString -> m a) -> m a withCWString str f = withRunInIO (\u -> F.withCWString str (u . f)) -- | Unlifted 'F.withCWStringLen'. -- -- @since 0.2.5.0 {-# INLINE withCWStringLen #-} withCWStringLen :: MonadUnliftIO m => String -> (CWStringLen -> m a) -> m a withCWStringLen str f = withRunInIO (\u -> F.withCWStringLen str (u . f)) -- | Lifted 'F.getErrno'. -- -- @since 0.2.5.0 {-# INLINE getErrno #-} getErrno :: MonadIO m => m Errno getErrno = liftIO F.getErrno -- | Lifted 'F.resetErrno'. -- -- @since 0.2.5.0 {-# INLINE resetErrno #-} resetErrno :: MonadIO m => m () resetErrno = liftIO F.resetErrno -- | Lifted 'F.throwErrno'. -- -- @since 0.2.5.0 {-# INLINE throwErrno #-} throwErrno :: MonadIO m => String -> m a throwErrno = liftIO . F.throwErrno -- | Unlifted 'F.throwErrnoIf'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIf #-} throwErrnoIf :: MonadUnliftIO m => (a -> Bool) -> String -> m a -> m a throwErrnoIf pred_ loc f = withRunInIO (\u -> F.throwErrnoIf pred_ loc (u f)) -- | Unlifted 'F.throwErrnoIf_'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIf_ #-} throwErrnoIf_ :: MonadUnliftIO m => (a -> Bool) -> String -> m a -> m () throwErrnoIf_ pred_ loc f = withRunInIO (\u -> F.throwErrnoIf_ pred_ loc (u f)) -- | Unlifted 'F.throwErrnoIfRetry'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfRetry #-} throwErrnoIfRetry :: MonadUnliftIO m => (a -> Bool) -> String -> m a -> m a throwErrnoIfRetry pred_ loc f = withRunInIO (\u -> F.throwErrnoIfRetry pred_ loc (u f)) -- | Unlifted 'F.throwErrnoIfRetry_'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfRetry_ #-} throwErrnoIfRetry_ :: MonadUnliftIO m => (a -> Bool) -> String -> m a -> m () throwErrnoIfRetry_ pred_ loc f = withRunInIO (\u -> F.throwErrnoIfRetry_ pred_ loc (u f)) -- | Unlifted 'F.throwErrnoIfMinus1'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfMinus1 #-} throwErrnoIfMinus1 :: (MonadUnliftIO m, Eq a, Num a) => String -> m a -> m a throwErrnoIfMinus1 loc f = withRunInIO (\u -> F.throwErrnoIfMinus1 loc (u f)) -- | Unlifted 'F.throwErrnoIfMinus1_' -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfMinus1_ #-} throwErrnoIfMinus1_ :: (MonadUnliftIO m, Eq a, Num a) => String -> m a -> m () throwErrnoIfMinus1_ loc f = withRunInIO (\u -> F.throwErrnoIfMinus1_ loc (u f)) -- | Unlifted 'F.throwErrnoIfMinus1Retry'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfMinus1Retry #-} throwErrnoIfMinus1Retry :: (MonadUnliftIO m, Eq a, Num a) => String -> m a -> m a throwErrnoIfMinus1Retry loc f = withRunInIO (\u -> F.throwErrnoIfMinus1Retry loc (u f)) -- | Unlifted 'F.throwErrnoIfMinus1Retry_'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfMinus1Retry_ #-} throwErrnoIfMinus1Retry_ :: (MonadUnliftIO m, Eq a, Num a) => String -> m a -> m () throwErrnoIfMinus1Retry_ loc f = withRunInIO (\u -> F.throwErrnoIfMinus1Retry_ loc (u f)) -- | Unlifted 'F.throwErrnoIfNull'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfNull #-} throwErrnoIfNull :: MonadUnliftIO m => String -> m (Ptr a) -> m (Ptr a) throwErrnoIfNull loc f = withRunInIO (\u -> F.throwErrnoIfNull loc (u f)) -- | Unlifted 'F.throwErrnoIfNullRetry'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfNullRetry #-} throwErrnoIfNullRetry :: MonadUnliftIO m => String -> m (Ptr a) -> m (Ptr a) throwErrnoIfNullRetry loc f = withRunInIO (\u -> F.throwErrnoIfNullRetry loc (u f)) -- | Unlifted 'F.throwErrnoIfRetryMayBlock'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfRetryMayBlock #-} throwErrnoIfRetryMayBlock :: MonadUnliftIO m => (a -> Bool) -> String -> m a -> m b -> m a throwErrnoIfRetryMayBlock pred_ loc f on_block = withRunInIO (\u -> F.throwErrnoIfRetryMayBlock pred_ loc (u f) (u on_block)) -- | Unlifted 'F.throwErrnoIfRetryMayBlock_'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfRetryMayBlock_ #-} throwErrnoIfRetryMayBlock_ :: MonadUnliftIO m => (a -> Bool) -> String -> m a -> m b -> m () throwErrnoIfRetryMayBlock_ pred_ loc f on_block = withRunInIO (\u -> F.throwErrnoIfRetryMayBlock_ pred_ loc (u f) (u on_block)) -- | Unlifted 'F.throwErrnoIfMinus1RetryMayBlock'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfMinus1RetryMayBlock #-} throwErrnoIfMinus1RetryMayBlock :: (MonadUnliftIO m, Eq a, Num a) => String -> m a -> m b -> m a throwErrnoIfMinus1RetryMayBlock loc f on_block = withRunInIO (\u -> F.throwErrnoIfMinus1RetryMayBlock loc (u f) (u on_block)) -- | Unlifted 'F.throwErrnoIfMinus1RetryMayBlock_' -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfMinus1RetryMayBlock_ #-} throwErrnoIfMinus1RetryMayBlock_ :: (MonadUnliftIO m, Eq a, Num a) => String -> m a -> m b -> m () throwErrnoIfMinus1RetryMayBlock_ loc f on_block = withRunInIO (\u -> F.throwErrnoIfMinus1RetryMayBlock_ loc (u f) (u on_block)) -- | Unlifted 'F.throwErrnoIfNullRetryMayBlock'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoIfNullRetryMayBlock #-} throwErrnoIfNullRetryMayBlock :: MonadUnliftIO m => String -> m (Ptr a) -> m b -> m (Ptr a) throwErrnoIfNullRetryMayBlock loc f on_block = withRunInIO (\u -> F.throwErrnoIfNullRetryMayBlock loc (u f) (u on_block)) -- | Lifted 'F.throwErrnoPath'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoPath #-} throwErrnoPath :: MonadIO m => String -> FilePath -> m a throwErrnoPath loc path = liftIO (F.throwErrnoPath loc path) -- | Unlifted 'F.throwErrnoPathIf'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoPathIf #-} throwErrnoPathIf :: MonadUnliftIO m => (a -> Bool) -> String -> FilePath -> m a -> m a throwErrnoPathIf pred_ loc path f = withRunInIO (\u -> F.throwErrnoPathIf pred_ loc path (u f)) -- | Unlifted 'F.throwErrnoPathIf_'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoPathIf_ #-} throwErrnoPathIf_ :: MonadUnliftIO m => (a -> Bool) -> String -> FilePath -> m a -> m () throwErrnoPathIf_ pred_ loc path f = withRunInIO (\u -> F.throwErrnoPathIf_ pred_ loc path (u f)) -- | Unlifted 'F.throwErrnoPathIfNull'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoPathIfNull #-} throwErrnoPathIfNull :: MonadUnliftIO m => String -> FilePath -> m (Ptr a) -> m (Ptr a) throwErrnoPathIfNull loc path f = withRunInIO (\u -> F.throwErrnoPathIfNull loc path (u f)) -- | Unlifted 'F.throwErrnoPathIfMinus1'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoPathIfMinus1 #-} throwErrnoPathIfMinus1 :: (MonadUnliftIO m, Eq a, Num a) => String -> FilePath -> m a -> m a throwErrnoPathIfMinus1 loc path f = withRunInIO (\u -> F.throwErrnoPathIfMinus1 loc path (u f)) -- | Unlifted 'F.throwErrnoPathIfMinus1_'. -- -- @since 0.2.5.0 {-# INLINE throwErrnoPathIfMinus1_ #-} throwErrnoPathIfMinus1_ :: (MonadUnliftIO m, Eq a, Num a) => String -> FilePath -> m a -> m () throwErrnoPathIfMinus1_ loc path f = withRunInIO (\u -> F.throwErrnoPathIfMinus1_ loc path (u f)) -- | Lifted 'F.freeHaskellFunPtr'. -- -- @since 0.2.5.0 {-# INLINE freeHaskellFunPtr #-} freeHaskellFunPtr :: MonadIO m => FunPtr a -> m () freeHaskellFunPtr = liftIO . F.freeHaskellFunPtr -- | Lifted 'F.newForeignPtr'. -- -- @since 0.2.5.0 {-# INLINE newForeignPtr #-} newForeignPtr :: MonadIO m => FinalizerPtr a -> Ptr a -> m (ForeignPtr a) newForeignPtr finalizer p = liftIO (F.newForeignPtr finalizer p) -- | Lifted 'F.newForeignPtr_'. -- -- @since 0.2.5.0 {-# INLINE newForeignPtr_ #-} newForeignPtr_ :: MonadIO m => Ptr a -> m (ForeignPtr a) newForeignPtr_ = liftIO . F.newForeignPtr_ -- | Lifted 'F.addForeignPtrFinalizer'. -- -- @since 0.2.5.0 {-# INLINE addForeignPtrFinalizer #-} addForeignPtrFinalizer :: MonadIO m => FinalizerPtr a -> ForeignPtr a -> m () addForeignPtrFinalizer finalizer_ptr foreign_ptr = liftIO (F.addForeignPtrFinalizer finalizer_ptr foreign_ptr) -- | Lifted 'F.newForeignPtrEnv'. -- -- @since 0.2.5.0 {-# INLINE newForeignPtrEnv #-} newForeignPtrEnv :: MonadIO m => FinalizerEnvPtr env a -> Ptr env -> Ptr a -> m (ForeignPtr a) newForeignPtrEnv finalizer env p = liftIO (F.newForeignPtrEnv finalizer env p) -- | Lifted 'F.addForeignPtrFinalizerEnv'. -- -- @since 0.2.5.0 {-# INLINE addForeignPtrFinalizerEnv #-} addForeignPtrFinalizerEnv :: MonadIO m => FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> m () addForeignPtrFinalizerEnv finalizer env fp = liftIO (F.addForeignPtrFinalizerEnv finalizer env fp) -- | Unlifted 'F.withForeignPtr'. -- -- @since 0.2.5.0 {-# INLINE withForeignPtr #-} withForeignPtr :: MonadUnliftIO m => ForeignPtr a -> (Ptr a -> m b) -> m b withForeignPtr fo io = withRunInIO (\u -> F.withForeignPtr fo (u . io)) -- | Lifted 'F.finalizeForeignPtr'. -- -- @since 0.2.5.0 {-# INLINE finalizeForeignPtr #-} finalizeForeignPtr :: MonadIO m => ForeignPtr a -> m () finalizeForeignPtr = liftIO . F.finalizeForeignPtr -- | Lifted 'F.touchForeignPtr'. -- -- @since 0.2.5.0 {-# INLINE touchForeignPtr #-} touchForeignPtr :: MonadIO m => ForeignPtr a -> m () touchForeignPtr = liftIO . F.touchForeignPtr -- | Lifted 'F.mallocForeignPtr'. -- -- @since 0.2.5.0 {-# INLINE mallocForeignPtr #-} mallocForeignPtr :: (MonadIO m, Storable a) => m (ForeignPtr a) mallocForeignPtr = liftIO F.mallocForeignPtr -- | Lifted 'F.mallocForeignPtrBytes'. -- -- @since 0.2.5.0 {-# INLINE mallocForeignPtrBytes #-} mallocForeignPtrBytes :: MonadIO m => Int -> m (ForeignPtr a) mallocForeignPtrBytes = liftIO . F.mallocForeignPtrBytes -- | Lifted 'F.mallocForeignPtrArray'. -- -- @since 0.2.5.0 {-# INLINE mallocForeignPtrArray #-} mallocForeignPtrArray :: (MonadIO m, Storable a) => Int -> m (ForeignPtr a) mallocForeignPtrArray = liftIO . F.mallocForeignPtrArray -- | Lifted 'F.mallocForeignPtrArray0'. -- -- @since 0.2.5.0 {-# INLINE mallocForeignPtrArray0 #-} mallocForeignPtrArray0 :: (MonadIO m, Storable a) => Int -> m (ForeignPtr a) mallocForeignPtrArray0 = liftIO . F.mallocForeignPtrArray0 -- | Unlifted 'FC.newForeignPtr'. -- -- @since 0.2.5.0 {-# INLINE newGHCForeignPtr #-} newGHCForeignPtr :: MonadUnliftIO m => Ptr a -> m () -> m (ForeignPtr a) newGHCForeignPtr ptr f = withRunInIO (\u -> FC.newForeignPtr ptr (u f)) -- | Unlifted 'FC.addForeignPtrFinalizer'. -- -- @since 0.2.5.0 {-# INLINE addGHCForeignPtrFinalizer #-} addGHCForeignPtrFinalizer :: MonadUnliftIO m => ForeignPtr a -> m () -> m () addGHCForeignPtrFinalizer fptr f = withRunInIO (\u -> FC.addForeignPtrFinalizer fptr (u f)) -- | Lifted 'F.newStablePtr'. -- -- @since 0.2.5.0 {-# INLINE newStablePtr #-} newStablePtr :: MonadIO m => a -> m (StablePtr a) newStablePtr = liftIO . F.newStablePtr -- | Lifted 'F.deRefStablePtr'. -- -- @since 0.2.5.0 {-# INLINE deRefStablePtr #-} deRefStablePtr :: MonadIO m => StablePtr a -> m a deRefStablePtr = liftIO . F.deRefStablePtr -- | Lifted 'F.freeStablePtr'. -- -- @since 0.2.5.0 {-# INLINE freeStablePtr #-} freeStablePtr :: MonadIO m => StablePtr a -> m () freeStablePtr = liftIO . F.freeStablePtr -- | Unlifted 'F.alloca'. -- -- @since 0.2.5.0 {-# INLINE alloca #-} alloca :: (MonadUnliftIO m, Storable a) => (Ptr a -> m b) -> m b alloca action = withRunInIO (\u -> F.alloca (u . action)) -- | Unlifted 'F.allocaBytes'. -- -- @since 0.2.5.0 {-# INLINE allocaBytes #-} allocaBytes :: MonadUnliftIO m => Int -> (Ptr a -> m b) -> m b allocaBytes size action = withRunInIO (\u -> F.allocaBytes size (u . action)) -- | Unlifted 'F.allocaBytesAligned'. -- -- @since 0.2.5.0 {-# INLINE allocaBytesAligned #-} allocaBytesAligned :: MonadUnliftIO m => Int -> Int -> (Ptr a -> m b) -> m b allocaBytesAligned size align action = withRunInIO (\u -> F.allocaBytesAligned size align (u . action)) -- | Lifted 'F.malloc'. -- -- @since 0.2.5.0 {-# INLINE malloc #-} malloc :: (MonadIO m, Storable a) => m (Ptr a) malloc = liftIO F.malloc -- | Lifted 'F.mallocBytes'. -- -- @since 0.2.5.0 {-# INLINE mallocBytes #-} mallocBytes :: MonadIO m => Int -> m (Ptr a) mallocBytes = liftIO . F.mallocBytes #if MIN_VERSION_base(4,8,0) -- | Lifted 'F.calloc'. -- -- @since 0.2.5.0 {-# INLINE calloc #-} calloc :: (MonadIO m, Storable a) => m (Ptr a) calloc = liftIO F.calloc -- | Lifted 'F.callocBytes'. -- -- @since 0.2.5.0 {-# INLINE callocBytes #-} callocBytes :: MonadIO m => Int -> m (Ptr a) callocBytes = liftIO . F.callocBytes #endif -- | Lifted 'F.realloc'. -- -- @since 0.2.5.0 {-# INLINE realloc #-} realloc :: (MonadIO m, Storable b) => Ptr a -> m (Ptr b) realloc = liftIO . F.realloc -- | Lifted 'F.reallocBytes'. -- -- @since 0.2.5.0 {-# INLINE reallocBytes #-} reallocBytes :: MonadIO m => Ptr a -> Int -> m (Ptr a) reallocBytes ptr size = liftIO (F.reallocBytes ptr size) -- | Lifted 'F.free'. -- -- @since 0.2.5.0 {-# INLINE free #-} free :: MonadIO m => Ptr a -> m () free = liftIO . F.free -- | Lifted 'F.mallocArray'. -- -- @since 0.2.5.0 {-# INLINE mallocArray #-} mallocArray :: (MonadIO m, Storable a) => Int -> m (Ptr a) mallocArray = liftIO . F.mallocArray -- | Lifted 'F.mallocArray0'. -- -- @since 0.2.5.0 {-# INLINE mallocArray0 #-} mallocArray0 :: (MonadIO m, Storable a) => Int -> m (Ptr a) mallocArray0 = liftIO . F.mallocArray -- | Unlifted 'F.allocaArray'. -- -- @since 0.2.5.0 {-# INLINE allocaArray #-} allocaArray :: (MonadUnliftIO m, Storable a) => Int -> (Ptr a -> m b) -> m b allocaArray size action = withRunInIO (\u -> F.allocaArray size (u . action)) -- | Unlifted 'F.allocaArray0'. -- -- @since 0.2.5.0 {-# INLINE allocaArray0 #-} allocaArray0 :: (MonadUnliftIO m, Storable a) => Int -> (Ptr a -> m b) -> m b allocaArray0 size action = withRunInIO (\u -> F.allocaArray0 size (u . action)) -- | Lifted 'F.reallocArray'. -- -- @since 0.2.5.0 {-# INLINE reallocArray #-} reallocArray :: (MonadIO m, Storable a) => Ptr a -> Int -> m (Ptr a) reallocArray ptr size = liftIO (F.reallocArray ptr size) -- | Lifted 'F.reallocArray0'. -- -- @since 0.2.5.0 {-# INLINE reallocArray0 #-} reallocArray0 :: (MonadIO m, Storable a) => Ptr a -> Int -> m (Ptr a) reallocArray0 ptr size = liftIO (F.reallocArray0 ptr size) #if MIN_VERSION_base(4,8,0) -- | Lifted 'F.callocArray'. -- -- @since 0.2.5.0 {-# INLINE callocArray #-} callocArray :: (MonadIO m, Storable a) => Int -> m (Ptr a) callocArray = liftIO . F.callocArray -- | Lifted 'F.callocArray0'. -- -- @since 0.2.5.0 {-# INLINE callocArray0 #-} callocArray0 :: (MonadIO m, Storable a) => Int -> m (Ptr a) callocArray0 = liftIO . F.callocArray0 #endif -- | Lifted 'F.peekArray'. -- -- @since 0.2.5.0 {-# INLINE peekArray #-} peekArray :: (MonadIO m, Storable a) => Int -> Ptr a -> m [a] peekArray size ptr = liftIO (F.peekArray size ptr) -- | Lifted 'F.peekArray0'. -- -- @since 0.2.5.0 {-# INLINE peekArray0 #-} peekArray0 :: (MonadIO m, Storable a, Eq a) => a -> Ptr a -> m [a] peekArray0 marker ptr = liftIO (F.peekArray0 marker ptr) -- | Lifted 'F.pokeArray'. -- -- @since 0.2.5.0 {-# INLINE pokeArray #-} pokeArray :: (MonadIO m, Storable a) => Ptr a -> [a] -> m () pokeArray ptr vals0 = liftIO (F.pokeArray ptr vals0) -- | Lifted 'F.pokeArray0'. -- -- @since 0.2.5.0 {-# INLINE pokeArray0 #-} pokeArray0 :: (MonadIO m, Storable a) => a -> Ptr a -> [a] -> m () pokeArray0 marker ptr vals0 = liftIO (F.pokeArray0 marker ptr vals0) -- | Lifted 'F.newArray'. -- -- @since 0.2.5.0 {-# INLINE newArray #-} newArray :: (MonadIO m, Storable a) => [a] -> m (Ptr a) newArray = liftIO . F.newArray -- | Lifted 'F.newArray0' -- -- @since 0.2.5.0 {-# INLINE newArray0 #-} newArray0 :: (MonadIO m, Storable a) => a -> [a] -> m (Ptr a) newArray0 marker vals = liftIO (F.newArray0 marker vals) -- | Unlifted 'F.withArray'. -- -- @since 0.2.5.0 {-# INLINE withArray #-} withArray :: (MonadUnliftIO m, Storable a) => [a] -> (Ptr a -> m b) -> m b withArray vals action = withRunInIO (\u -> F.withArray vals (u . action)) -- | Unlifted 'F.withArray0'. -- -- @since 0.2.5.0 {-# INLINE withArray0 #-} withArray0 :: (MonadUnliftIO m, Storable a) => a -> [a] -> (Ptr a -> m b) -> m b withArray0 marker vals action = withRunInIO (\u -> F.withArray0 marker vals (u . action)) -- | Unlifted 'F.withArrayLen'. -- -- @since 0.2.5.0 {-# INLINE withArrayLen #-} withArrayLen :: (MonadUnliftIO m, Storable a) => [a] -> (Int -> Ptr a -> m b) -> m b withArrayLen vals f = withRunInIO (\u -> F.withArrayLen vals (\s p -> u (f s p))) -- | Unlifted 'F.withArrayLen0'. -- -- @since 0.2.5.0 {-# INLINE withArrayLen0 #-} withArrayLen0 :: (MonadUnliftIO m, Storable a) => a -> [a] -> (Int -> Ptr a -> m b) -> m b withArrayLen0 marker vals f = withRunInIO (\u -> F.withArrayLen0 marker vals (\s p -> u (f s p))) -- | Lifted 'F.copyArray'. -- -- @since 0.2.5.0 {-# INLINE copyArray #-} copyArray :: (MonadIO m, Storable a) => Ptr a -> Ptr a -> Int -> m () copyArray dest src size = liftIO (F.copyArray dest src size) -- | Lifted 'F.moveArray'. -- -- @since 0.2.5.0 {-# INLINE moveArray #-} moveArray :: (MonadIO m, Storable a) => Ptr a -> Ptr a -> Int -> m () moveArray dest src size = liftIO (F.moveArray dest src size) -- | Lifted 'F.lengthArray0'. -- -- @since 0.2.5.0 {-# INLINE lengthArray0 #-} lengthArray0 :: (MonadIO m, Storable a, Eq a) => a -> Ptr a -> m Int lengthArray0 marker ptr = liftIO (F.lengthArray0 marker ptr) -- | Unlifted 'F.throwIf'. -- -- @since 0.2.5.0 {-# INLINE throwIf #-} throwIf :: MonadUnliftIO m => (a -> Bool) -> (a -> String) -> m a -> m a throwIf pred_ msgfct act = withRunInIO (\u -> F.throwIf pred_ msgfct (u act)) -- | Unlifted 'F.throwIf_'. -- -- @since 0.2.5.0 {-# INLINE throwIf_ #-} throwIf_ :: MonadUnliftIO m => (a -> Bool) -> (a -> String) -> m a -> m () throwIf_ pred_ msgfct act = withRunInIO (\u -> F.throwIf_ pred_ msgfct (u act)) -- | Unlifted 'F.throwIfNeg'. -- -- @since 0.2.5.0 {-# INLINE throwIfNeg #-} throwIfNeg :: (MonadUnliftIO m, Ord a, Num a) => (a -> String) -> m a -> m a throwIfNeg msgfct act = withRunInIO (\u -> F.throwIfNeg msgfct (u act)) -- | Unlifted 'F.throwIfNeg_'. -- -- @since 0.2.5.0 {-# INLINE throwIfNeg_ #-} throwIfNeg_ :: (MonadUnliftIO m, Ord a, Num a) => (a -> String) -> m a -> m () throwIfNeg_ msgfct act = withRunInIO (\u -> F.throwIfNeg_ msgfct (u act)) -- | Unlifted 'F.throwIfNull'. -- -- @since 0.2.5.0 {-# INLINE throwIfNull #-} throwIfNull :: MonadUnliftIO m => String -> m (Ptr a) -> m (Ptr a) throwIfNull msg act = withRunInIO (\u -> F.throwIfNull msg (u act)) -- | Lifted 'F.newPool'. -- -- @since 0.2.5.0 {-# INLINE newPool #-} newPool :: MonadIO m => m Pool newPool = liftIO F.newPool -- | Lifted 'F.freePool'. -- -- @since 0.2.5.0 {-# INLINE freePool #-} freePool :: MonadIO m => Pool -> m () freePool = liftIO . F.freePool -- | Unlifted 'F.withPool'. -- -- @since 0.2.5.0 {-# INLINE withPool #-} withPool :: MonadUnliftIO m => (Pool -> m b) -> m b withPool act = withRunInIO (\u -> F.withPool (u . act)) -- | Lifted 'F.pooledMalloc'. -- -- @since 0.2.5.0 {-# INLINE pooledMalloc #-} pooledMalloc :: (MonadIO m, Storable a) => Pool -> m (Ptr a) pooledMalloc = liftIO . F.pooledMalloc -- | Lifted 'F.pooledMallocBytes'. -- -- @since 0.2.5.0 {-# INLINE pooledMallocBytes #-} pooledMallocBytes :: MonadIO m => Pool -> Int -> m (Ptr a) pooledMallocBytes pool size = liftIO (F.pooledMallocBytes pool size) -- | Lifted 'F.pooledRealloc'. -- -- @since 0.2.5.0 {-# INLINE pooledRealloc #-} pooledRealloc :: (MonadIO m, Storable a) => Pool -> Ptr a -> m (Ptr a) pooledRealloc pool ptr = liftIO (F.pooledRealloc pool ptr) -- | Lifted 'F.pooledReallocBytes'. -- -- @since 0.2.5.0 {-# INLINE pooledReallocBytes #-} pooledReallocBytes :: MonadIO m => Pool -> Ptr a -> Int -> m (Ptr a) pooledReallocBytes pool ptr size = liftIO (F.pooledReallocBytes pool ptr size) -- | Lifted 'F.pooledMallocArray'. -- -- @since 0.2.5.0 {-# INLINE pooledMallocArray #-} pooledMallocArray :: (MonadIO m, Storable a) => Pool -> Int -> m (Ptr a) pooledMallocArray pool size = liftIO (F.pooledMallocArray pool size) -- | Lifted 'F.pooledMallocArray0'. -- -- @since 0.2.5.0 {-# INLINE pooledMallocArray0 #-} pooledMallocArray0 :: (MonadIO m, Storable a) => Pool -> Int -> m (Ptr a) pooledMallocArray0 pool size = liftIO (F.pooledMallocArray0 pool size) -- | Lifted 'F.pooledReallocArray'. -- -- @since 0.2.5.0 {-# INLINE pooledReallocArray #-} pooledReallocArray :: (MonadIO m, Storable a) => Pool -> Ptr a -> Int -> m (Ptr a) pooledReallocArray pool ptr size = liftIO (F.pooledReallocArray pool ptr size) -- | Lifted 'F.pooledReallocArray0'. -- -- @since 0.2.5.0 {-# INLINE pooledReallocArray0 #-} pooledReallocArray0 :: (MonadIO m, Storable a) => Pool -> Ptr a -> Int -> m (Ptr a) pooledReallocArray0 pool ptr size = liftIO (F.pooledReallocArray0 pool ptr size) -- | Lifted 'F.pooledNew'. -- -- @since 0.2.5.0 {-# INLINE pooledNew #-} pooledNew :: (MonadIO m, Storable a) => Pool -> a -> m (Ptr a) pooledNew pool val = liftIO (F.pooledNew pool val) -- | Lifted 'F.pooledNewArray'. -- -- @since 0.2.5.0 {-# INLINE pooledNewArray #-} pooledNewArray :: (MonadIO m, Storable a) => Pool -> [a] -> m (Ptr a) pooledNewArray pool vals = liftIO (F.pooledNewArray pool vals) -- | Lifted 'F.pooledNewArray0'. -- -- @since 0.2.5.0 {-# INLINE pooledNewArray0 #-} pooledNewArray0 :: (MonadIO m, Storable a) => Pool -> a -> [a] -> m (Ptr a) pooledNewArray0 pool marker vals = liftIO (F.pooledNewArray0 pool marker vals) -- | Unlifted 'F.with'. -- -- @since 0.2.5.0 {-# INLINE with #-} with :: (MonadUnliftIO m, Storable a) => a -> (Ptr a -> m b) -> m b with val f = withRunInIO (\u -> F.with val (u . f)) -- | Lifted 'F.new'. -- -- @since 0.2.5.0 {-# INLINE new #-} new :: (MonadIO m, Storable a) => a -> m (Ptr a) new = liftIO . F.new -- | Lifted 'F.maybeNew'. -- -- @since 0.2.5.0 {-# INLINE maybeNew #-} maybeNew :: MonadIO m => (a -> m (Ptr b)) -> Maybe a -> m (Ptr b) maybeNew = maybe (return nullPtr) -- | Lifted 'F.maybeWith'. -- -- @since 0.2.5.0 {-# INLINE maybeWith #-} maybeWith :: MonadIO m => (a -> (Ptr b -> m c) -> m c) -> Maybe a -> (Ptr b -> m c) -> m c maybeWith = maybe ($ nullPtr) -- | Unlifted 'F.maybePeek'. -- -- @since 0.2.5.0 {-# INLINE maybePeek #-} maybePeek :: MonadUnliftIO m => (Ptr a -> m b) -> Ptr a -> m (Maybe b) maybePeek peek_ ptr = withRunInIO (\u -> F.maybePeek (u . peek_) ptr) -- | Lifted 'F.copyBytes'. -- -- @since 0.2.5.0 {-# INLINE copyBytes #-} copyBytes :: MonadIO m => Ptr a -> Ptr a -> Int -> m () copyBytes dest src size = liftIO (F.copyBytes dest src size) -- | Lifted 'F.moveBytes'. -- -- @since 0.2.5.0 {-# INLINE moveBytes #-} moveBytes :: MonadIO m => Ptr a -> Ptr a -> Int -> m () moveBytes dest src size = liftIO (F.moveBytes dest src size) #if MIN_VERSION_base(4,8,0) -- | Lifted 'F.fillBytes'. -- -- @since 0.2.5.0 {-# INLINE fillBytes #-} fillBytes :: MonadIO m => Ptr a -> Word8 -> Int -> m () fillBytes dest char size = liftIO (F.fillBytes dest char size) #endif unliftio-0.2.11/src/UnliftIO/Internals/Async.hs0000644000000000000000000011044713412137046017452 0ustar0000000000000000{-# 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 -- @FIXME link to blog post@. 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 #-} mappend = liftA2 mappend {-# INLINE mappend #-} ------------------------- -- 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] unliftio-0.2.11/src/UnliftIO/IO.hs0000644000000000000000000001040213251722173014735 0ustar0000000000000000-- | Unlifted "System.IO". -- -- @since 0.1.0.0 module UnliftIO.IO ( IOMode (..) , Handle , IO.stdin , IO.stdout , IO.stderr , withFile , withBinaryFile , hClose , hFlush , hFileSize , hSetFileSize , hIsEOF , IO.BufferMode (..) , hSetBuffering , hGetBuffering , hSeek , IO.SeekMode , hTell , hIsOpen , hIsClosed , hIsReadable , hIsWritable , hIsSeekable , hIsTerminalDevice , hSetEcho , hGetEcho , hWaitForInput , hReady , getMonotonicTime ) where import qualified System.IO as IO import System.IO (Handle, IOMode (..)) import Control.Monad.IO.Unlift import System.IO.Unsafe (unsafePerformIO) -- | Unlifted version of 'IO.withFile'. -- -- @since 0.1.0.0 withFile :: MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m a) -> m a withFile fp mode inner = withRunInIO $ \run -> IO.withFile fp mode $ run . inner -- | Unlifted version of 'IO.withBinaryFile'. -- -- @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.hClose' -- -- @since 0.2.1.0 hClose :: MonadIO m => Handle -> m () hClose = liftIO . IO.hClose -- | Lifted version of 'IO.hFlush' -- -- @since 0.2.1.0 hFlush :: MonadIO m => Handle -> m () hFlush = liftIO . IO.hFlush -- | Lifted version of 'IO.hFileSize' -- -- @since 0.2.1.0 hFileSize :: MonadIO m => Handle -> m Integer hFileSize = liftIO . IO.hFileSize -- | Lifted version of 'IO.hSetFileSize' -- -- @since 0.2.1.0 hSetFileSize :: MonadIO m => Handle -> Integer -> m () hSetFileSize h = liftIO . IO.hSetFileSize h -- | Lifted version of 'IO.hIsEOF' -- -- @since 0.2.1.0 hIsEOF :: MonadIO m => Handle -> m Bool hIsEOF = liftIO . IO.hIsEOF -- | Lifted version of 'IO.hSetBuffering' -- -- @since 0.2.1.0 hSetBuffering :: MonadIO m => Handle -> IO.BufferMode -> m () hSetBuffering h = liftIO . IO.hSetBuffering h -- | Lifted version of 'IO.hGetBuffering' -- -- @since 0.2.1.0 hGetBuffering :: MonadIO m => Handle -> m IO.BufferMode hGetBuffering = liftIO . IO.hGetBuffering -- | Lifted version of 'IO.hSeek' -- -- @since 0.2.1.0 hSeek :: MonadIO m => Handle -> IO.SeekMode -> Integer -> m () hSeek h s = liftIO . IO.hSeek h s -- | Lifted version of 'IO.hTell' -- -- @since 0.2.1.0 hTell :: MonadIO m => Handle -> m Integer hTell = liftIO . IO.hTell -- | Lifted version of 'IO.hIsOpen' -- -- @since 0.2.1.0 hIsOpen :: MonadIO m => Handle -> m Bool hIsOpen = liftIO . IO.hIsOpen -- | Lifted version of 'IO.hIsClosed' -- -- @since 0.2.1.0 hIsClosed :: MonadIO m => Handle -> m Bool hIsClosed = liftIO . IO.hIsClosed -- | Lifted version of 'IO.hIsReadable' -- -- @since 0.2.1.0 hIsReadable :: MonadIO m => Handle -> m Bool hIsReadable = liftIO . IO.hIsReadable -- | Lifted version of 'IO.hIsWritable' -- -- @since 0.2.1.0 hIsWritable :: MonadIO m => Handle -> m Bool hIsWritable = liftIO . IO.hIsWritable -- | Lifted version of 'IO.hIsSeekable' -- -- @since 0.2.1.0 hIsSeekable :: MonadIO m => Handle -> m Bool hIsSeekable = liftIO . IO.hIsSeekable -- | Lifted version of 'IO.hIsTerminalDevice' -- -- @since 0.2.1.0 hIsTerminalDevice :: MonadIO m => Handle -> m Bool hIsTerminalDevice = liftIO . IO.hIsTerminalDevice -- | Lifted version of 'IO.hSetEcho' -- -- @since 0.2.1.0 hSetEcho :: MonadIO m => Handle -> Bool -> m () hSetEcho h = liftIO . IO.hSetEcho h -- | Lifted version of 'IO.hGetEcho' -- -- @since 0.2.1.0 hGetEcho :: MonadIO m => Handle -> m Bool hGetEcho = liftIO . IO.hGetEcho -- | Lifted version of 'IO.hWaitForInput' -- -- @since 0.2.1.0 hWaitForInput :: MonadIO m => Handle -> Int -> m Bool hWaitForInput h = liftIO . IO.hWaitForInput h -- | Lifted version of 'IO.hReady' -- -- @since 0.2.1.0 hReady :: MonadIO m => Handle -> m Bool hReady = liftIO . IO.hReady -- | Get the number of seconds which have passed since an arbitrary starting -- time, useful for calculating runtime in a program. -- -- @since 0.2.3.0 getMonotonicTime :: MonadIO m => m Double getMonotonicTime = liftIO $ initted `seq` getMonotonicTime' -- | Set up time measurement. foreign import ccall unsafe "unliftio_inittime" initializeTime :: IO () initted :: () initted = unsafePerformIO initializeTime {-# NOINLINE initted #-} foreign import ccall unsafe "unliftio_gettime" getMonotonicTime' :: IO Double unliftio-0.2.11/src/UnliftIO/IORef.hs0000644000000000000000000000340013207246422015371 0ustar0000000000000000-- | Unlifted "Data.IORef". -- -- @since 0.1.0.0 module UnliftIO.IORef ( IORef , newIORef , readIORef , writeIORef , modifyIORef , modifyIORef' , atomicModifyIORef , atomicModifyIORef' , atomicWriteIORef , mkWeakIORef ) where import Data.IORef (IORef) import qualified Data.IORef as I import Control.Monad.IO.Unlift import System.Mem.Weak (Weak) -- | Lifted 'I.newIORef'. -- -- @since 0.1.0.0 newIORef :: MonadIO m => a -> m (IORef a) newIORef = liftIO . I.newIORef -- | Lifted 'I.readIORef'. -- -- @since 0.1.0.0 readIORef :: MonadIO m => IORef a -> m a readIORef = liftIO . I.readIORef -- | Lifted 'I.writeIORef'. -- -- @since 0.1.0.0 writeIORef :: MonadIO m => IORef a -> a -> m () writeIORef ref = liftIO . I.writeIORef ref -- | Lifted 'I.modifyIORef'. -- -- @since 0.1.0.0 modifyIORef :: MonadIO m => IORef a -> (a -> a) -> m () modifyIORef ref = liftIO . I.modifyIORef ref -- | Lifted 'I.modifyIORef''. -- -- @since 0.1.0.0 modifyIORef' :: MonadIO m => IORef a -> (a -> a) -> m () modifyIORef' ref = liftIO . I.modifyIORef' ref -- | Lifted 'I.atomicModifyIORef'. -- -- @since 0.1.0.0 atomicModifyIORef :: MonadIO m => IORef a -> (a -> (a, b)) -> m b atomicModifyIORef ref = liftIO . I.atomicModifyIORef ref -- | Lifted 'I.atomicModifyIORef''. -- -- @since 0.1.0.0 atomicModifyIORef' :: MonadIO m => IORef a -> (a -> (a, b)) -> m b atomicModifyIORef' ref = liftIO . I.atomicModifyIORef' ref -- | Lifted 'I.atomicWriteIORef'. -- -- @since 0.1.0.0 atomicWriteIORef :: MonadIO m => IORef a -> a -> m () atomicWriteIORef ref = liftIO . I.atomicWriteIORef ref -- | Unlifted 'I.mkWeakIORef'. -- -- @since 0.1.0.0 mkWeakIORef :: MonadUnliftIO m => IORef a -> m () -> m (Weak (IORef a)) mkWeakIORef ref final = withRunInIO $ \run -> I.mkWeakIORef ref (run final) unliftio-0.2.11/src/UnliftIO/Memoize.hs0000644000000000000000000000464213343444703016046 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Memoize the results of actions. In other words: actions -- will be run once, on demand, and their results saved. -- -- Exceptions semantics: if a synchronous exception is thrown while performing -- the computation, that result will be saved and rethrown each time -- 'runMemoized' is called subsequently.' -- -- @since 0.2.8.0 module UnliftIO.Memoize ( Memoized , runMemoized , memoizeRef , memoizeMVar ) where import Control.Applicative as A import Control.Monad (join) import Control.Monad.IO.Unlift import UnliftIO.Exception import UnliftIO.IORef import UnliftIO.MVar -- | A \"run once\" value, with results saved. Extract the value with -- 'runMemoized'. For single-threaded usage, you can use 'memoizeRef' to -- create a value. If you need guarantees that only one thread will run the -- action at a time, use 'memoizeMVar'. -- -- Note that this type provides a 'Show' instance for convenience, but not -- useful information can be provided. -- -- @since 0.2.8.0 newtype Memoized a = Memoized (IO a) deriving (Functor, A.Applicative, Monad) instance Show (Memoized a) where show _ = "<>" -- | Extract a value from a 'Memoized', running an action if no cached value is -- available. -- -- @since 0.2.8.0 runMemoized :: MonadIO m => Memoized a -> m a runMemoized (Memoized m) = liftIO m {-# INLINE runMemoized #-} -- | Create a new 'Memoized' value using an 'IORef' under the surface. Note that -- the action may be run in multiple threads simultaneously, so this may not be -- thread safe (depending on the underlying action). Consider using -- 'memoizeMVar'. -- -- @since 0.2.8.0 memoizeRef :: MonadUnliftIO m => m a -> m (Memoized a) memoizeRef action = withRunInIO $ \run -> do ref <- newIORef Nothing pure $ Memoized $ do mres <- readIORef ref res <- case mres of Just res -> pure res Nothing -> do res <- tryAny $ run action writeIORef ref $ Just res pure res either throwIO pure res -- | Same as 'memoizeRef', but uses an 'MVar' to ensure that an action is -- only run once, even in a multithreaded application. -- -- @since 0.2.8.0 memoizeMVar :: MonadUnliftIO m => m a -> m (Memoized a) memoizeMVar action = withRunInIO $ \run -> do var <- newMVar Nothing pure $ Memoized $ join $ modifyMVar var $ \mres -> do res <- maybe (tryAny $ run action) pure mres pure (Just res, either throwIO pure res) unliftio-0.2.11/src/UnliftIO/MVar.hs0000644000000000000000000000612013207246422015274 0ustar0000000000000000-- | Unlifted "Control.Concurrent.MVar". -- -- @since 0.1.0.0 module UnliftIO.MVar ( MVar , newEmptyMVar , newMVar , takeMVar , putMVar , readMVar , swapMVar , tryTakeMVar , tryPutMVar , isEmptyMVar , withMVar , withMVarMasked , modifyMVar , modifyMVar_ , modifyMVarMasked , modifyMVarMasked_ , tryReadMVar , mkWeakMVar ) where import System.Mem.Weak (Weak) import Control.Concurrent.MVar (MVar) import Control.Monad.IO.Unlift import qualified Control.Concurrent.MVar as M -- | Lifted 'M.newEmptyMVar'. -- -- @since 0.1.0.0 newEmptyMVar :: MonadIO m => m (MVar a) newEmptyMVar = liftIO M.newEmptyMVar -- | Lifted 'M.newMVar'. -- -- @since 0.1.0.0 newMVar :: MonadIO m => a -> m (MVar a) newMVar = liftIO . M.newMVar -- | Lifted 'M.takeMVar'. -- -- @since 0.1.0.0 takeMVar :: MonadIO m => MVar a -> m a takeMVar = liftIO . M.takeMVar -- | Lifted 'M.putMVar'. -- -- @since 0.1.0.0 putMVar :: MonadIO m => MVar a -> a -> m () putMVar var = liftIO . M.putMVar var -- | Lifted 'M.readMVar'. -- -- @since 0.1.0.0 readMVar :: MonadIO m => MVar a -> m a readMVar = liftIO . M.readMVar -- | Lifted 'M.swapMVar'. -- -- @since 0.1.0.0 swapMVar :: MonadIO m => MVar a -> a -> m a swapMVar var = liftIO . M.swapMVar var -- | Lifted 'M.tryTakeMVar'. -- -- @since 0.1.0.0 tryTakeMVar :: MonadIO m => MVar a -> m (Maybe a) tryTakeMVar = liftIO . M.tryTakeMVar -- | Lifted 'M.tryPutMVar'. -- -- @since 0.1.0.0 tryPutMVar :: MonadIO m => MVar a -> a -> m Bool tryPutMVar var = liftIO . M.tryPutMVar var -- | Lifted 'M.isEmptyMVar'. -- -- @since 0.1.0.0 isEmptyMVar :: MonadIO m => MVar a -> m Bool isEmptyMVar = liftIO . M.isEmptyMVar -- | Lifted 'M.tryReadMVar'. -- -- @since 0.1.0.0 tryReadMVar :: MonadIO m => MVar a -> m (Maybe a) tryReadMVar = liftIO . M.tryReadMVar -- | Unlifted 'M.withMVar'. -- -- @since 0.1.0.0 withMVar :: MonadUnliftIO m => MVar a -> (a -> m b) -> m b withMVar var f = withRunInIO $ \run -> M.withMVar var (run . f) -- | Unlifted 'M.withMVarMasked'. -- -- @since 0.1.0.0 withMVarMasked :: MonadUnliftIO m => MVar a -> (a -> m b) -> m b withMVarMasked var f = withRunInIO $ \run -> M.withMVarMasked var (run . f) -- | Unlifted 'M.modifyMVar_'. -- -- @since 0.1.0.0 modifyMVar_ :: MonadUnliftIO m => MVar a -> (a -> m a) -> m () modifyMVar_ var f = withRunInIO $ \run -> M.modifyMVar_ var (run . f) -- | Unlifted 'M.modifyMVar'. -- -- @since 0.1.0.0 modifyMVar :: MonadUnliftIO m => MVar a -> (a -> m (a, b)) -> m b modifyMVar var f = withRunInIO $ \run -> M.modifyMVar var (run . f) -- | Unlifted 'M.modifyMVarMasked_'. -- -- @since 0.1.0.0 modifyMVarMasked_ :: MonadUnliftIO m => MVar a -> (a -> m a) -> m () modifyMVarMasked_ var f = withRunInIO $ \run -> M.modifyMVarMasked_ var (run . f) -- | Unlifted 'M.modifyMVarMasked'. -- -- @since 0.1.0.0 modifyMVarMasked :: MonadUnliftIO m => MVar a -> (a -> m (a, b)) -> m b modifyMVarMasked var f = withRunInIO $ \run -> M.modifyMVarMasked var (run . f) -- | Unlifted 'M.mkWeakMVar'. -- -- @since 0.1.0.0 mkWeakMVar :: MonadUnliftIO m => MVar a -> m () -> m (Weak (MVar a)) mkWeakMVar var f = withRunInIO $ \run -> M.mkWeakMVar var (run f) unliftio-0.2.11/src/UnliftIO/Process.hs0000644000000000000000000001223013251722566016053 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Unlifted "System.Process". -- -- @since 0.2.5.0 module UnliftIO.Process ( -- * Running sub-processes CreateProcess(..), CmdSpec(..), StdStream(..), ProcessHandle, createProcess #if MIN_VERSION_process(1,2,1) , createProcess_ #endif , P.shell, P.proc -- ** Simpler functions for common tasks , callProcess, callCommand, spawnProcess, spawnCommand #if MIN_VERSION_process(1,2,3) , readCreateProcess #endif , readProcess #if MIN_VERSION_process(1,2,3) , readCreateProcessWithExitCode #endif , readProcessWithExitCode #if MIN_VERSION_process(1,4,3) , withCreateProcess #endif -- ** Related utilities , P.showCommandForUser -- * Process completion , waitForProcess, getProcessExitCode, terminateProcess, interruptProcessGroupOf #if MIN_VERSION_process(1,2,1) -- * Interprocess communication , createPipe #endif #if MIN_VERSION_process(1,4,2) , createPipeFd #endif ) where import Control.Monad.IO.Unlift import System.Exit import System.IO import System.Posix.Internals import System.Process ( CmdSpec(..) , CreateProcess(..) , ProcessHandle , StdStream(..) ) import qualified System.Process as P -- | Lifted 'P.createProcess'. -- -- @since 0.2.5.0 {-# INLINE createProcess #-} createProcess :: MonadIO m => CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess = liftIO . P.createProcess #if MIN_VERSION_process(1,2,1) -- | Lifted 'P.createProcess_'. -- -- @since 0.2.5.0 {-# INLINE createProcess_ #-} createProcess_ :: MonadIO m => String -> CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess_ msg proc_ = liftIO (P.createProcess_ msg proc_) #endif -- | Lifted 'P.callProcess'. -- -- @since 0.2.5.0 {-# INLINE callProcess #-} callProcess :: MonadIO m => FilePath -> [String] -> m () callProcess cmd args = liftIO (P.callProcess cmd args) -- | Lifted 'P.callCommand'. -- -- @since 0.2.5.0 {-# INLINE callCommand #-} callCommand :: MonadIO m => String -> m () callCommand = liftIO . P.callCommand -- | Lifted 'P.spawnProcess'. -- -- @since 0.2.5.0 {-# INLINE spawnProcess #-} spawnProcess :: MonadIO m => FilePath -> [String] -> m ProcessHandle spawnProcess cmd args = liftIO (P.spawnProcess cmd args) -- | Lifted 'P.spawnCommand'. -- -- @since 0.2.5.0 {-# INLINE spawnCommand #-} spawnCommand :: MonadIO m => String -> m ProcessHandle spawnCommand = liftIO . P.spawnCommand #if MIN_VERSION_process(1,2,3) -- | Lifted 'P.readCreateProcess'. -- -- @since 0.2.5.0 {-# INLINE readCreateProcess #-} readCreateProcess :: MonadIO m => CreateProcess -> String -> m String readCreateProcess cp input = liftIO (P.readCreateProcess cp input) #endif -- | Lifted 'P.readProcess'. -- -- @since 0.2.5.0 {-# INLINE readProcess #-} readProcess :: MonadIO m => FilePath -> [String] -> String -> m String readProcess cmd args input = liftIO (P.readProcess cmd args input) #if MIN_VERSION_process(1,2,3) -- | Lifted 'P.readCreateProcessWithExitCode'. -- -- @since 0.2.5.0 {-# INLINE readCreateProcessWithExitCode #-} readCreateProcessWithExitCode :: MonadIO m => CreateProcess -> String -> m (ExitCode, String, String) readCreateProcessWithExitCode cp input = liftIO (P.readCreateProcessWithExitCode cp input) #endif -- | Lifted 'P.readProcessWithExitCode'. -- -- @since 0.2.5.0 {-# INLINE readProcessWithExitCode #-} readProcessWithExitCode :: MonadIO m => FilePath -> [String] -> String -> m (ExitCode, String, String) readProcessWithExitCode cmd args input = liftIO (P.readProcessWithExitCode cmd args input) #if MIN_VERSION_process(1,4,3) -- | Unlifted 'P.withCreateProcess'. -- -- @since 0.2.5.0 {-# INLINE withCreateProcess #-} withCreateProcess :: MonadUnliftIO m => CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> m a) -> m a withCreateProcess c action = withRunInIO (\u -> P.withCreateProcess c (\stdin_h stdout_h stderr_h proc_h -> u (action stdin_h stdout_h stderr_h proc_h))) #endif -- | Lifted 'P.waitForProcess'. -- -- @since 0.2.5.0 {-# INLINE waitForProcess #-} waitForProcess :: MonadIO m => ProcessHandle -> m ExitCode waitForProcess = liftIO . P.waitForProcess -- | Lifted 'P.getProcessExitCode'. -- -- @since 0.2.5.0 {-# INLINE getProcessExitCode #-} getProcessExitCode :: MonadIO m => ProcessHandle -> m (Maybe ExitCode) getProcessExitCode = liftIO . P.getProcessExitCode -- | Lifted 'P.terminateProcess'. -- -- @since 0.2.5.0 {-# INLINE terminateProcess #-} terminateProcess :: MonadIO m => ProcessHandle -> m () terminateProcess = liftIO . P.terminateProcess -- | Lifted 'P.interruptProcessGroupOf'. -- -- @since 0.2.5.0 {-# INLINE interruptProcessGroupOf #-} interruptProcessGroupOf :: MonadIO m => ProcessHandle -> m () interruptProcessGroupOf = liftIO . P.interruptProcessGroupOf #if MIN_VERSION_process(1,2,1) -- | Lifted 'P.createPipe'. -- -- @since 0.2.5.0 {-# INLINE createPipe #-} createPipe :: MonadIO m => m (Handle, Handle) createPipe = liftIO P.createPipe #endif #if MIN_VERSION_process(1,4,2) -- | Lifted 'P.createPipeFd'. -- -- @since 0.2.5.0 {-# INLINE createPipeFd #-} createPipeFd :: MonadIO m => m (FD, FD) createPipeFd = liftIO P.createPipeFd #endif unliftio-0.2.11/src/UnliftIO/STM.hs0000644000000000000000000000750113412137046015075 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Lifted version of "Control.Concurrent.STM" -- -- @since 0.2.1.0 module UnliftIO.STM ( -- * Core STM.STM , atomically , retrySTM , checkSTM -- * TVar , STM.TVar , newTVarIO , readTVarIO , STM.newTVar , STM.readTVar , STM.writeTVar , STM.modifyTVar , STM.modifyTVar' , STM.swapTVar , registerDelay , mkWeakTVar -- * TMVar , STM.TMVar , STM.newTMVar , STM.newEmptyTMVar , newTMVarIO , newEmptyTMVarIO , STM.takeTMVar , STM.putTMVar , STM.readTMVar , STM.tryReadTMVar , STM.swapTMVar , STM.tryTakeTMVar , STM.tryPutTMVar , STM.isEmptyTMVar , mkWeakTMVar -- * TChan , STM.TChan , STM.newTChan , newTChanIO , STM.newBroadcastTChan , newBroadcastTChanIO , STM.dupTChan , STM.cloneTChan , STM.readTChan , STM.tryReadTChan , STM.peekTChan , STM.tryPeekTChan , STM.writeTChan , STM.unGetTChan , STM.isEmptyTChan -- * TQueue , STM.TQueue , STM.newTQueue , newTQueueIO , STM.readTQueue , STM.tryReadTQueue , STM.peekTQueue , STM.tryPeekTQueue , STM.writeTQueue , STM.unGetTQueue , STM.isEmptyTQueue -- * TBQueue , STM.TBQueue , STM.newTBQueue , newTBQueueIO , STM.readTBQueue , STM.tryReadTBQueue , STM.peekTBQueue , STM.tryPeekTBQueue , STM.writeTBQueue , STM.unGetTBQueue , STM.isEmptyTBQueue , STM.isFullTBQueue ) where import Control.Concurrent.STM (STM, TVar, TMVar, TChan, TQueue, TBQueue) import qualified Control.Concurrent.STM as STM import Control.Monad.IO.Unlift import System.Mem.Weak (Weak) #if MIN_VERSION_base(4, 8, 0) import GHC.Natural (Natural) #else import Numeric.Natural (Natural) #endif -- | Lifted version of 'STM.atomically' -- -- @since 0.2.1.0 atomically :: MonadIO m => STM a -> m a atomically = liftIO . STM.atomically -- | Renamed 'STM.retry' for unqualified export -- -- @since 0.2.1.0 retrySTM :: STM a retrySTM = STM.retry -- | Renamed 'STM.check' for unqualified export -- -- @since 0.2.1.0 checkSTM :: Bool -> STM () checkSTM = STM.check -- | Lifted version of 'STM.newTVarIO' -- -- @since 0.2.1.0 newTVarIO :: MonadIO m => a -> m (TVar a) newTVarIO = liftIO . STM.newTVarIO -- | Lifted version of 'STM.readTVarIO' -- -- @since 0.2.1.0 readTVarIO :: MonadIO m => TVar a -> m a readTVarIO = liftIO . STM.readTVarIO -- | Lifted version of 'STM.registerDelay' -- -- @since 0.2.1.0 registerDelay :: MonadIO m => Int -> m (TVar Bool) registerDelay = liftIO . STM.registerDelay -- | Lifted version of 'STM.mkWeakTVar' -- -- @since 0.2.1.0 mkWeakTVar :: MonadUnliftIO m => TVar a -> m () -> m (Weak (TVar a)) mkWeakTVar var final = withRunInIO $ \run -> STM.mkWeakTVar var (run final) -- | Lifted version of 'STM.newTMVarIO' -- -- @since 0.2.1.0 newTMVarIO :: MonadIO m => a -> m (TMVar a) newTMVarIO = liftIO . STM.newTMVarIO -- | Lifted version of 'STM.newEmptyTMVarIO' -- -- @since 0.2.1.0 newEmptyTMVarIO :: MonadIO m => m (TMVar a) newEmptyTMVarIO = liftIO STM.newEmptyTMVarIO -- | Lifted version of 'STM.mkWeakTMVar' -- -- @since 0.2.1.0 mkWeakTMVar :: MonadUnliftIO m => TMVar a -> m () -> m (Weak (TMVar a)) mkWeakTMVar var final = withRunInIO $ \run -> STM.mkWeakTMVar var (run final) -- | Lifted version of 'STM.newTChanIO' -- -- @since 0.2.1.0 newTChanIO :: MonadIO m => m (TChan a) newTChanIO = liftIO STM.newTChanIO -- | Lifted version of 'STM.newBroadcastTChanIO' -- -- @since 0.2.1.0 newBroadcastTChanIO :: MonadIO m => m (TChan a) newBroadcastTChanIO = liftIO STM.newBroadcastTChanIO -- | Lifted version of 'STM.newTQueueIO' -- -- @since 0.2.1.0 newTQueueIO :: MonadIO m => m (TQueue a) newTQueueIO = liftIO STM.newTQueueIO -- | Lifted version of 'STM.newTBQueueIO' -- -- @since 0.2.1.0 #if MIN_VERSION_stm(2, 5, 0) newTBQueueIO :: MonadIO m => Natural -> m (TBQueue a) #else newTBQueueIO :: MonadIO m => Int -> m (TBQueue a) #endif newTBQueueIO = liftIO . STM.newTBQueueIO unliftio-0.2.11/src/UnliftIO/Temporary.hs0000644000000000000000000001137313251722173016420 0ustar0000000000000000{-# LANGUAgE CPP #-} -- | Temporary file and directory support. -- -- Strongly inspired by\/stolen from the package. -- -- @since 0.1.0.0 module UnliftIO.Temporary ( withSystemTempFile , withSystemTempDirectory , withTempFile , withTempDirectory ) where import Control.Monad.IO.Unlift import Control.Monad (liftM) import UnliftIO.Exception import System.Directory import System.IO (Handle, openTempFile, hClose) import System.IO.Error import System.Posix.Internals (c_getpid) import System.FilePath (()) #ifdef mingw32_HOST_OS import System.Directory ( createDirectory ) #else import qualified System.Posix #endif -- | Create and use a temporary file in the system standard temporary directory. -- -- Behaves exactly the same as 'withTempFile', except that the parent temporary directory -- will be that returned by 'getCanonicalTemporaryDirectory'. -- -- @since 0.1.0.0 withSystemTempFile :: MonadUnliftIO m => String -- ^ File name template. See 'openTempFile'. -> (FilePath -> Handle -> m a) -- ^ Callback that can use the file -> m a withSystemTempFile template action = liftIO getCanonicalTemporaryDirectory >>= \tmpDir -> withTempFile tmpDir template action -- | Create and use a temporary directory in the system standard temporary directory. -- -- Behaves exactly the same as 'withTempDirectory', except that the parent temporary directory -- will be that returned by 'getCanonicalTemporaryDirectory'. -- -- @since 0.1.0.0 withSystemTempDirectory :: MonadUnliftIO m => String -- ^ Directory name template. See 'openTempFile'. -> (FilePath -> m a) -- ^ Callback that can use the directory. -> m a withSystemTempDirectory template action = liftIO getCanonicalTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action -- | Use a temporary filename that doesn't already exist. -- -- Creates a new temporary file inside the given directory, making use of the -- template. The temp file is deleted after use. For example: -- -- > withTempFile "src" "sdist." $ \tmpFile hFile -> do ... -- -- The @tmpFile@ will be file in the given directory, e.g. -- @src/sdist.342@. -- -- @since 0.1.0.0 withTempFile :: MonadUnliftIO m => FilePath -- ^ Temp dir to create the file in. -> String -- ^ File name template. See 'openTempFile'. -> (FilePath -> Handle -> m a) -- ^ Callback that can use the file. -> m a withTempFile tmpDir template action = bracket (liftIO (openTempFile tmpDir template)) (\(name, handle') -> liftIO (hClose handle' >> ignoringIOErrors (removeFile name))) (uncurry action) -- | Create and use a temporary directory. -- -- Creates a new temporary directory inside the given directory, making use -- of the template. The temp directory is deleted after use. For example: -- -- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... -- -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. -- -- @since 0.1.0.0 withTempDirectory :: MonadUnliftIO m => FilePath -- ^ Temp directory to create the directory in. -> String -- ^ Directory name template. See 'openTempFile'. -> (FilePath -> m a) -- ^ Callback that can use the directory. -> m a withTempDirectory targetDir template = bracket (liftIO (createTempDirectory targetDir template)) (liftIO . ignoringIOErrors . removeDirectoryRecursive) -- | Return the absolute and canonical path to the system temporary -- directory. -- -- >>> setCurrentDirectory "/home/feuerbach/" -- >>> setEnv "TMPDIR" "." -- >>> getTemporaryDirectory -- "." -- >>> getCanonicalTemporaryDirectory -- "/home/feuerbach" getCanonicalTemporaryDirectory :: IO FilePath getCanonicalTemporaryDirectory = getTemporaryDirectory >>= canonicalizePath -- | Create a temporary directory. See 'withTempDirectory'. createTempDirectory :: FilePath -- ^ Temp directory to create the directory in. -> String -- ^ Directory name template. -> IO FilePath createTempDirectory dir template = do pid <- c_getpid findTempName pid where findTempName x = do let dirpath = dir template ++ show x r <- try $ mkPrivateDir dirpath case r of Right _ -> return dirpath Left e | isAlreadyExistsError e -> findTempName (x+1) | otherwise -> ioError e mkPrivateDir :: String -> IO () #ifdef mingw32_HOST_OS mkPrivateDir s = createDirectory s #else mkPrivateDir s = System.Posix.createDirectory s 0o700 #endif ignoringIOErrors :: MonadUnliftIO m => m () -> m () ignoringIOErrors = liftM (const ()) . tryIO -- yes, it's just void, but for pre-AMP GHCs unliftio-0.2.11/src/UnliftIO/Timeout.hs0000644000000000000000000000051113207246422016053 0ustar0000000000000000-- | Unlifted "System.Timeout". -- -- @since 0.1.0.0 module UnliftIO.Timeout ( timeout ) where import qualified System.Timeout as S import Control.Monad.IO.Unlift -- | Unlifted 'S.timeout'. -- -- @since 0.1.0.0 timeout :: MonadUnliftIO m => Int -> m a -> m (Maybe a) timeout x y = withRunInIO $ \run -> S.timeout x $ run y unliftio-0.2.11/cbits/time-osx.c0000644000000000000000000000066513251722173014641 0ustar0000000000000000/* From https://github.com/bos/criterion */ #include #include static mach_timebase_info_data_t timebase_info; static double timebase_recip; 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; } unliftio-0.2.11/cbits/time-windows.c0000644000000000000000000000202113251722173015506 0ustar0000000000000000/* From https://github.com/bos/criterion */ /* * Windows has the most amazingly cretinous time measurement APIs you * can possibly imagine. * * Our first possibility is GetSystemTimeAsFileTime, which updates at * roughly 60Hz, and is hence worthless - we'd have to run a * computation for tens or hundreds of seconds to get a trustworthy * number. * * Alternatively, we can use QueryPerformanceCounter, which has * undefined behaviour under almost all interesting circumstances * (e.g. multicore systems, CPU frequency changes). But at least it * increments reasonably often. */ #include static double freq_recip; static LARGE_INTEGER firstClock; void unliftio_inittime(void) { LARGE_INTEGER freq; if (freq_recip == 0) { QueryPerformanceFrequency(&freq); QueryPerformanceCounter(&firstClock); freq_recip = 1.0 / freq.QuadPart; } } double unliftio_gettime(void) { LARGE_INTEGER li; QueryPerformanceCounter(&li); return ((double) (li.QuadPart - firstClock.QuadPart)) * freq_recip; } unliftio-0.2.11/cbits/time-posix.c0000644000000000000000000000036113251722173015163 0ustar0000000000000000/* From https://github.com/bos/criterion */ #include void unliftio_inittime(void) { } double unliftio_gettime(void) { struct timespec ts; clock_gettime(CLOCK_MONOTONIC, &ts); return ts.tv_sec + ts.tv_nsec * 1e-9; } unliftio-0.2.11/test/Spec.hs0000644000000000000000000000005413221441450014012 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} unliftio-0.2.11/test/UnliftIO/AsyncSpec.hs0000644000000000000000000001530213403661532016512 0ustar0000000000000000{-# 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 unliftio-0.2.11/test/UnliftIO/ExceptionSpec.hs0000644000000000000000000000134213221441450017363 0ustar0000000000000000module UnliftIO.ExceptionSpec (spec) where import Test.Hspec import UnliftIO spec :: Spec spec = do let shouldLeft x = either (const Nothing) Just x `shouldBe` Nothing shouldRight x = either (Just . show) (const Nothing) x `shouldBe` Nothing describe "pureTry" $ do it "Right for defined values" $ shouldRight $ pureTry () it "Left for bottom" $ shouldLeft $ pureTry (undefined :: ()) it "Right for wrapped bottom" $ shouldRight $ pureTry $ Just (undefined :: ()) describe "pureTryDeep" $ do it "Right for defined values" $ shouldRight $ pureTryDeep () it "Left for bottom" $ shouldLeft $ pureTryDeep (undefined :: ()) it "Left for wrapped bottom" $ shouldLeft $ pureTryDeep $ Just (undefined :: ()) unliftio-0.2.11/test/UnliftIO/IOSpec.hs0000644000000000000000000000047213251722173015746 0ustar0000000000000000module UnliftIO.IOSpec (spec) where import Test.Hspec import UnliftIO.IO import Control.Concurrent (threadDelay) spec :: Spec spec = do describe "getMonotonicTime" $ do it "increases" $ do x <- getMonotonicTime threadDelay 5000 y <- getMonotonicTime y - x `shouldSatisfy` (>= 5e-3) unliftio-0.2.11/test/UnliftIO/MemoizeSpec.hs0000644000000000000000000000265513343444703017053 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module UnliftIO.MemoizeSpec (spec) where import Control.Concurrent (threadDelay) import Control.Monad (replicateM_) import Test.Hspec import Test.Hspec.QuickCheck import UnliftIO import Data.Typeable data Dummy = Dummy deriving (Show, Typeable) instance Exception Dummy spec :: Spec spec = do let basics maker = do prop "sanity" $ \i -> do x <- maker $ return (i :: Int) runMemoized x `shouldReturn` i prop "runs once" $ \i -> do count <- newIORef (0 :: Int) x <- maker $ do modifyIORef' count (+ 1) return (i :: Int) replicateM_ 10 $ runMemoized x `shouldReturn` i readIORef count `shouldReturn` 1 it "runs once with exception" $ do count <- newIORef (0 :: Int) x <- maker $ do modifyIORef' count (+ 1) throwIO Dummy replicateM_ 10 $ runMemoized x `shouldThrow` (\Dummy -> True) readIORef count `shouldReturn` 1 describe "memoizeRef" $ basics memoizeRef describe "memoizeMVar" $ do basics memoizeMVar prop "runs once in multiple threads" $ \i -> do count <- newIORef (0 :: Int) x <- memoizeMVar $ do threadDelay 10000 atomicModifyIORef' count $ \cnt -> (cnt + 1, ()) return (i :: Int) replicateConcurrently_ 10 $ runMemoized x `shouldReturn` i readIORef count `shouldReturn` 1 unliftio-0.2.11/test/UnliftIO/PooledAsyncSpec.hs0000644000000000000000000001600313412137046017652 0ustar0000000000000000{-#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-0.2.11/bench/ConcBench.hs0000644000000000000000000001226513403661532015060 0ustar0000000000000000import 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 ] ] unliftio-0.2.11/LICENSE0000644000000000000000000000203713131436235012622 0ustar0000000000000000Copyright (c) 2017 FP Complete Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. unliftio-0.2.11/Setup.hs0000644000000000000000000000005613131436235013250 0ustar0000000000000000import Distribution.Simple main = defaultMain unliftio-0.2.11/unliftio.cabal0000644000000000000000000000577013476437450014455 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- -- hash: 9b54d473debcf0958351a2c8a7924ed9a8d3504243c348545109ffe72b005683 name: unliftio version: 0.2.11 synopsis: The MonadUnliftIO typeclass for unlifting monads to IO (batteries included) description: Please see the documentation and README at category: Control homepage: https://github.com/fpco/unliftio/tree/master/unliftio#readme author: Michael Snoyman, Francesco Mazzoli maintainer: michael@snoyman.com copyright: 2017 FP Complete license: MIT license-file: LICENSE build-type: Simple extra-source-files: README.md ChangeLog.md library hs-source-dirs: src ghc-options: -fwarn-incomplete-uni-patterns build-depends: async >2.1.1 , base >=4.7 && <5 , deepseq , directory , filepath , process >=1.2.0.0 , stm >=2.4.3 , time , transformers , unliftio-core >=0.1.1.0 if os(windows) cpp-options: -DWINDOWS else build-depends: unix if impl(ghc <= 7.10) build-depends: nats if os(darwin) c-sources: cbits/time-osx.c else if os(windows) c-sources: cbits/time-windows.c else c-sources: cbits/time-posix.c exposed-modules: UnliftIO UnliftIO.Async UnliftIO.Chan UnliftIO.Concurrent UnliftIO.Directory UnliftIO.Environment UnliftIO.Exception UnliftIO.Foreign UnliftIO.Internals.Async 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 hs-source-dirs: test build-depends: QuickCheck , async >2.1.1 , base >=4.7 && <5 , containers , deepseq , directory , filepath , hspec , process >=1.2.0.0 , stm >=2.4.3 , time , transformers , unliftio , unliftio-core >=0.1.1.0 if os(windows) cpp-options: -DWINDOWS else build-depends: unix other-modules: UnliftIO.AsyncSpec UnliftIO.ExceptionSpec UnliftIO.IOSpec UnliftIO.MemoizeSpec UnliftIO.PooledAsyncSpec Paths_unliftio default-language: Haskell2010 benchmark conc-bench type: exitcode-stdio-1.0 main-is: ConcBench.hs other-modules: Paths_unliftio hs-source-dirs: bench ghc-options: -O2 -threaded -rtsopts build-depends: async >2.1.1 , base >=4.7 && <5 , deepseq , directory , filepath , gauge , process >=1.2.0.0 , stm >=2.4.3 , time , transformers , unliftio , unliftio-core >=0.1.1.0 if os(windows) cpp-options: -DWINDOWS else build-depends: unix default-language: Haskell2010 unliftio-0.2.11/README.md0000644000000000000000000003645313412137046013105 0ustar0000000000000000# unliftio [![Travis Build Status](https://travis-ci.org/fpco/unliftio.svg?branch=master)](https://travis-ci.org/fpco/unliftio) [![AppVeyor Build status](https://ci.appveyor.com/api/projects/status/sprg5nlyh0codcpv?svg=true)](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 * Replace imports like `Control.Exception` with `UnliftIO.Exception`. Yay, your `catch` and `finally` are more powerful and safer (see [Async exception safety](#async-exception-safety))! * Similar with `Control.Concurrent.Async` with `UnliftIO.Async` * Or go all in and import `UnliftIO` * Naming conflicts: let `unliftio` win * 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! ## Unlifting in 2 minutes Let's say I have a function: ```haskell readFile :: FilePath -> IO ByteString ``` But I'm writing code inside a function that uses `ReaderT Env IO`, not just plain `IO`. How can I call my `readFile` function in that context? One way is to manually unwrap the `ReaderT` data constructor: ```haskell myReadFile :: FilePath -> ReaderT Env IO ByteString myReadFile fp = ReaderT $ \_env -> readFile fp ``` But having to do this regularly is tedious, and ties our code to a specific monad transformer stack. Instead, many of us would use `MonadIO`: ```haskell myReadFile :: MonadIO m => FilePath -> m ByteString myReadFile = liftIO . readFile ``` But now let's play with a different function: ```haskell withBinaryFile :: FilePath -> IOMode -> (Handle -> IO a) -> IO a ``` We want a function with signature: ```haskell myWithBinaryFile :: FilePath -> IOMode -> (Handle -> ReaderT Env IO a) -> ReaderT Env IO a ``` If I squint hard enough, I can accomplish this directly with the `ReaderT` constructor via: ```haskell myWithBinaryFile fp mode inner = ReaderT $ \env -> withBinaryFile fp mode (\h -> runReaderT (inner h) env) ``` 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) in `withBinaryFile`.) However, with `MonadUnliftIO`, this is possible: ```haskell import Control.Monad.IO.Unlift myWithBinaryFile :: MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m a) -> m a myWithBinaryFile fp mode inner = withRunInIO $ \runInIO -> withBinaryFile fp mode (\h -> runInIO (inner h)) ``` That's it, you now know the entire basis of this library. ## How common is this problem? This pops up in a number of places. Some examples: * Proper exception handling, with functions like `bracket`, `catch`, and `finally` * Working with `MVar`s via `modifyMVar` and similar * Using the `timeout` function * Installing callback handlers (e.g., do you want to do [logging](https://www.stackage.org/package/monad-logger) in a signal handler?). This also pops up when working with libraries which are monomorphic on `IO`, even if they could be written more extensibly. ## Examples Reading through the codebase here is likely the best example to see how to use `MonadUnliftIO` in practice. And for many cases, you can simply add the `MonadUnliftIO` constraint and then use the 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`: ```haskell newtype UnliftIO m = UnliftIO { unliftIO :: forall a. m a -> IO a } class MonadIO m => MonadUnliftIO m where askUnliftIO :: m (UnliftIO m) ``` `askUnliftIO` gives us a function to run arbitrary computation 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)) instance MonadUnliftIO m => MonadUnliftIO (ReaderT r m) where askUnliftIO = ReaderT $ \r -> withUnliftIO $ \u -> return (UnliftIO (unliftIO u . flip runReaderT r)) ``` Note that: * 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 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 :: UnliftIO m) <- askUnliftIO liftIO $ System.Timeout.timeout x $ unliftIO u y ``` or more concisely using `withRunInIO`: ```haskell timeout :: MonadUnliftIO m => Int -> m a -> m (Maybe a) timeout x y = withRunInIO $ \run -> System.Timeout.timeout x $ run y ``` This is a common pattern: use `withRunInIO` to capture a run function, and then call the original function with the user-supplied arguments, applying `run` as necessary. `withRunInIO` takes care of invoking `unliftIO` for us. We can also use the run function with different types due to `withRunInIO` being higher-rank polymorphic: ```haskell race :: MonadUnliftIO m => m a -> m b -> m (Either a b) race a b = withRunInIO $ \run -> A.race (run a) (run b) ``` And finally, a more complex usage, when unlifting the `mask` function. This function needs to unlift values to be passed into the `restore` function, and then `liftIO` the result of the `restore` function. ```haskell mask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m b) -> m b mask f = withRunInIO $ \run -> Control.Exception.mask $ \restore -> run $ f $ liftIO . restore . run ``` ## Limitations Not all monads which can be an instance of `MonadIO` can be instances of `MonadUnliftIO`, due to the `MonadUnliftIO` laws (described in the Haddocks for the typeclass). This prevents instances for a number of classes of transformers: * Transformers using continuations (e.g., `ContT`, `ConduitM`, `Pipe`) * Transformers with some monadic state (e.g., `StateT`, `WriterT`) * Transformers with multiple exit points (e.g., `ExceptT` and its ilk) In fact, there are two specific classes of transformers that this approach does work for: * Transformers with no context at all (e.g., `IdentityT`, `NoLoggingT`) * Transformers with a context but no state (e.g., `ReaderT`, `LoggingT`) This may sound restrictive, but this restriction is fully intentional. Trying to unlift actions in stateful monads leads to unpredictable behavior. For a long and exhaustive example of this, see [A Tale of Two Brackets](https://www.fpcomplete.com/blog/2017/06/tale-of-two-brackets), which was a large motivation for writing this library. ## Comparison to other approaches You may be thinking "Haven't I seen a way to do `catch` in `StateT`?" You almost certainly have. Let's compare this approach with alternatives. (For an older but more thorough rundown of the options, see [Exceptions and monad transformers](http://www.yesodweb.com/blog/2014/06/exceptions-transformers).) There are really two approaches to this problem: * Use a set of typeclasses for the specific functionality we care about. This is the approach taken by the `exceptions` package with `MonadThrow`, `MonadCatch`, and `MonadMask`. (Earlier approaches include `MonadCatchIO-mtl` and `MonadCatchIO-transformers`.) * Define a generic typeclass that allows any control structure to be unlifted. This is the approach taken by the `monad-control` package. (Earlier approaches include `monad-peel` and `neither`.) The first style gives extra functionality in allowing instances that have nothing to do with runtime exceptions (e.g., a `MonadCatch` instance for `Either`). This is arguably a good thing. The second style gives extra functionality in allowing more operations to be unlifted (like threading primitives, not supported by the `exceptions` package). Another distinction within the generic typeclass family is whether we unlift to just `IO`, or to arbitrary base monads. For those familiar, this is the distinction between the `MonadIO` and `MonadBase` typeclasses. This package's main objection to all of the above approaches is that they work for too many monads, and provide difficult-to-predict behavior for a number of them (arguably: plain wrong behavior). For example, in `lifted-base` (built on top of `monad-control`), the `finally` operation will discard mutated state coming from the cleanup action, which is usually not what people expect. `exceptions` has _different_ behavior here, which is arguably better. But we're arguing here that we should disallow all such ambiguity at the type level. So comparing to other approaches: ### monad-unlift Throwing this one out there now: the `monad-unlift` library is built on top of `monad-control`, and uses fairly sophisticated type level features to restrict it to only the safe subset of monads. The same approach is taken by `Control.Concurrent.Async.Lifted.Safe` in the `lifted-async` package. Two problems with this: * The complicated type level functionality can confuse GHC in some cases, making it difficult to get code to compile. * We don't have an ecosystem of functions like `lifted-base` built on top of it, making it likely people will revert to the less safe cousin functions. ### monad-control The main contention until now is that unlifting in a transformer like `StateT` is unsafe. This is not universally true: if only one action is being unlifted, no ambiguity exists. So, for example, `try :: IO a -> IO (Either e a)` can safely be unlifted in `StateT`, while `finally :: IO a -> IO b -> IO a` cannot. `monad-control` allows us to unlift both styles. In theory, we could write a variant of `lifted-base` that never does state discards, and let `try` be more general than `finally`. In other words, this is an advantage of `monad-control` over `MonadUnliftIO`. We've avoided providing any such extra typeclass in this package though, for two reasons: * `MonadUnliftIO` is a simple typeclass, easy to explain. We don't want to complicated matters (`MonadBaseControl` is a notoriously difficult to understand typeclass). This simplicity is captured by the laws for `MonadUnliftIO`, which make the behavior of the run functions close to that of the already familiar `lift` and `liftIO`. * Having this kind of split would be confusing in user code, when suddenly `finally` is not available to us. We would rather encourage [good practices](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern) from the beginning. Another distinction is that `monad-control` uses the `MonadBase` style, allowing unlifting to arbitrary base monads. In this package, we've elected to go with `MonadIO` style. This limits what we can do (e.g., no unlifting to `STM`), but we went this way because: * In practice, we've found that the vast majority of cases are dealing with `IO` * The split in the ecosystem between constraints like `MonadBase IO` and `MonadIO` leads to significant confusion, and `MonadIO` is by far the more common constraints (with the typeclass existing in `base`) ### exceptions One thing we lose by leaving the `exceptions` approach is the ability to model both pure and side-effecting (via `IO`) monads with a single paradigm. For example, it can be pretty convenient to have `MonadThrow` constraints for parsing functions, which will either return an `Either` value or throw a runtime exception. That said, there are detractors of that approach: * You lose type information about which exception was thrown * There is ambiguity about _how_ the exception was returned in a constraint like `(MonadIO m, MonadThrow m`) The latter could be addressed by defining a law such as `throwM = liftIO . throwIO`. However, we've decided in this library to go the route of encouraging `Either` return values for pure functions, and using runtime exceptions in `IO` otherwise. (You're of course free to also return `IO (Either e a)`.) By losing `MonadCatch`, we lose the ability to define a generic way to catch exceptions in continuation based monads (such as `ConduitM`). Our argument here is that those monads can freely provide their own catching functions. And in practice, long before the `MonadCatch` typeclass existed, `conduit` provided a `catchC` function. In exchange for the `MonadThrow` typeclass, we provide helper functions to convert `Either` values to runtime exceptions in this package. And the `MonadMask` typeclass is now replaced fully by `MonadUnliftIO`, which like the `monad-control` case limits which monads we can be working with. ## Async exception safety The [`safe-exceptions`](https://hackage.haskell.org/package/safe-exceptions) package builds on top of the `exceptions` package and provides intelligent behavior for dealing with asynchronous exceptions, a common pitfall. This library provides a set of exception handling functions with the same async exception behavior as that library. You can consider this library a drop-in replacement for `safe-exceptions`. In the future, we may reimplement `safe-exceptions` to use `MonadUnliftIO` instead of `MonadCatch` and `MonadMask`. ## Package split 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 providing a plethora of pre-unlifted helper functions. It's a good choice for importing, or even for use in a custom prelude. ## Orphans The `unliftio` package currently provides orphan instances for types from the `resourcet` and `monad-logger` packages. This is not intended as a long-term solution; once `unliftio` is deemed more stable, the plan is to move those instances into the respective libraries and 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 selective about adding dependencies. ## Future questions * Should we extend the set of functions exposed in `UnliftIO.IO` to include things like `hSeek`? * Are there other libraries that deserve to be unlifted here? unliftio-0.2.11/ChangeLog.md0000644000000000000000000000244013476437166014004 0ustar0000000000000000# Changelog for unliftio ## 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` ## 0.2.8.0 * Add 'UnliftIO.Memoize' ## 0.2.7.1 * Minor doc improvements ## 0.2.7.0 * Re-export `tryPutTMVar` from `UnliftIO.STM` ## 0.2.6.0 * Add `UnliftIO.Directory` ## 0.2.5.0 * Add `UnliftIO.Environment`/`UnliftIO.Foreign`/`UnliftIO.Process` ## 0.2.4.0 * Use more generalized `withRunInIO` in `unliftio-core-0.1.1.0` * Add `getMonotonicTime` function ## 0.2.2.0 * Add `pureTry` and `pureTryDeep` ## 0.2.1.0 * Add `UnliftIO.STM` * Add a number of functions to `UnliftIO.IO` ## 0.2.0.0 * Remove `monad-logger` instances (moved into `monad-logger` itself in release `0.3.26`) * Remove `resourcet` instances and `UnliftIO.Resource` (moved into `resourcet` itself in release `1.1.10`) ## 0.1.1.0 * Doc improvements. * Fix `UnliftIO.Chan` type signatures [#3](https://github.com/fpco/unliftio/pull/3). * Add `UnliftIO.Concurrent` module [#5](https://github.com/fpco/unliftio/pull/5). ## 0.1.0.0 * Initial release.