unliftio-0.2.25.0/bench/0000755000000000000000000000000014370231514013034 5ustar0000000000000000unliftio-0.2.25.0/cbits/0000755000000000000000000000000014370231514013061 5ustar0000000000000000unliftio-0.2.25.0/src/0000755000000000000000000000000014370231514012544 5ustar0000000000000000unliftio-0.2.25.0/src/UnliftIO/0000755000000000000000000000000014442761553014250 5ustar0000000000000000unliftio-0.2.25.0/src/UnliftIO/Exception/0000755000000000000000000000000014442761553016206 5ustar0000000000000000unliftio-0.2.25.0/src/UnliftIO/IO/0000755000000000000000000000000014370231514014544 5ustar0000000000000000unliftio-0.2.25.0/src/UnliftIO/IO/File/0000755000000000000000000000000014370231514015423 5ustar0000000000000000unliftio-0.2.25.0/src/UnliftIO/Internals/0000755000000000000000000000000014370231514016174 5ustar0000000000000000unliftio-0.2.25.0/test/0000755000000000000000000000000014370231514012734 5ustar0000000000000000unliftio-0.2.25.0/test/UnliftIO/0000755000000000000000000000000014370231514014425 5ustar0000000000000000unliftio-0.2.25.0/test/UnliftIO/IO/0000755000000000000000000000000014370231514014734 5ustar0000000000000000unliftio-0.2.25.0/src/UnliftIO.hs0000644000000000000000000000144114370231514014571 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.QSem , module UnliftIO.QSemN , 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.QSem import UnliftIO.QSemN import UnliftIO.STM import UnliftIO.Temporary import UnliftIO.Timeout unliftio-0.2.25.0/src/UnliftIO/Async.hs0000644000000000000000000000426014370231514015650 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 -- * Re-exports #if MIN_VERSION_async(2,2,0) A.AsyncCancelled (..), #endif ) where import Control.Concurrent.Async (Async) import qualified Control.Concurrent.Async as A import UnliftIO.Internals.Async unliftio-0.2.25.0/src/UnliftIO/Chan.hs0000644000000000000000000000210014370231514015433 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.25.0/src/UnliftIO/Concurrent.hs0000644000000000000000000001261514370231514016720 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.25.0/src/UnliftIO/Directory.hs0000644000000000000000000003252314370231514016542 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Unlifted "System.Directory". -- -- @since 0.2.6.0 module UnliftIO.Directory ( -- * Actions on directories createDirectory , createDirectoryIfMissing #if MIN_VERSION_directory(1,3,1) , createFileLink , createDirectoryLink , removeDirectoryLink , getSymbolicLinkTarget #endif , removeDirectory , removeDirectoryRecursive #if MIN_VERSION_directory(1,2,7) , 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 #if MIN_VERSION_directory(1,3,2) , XdgDirectoryList(..) , getXdgDirectoryList #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 #if MIN_VERSION_directory(1,3,2) , XdgDirectoryList(..) #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) #if MIN_VERSION_directory(1,3,1) -- | Lifted 'D.createFileLink'. -- directory package version should be >= 1.3.1. -- @since 0.2.16.0 {-# INLINE createFileLink #-} createFileLink :: MonadIO m => FilePath -- ^ path to the target file -> FilePath -- ^ path of the link to be created -> m () createFileLink targetPath linkPath = liftIO (D.createFileLink targetPath linkPath) -- | Lifted 'D.createDirectoryLink'. -- -- @since 0.2.21.0 createDirectoryLink :: MonadIO m => FilePath -> FilePath -> m () createDirectoryLink targetPath linkPath = liftIO (D.createDirectoryLink targetPath linkPath) -- | Lifted 'D.removeDirectoryLink'. -- -- @since 0.2.21.0 removeDirectoryLink :: MonadIO m => FilePath -> m () removeDirectoryLink linkPath = liftIO (D.removeDirectoryLink linkPath) -- | Lifted 'D.getSymbolicLinkTarget'. -- -- @since 0.2.21.0 getSymbolicLinkTarget :: MonadIO m => FilePath -> m FilePath getSymbolicLinkTarget linkPath = liftIO (D.getSymbolicLinkTarget linkPath) #endif -- | Lifted 'D.removeDirectory'. -- -- @since 0.2.6.0 {-# 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 #if MIN_VERSION_directory(1,3,2) -- | Lifted 'D.getXdgDirectoryList'. -- -- @since 0.2.21.0 getXdgDirectoryList :: MonadIO m => XdgDirectoryList -> m [FilePath] getXdgDirectoryList xdgDirectoryList = liftIO (D.getXdgDirectoryList xdgDirectoryList) #endif -- | Lifted 'D.getAppUserDataDirectory'. -- -- @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.25.0/src/UnliftIO/Environment.hs0000644000000000000000000000364614370231514017106 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.25.0/src/UnliftIO/Exception.hs0000644000000000000000000005117714370231514016542 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://www.fpcomplete.com/haskell/tutorial/exceptions/). module UnliftIO.Exception ( -- * Throwing throwIO , throwString , StringException (..) , stringException , throwTo , impureThrow , fromEither , fromEitherIO , fromEitherM , mapExceptionM -- * Catching (with recovery) , catch , catchIO , catchAny , catchDeep , catchAnyDeep , catchJust , handle , handleIO , handleAny , handleDeep , handleAnyDeep , handleJust , try , tryIO , tryAny , tryDeep , tryAnyDeep , tryJust , pureTry , pureTryDeep , ESafe.Handler (..) , catches , catchesDeep -- * Catching async exceptions (with recovery) , catchSyncOrAsync , handleSyncOrAsync , trySyncOrAsync -- * Cleanup (no recovery) , onException , bracket , bracket_ , finally , withException , bracketOnError , bracketOnError_ -- * Coercion to sync and async -- | In version /0.2.23.0/, these were changed with aliases to the values -- from "Control.Exception.Safe" in the @safe-exceptions@ package. , ESafe.SyncExceptionWrapper(..) , toSyncException , ESafe.AsyncExceptionWrapper(..) , toAsyncException , fromExceptionUnwrap -- * Check exception type , isSyncException , isAsyncException -- * Masking , mask , uninterruptibleMask , mask_ , uninterruptibleMask_ -- * Evaluation , evaluate , evaluateDeep -- * Reexports , Exception (..) , Typeable , SomeException (..) , SomeAsyncException (..) , IOException , EUnsafe.assert , EUnsafe.asyncExceptionToException , EUnsafe.asyncExceptionFromException #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) import qualified Control.Exception.Safe as ESafe import Control.Exception.Safe (Handler(..)) #if MIN_VERSION_base(4,9,0) import GHC.Stack (prettySrcLoc) import GHC.Stack.Types (HasCallStack, CallStack, getCallStack) #endif -- | Catch a synchronous (but not asynchronous) exception and recover from it. -- -- This is parameterized on the exception type. To catch all synchronous exceptions, -- use 'catchAny'. -- -- @since 0.1.0.0 catch :: (MonadUnliftIO m, Exception e) => m a -- ^ action -> (e -> m a) -- ^ handler -> 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 exceptions. -- -- @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 -- | A variant of 'catch' that catches both synchronous and asynchronous exceptions. -- -- WARNING: This function (and other @*SyncOrAsync@ functions) is for advanced users. Most of the -- time, you probably want to use the non-@SyncOrAsync@ versions. -- -- Before attempting to use this function, be familiar with the "Rules for async safe handling" -- section in -- [this blog post](https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/). -- -- @since 0.2.17 catchSyncOrAsync :: (MonadUnliftIO m, Exception e) => m a -> (e -> m a) -> m a catchSyncOrAsync f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> run (g e) -- | Flipped version of 'catch'. -- -- @since 0.1.0.0 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) -- | A variant of 'handle' that catches both synchronous and asynchronous exceptions. -- -- See 'catchSyncOrAsync'. -- -- @since 0.2.17 handleSyncOrAsync :: (MonadUnliftIO m, Exception e) => (e -> m a) -> m a -> m a handleSyncOrAsync = flip catchSyncOrAsync -- | Run the given action and catch any synchronous exceptions as a 'Left' value. -- -- This is parameterized on the exception type. To catch all synchronous exceptions, -- use 'tryAny'. -- -- @since 0.1.0.0 try :: (MonadUnliftIO m, Exception e) => m a -> m (Either e a) try f = catch (liftM Right f) (return . Left) -- | '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)) -- | A variant of 'try' that catches both synchronous and asynchronous exceptions. -- -- See 'catchSyncOrAsync'. -- -- @since 0.2.17 trySyncOrAsync :: (MonadUnliftIO m, Exception e) => m a -> m (Either e a) trySyncOrAsync f = catchSyncOrAsync (liftM Right f) (return . Left) -- | Evaluate the value to WHNF and catch any synchronous exceptions. -- -- The expression may still have bottom values within it; you may -- 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 -- | Internal. catchesHandler :: MonadIO m => [Handler m a] -> SomeException -> m a catchesHandler handlers e = foldr tryHandler (liftIO (EUnsafe.throwIO e)) handlers where tryHandler (ESafe.Handler handler) res = case fromException e of Just e' -> handler e' Nothing -> res -- | Similar to 'catch', but provides multiple different handler functions. -- -- For more information on motivation, see @base@'s 'EUnsafe.catches'. Note that, -- unlike that function, this function will not catch asynchronous exceptions. -- -- @since 0.1.0.0 catches :: MonadUnliftIO m => m a -> [Handler m a] -> m a catches io handlers = io `catch` catchesHandler handlers -- | 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 $!!) -- | Allocate and clean up a resource safely. -- -- For more information on motivation and usage of this function, see @base@'s -- 'EUnsafe.bracket'. This function has two differences from the one in @base@. -- The first, and more obvious, is that it works on any @MonadUnliftIO@ -- instance, not just @IO@. -- -- The more subtle difference is that this function will use uninterruptible -- masking for its cleanup handler. This is a subtle distinction, but at a -- high level, means that resource cleanup has more guarantees to complete. -- This comes at the cost that an incorrectly written cleanup function -- cannot be interrupted. -- -- For more information, please see . -- -- @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 -- | Same as 'bracket', but does not pass the acquired resource to cleanup and use functions. -- -- For more information, see @base@'s 'EUnsafe.bracket_'. -- -- @since 0.1.0.0 bracket_ :: MonadUnliftIO m => m a -> m b -> m c -> m c bracket_ before after thing = bracket before (const after) (const thing) -- | Same as 'bracket', but only perform the cleanup if an exception is thrown. -- -- @since 0.1.0.0 bracketOnError :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m c) -> m c 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) -- | Perform @thing@, guaranteeing that @after@ will run after, even if an exception occurs. -- -- Same interruptible vs uninterrupible points apply as with 'bracket'. See @base@'s -- 'EUnsafe.finally' for more information. -- -- @since 0.1.0.0 finally :: MonadUnliftIO m => m a -- ^ thing -> m b -- ^ after -> 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 -- | Like 'finally', but only call @after@ if an exception occurs. -- -- @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. -- -- Note that, if you provide an exception value which is of an asynchronous -- type, it will be wrapped up in 'SyncExceptionWrapper'. See 'toSyncException'. -- -- @since 0.1.0.0 throwIO :: (MonadIO m, Exception e) => e -> m a throwIO = liftIO . EUnsafe.throwIO . toSyncException -- | 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 = ESafe.toSyncException -- | 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 = ESafe.toAsyncException -- | Convert from a possibly wrapped exception. -- -- The inverse of 'toAsyncException' and 'toSyncException'. When using those -- functions (or functions that use them, like 'throwTo' or 'throwIO'), -- 'fromException' might not be sufficient because the exception might be -- wrapped within 'SyncExceptionWrapper' or 'AsyncExceptionWrapper'. -- -- @since 0.2.17 fromExceptionUnwrap :: Exception e => SomeException -> Maybe e fromExceptionUnwrap se | Just (ESafe.AsyncExceptionWrapper e) <- fromException se = cast e | Just (ESafe.SyncExceptionWrapper e) <- fromException se = cast e | otherwise = fromException se -- | Check if the given exception is synchronous. -- -- @since 0.1.0.0 isSyncException :: Exception e => e -> Bool isSyncException = ESafe.isSyncException -- | 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 $ "UnliftIO.Exception.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 _) = "UnliftIO.Exception.throwString called with:\n\n" ++ s #endif -- | @since 0.2.19 instance Eq StringException where StringException msg1 _ == StringException msg2 _ = msg1 == msg2 -- | @since 0.1.0.0 instance Exception StringException -- | 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) -- | Same as 'Control.Exception.mapException', except works in -- a monadic context. -- -- @since 0.2.15 mapExceptionM :: (Exception e1, Exception e2, MonadUnliftIO m) => (e1 -> e2) -> m a -> m a mapExceptionM f = handle (throwIO . f) unliftio-0.2.25.0/src/UnliftIO/Exception/Lens.hs0000644000000000000000000000611514442761553017446 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Functions from "Control.Exception.Lens", but using 'MonadUnliftIO', not -- 'MonadCatch' module UnliftIO.Exception.Lens ( catching , catching_ , handling , handling_ , trying , trying_ ) where import Prelude import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad (liftM) import Data.Monoid (First) import UnliftIO.Exception (SomeException, catchJust, tryJust) import Control.Applicative (Const(..)) import Data.Monoid (First(..)) #if __GLASGOW_HASKELL__ >= 708 import Data.Coerce #else import Unsafe.Coerce #endif -- | 'Control.Exception.Lens.catching' using 'MonadUnliftIO' -- -- @since 0.2.25.0 catching :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} -- | 'Control.Exception.Lens.catching_' using 'MonadUnliftIO' -- -- @since 0.2.25.0 catching_ :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m r -> m r catching_ l a b = catchJust (preview l) a (const b) {-# INLINE catching_ #-} -- | 'Control.Exception.Lens.handling' using 'MonadUnliftIO' -- -- @since 0.2.25.0 handling :: MonadUnliftIO m => Getting (First a) SomeException a -> (a -> m r) -> m r -> m r handling l = flip (catching l) {-# INLINE handling #-} -- | 'Control.Exception.Lens.handling_' using 'MonadUnliftIO' -- -- @since 0.2.25.0 handling_ :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m r -> m r handling_ l = flip (catching_ l) {-# INLINE handling_ #-} -- | 'Control.Exception.Lens.trying' using 'MonadUnliftIO' -- -- @since 0.2.25.0 trying :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m (Either a r) trying l = tryJust (preview l) {-# INLINE trying #-} -- | 'Control.Exception.Lens.trying_' using 'MonadUnliftIO' -- -- @since 0.2.25.0 trying_ :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m (Maybe r) trying_ l m = preview _Right `liftM` trying l m {-# INLINE trying_ #-} -------------------------------------------------------------------------------- -- Enough of (micro)lens to accomplish this mondule without any dependencies -- -- TODO: code review note: should we just bring in microlens? -------------------------------------------------------------------------------- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t _Right :: Traversal (Either a b) (Either a b') b b' _Right f (Right b) = Right <$> f b _Right _ (Left a) = pure (Left a) {-# INLINE _Right #-} type Getting r s a = (a -> Const r a) -> s -> Const r s preview :: Getting (First a) s a -> s -> Maybe a preview l = getFirst #. foldMapOf l (First #. Just) {-# INLINE preview #-} foldMapOf :: Getting r s a -> (a -> r) -> s -> r foldMapOf l f = getConst #. l (Const #. f) {-# INLINE foldMapOf #-} #if __GLASGOW_HASKELL__ >= 708 ( #. ) :: Coercible c b => (b -> c) -> (a -> b) -> (a -> c) ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b #else ( #. ) :: (b -> c) -> (a -> b) -> (a -> c) ( #. ) _ = unsafeCoerce #endif {-# INLINE ( #. ) #-} infixr 9 #. unliftio-0.2.25.0/src/UnliftIO/Foreign.hs0000644000000000000000000010023514370231514016163 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.25.0/src/UnliftIO/Internals/Async.hs0000644000000000000000000011056714370231514017617 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 -- [this blog post](https://www.fpcomplete.com/blog/transformations-on-applicative-concurrent-computations/). -- This is provided as a separate type to @Concurrently@ as it has a slightly different API. -- -- Use the 'conc' function to construct values of type 'Conc', and -- 'runConc' to execute the composed actions. You can use the -- @Applicative@ instance to run different actions and wait for all of -- them to complete, or the @Alternative@ instance to wait for the -- first thread to complete. -- -- In the event of a runtime exception thrown by any of the children -- threads, or an asynchronous exception received in the parent -- thread, all threads will be killed with an 'A.AsyncCancelled' -- exception and the original exception rethrown. If multiple -- exceptions are generated by different threads, there are no -- guarantees on which exception will end up getting rethrown. -- -- For many common use cases, you may prefer using helper functions in -- this module like 'mapConcurrently'. -- -- There are some intentional differences in behavior to -- @Concurrently@: -- -- * Children threads are always launched in an unmasked state, not -- the inherited state of the parent thread. -- -- Note that it is a programmer error to use the @Alternative@ -- instance in such a way that there are no alternatives to an empty, -- e.g. @runConc (empty <|> empty)@. In such a case, a 'ConcException' -- will be thrown. If there was an @Alternative@ in the standard -- libraries without @empty@, this library would use it instead. -- -- @since 0.2.9.0 data Conc m a where Action :: m a -> Conc m a Apply :: Conc m (v -> a) -> Conc m v -> Conc m a LiftA2 :: (x -> y -> a) -> Conc m x -> Conc m y -> Conc m a -- Just an optimization to avoid spawning extra threads Pure :: a -> Conc m a -- I thought there would be an optimization available from having a -- data constructor that explicit doesn't care about the first -- result. Turns out it doesn't help much: we still need to keep a -- TMVar below to know when the thread completes. -- -- Then :: Conc m a -> Conc m b -> Conc m b Alt :: Conc m a -> Conc m a -> Conc m a Empty :: Conc m a deriving instance Functor m => Functor (Conc m) -- fmap f (Action routine) = Action (fmap f routine) -- fmap f (LiftA2 g x y) = LiftA2 (fmap f g) x y -- fmap f (Pure val) = Pure (f val) -- fmap f (Alt a b) = Alt (fmap f a) (fmap f b) -- fmap f Empty = Empty -- | Construct a value of type 'Conc' from an action. Compose these -- values using the typeclass instances (most commonly 'Applicative' -- and 'Alternative') and then run with 'runConc'. -- -- @since 0.2.9.0 conc :: m a -> Conc m a conc = Action {-# INLINE conc #-} -- | Run a 'Conc' value on multiple threads. -- -- @since 0.2.9.0 runConc :: MonadUnliftIO m => Conc m a -> m a runConc = flatten >=> (liftIO . runFlat) {-# INLINE runConc #-} -- | @since 0.2.9.0 instance MonadUnliftIO m => Applicative (Conc m) where pure = Pure {-# INLINE pure #-} -- | Following is an example of how an 'Applicative' expands to a Tree -- -- @@@ -- downloadA :: IO String -- downloadB :: IO String -- -- (f <$> conc downloadA <*> conc downloadB <*> pure 123) -- -- (((f <$> a) <*> b) <*> c)) -- (1) (2) (3) -- -- (1) -- Action (fmap f downloadA) -- (2) -- Apply (Action (fmap f downloadA)) (Action downloadB) -- (3) -- Apply (Apply (Action (fmap f downloadA)) (Action downloadB)) -- (Pure 123) -- @@@ -- (<*>) = Apply {-# INLINE (<*>) #-} -- See comment above on Then -- (*>) = Then #if MIN_VERSION_base(4,11,0) liftA2 = LiftA2 {-# INLINE liftA2 #-} #endif a *> b = LiftA2 (\_ x -> x) a b {-# INLINE (*>) #-} -- | @since 0.2.9.0 instance MonadUnliftIO m => Alternative (Conc m) where empty = Empty -- this is so ugly, we don't actually want to provide it! {-# INLINE empty #-} (<|>) = Alt {-# INLINE (<|>) #-} #if MIN_VERSION_base(4, 11, 0) -- | @since 0.2.9.0 instance (MonadUnliftIO m, Semigroup a) => Semigroup (Conc m a) where (<>) = liftA2 (<>) {-# INLINE (<>) #-} #endif -- | @since 0.2.9.0 instance (Monoid a, MonadUnliftIO m) => Monoid (Conc m a) where mempty = pure mempty {-# INLINE mempty #-} 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.25.0/src/UnliftIO/IO.hs0000644000000000000000000001065414370231514015106 0ustar0000000000000000-- | Unlifted "System.IO". -- -- @since 0.1.0.0 module UnliftIO.IO ( IOMode (..) , Handle , IO.stdin , IO.stdout , IO.stderr , withFile , withBinaryFile , openFile , 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.openFile' -- -- @since 0.2.20 openFile :: MonadIO m => FilePath -> IOMode -> m Handle openFile fp = liftIO . IO.openFile fp -- | 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.25.0/src/UnliftIO/IO/File.hs0000644000000000000000000002601214370231514015760 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| == Rationale This module offers functions to handle files that offer better durability and/or atomicity. == When to use functions in this module? Given the usage of this functions comes at a cost in performance, it is important to consider what are the use cases that are ideal for each of the functions. === Not Durable and not Atomic For this use case, you want to use the regular functions: * 'withBinaryFile' * 'writeBinaryFile' The regular use case for this scenario happens when your program is dealing with outputs that are never going to be consumed again by your program. For example, imagine you have a program that generates sales reports for the last month, this is a report that can be generated quickly; you don't really care if the output file gets corrupted or lost at one particular execution of your program given that is cheap to execute the data export program a second time. In other words, your program doesn't /rely/ on the data contained in this file in order to work. === Atomic but not Durable Imagine a scenario where your program builds a temporary file that serves as an intermediate step to a bigger task, like Object files (@.o@) in a compilation process. The program will use an existing @.o@ file if it is present, or it will build one from scratch if it is not. The file is not really required, but if it is present, it *must* be valid and consistent. In this situation, you care about atomicity, but not durability. You can use the functions for such scenario: * 'withBinaryFileAtomic' * 'writeBinaryFileAtomic' __Note__ - there is a peculiar difference between regular file writing functionality and the one that is done atomically. Even if the orignal file is removed while it is being modified, because of atomicity, it will be restored with all modifications, if any. The reason for this is because a copy of the file was made prior to modifications and at the end the existing is atomically replaced. An important consequence of this fact is that whenever the folder containing the file which is being modified is removed, all bets are off and all atomic functions will result in an exception. === Durable but not Atomic For this use case, you want to use the functions: * 'withBinaryFileDurable' * 'writeBinaryFileDurable' The regular use case for this scenario happens when your program deals with file modifications that must be guaranteed to be durable, but you don't care that changes are consistent. If you use this function, more than likely your program is ensuring consistency guarantees through other means, for example, SQLite uses the Write Ahead Log (WAL) algorithm to ensure changes are atomic at an application level. === Durable and Atomic For this use case, you can use the functions: * 'withBinaryFileDurableAtomic' * 'writeBinaryFileDurableAtomic' The regular use case for this scenario happens when you want to ensure that after a program is executed, the modifications done to a file are guaranteed to be saved, and also that changes are rolled-back in case there is a failure (e.g. hard reboot, shutdown, etc). -} module UnliftIO.IO.File ( writeBinaryFile , writeBinaryFileAtomic , writeBinaryFileDurable , writeBinaryFileDurableAtomic , withBinaryFile , withBinaryFileAtomic , withBinaryFileDurable , withBinaryFileDurableAtomic , ensureFileDurable ) where import Data.ByteString as B (ByteString, writeFile) import Control.Monad.IO.Unlift import UnliftIO.IO (Handle, IOMode(..), withBinaryFile) #if WINDOWS ensureFileDurable = (`seq` pure ()) writeBinaryFileDurable = writeBinaryFile writeBinaryFileDurableAtomic = writeBinaryFile writeBinaryFileAtomic = writeBinaryFile withBinaryFileDurable = withBinaryFile withBinaryFileDurableAtomic = withBinaryFile withBinaryFileAtomic = withBinaryFile #else import qualified Data.ByteString as B (hPut) import qualified UnliftIO.IO.File.Posix as Posix ensureFileDurable = Posix.ensureFileDurable writeBinaryFileDurable fp bytes = liftIO $ withBinaryFileDurable fp WriteMode (`B.hPut` bytes) writeBinaryFileDurableAtomic fp bytes = liftIO $ withBinaryFileDurableAtomic fp WriteMode (`B.hPut` bytes) writeBinaryFileAtomic fp bytes = liftIO $ withBinaryFileAtomic fp WriteMode (`B.hPut` bytes) withBinaryFileDurable = Posix.withBinaryFileDurable withBinaryFileDurableAtomic = Posix.withBinaryFileDurableAtomic withBinaryFileAtomic = Posix.withBinaryFileAtomic #endif -- | After a file is closed, this function opens it again and executes @fsync()@ -- internally on both the file and the directory that contains it. Note that this function -- is intended to work around the non-durability of existing file APIs, as opposed to -- being necessary for the API functions provided in this module. -- -- [The effectiveness of calling this function is -- debatable](https://stackoverflow.com/questions/37288453/calling-fsync2-after-close2/50158433#50158433), -- as it relies on internal implementation details at the Kernel level that might -- change. We argue that, despite this fact, calling this function may bring benefits in -- terms of durability. -- -- This function does not provide the same guarantee as if you would open and modify a -- file using `withBinaryFileDurable` or `writeBinaryFileDurable`, since they ensure that -- the @fsync()@ is called before the file is closed, so if possible use those instead. -- -- === Cross-Platform support -- -- This function is a noop on Windows platforms. -- -- @since 0.2.12 ensureFileDurable :: MonadIO m => FilePath -> m () -- Implementation is at the top of the module -- | Similar to 'writeBinaryFile', but it also ensures that changes executed to the file -- are guaranteed to be durable. It internally uses @fsync()@ and makes sure it -- synchronizes the file on disk. -- -- === Cross-Platform support -- -- This function behaves the same as 'RIO.writeBinaryFile' on Windows platforms. -- -- @since 0.2.12 writeBinaryFileDurable :: MonadIO m => FilePath -> ByteString -> m () -- Implementation is at the top of the module -- | Similar to 'writeBinaryFile', but it also guarantes that changes executed to the file -- are durable, also, in case of failure, the modified file is never going to get -- corrupted. It internally uses @fsync()@ and makes sure it synchronizes the file on -- disk. -- -- === Cross-Platform support -- -- This function behaves the same as 'writeBinaryFile' on Windows platforms. -- -- @since 0.2.12 writeBinaryFileDurableAtomic :: MonadIO m => FilePath -> ByteString -> m () -- Implementation is at the top of the module -- | Same as 'writeBinaryFileDurableAtomic', except it does not guarantee durability. -- -- === Cross-Platform support -- -- This function behaves the same as 'writeBinaryFile' on Windows platforms. -- -- @since 0.2.12 writeBinaryFileAtomic :: MonadIO m => FilePath -> ByteString -> m () -- Implementation is at the top of the module -- | Opens a file with the following guarantees: -- -- * It successfully closes the file in case of an asynchronous exception -- -- * It reliably saves the file in the correct directory; including edge case situations -- like a different device being mounted to the current directory, or the current -- directory being renamed to some other name while the file is being used. -- -- * It ensures durability by executing an @fsync()@ call before closing the file handle -- -- === Cross-Platform support -- -- This function behaves the same as 'System.IO.withBinaryFile' on Windows platforms. -- -- @since 0.2.12 withBinaryFileDurable :: MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r -- Implementation is at the top of the module -- | Opens a file with the following guarantees: -- -- * It successfully closes the file in case of an asynchronous exception -- -- * It reliably saves the file in the correct directory; including edge case situations -- like a different device being mounted to the current directory, or the current -- directory being renamed to some other name while the file is being used. -- -- * It ensures durability by executing an @fsync()@ call before closing the file handle -- -- * It keeps all changes in a temporary file, and after it is closed it atomically moves -- the temporary file to the original filepath, in case of catastrophic failure, the -- original file stays unaffected. -- -- If you do not need durability but only atomicity, use `withBinaryFileAtomic` instead, -- which is faster as it does not perform @fsync()@. -- -- __Important__ - Make sure not to close the `Handle`, it will be closed for you, -- otherwise it will result in @invalid argument (Bad file descriptor)@ exception. -- -- === Performance Considerations -- -- When using a writable but non-truncating 'IOMode' (i.e. 'ReadWriteMode' and -- 'AppendMode'), this function performs a copy operation of the specified input file to -- guarantee the original file is intact in case of a catastrophic failure (no partial -- writes). This approach may be prohibitive in scenarios where the input file is expected -- to be large in size. -- -- === Cross-Platform support -- -- This function behaves the same as 'System.IO.withBinaryFile' on Windows platforms. -- -- @since 0.2.12 withBinaryFileDurableAtomic :: MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r -- Implementation is at the top of the module -- | Perform an action on a new or existing file at the destination file path. If -- previously the file existed at the supplied file path then: -- -- * in case of `WriteMode` it will be overwritten -- -- * upon `ReadWriteMode` or `AppendMode` files contents will be copied over into a -- temporary file, thus making sure no corruption can happen to an existing file upon any -- failures, even catastrophic one, yet its contents are availble for modification. -- -- * There is nothing atomic about `ReadMode`, so no special treatment there. -- -- It is similar to `withBinaryFileDurableAtomic`, but without the durability part. It -- means that all modification can still disappear after it has been succesfully written -- due to some extreme event like an abrupt power loss, but the contents will not be -- corrupted in case when the file write did not end successfully. -- -- The same performance caveats apply as for `withBinaryFileDurableAtomic` due to making a -- copy of the content of existing files during non-truncating writes. -- -- __Important__ - Do not close the handle, otherwise it will result in @invalid argument -- (Bad file descriptor)@ exception -- -- __Note__ - on Linux operating system and only with supported file systems an anonymous -- temporary file will be used while working on the file (see @O_TMPFILE@ in @man -- openat@). In case when such feature is not available or not supported a temporary file -- ".target-file-nameXXX.ext.tmp", where XXX is some random number, will be created -- alongside the target file in the same directory -- -- @since 0.2.12 withBinaryFileAtomic :: MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r -- Implementation is at the top of the module -- | Lifted version of `B.writeFile` -- -- @since 0.2.12 writeBinaryFile :: MonadIO m => FilePath -> ByteString -> m () writeBinaryFile fp = liftIO . B.writeFile fp unliftio-0.2.25.0/src/UnliftIO/IORef.hs0000644000000000000000000000340014370231514015532 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.25.0/src/UnliftIO/Memoize.hs0000644000000000000000000000464214370231514016204 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.25.0/src/UnliftIO/MVar.hs0000644000000000000000000000612014370231514015435 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.25.0/src/UnliftIO/Process.hs0000644000000000000000000001223014370231514016205 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.25.0/src/UnliftIO/QSem.hs0000644000000000000000000000201414370231514015433 0ustar0000000000000000-- | Unlifted "Control.Concurrent.QSem". -- -- @since 0.2.14 module UnliftIO.QSem ( QSem , newQSem , waitQSem , signalQSem , withQSem ) where import Control.Concurrent.QSem (QSem) import Control.Monad.IO.Unlift import UnliftIO.Exception import qualified Control.Concurrent.QSem as Q -- | Lifted 'Q.newQSem'. -- -- @since 0.2.14 newQSem :: MonadIO m => Int -> m QSem newQSem = liftIO . Q.newQSem -- | Lifted 'Q.waitQSem'. -- -- @since 0.2.14 waitQSem :: MonadIO m => QSem -> m () waitQSem = liftIO . Q.waitQSem -- | Lifted 'Q.signalQSem'. -- -- @since 0.2.14 signalQSem :: MonadIO m => QSem -> m () signalQSem = liftIO . Q.signalQSem -- | 'withQSem' is an exception-safe wrapper for performing the -- provided operation while holding a unit of value from the semaphore. -- It ensures the semaphore cannot be leaked if there are exceptions. -- -- @since 0.2.14 {-# INLINE withQSem #-} withQSem :: MonadUnliftIO m => QSem -> m a -> m a withQSem x io = withRunInIO $ \run -> bracket_ (waitQSem x) (signalQSem x) (run io) unliftio-0.2.25.0/src/UnliftIO/QSemN.hs0000644000000000000000000000211714370231514015555 0ustar0000000000000000-- | Unlifted "Control.Concurrent.QSemN". -- -- @since 0.2.14 module UnliftIO.QSemN ( QSemN , newQSemN , waitQSemN , signalQSemN , withQSemN ) where import Control.Concurrent.QSemN (QSemN) import Control.Monad.IO.Unlift import UnliftIO.Exception import qualified Control.Concurrent.QSemN as Q -- | Lifted 'Q.newQSemN'. -- -- @since 0.2.14 newQSemN :: MonadIO m => Int -> m QSemN newQSemN = liftIO . Q.newQSemN -- | Lifted 'Q.waitQSemN'. -- -- @since 0.2.14 waitQSemN :: MonadIO m => QSemN -> Int -> m () waitQSemN x = liftIO . Q.waitQSemN x -- | Lifted 'Q.signalQSemN'. -- -- @since 0.2.14 signalQSemN :: MonadIO m => QSemN -> Int -> m () signalQSemN x = liftIO . Q.signalQSemN x -- | 'withQSemN' is an exception-safe wrapper for performing the -- provided operation while holding N unit of value from the semaphore. -- It ensures the semaphore cannot be leaked if there are exceptions. -- -- @since 0.2.14 {-# INLINE withQSemN #-} withQSemN :: MonadUnliftIO m => QSemN -> Int -> m a -> m a withQSemN x n io = withRunInIO $ \run -> bracket_ (waitQSemN x n) (signalQSemN x n) (run io) unliftio-0.2.25.0/src/UnliftIO/STM.hs0000644000000000000000000000770414377342534015260 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Lifted version of "Control.Concurrent.STM" -- -- @since 0.2.1.0 module UnliftIO.STM ( -- * Core STM.STM , atomically , retrySTM , checkSTM , STM.orElse -- * TVar , STM.TVar , newTVarIO , readTVarIO , STM.newTVar , STM.readTVar , STM.writeTVar , STM.modifyTVar , STM.modifyTVar' , STM.stateTVar , STM.swapTVar , registerDelay , mkWeakTVar -- * TMVar , STM.TMVar , STM.newTMVar , STM.newEmptyTMVar , newTMVarIO , newEmptyTMVarIO , STM.takeTMVar , STM.putTMVar , STM.readTMVar #if MIN_VERSION_stm(2, 5, 1) , STM.writeTMVar #endif , 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.flushTBQueue , STM.peekTBQueue , STM.tryPeekTBQueue , STM.writeTBQueue , STM.unGetTBQueue , STM.lengthTBQueue , 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.25.0/src/UnliftIO/Temporary.hs0000644000000000000000000001522414370231514016557 0ustar0000000000000000{-# LANGUAgE CPP #-} -- | Temporary file and directory support. -- -- Strongly inspired by\/stolen from the package. -- -- @since 0.1.0.0 -- -- === __Copyright notice:__ -- -- The following copyright notice is taken from -- and is reproduced here as part of license terms of that package, of which this module is -- a derivate work. -- -- @ -- Copyright -- (c) 2003-2006, Isaac Jones -- (c) 2005-2009, Duncan Coutts -- (c) 2008, Maximilian Bolingbroke -- ... and other contributors -- -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without modification, are permitted -- provided that the following conditions are met: -- -- * Redistributions of source code must retain the above copyright notice, this list of -- conditions and the following disclaimer. -- * Redistributions in binary form must reproduce the above copyright notice, this list of -- conditions and the following disclaimer in the documentation and/or other materials -- provided with the distribution. -- * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to -- endorse or promote products derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -- IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- @ module UnliftIO.Temporary ( withSystemTempFile , withSystemTempDirectory , 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.25.0/src/UnliftIO/Timeout.hs0000644000000000000000000000051114370231514016214 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.25.0/src/UnliftIO/IO/File/Posix.hs0000644000000000000000000005554314370231514017075 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module UnliftIO.IO.File.Posix ( withBinaryFileDurable , withBinaryFileDurableAtomic , withBinaryFileAtomic , ensureFileDurable ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad (forM_, guard, unless, void, when) import Control.Monad.IO.Unlift import Data.Bits (Bits, (.|.)) import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Data.Typeable (cast) import Foreign (allocaBytes) import Foreign.C (CInt(..), throwErrnoIfMinus1, throwErrnoIfMinus1Retry, throwErrnoIfMinus1Retry_) import GHC.IO.Device (IODeviceType(RegularFile)) import qualified GHC.IO.Device as Device import GHC.IO.Exception (IOErrorType(UnsupportedOperation)) import qualified GHC.IO.FD as FD import qualified GHC.IO.Handle.FD as HandleFD import qualified GHC.IO.Handle.Types as HandleFD (Handle(..), Handle__(..)) import System.Directory (removeFile) import System.FilePath (takeDirectory, takeFileName) import System.IO (Handle, IOMode(..), SeekMode(..), hGetBuf, hPutBuf, openBinaryTempFile) import System.IO.Error (ioeGetErrorType, isAlreadyExistsError, isDoesNotExistError) import qualified System.Posix.Files as Posix import System.Posix.Internals (CFilePath, c_close, c_safe_open, withFilePath) import System.Posix.Types (CMode(..), Fd(..), FileMode) import UnliftIO.Exception import UnliftIO.IO import UnliftIO.MVar -- NOTE: System.Posix.Internal doesn't re-export this constants so we have to -- recreate-them here newtype CFlag = CFlag CInt deriving (Eq, Show, Bits) foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CFlag foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CFlag foreign import ccall unsafe "HsBase.h __hscore_o_rdwr" o_RDWR :: CFlag foreign import ccall unsafe "HsBase.h __hscore_o_append" o_APPEND :: CFlag foreign import ccall unsafe "HsBase.h __hscore_o_creat" o_CREAT :: CFlag foreign import ccall unsafe "HsBase.h __hscore_o_noctty" o_NOCTTY :: CFlag -- After here, we have our own imports -- On non-Linux operating systems that do not support `O_TMPFILE` the value of -- `o_TMPFILE` will be 0, which is then used to fallback onto a different -- implementation of temporary files. foreign import ccall unsafe "file-posix.c unliftio_o_tmpfile" o_TMPFILE :: CFlag -- | Whenever Operating System does not support @O_TMPFILE@ flag and anonymous -- temporary files then `o_TMPFILE` flag will be set to @0@ o_TMPFILE_not_supported :: CFlag o_TMPFILE_not_supported = CFlag 0 newtype CAt = CAt { unCAt :: CInt } deriving (Eq, Show, Bits) foreign import ccall unsafe "file-posix.c unliftio_at_fdcwd" at_FDCWD :: CAt foreign import ccall unsafe "file-posix.c unliftio_at_symlink_follow" at_SYMLINK_FOLLOW :: CAt foreign import ccall unsafe "file-posix.c unliftio_s_irusr" s_IRUSR :: CMode foreign import ccall unsafe "file-posix.c unliftio_s_iwusr" s_IWUSR :: CMode c_open :: CFilePath -> CFlag -> CMode -> IO CInt c_open fp (CFlag flags) = c_safe_open fp flags foreign import ccall safe "fcntl.h openat" c_safe_openat :: CInt -> CFilePath -> CInt -> CMode -> IO CInt c_openat :: DirFd -> CFilePath -> CFlag -> CMode -> IO CInt c_openat (DirFd (Fd fd)) fp (CFlag flags) = c_safe_openat fd fp flags foreign import ccall safe "fcntl.h renameat" c_safe_renameat :: CInt -> CFilePath -> CInt -> CFilePath -> IO CInt c_renameat :: DirFd -> CFilePath -> DirFd -> CFilePath -> IO CInt c_renameat (DirFd (Fd fdFrom)) cFpFrom (DirFd (Fd fdTo)) cFpTo = c_safe_renameat fdFrom cFpFrom fdTo cFpTo foreign import ccall safe "unistd.h fsync" c_safe_fsync :: CInt -> IO CInt c_fsync :: Fd -> IO CInt c_fsync (Fd fd) = c_safe_fsync fd foreign import ccall safe "unistd.h linkat" c_safe_linkat :: CInt -> CFilePath -> CInt -> CFilePath -> CInt -> IO CInt c_linkat :: CAt -> CFilePath -> Either DirFd CAt -> CFilePath -> CAt -> IO CInt c_linkat cat oldPath eNewDir newPath (CAt flags) = c_safe_linkat (unCAt cat) oldPath newDir newPath flags where unFd (Fd fd) = fd newDir = either (unFd . unDirFd) unCAt eNewDir std_flags, output_flags, read_flags, write_flags, rw_flags, append_flags :: CFlag std_flags = o_NOCTTY output_flags = std_flags .|. o_CREAT read_flags = std_flags .|. o_RDONLY write_flags = output_flags .|. o_WRONLY rw_flags = output_flags .|. o_RDWR append_flags = write_flags .|. o_APPEND ioModeToFlags :: IOMode -> CFlag ioModeToFlags iomode = case iomode of ReadMode -> read_flags WriteMode -> write_flags ReadWriteMode -> rw_flags AppendMode -> append_flags newtype DirFd = DirFd { unDirFd :: Fd } -- | Returns a low-level file descriptor for a directory path. This function -- exists given the fact that 'openFile' does not work with directories. -- -- If you use this function, make sure you are working on a masked state, -- otherwise async exceptions may leave file descriptors open. openDir :: MonadIO m => FilePath -> m Fd openDir fp -- TODO: Investigate what is the situation with Windows FS in regards to non_blocking -- NOTE: File operations _do not support_ non_blocking on various kernels, more -- info can be found here: https://ghc.haskell.org/trac/ghc/ticket/15153 = liftIO $ withFilePath fp $ \cFp -> Fd <$> throwErrnoIfMinus1Retry "openDir" (c_open cFp (ioModeToFlags ReadMode) 0o660) -- | Closes a 'Fd' that points to a Directory. closeDirectory :: MonadIO m => DirFd -> m () closeDirectory (DirFd (Fd dirFd)) = liftIO $ throwErrnoIfMinus1Retry_ "closeDirectory" $ c_close dirFd -- | Executes the low-level C function fsync on a C file descriptor fsyncFileDescriptor :: MonadIO m => String -- ^ Meta-description for error messages -> Fd -- ^ C File Descriptor -> m () fsyncFileDescriptor name fd = liftIO $ void $ throwErrnoIfMinus1 ("fsync - " ++ name) $ c_fsync fd -- | Call @fsync@ on the file handle. Accepts an arbitary string for error reporting. fsyncFileHandle :: String -> Handle -> IO () fsyncFileHandle fname hdl = withHandleFd hdl (fsyncFileDescriptor (fname ++ "/File")) -- | Call @fsync@ on the opened directory file descriptor. Accepts an arbitary -- string for error reporting. fsyncDirectoryFd :: String -> DirFd -> IO () fsyncDirectoryFd fname = fsyncFileDescriptor (fname ++ "/Directory") . unDirFd -- | Opens a file from a directory, using this function in favour of a regular -- 'openFile' guarantees that any file modifications are kept in the same -- directory where the file was opened. An edge case scenario is a mount -- happening in the directory where the file was opened while your program is -- running. -- -- If you use this function, make sure you are working on an masked state, -- otherwise async exceptions may leave file descriptors open. -- openFileFromDir :: MonadIO m => DirFd -> FilePath -> IOMode -> m Handle openFileFromDir dirFd filePath@(takeFileName -> fileName) iomode = liftIO $ withFilePath fileName $ \cFileName -> bracketOnError (do fileFd <- throwErrnoIfMinus1Retry "openFileFromDir" $ c_openat dirFd cFileName (ioModeToFlags iomode) 0o666 {- Can open directory with read only -} FD.mkFD fileFd iomode Nothing {- no stat -} False {- not a socket -} False {- non_blocking -} `onException` c_close fileFd) (liftIO . Device.close . fst) (\(fD, fd_type) -- we want to truncate() if this is an open in WriteMode, but only if the -- target is a RegularFile. ftruncate() fails on special files like -- /dev/null. -> do when (iomode == WriteMode && fd_type == RegularFile) $ Device.setSize fD 0 HandleFD.mkHandleFromFD fD fd_type filePath iomode False Nothing) -- | Similar to `openFileFromDir`, but will open an anonymous (nameless) -- temporary file in the supplied directory openAnonymousTempFileFromDir :: MonadIO m => Maybe DirFd -- ^ If a file descriptor is given for the directory where the target file is/will be -- located in, then it will be used for opening an anonymous file. Otherwise -- anonymous will be opened unattached to any file path. -> FilePath -- ^ File path of the target file that we are working on. -> IOMode -> m Handle openAnonymousTempFileFromDir mDirFd filePath iomode = liftIO $ case mDirFd of Just dirFd -> withFilePath "." (openAnonymousWith . c_openat dirFd) Nothing -> withFilePath (takeDirectory filePath) (openAnonymousWith . c_open) where fdName = "openAnonymousTempFileFromDir - " ++ filePath ioModeToTmpFlags :: IOMode -> CFlag ioModeToTmpFlags = \case ReadMode -> o_RDWR -- It is an error to create a O_TMPFILE with O_RDONLY ReadWriteMode -> o_RDWR _ -> o_WRONLY openAnonymousWith fopen = bracketOnError (do fileFd <- throwErrnoIfMinus1Retry "openAnonymousTempFileFromDir" $ fopen (o_TMPFILE .|. ioModeToTmpFlags iomode) (s_IRUSR .|. s_IWUSR) FD.mkFD fileFd iomode Nothing {- no stat -} False {- not a socket -} False {- non_blocking -} `onException` c_close fileFd) (liftIO . Device.close . fst) (\(fD, fd_type) -> HandleFD.mkHandleFromFD fD fd_type fdName iomode False Nothing) atomicDurableTempFileRename :: DirFd -> Maybe FileMode -> Handle -> Maybe FilePath -> FilePath -> IO () atomicDurableTempFileRename dirFd mFileMode tmpFileHandle mTmpFilePath filePath = do fsyncFileHandle "atomicDurableTempFileCreate" tmpFileHandle -- at this point we know that the content has been persisted to the storage it -- is safe to do the atomic move/replace let eTmpFile = maybe (Left tmpFileHandle) Right mTmpFilePath atomicTempFileRename (Just dirFd) mFileMode eTmpFile filePath -- Important to close the handle, so the we can fsync the directory hClose tmpFileHandle -- file path is updated, now we can fsync the directory fsyncDirectoryFd "atomicDurableTempFileCreate" dirFd -- | There will be an attempt to atomically convert an invisible temporary file -- into a target file at the supplied file path. In case when there is already a -- file at that file path, a new visible temporary file will be created in the -- same folder and then atomically renamed into the target file path, replacing -- any existing file. This is necessary since `c_safe_linkat` cannot replace -- files atomically and we have to fall back onto `c_safe_renameat`. This should -- not be a problem in practice, since lifetime of such visible file is -- extremely short and it will be cleaned up regardless of the outcome of the -- rename. -- -- It is important to note, that whenever a file descriptor for the containing -- directory is supplied, renaming and linking will be done in its context, -- thus allowing to do proper fsyncing if durability is necessary. -- -- __NOTE__: this function will work only on Linux. -- atomicTempFileCreate :: Maybe DirFd -- ^ Possible handle for the directory where the target file is located. Which -- means that the file is already in that directory, just without a name. In other -- words it was opened before with `openAnonymousTempFileFromDir` -> Maybe FileMode -- ^ If file permissions are supplied they will be set on the new file prior -- to atomic rename. -> Handle -- ^ Handle to the anonymous temporary file created with `c_openat` and -- `o_TMPFILE` -> FilePath -- ^ File path for the target file. -> IO () atomicTempFileCreate mDirFd mFileMode tmpFileHandle filePath = withHandleFd tmpFileHandle $ \fd@(Fd cFd) -> withFilePath ("/proc/self/fd/" ++ show cFd) $ \cFromFilePath -> withFilePath filePathName $ \cToFilePath -> do let fileMode = fromMaybe Posix.stdFileMode mFileMode -- work around for the glibc bug: https://sourceware.org/bugzilla/show_bug.cgi?id=17523 Posix.setFdMode fd fileMode let safeLink which to = throwErrnoIfMinus1Retry_ ("atomicFileCreate - c_safe_linkat - " ++ which) $ -- see `man linkat` and `man openat` for more info c_linkat at_FDCWD cFromFilePath cDirFd to at_SYMLINK_FOLLOW eExc <- tryJust (guard . isAlreadyExistsError) $ safeLink "anonymous" cToFilePath case eExc of Right () -> pure () Left () -> withBinaryTempFileFor filePath $ \visTmpFileName visTmpFileHandle -> do hClose visTmpFileHandle removeFile visTmpFileName case mDirFd of Nothing -> do withFilePath visTmpFileName (safeLink "visible") Posix.rename visTmpFileName filePath Just dirFd -> withFilePath (takeFileName visTmpFileName) $ \cVisTmpFile -> do safeLink "visible" cVisTmpFile throwErrnoIfMinus1Retry_ "atomicFileCreate - c_safe_renameat" $ c_renameat dirFd cVisTmpFile dirFd cToFilePath where (cDirFd, filePathName) = case mDirFd of Nothing -> (Right at_FDCWD, filePath) Just dirFd -> (Left dirFd, takeFileName filePath) atomicTempFileRename :: Maybe DirFd -- ^ Possible handle for the directory where the target file is located. -> Maybe FileMode -- ^ If file permissions are supplied they will be set on the new file prior -- to atomic rename. -> Either Handle FilePath -- ^ Temporary file. If a handle is supplied, it means it was opened with -- @O_TMPFILE@ flag and thus we are on the Linux OS and can safely call -- `atomicTempFileCreate` -> FilePath -- ^ File path for the target file. Whenever `DirFd` is supplied, it must be -- the containgin directory fo this file, but that invariant is not enforced -- within this function. -> IO () atomicTempFileRename mDirFd mFileMode eTmpFile filePath = case eTmpFile of Left tmpFileHandle -> atomicTempFileCreate mDirFd mFileMode tmpFileHandle filePath Right tmpFilePath -> do forM_ mFileMode $ \fileMode -> Posix.setFileMode tmpFilePath fileMode case mDirFd of Nothing -> Posix.rename tmpFilePath filePath Just dirFd -> withFilePath (takeFileName filePath) $ \cToFilePath -> withFilePath (takeFileName tmpFilePath) $ \cTmpFilePath -> throwErrnoIfMinus1Retry_ "atomicFileCreate - c_safe_renameat" $ c_renameat dirFd cTmpFilePath dirFd cToFilePath withDirectory :: MonadUnliftIO m => FilePath -> (DirFd -> m a) -> m a withDirectory dirPath = bracket (DirFd <$> openDir dirPath) closeDirectory withFileInDirectory :: MonadUnliftIO m => DirFd -> FilePath -> IOMode -> (Handle -> m a) -> m a withFileInDirectory dirFd filePath iomode = bracket (openFileFromDir dirFd filePath iomode) hClose -- | Create a temporary file for a matching possibly exiting target file that -- will be replaced in the future. Temporary file is meant to be renamed -- afterwards, thus it is only deleted upon error. -- -- __Important__: Temporary file is not removed and file handle is not closed if -- there was no exception thrown by the supplied action. withBinaryTempFileFor :: MonadUnliftIO m => FilePath -- ^ "For" file. It may exist or may not. -> (FilePath -> Handle -> m a) -> m a withBinaryTempFileFor filePath action = bracketOnError (liftIO (openBinaryTempFile dirPath tmpFileName)) (\(tmpFilePath, tmpFileHandle) -> hClose tmpFileHandle >> liftIO (tryIO (removeFile tmpFilePath))) (uncurry action) where dirPath = takeDirectory filePath fileName = takeFileName filePath tmpFileName = "." ++ fileName ++ ".tmp" -- | Returns `Nothing` if anonymous temporary file is not supported by the OS or -- the underlying file system can't handle that feature. withAnonymousBinaryTempFileFor :: MonadUnliftIO m => Maybe DirFd -- ^ It is possible to open the temporary file in the context of a directory, -- in such case supply its file descriptor. i.e. @openat@ will be used instead -- of @open@ -> FilePath -- ^ "For" file. The file may exist or may not. -> IOMode -> (Handle -> m a) -> m (Maybe a) withAnonymousBinaryTempFileFor mDirFd filePath iomode action | o_TMPFILE == o_TMPFILE_not_supported = pure Nothing | otherwise = trySupported $ bracket (openAnonymousTempFileFromDir mDirFd filePath iomode) hClose action where trySupported m = tryIO m >>= \case Right res -> pure $ Just res Left exc | ioeGetErrorType exc == UnsupportedOperation -> pure Nothing Left exc -> throwIO exc withNonAnonymousBinaryTempFileFor :: MonadUnliftIO m => Maybe DirFd -- ^ It is possible to open the temporary file in the context of a directory, -- in such case supply its file descriptor. i.e. @openat@ will be used instead -- of @open@ -> FilePath -- ^ "For" file. The file may exist or may not. -> IOMode -> (FilePath -> Handle -> m a) -> m a withNonAnonymousBinaryTempFileFor mDirFd filePath iomode action = withBinaryTempFileFor filePath $ \tmpFilePath tmpFileHandle -> do hClose tmpFileHandle case mDirFd of Nothing -> withBinaryFile tmpFilePath iomode (action tmpFilePath) Just dirFd -> withFileInDirectory dirFd tmpFilePath iomode (action tmpFilePath) -- | Copy the contents of the file into the handle, but only if that file exists -- and either `ReadWriteMode` or `AppendMode` is specified. Returned are the -- file permissions of the original file so it can be set later when original -- gets overwritten atomically. copyFileHandle :: MonadUnliftIO f => IOMode -> FilePath -> Handle -> f (Maybe FileMode) copyFileHandle iomode fromFilePath toHandle = either (const Nothing) Just <$> tryJust (guard . isDoesNotExistError) (do fileStatus <- liftIO $ Posix.getFileStatus fromFilePath -- Whenever we are not overwriting an existing file, we also need a -- copy of the file's contents unless (iomode == WriteMode) $ do withBinaryFile fromFilePath ReadMode (`copyHandleData` toHandle) unless (iomode == AppendMode) $ hSeek toHandle AbsoluteSeek 0 -- Get the copy of source file permissions, but only whenever it exists pure $ Posix.fileMode fileStatus) -- This is a copy of the internal function from `directory-1.3.3.2`. It became -- available only in directory-1.3.3.0 and is still internal, hence the -- duplication. copyHandleData :: MonadIO m => Handle -> Handle -> m () copyHandleData hFrom hTo = liftIO $ allocaBytes bufferSize go where bufferSize = 131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h) go buffer = do count <- hGetBuf hFrom buffer bufferSize when (count > 0) $ do hPutBuf hTo buffer count go buffer -- | Thread safe access to the file descriptor in the file handle withHandleFd :: Handle -> (Fd -> IO a) -> IO a withHandleFd h cb = case h of HandleFD.FileHandle _ mv -> withMVar mv $ \HandleFD.Handle__{HandleFD.haDevice = dev} -> case cast dev of Just fd -> cb $ Fd $ FD.fdFD fd Nothing -> error "withHandleFd: not a file handle" HandleFD.DuplexHandle {} -> error "withHandleFd: not a file handle" -- | See `ensureFileDurable` ensureFileDurable :: MonadIO m => FilePath -> m () ensureFileDurable filePath = liftIO $ withDirectory (takeDirectory filePath) $ \dirFd -> withFileInDirectory dirFd filePath ReadMode $ \fileHandle -> liftIO $ do fsyncFileHandle "ensureFileDurablePosix" fileHandle -- NOTE: Here we are purposefully not fsyncing the directory if the file fails to fsync fsyncDirectoryFd "ensureFileDurablePosix" dirFd -- | See `withBinaryFileDurable` withBinaryFileDurable :: MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r withBinaryFileDurable filePath iomode action = case iomode of ReadMode -- We do not need to consider durable operations when we are in a -- 'ReadMode', so we can use a regular `withBinaryFile` -> withBinaryFile filePath iomode action _ {- WriteMode, ReadWriteMode, AppendMode -} -> withDirectory (takeDirectory filePath) $ \dirFd -> withFileInDirectory dirFd filePath iomode $ \tmpFileHandle -> do res <- action tmpFileHandle liftIO $ do fsyncFileHandle "withBinaryFileDurablePosix" tmpFileHandle -- NOTE: Here we are purposefully not fsyncing the directory if the file fails to fsync fsyncDirectoryFd "withBinaryFileDurablePosix" dirFd pure res -- | See `withBinaryFileDurableAtomic` withBinaryFileDurableAtomic :: MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r withBinaryFileDurableAtomic filePath iomode action = case iomode of ReadMode -- We do not need to consider an atomic operation when we are in a -- 'ReadMode', so we can use a regular `withBinaryFile` -> withBinaryFile filePath iomode action _ {- WriteMode, ReadWriteMode, AppendMode -} -> withDirectory (takeDirectory filePath) $ \dirFd -> do mRes <- withAnonymousBinaryTempFileFor (Just dirFd) filePath iomode $ durableAtomicAction dirFd Nothing case mRes of Just res -> pure res Nothing -> withNonAnonymousBinaryTempFileFor (Just dirFd) filePath iomode $ \tmpFilePath -> durableAtomicAction dirFd (Just tmpFilePath) where durableAtomicAction dirFd mTmpFilePath tmpFileHandle = do mFileMode <- copyFileHandle iomode filePath tmpFileHandle res <- action tmpFileHandle liftIO $ atomicDurableTempFileRename dirFd mFileMode tmpFileHandle mTmpFilePath filePath pure res -- | See `withBinaryFileAtomic` withBinaryFileAtomic :: MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r withBinaryFileAtomic filePath iomode action = case iomode of ReadMode -- We do not need to consider an atomic operation when we are in a -- 'ReadMode', so we can use a regular `withBinaryFile` -> withBinaryFile filePath iomode action _ {- WriteMode, ReadWriteMode, AppendMode -} -> do mRes <- withAnonymousBinaryTempFileFor Nothing filePath iomode $ atomicAction Nothing case mRes of Just res -> pure res Nothing -> withNonAnonymousBinaryTempFileFor Nothing filePath iomode $ \tmpFilePath -> atomicAction (Just tmpFilePath) where atomicAction mTmpFilePath tmpFileHandle = do let eTmpFile = maybe (Left tmpFileHandle) Right mTmpFilePath mFileMode <- copyFileHandle iomode filePath tmpFileHandle res <- action tmpFileHandle liftIO $ atomicTempFileRename Nothing mFileMode eTmpFile filePath pure res unliftio-0.2.25.0/cbits/time-osx.c0000644000000000000000000000031714370231514014773 0ustar0000000000000000/* From https://github.com/bos/criterion */ #include #include void unliftio_inittime(void) { } double unliftio_gettime(void) { return clock_gettime_nsec_np(CLOCK_UPTIME_RAW); } unliftio-0.2.25.0/cbits/file-posix.c0000644000000000000000000000061314370231514015304 0ustar0000000000000000#include #include #include int unliftio_o_tmpfile( void ) { #ifdef __O_TMPFILE return __O_TMPFILE; #else return 0; #endif } int unliftio_at_fdcwd( void ) { return AT_FDCWD; } int unliftio_at_symlink_follow( void ) { return AT_SYMLINK_FOLLOW; } int unliftio_s_irusr( void ) { return S_IRUSR; } int unliftio_s_iwusr( void ) { return S_IWUSR; } unliftio-0.2.25.0/cbits/time-windows.c0000644000000000000000000000202114370231514015646 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.25.0/cbits/time-posix.c0000644000000000000000000000036114370231514015323 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.25.0/test/Spec.hs0000644000000000000000000000005414370231514014161 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} unliftio-0.2.25.0/test/UnliftIO/AsyncSpec.hs0000644000000000000000000001530214370231514016652 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.25.0/test/UnliftIO/DirectorySpec.hs0000644000000000000000000000147714370231514017551 0ustar0000000000000000{-# LANGUAGE CPP #-} module UnliftIO.DirectorySpec (spec) where import Test.Hspec #if MIN_VERSION_directory(1,3,1) import System.FilePath import UnliftIO.IO import UnliftIO.Directory import UnliftIO.Temporary spec :: Spec spec = do describe "createFileLink" $ do it "mirror" $ do withSystemTempDirectory "createFileLink.mirror" $ \fp -> do let fileContent = "i am the same" fileContent' = "I AM THE SAME" origin = fp "origin.txt" link = fp "link.txt" writeFile origin fileContent createFileLink origin link linkContent <- readFile link linkContent `shouldBe`fileContent writeFile origin fileContent' linkContent' <- readFile link linkContent' `shouldBe`fileContent' #else spec :: Spec spec = pure () #endif unliftio-0.2.25.0/test/UnliftIO/ExceptionSpec.hs0000644000000000000000000001134414370231514017535 0ustar0000000000000000{-# LANGUAGE CPP #-} module UnliftIO.ExceptionSpec (spec) where import qualified Control.Exception import Control.Monad (void, (<=<)) import Data.Bifunctor (first) import Test.Hspec import UnliftIO import UnliftIO.Concurrent (threadDelay) #if MIN_VERSION_async(2,2,0) cancelled :: AsyncCancelled cancelled = AsyncCancelled #else cancelled :: Control.Exception.AsyncException cancelled = Control.Exception.ThreadKilled #endif spec :: Spec spec = do let -- The callback will run in a thread that gets cancelled immediately, -- then get Exception2 thrown synchronously after 1 second. withAsyncExceptionThrown :: (IO a -> IO b) -> IO b withAsyncExceptionThrown f = do var <- newEmptyMVar a <- async $ f $ do putMVar var () threadDelay 1000000 throwIO Exception2 -- wait until thread is running, then cancel takeMVar var cancel a -- check result wait a -- The callback will run in a thread that gets Exception1 thrown as -- an async exception immediately, then get Exception2 thrown -- synchronously after 1 second. withWrappedAsyncExceptionThrown :: (IO a -> IO b) -> IO b withWrappedAsyncExceptionThrown f = do var <- newEmptyMVar a <- async $ f $ do putMVar var () threadDelay 1000000 throwIO Exception2 -- wait until thread is running, then cancel takeMVar var throwTo (asyncThreadId a) Exception1 -- check result wait a describe "catchSyncOrAsync" $ do it "should catch sync exceptions" $ do result <- (`catchSyncOrAsync` return) $ throwIO Exception1 result `shouldBe` Exception1 it "should catch async exceptions" $ do result <- withAsyncExceptionThrown $ \m -> m `catchSyncOrAsync` return result `shouldBe` cancelled it "should catch unliftio-wrapped async exceptions" $ do result <- withWrappedAsyncExceptionThrown $ \m -> m `catchSyncOrAsync` return fromExceptionUnwrap result `shouldBe` Just Exception1 describe "handleSyncOrAsync" $ do it "should catch sync exceptions" $ do result <- handleSyncOrAsync return $ throwIO Exception1 result `shouldBe` Exception1 it "should catch async exceptions" $ do result <- withAsyncExceptionThrown $ \m -> handleSyncOrAsync return m result `shouldBe` cancelled it "should catch unliftio-wrapped async exceptions" $ do result <- withWrappedAsyncExceptionThrown $ \m -> handleSyncOrAsync return m fromExceptionUnwrap result `shouldBe` Just Exception1 describe "trySyncOrAsync" $ do it "should catch sync exceptions" $ do result <- trySyncOrAsync $ void $ throwIO Exception1 result `shouldBe` Left Exception1 it "should catch async exceptions" $ do result <- withAsyncExceptionThrown $ \m -> trySyncOrAsync (void m) result `shouldBe` Left cancelled it "should catch unliftio-wrapped async exceptions" $ do result <- withWrappedAsyncExceptionThrown $ \m -> trySyncOrAsync (void m) first fromExceptionUnwrap result `shouldBe` Left (Just Exception1) describe "fromExceptionUnwrap" $ do it "should be the inverse of toAsyncException" $ do fromExceptionUnwrap (toAsyncException Exception1) `shouldBe` Just Exception1 it "should be the inverse of toSyncException" $ do let toAsyncToSync = toSyncException . toAsyncException fromSyncFromAsyc = fromExceptionUnwrap <=< fromExceptionUnwrap fromSyncFromAsyc (toAsyncToSync Exception1) `shouldBe` Just Exception1 let shouldLeft x = either (const Nothing) Just x `shouldBe` Nothing shouldRight x = either (Just . show) (const Nothing) x `shouldBe` Nothing describe "pureTry" $ do 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 :: ()) describe "mapExceptionM" $ do it "should convert an exception" $ do result <- try $ mapExceptionM (\Exception1 -> Exception2) (throwIO Exception1) result `shouldBe` (Left Exception2 :: Either Exception2 ()) it "should not convert unrelated exceptions" $ do result <- try $ mapExceptionM (\Exception1 -> Exception2) (throwIO Exception2) result `shouldBe` (Left Exception2 :: Either Exception2 ()) data Exception1 = Exception1 deriving (Show, Eq) instance Exception Exception1 data Exception2 = Exception2 deriving (Show, Eq) instance Exception Exception2 unliftio-0.2.25.0/test/UnliftIO/IO/FileSpec.hs0000644000000000000000000001742114370231514016767 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module UnliftIO.IO.FileSpec where import Test.Hspec -- Atomic/durable file writing is not supported on Windows. #ifndef WINDOWS import Control.Monad (forM_) import Data.Bool (bool) import System.FilePath (()) import Test.QuickCheck import UnliftIO.Directory import UnliftIO.Exception import UnliftIO.IO import UnliftIO.IO.File as File import UnliftIO.Temporary (withSystemTempDirectory) import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL #if __GLASGOW_HASKELL__ < 820 import Data.Monoid #endif data ExpectedException = ExpectedException deriving (Show) instance Exception ExpectedException spec :: Spec spec = do describe "ensureFileDurable" $ it "ensures a file is durable with an fsync" $ withSystemTempDirectory "rio" $ \dir -> do let fp = dir "ensure_file_durable" writeFile fp "Hello World" File.ensureFileDurable fp contents <- B.readFile fp contents `shouldBe` "Hello World" withBinaryFileSpec False "withBinaryFile" withBinaryFile writeBinaryFileSpec "writeBinaryFile" writeBinaryFile -- Above two specs are validating the specs behavior by applying to -- known good implementations withBinaryFileSpec True "withBinaryFileAtomic" File.withBinaryFileAtomic writeBinaryFileSpec "writeBinaryFileAtomic" File.writeBinaryFileAtomic withBinaryFileSpec False "withBinaryFileDurable" File.withBinaryFileDurable writeBinaryFileSpec "writeBinaryFileDurable" File.writeBinaryFileDurable withBinaryFileSpec True "withBinaryFileDurableAtomic" File.withBinaryFileDurableAtomic writeBinaryFileSpec "writeBinaryFileDurableAtomic" File.writeBinaryFileDurableAtomic writeFileUtf8 fp str = withBinaryFile fp WriteMode (`BB.hPutBuilder` BB.stringUtf8 str) withBinaryFileSpec :: Bool -- ^ Should we test atomicity -> String -> (forall a. FilePath -> IOMode -> (Handle -> IO a) -> IO a) -> Spec withBinaryFileSpec atomic fname withFileTestable = do let hello = "Hello World" helloString = "Hello World" writeHello fp = writeFileUtf8 fp helloString -- Create a file, write "Hello World" into it and apply the action. withHelloFileTestable fp iomode action = do writeHello fp withFileTestable fp iomode action goodbye = "Goodbye yall" modifiedPermissions = setOwnerExecutable True $ setOwnerReadable True $ setOwnerWritable True emptyPermissions describe fname $ do it "read" $ withSystemTempDirectory "rio" $ \dir -> do let fp = dir fname ++ "-read" withHelloFileTestable fp ReadWriteMode (`B.hGet` B.length hello) `shouldReturn` hello it "write" $ withSystemTempDirectory "rio" $ \dir -> do let fp = dir fname ++ "-write" withHelloFileTestable fp WriteMode (`B.hPut` goodbye) B.readFile fp `shouldReturn` goodbye it "read/write" $ withSystemTempDirectory "rio" $ \dir -> do let fp = dir fname ++ "-read-write" withHelloFileTestable fp ReadWriteMode $ \h -> do B.hGetLine h `shouldReturn` hello B.hPut h goodbye B.readFile fp `shouldReturn` (hello <> goodbye) it "append" $ withSystemTempDirectory "rio" $ \dir -> do let fp = dir fname ++ "-append" privet = "Привет Мир" -- some unicode won't hurt encodeUtf8 = BL.toStrict . BB.toLazyByteString . BB.stringUtf8 writeFileUtf8 fp privet setPermissions fp modifiedPermissions withFileTestable fp AppendMode $ \h -> B.hPut h goodbye B.readFile fp `shouldReturn` (encodeUtf8 privet <> goodbye) it "sub-directory" $ withSystemTempDirectory "rio" $ \dir -> do let subDir = dir fname ++ "-sub-directory" fp = subDir "test.file" createDirectoryIfMissing True subDir withHelloFileTestable fp ReadWriteMode $ \h -> do B.hGetLine h `shouldReturn` hello B.hPut h goodbye B.readFile fp `shouldReturn` (hello <> goodbye) it "relative-directory" $ withSystemTempDirectory "rio" $ \dir -> do let relDir = fname ++ "-relative-directory" subDir = dir relDir fp = relDir "test.file" createDirectoryIfMissing True subDir withCurrentDirectoryCompat dir $ do withHelloFileTestable fp ReadWriteMode $ \h -> do B.hGetLine h `shouldReturn` hello B.hPut h goodbye B.readFile fp `shouldReturn` (hello <> goodbye) it "modified-permissions" $ forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode -> withSystemTempDirectory "rio" $ \dir -> do let fp = dir fname ++ "-modified-permissions" writeHello fp setPermissions fp modifiedPermissions withFileTestable fp iomode $ \h -> B.hPut h goodbye getPermissions fp `shouldReturn` modifiedPermissions it "exception - Does not corrupt files" $ bool expectFailure property atomic $ -- should fail for non-atomic forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode -> withSystemTempDirectory "rio" $ \dir -> do let fp = dir fname ++ "-exception" _ :: Either ExpectedException () <- try $ withHelloFileTestable fp iomode $ \h -> do B.hPut h goodbye throwIO ExpectedException B.readFile fp `shouldReturn` hello it "exception - Does not leave files behind" $ bool expectFailure property atomic $ -- should fail for non-atomic forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode -> withSystemTempDirectory "rio" $ \dir -> do let fp = dir fname ++ "-exception" _ :: Either ExpectedException () <- try $ withFileTestable fp iomode $ \h -> do B.hPut h goodbye throwIO ExpectedException doesFileExist fp `shouldReturn` False listDirectoryCompat dir `shouldReturn` [] it "delete - file" $ bool expectFailure property atomic $ -- should fail for non-atomic forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode -> withSystemTempDirectory "rio" $ \dir -> do let fp = dir fname ++ "-delete" withHelloFileTestable fp iomode $ \h -> do removeFile fp B.hPut h goodbye doesFileExist fp `shouldReturn` True writeBinaryFileSpec :: String -> (FilePath -> B.ByteString -> IO ()) -> SpecWith () writeBinaryFileSpec fname writeFileTestable = do let hello = "Hello World" describe fname $ do it "write" $ withSystemTempDirectory "rio" $ \dir -> do let fp = dir fname ++ "-write" writeFileTestable fp hello B.readFile fp `shouldReturn` hello it "default-permissions" $ withSystemTempDirectory "rio" $ \dir -> do let fp = dir fname ++ "-default-permissions" defaultPermissions = setOwnerReadable True $ setOwnerWritable True emptyPermissions writeFileTestable fp hello getPermissions fp `shouldReturn` defaultPermissions listDirectoryCompat :: FilePath -> IO [FilePath] #if MIN_VERSION_directory(1,2,5) listDirectoryCompat = listDirectory #else listDirectoryCompat path = filter f <$> getDirectoryContents path where f filename = filename /= "." && filename /= ".." #endif withCurrentDirectoryCompat :: FilePath -> IO a -> IO a #if MIN_VERSION_directory(1,2,3) withCurrentDirectoryCompat = withCurrentDirectory #else withCurrentDirectoryCompat dir action = bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do setCurrentDirectory dir action #endif #else spec :: Spec spec = pure () #endif unliftio-0.2.25.0/test/UnliftIO/IOSpec.hs0000644000000000000000000000047214370231514016106 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.25.0/test/UnliftIO/MemoizeSpec.hs0000644000000000000000000000265514370231514017211 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.25.0/test/UnliftIO/PooledAsyncSpec.hs0000644000000000000000000001600314370231514020014 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.25.0/bench/ConcBench.hs0000644000000000000000000001226514370231514015220 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.25.0/LICENSE0000644000000000000000000000203714370231514012764 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.25.0/Setup.hs0000644000000000000000000000005614370231514013412 0ustar0000000000000000import Distribution.Simple main = defaultMain unliftio-0.2.25.0/unliftio.cabal0000644000000000000000000000652214442761607014612 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack name: unliftio version: 0.2.25.0 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 exposed-modules: UnliftIO UnliftIO.Async UnliftIO.Chan UnliftIO.Concurrent UnliftIO.Directory UnliftIO.Environment UnliftIO.Exception UnliftIO.Exception.Lens UnliftIO.Foreign UnliftIO.Internals.Async UnliftIO.IO UnliftIO.IO.File UnliftIO.IORef UnliftIO.Memoize UnliftIO.MVar UnliftIO.Process UnliftIO.QSem UnliftIO.QSemN UnliftIO.STM UnliftIO.Temporary UnliftIO.Timeout other-modules: Paths_unliftio hs-source-dirs: src ghc-options: -fwarn-incomplete-uni-patterns build-depends: async >2.1.1 , base >=4.9 && <5 , bytestring , deepseq , directory , filepath , process >=1.2.0.0 , safe-exceptions , stm >=2.5 , time , transformers , unliftio-core >=0.1.1.0 default-language: Haskell2010 if os(windows) cpp-options: -DWINDOWS else build-depends: unix if impl(ghc <= 7.10) build-depends: nats if os(darwin) other-modules: UnliftIO.IO.File.Posix c-sources: cbits/time-osx.c cbits/file-posix.c else if os(windows) c-sources: cbits/time-windows.c else other-modules: UnliftIO.IO.File.Posix c-sources: cbits/file-posix.c cbits/time-posix.c test-suite unliftio-spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: UnliftIO.AsyncSpec UnliftIO.DirectorySpec UnliftIO.ExceptionSpec UnliftIO.IO.FileSpec UnliftIO.IOSpec UnliftIO.MemoizeSpec UnliftIO.PooledAsyncSpec Paths_unliftio hs-source-dirs: test build-depends: QuickCheck , async >2.1.1 , base >=4.9 && <5 , bytestring , containers , deepseq , directory , filepath , hspec , process >=1.2.0.0 , safe-exceptions , stm >=2.5 , time , transformers , unliftio , unliftio-core >=0.1.1.0 default-language: Haskell2010 if os(windows) cpp-options: -DWINDOWS else build-depends: unix 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.9 && <5 , bytestring , deepseq , directory , filepath , gauge , process >=1.2.0.0 , safe-exceptions , stm >=2.5 , time , transformers , unliftio , unliftio-core >=0.1.1.0 default-language: Haskell2010 if os(windows) cpp-options: -DWINDOWS else build-depends: unix unliftio-0.2.25.0/README.md0000644000000000000000000003544014370231514013242 0ustar0000000000000000# unliftio ![Tests](https://github.com/fpco/unliftio/workflows/Tests/badge.svg) 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 -- `withRunInIO`: ```haskell class MonadIO m => MonadUnliftIO m where withRunInIO :: ((forall a. m a -> IO a) -> IO b) -> m b ``` `withRunInIO` provides a function to run arbitrary computations in `m` in `IO`. Thus the "unlift": it's like `liftIO`, but the other way around. Here are some sample typeclass instances: ```haskell instance MonadUnliftIO IO where withRunInIO inner = inner id instance MonadUnliftIO m => MonadUnliftIO (ReaderT r m) where withRunInIO inner = ReaderT $ \r -> withRunInIO $ \run -> inner (run . flip runReaderT r) instance MonadUnliftIO m => MonadUnliftIO (IdentityT m) where withRunInIO inner = IdentityT $ withRunInIO $ \run -> inner (run . runIdentityT) ``` Note that: * 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 `withRunInIO` on the underlying monad. * `ReaderT` is just like `IdentityT`, but it captures the reader environment when starting. We can use `withRunInIO` to unlift a function: ```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.25.0/ChangeLog.md0000644000000000000000000000715414442761553014150 0ustar0000000000000000# Changelog for unliftio ## 0.2.25.0 * Add `UnliftIO.Exception.Lens` ## 0.2.24.0 * Add `UnliftIO.STM.writeTMVar` * Add `UnliftIO.STM.stateTVar` ## 0.2.23.0 * `UnliftIO.Exception` re-exports the `Handler` and sync/async exception wrappers from `safe-exceptions`, instead of redefining them. * With this change, you won't be able to distinguish between an asynchronous exception from `UnliftIO.Exception.throwTo` and `Control.Exception.Safe.throwTo`. * [#103](https://github.com/fpco/unliftio/pull/103) ## 0.2.22.0 * Add `UnliftIO.STM.flushTBQueue` * Add `UnliftIO.STM.lengthTBQueue` ## 0.2.21.0 * Add `UnliftIO.Directory.createDirectoryLink` * Add `UnliftIO.Directory.removeDirectoryLink` * Add `UnliftIO.Directory.getSymbolicLinkTarget` * Add `UnliftIO.Directory.XdgDirectoryList` * Add `UnliftIO.Directory.getXdgDirectoryList` ## 0.2.20.1 * Fix time-osx.c for aarch64 mac [#91](https://github.com/fpco/unliftio/pull/91) ## 0.2.20 * Add lifted `System.IO.openFile` (https://github.com/fpco/unliftio/pull/88) ## 0.2.19 * Add `Eq` instance for `StringException` (https://github.com/fpco/unliftio/pull/83) ## 0.2.18 * Reexport `asyncExceptionFromException` and `asyncExceptionToException` [#81](https://github.com/fpco/unliftio/issues/81) ## 0.2.17 * Re-export `AsyncCancelled` in `UnliftIO.Async` [#80](https://github.com/fpco/unliftio/pull/80) * Add `fromExceptionUnwrap` [#80](https://github.com/fpco/unliftio/pull/80) * Add `catchSyncOrAsync`, `handleSyncOrAsync`, and `trySyncOrAsync` [#80](https://github.com/fpco/unliftio/pull/80) ## 0.2.16 * Add `createFileLink` ## 0.2.15 * Updated documentation mentioning that `MonadUnliftIO` may be derived using the `newtype` strategy [#72](https://github.com/fpco/unliftio/pull/72) * Add `mapExceptionM` [#75](https://github.com/fpco/unliftio/pull/75) ## 0.2.14 * Add `UnliftIO.QSem` * Add `UnliftIO.QSemN` ## 0.2.13.1 * Improve `UnliftIO.Exception` documentation ## 0.2.13 * Add `UnliftIO.STM.orElse` * Re-export all of `SeekMode` ## 0.2.12.1 * Minor doc improvements ## 0.2.12 * Dropped support for ghc-7.8 * Addition of `UnliftIO.IO.File` module and atomic+durable file writes: * `writeBinaryFile` * `writeBinaryFileAtomic` * `writeBinaryFileDurable` * `writeBinaryFileDurableAtomic` * `withBinaryFileAtomic` * `withBinaryFileDurable` * `withBinaryFileDurableAtomic` * `ensureFileDurable` ## 0.2.11 * Deprecate `forkWithUnmask` in favor of the newly added `forkIOWithUnmask` to improve consistency. [https://github.com/fpco/unliftio/issues/44] ## 0.2.10 * Add pooling related functions for unliftio ## 0.2.9.0 * Add the new `Conc` datatype as a more efficient alternative to `Concurrently` ## 0.2.8.1 * Support for `stm-2.5.0.0` ## 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.