Skip to content

Commit 0ad348e

Browse files
snoybergsnoyberg
committed
MonadUnliftIO
1 parent f9aaadd commit 0ad348e

73 files changed

Lines changed: 593 additions & 468 deletions

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

‎src/Control/Concurrent/Execute.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -13,8 +13,9 @@ module Control.Concurrent.Execute
1313
import Control.Applicative
1414
import Control.Concurrent.Async (Concurrently (..), async)
1515
import Control.Concurrent.STM
16-
import Control.Exception
16+
import Control.Exception (mask)
1717
import Control.Monad (join, unless)
18+
import Control.Monad.IO.Unlift
1819
import Data.Foldable (sequenceA_)
1920
import Data.Set (Set)
2021
import qualified Data.Set as Set

‎src/Control/Monad/IO/Unlift.hs‎

Lines changed: 236 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,236 @@
1+
{-# LANGUAGE RankNTypes #-}
2+
-- | FIXME to be moved to an external package at some point
3+
module Control.Monad.IO.Unlift
4+
( MonadUnliftIO (..)
5+
, UnliftIO (..)
6+
, askRunIO
7+
, withUnliftIO
8+
, withRunIO
9+
, toIO
10+
, MonadIO (..)
11+
12+
, Res.ResourceT
13+
, runResourceT
14+
, liftResourceT
15+
, runConduitRes
16+
17+
, catch
18+
, catchIO
19+
, catchAny
20+
, catchAnyDeep
21+
, catchJust
22+
23+
, handle
24+
, handleIO
25+
, handleAny
26+
, handleAnyDeep
27+
, handleJust
28+
29+
, try
30+
, tryIO
31+
, tryAny
32+
, tryAnyDeep
33+
, tryJust
34+
35+
, ES.Exception (..)
36+
, ES.SomeException (..)
37+
, E.ErrorCall
38+
, ES.IOException
39+
, ES.assert
40+
, ES.MonadThrow -- FIXME perhaps completely ditch MonadThrow?
41+
, throwIO
42+
, ES.throwM
43+
, ES.impureThrow
44+
, ES.Handler (..)
45+
, evaluate
46+
, bracket
47+
, bracket_
48+
, bracketOnError
49+
, bracketOnError_
50+
, finally
51+
, withException
52+
, onException
53+
54+
, M.MVar
55+
, newMVar
56+
, modifyMVar
57+
, modifyMVar_
58+
, takeMVar
59+
, withMVar
60+
) where
61+
62+
import Control.DeepSeq (NFData)
63+
import Control.Monad.IO.Class
64+
import Control.Monad.Logger (LoggingT (..), NoLoggingT (..))
65+
import Control.Monad.Trans.Reader (ReaderT (..))
66+
import qualified Control.Monad.Trans.Resource as Res
67+
import qualified Control.Monad.Trans.Resource.Internal as Res
68+
import qualified Control.Exception as E (ErrorCall, evaluate)
69+
import qualified Control.Exception.Safe as ES
70+
import qualified Data.Conduit as Con
71+
import Data.Void (Void)
72+
import qualified Control.Concurrent.MVar as M
73+
74+
-- FIXME consider making MonadThrow a superclass and demanding that
75+
-- throwIO = throwM
76+
class MonadIO m => MonadUnliftIO m where
77+
askUnliftIO :: m (UnliftIO m)
78+
-- Would be better, but GHC hates us
79+
-- askUnliftIO :: m (forall a. m a -> IO a)
80+
instance MonadUnliftIO IO where
81+
askUnliftIO = return (UnliftIO id)
82+
instance MonadUnliftIO m => MonadUnliftIO (ReaderT r m) where
83+
askUnliftIO = ReaderT $ \r ->
84+
withUnliftIO $ \u ->
85+
return (UnliftIO (unliftIO u . flip runReaderT r))
86+
instance MonadUnliftIO m => MonadUnliftIO (LoggingT m) where
87+
askUnliftIO = LoggingT $ \f ->
88+
withUnliftIO $ \u ->
89+
return (UnliftIO (unliftIO u . flip runLoggingT f))
90+
instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where
91+
askUnliftIO = NoLoggingT $
92+
withUnliftIO $ \u ->
93+
return (UnliftIO (unliftIO u . runNoLoggingT))
94+
instance MonadUnliftIO m => MonadUnliftIO (Res.ResourceT m) where
95+
askUnliftIO = Res.ResourceT $ \r ->
96+
withUnliftIO $ \u ->
97+
return (UnliftIO (unliftIO u . flip Res.unResourceT r))
98+
99+
{- Invalid instance, violates the laws
100+
instance MonadUnliftIO (StateT s IO) where
101+
askUnliftIO = StateT $ \s0 -> do
102+
let u = UnliftIO $ \m -> do
103+
(a, s1) <- runStateT m s0 -- Invalid by construction! Fails the MonadUnliftIO laws
104+
return a
105+
return (u, s0)
106+
-}
107+
108+
newtype UnliftIO m = UnliftIO { unliftIO :: forall a. m a -> IO a }
109+
110+
askRunIO :: MonadUnliftIO m => m (m a -> IO a)
111+
askRunIO = fmap unliftIO askUnliftIO
112+
113+
withUnliftIO :: MonadUnliftIO m => (UnliftIO m -> IO a) -> m a
114+
withUnliftIO inner = askUnliftIO >>= liftIO . inner
115+
116+
withRunIO :: MonadUnliftIO m => ((m a -> IO a) -> IO b) -> m b
117+
withRunIO inner = askRunIO >>= liftIO . inner
118+
119+
toIO :: MonadUnliftIO m => m a -> m (IO a)
120+
toIO m = withRunIO $ \run -> return $ run m
121+
122+
runResourceT :: MonadUnliftIO m => Res.ResourceT m a -> m a
123+
runResourceT m = withRunIO $ \run -> Res.runResourceT $ Res.transResourceT run m
124+
125+
liftResourceT :: MonadIO m => Res.ResourceT IO a -> Res.ResourceT m a
126+
liftResourceT (Res.ResourceT f) = Res.ResourceT $ liftIO . f
127+
128+
runConduitRes :: MonadUnliftIO m => Con.ConduitM () Void (Res.ResourceT m) r -> m r
129+
runConduitRes = runResourceT . Con.runConduit
130+
131+
catch :: (MonadUnliftIO m, ES.Exception e) => m a -> (e -> m a) -> m a
132+
catch x y = withUnliftIO $ \u -> unliftIO u x `ES.catch` (unliftIO u . y)
133+
134+
catchIO :: MonadUnliftIO m => m a -> (ES.IOException -> m a) -> m a
135+
catchIO = catch
136+
137+
catchAny :: MonadUnliftIO m => m a -> (ES.SomeException -> m a) -> m a
138+
catchAny = catch
139+
140+
catchAnyDeep :: (NFData a, MonadUnliftIO m) => m a -> (ES.SomeException -> m a) -> m a
141+
catchAnyDeep x y = withUnliftIO $ \u -> unliftIO u x `ES.catchAnyDeep` (unliftIO u . y)
142+
143+
catchJust :: (MonadUnliftIO m, ES.Exception e) => (e -> Maybe b) -> m a -> (b -> m a) -> m a
144+
catchJust f a b = a `catch` \e -> maybe (liftIO (ES.throwM e)) b $ f e
145+
146+
handle :: (MonadUnliftIO m, ES.Exception e) => (e -> m a) -> m a -> m a
147+
handle = flip catch
148+
149+
handleIO :: MonadUnliftIO m => (ES.IOException -> m a) -> m a -> m a
150+
handleIO = handle
151+
152+
handleAny :: MonadUnliftIO m => (ES.SomeException -> m a) -> m a -> m a
153+
handleAny = handle
154+
155+
handleAnyDeep :: (MonadUnliftIO m, NFData a) => (ES.SomeException -> m a) -> m a -> m a
156+
handleAnyDeep = flip catchAnyDeep
157+
158+
handleJust :: (MonadUnliftIO m, ES.Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a
159+
handleJust f = flip (catchJust f)
160+
161+
try :: (MonadUnliftIO m, ES.Exception e) => m a -> m (Either e a)
162+
try m = withRunIO $ \run -> ES.try (run m)
163+
164+
tryIO :: MonadUnliftIO m => m a -> m (Either ES.SomeException a)
165+
tryIO = try
166+
167+
tryAny :: MonadUnliftIO m => m a -> m (Either ES.SomeException a)
168+
tryAny = try
169+
170+
tryAnyDeep :: (MonadUnliftIO m, NFData a) => m a -> m (Either ES.SomeException a)
171+
tryAnyDeep m = withRunIO $ \run -> ES.tryAnyDeep (run m)
172+
173+
tryJust :: (MonadUnliftIO m, ES.Exception e) => (e -> Maybe b) -> m a -> m (Either b a)
174+
tryJust f m = withRunIO $ \run -> ES.tryJust f (run m)
175+
176+
evaluate :: MonadIO m => a -> m a
177+
evaluate = liftIO . E.evaluate
178+
179+
bracket :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m c) -> m c
180+
bracket x y z = withUnliftIO $ \u -> ES.bracket
181+
(unliftIO u x)
182+
(unliftIO u . y)
183+
(unliftIO u . z)
184+
185+
bracket_ :: MonadUnliftIO m => m a -> m b -> m c -> m c
186+
bracket_ x y z = withUnliftIO $ \u -> ES.bracket_
187+
(unliftIO u x)
188+
(unliftIO u y)
189+
(unliftIO u z)
190+
191+
bracketOnError :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m c) -> m c
192+
bracketOnError x y z = withUnliftIO $ \u -> ES.bracketOnError
193+
(unliftIO u x)
194+
(unliftIO u . y)
195+
(unliftIO u . z)
196+
197+
bracketOnError_ :: MonadUnliftIO m => m a -> m b -> m c -> m c
198+
bracketOnError_ x y z = withUnliftIO $ \u -> ES.bracketOnError_
199+
(unliftIO u x)
200+
(unliftIO u y)
201+
(unliftIO u z)
202+
203+
finally :: MonadUnliftIO m => m a -> m b -> m a
204+
finally x y = withUnliftIO $ \u -> ES.finally
205+
(unliftIO u x)
206+
(unliftIO u y)
207+
208+
withException :: (MonadUnliftIO m, ES.Exception e)
209+
=> m a -> (e -> m b) -> m a
210+
withException x y = withUnliftIO $ \u -> ES.withException
211+
(unliftIO u x)
212+
(unliftIO u . y)
213+
214+
onException :: MonadUnliftIO m => m a -> m b -> m a
215+
onException x y = withUnliftIO $ \u -> ES.onException
216+
(unliftIO u x)
217+
(unliftIO u y)
218+
219+
-- FIXME I'm not too happy about differing behavior between throwM and throwIO
220+
throwIO :: (MonadIO m, ES.Exception e) => e -> m a
221+
throwIO = liftIO . ES.throwM
222+
223+
newMVar :: MonadIO m => a -> m (M.MVar a)
224+
newMVar = liftIO . M.newMVar
225+
226+
modifyMVar :: MonadUnliftIO m => M.MVar a -> (a -> m (a, b)) -> m b
227+
modifyMVar var f = withRunIO $ \run -> M.modifyMVar var (run . f)
228+
229+
modifyMVar_ :: MonadUnliftIO m => M.MVar a -> (a -> m a) -> m ()
230+
modifyMVar_ var f = withRunIO $ \run -> M.modifyMVar_ var (run . f)
231+
232+
takeMVar :: MonadIO m => M.MVar a -> m a
233+
takeMVar = liftIO . M.takeMVar
234+
235+
withMVar :: MonadUnliftIO m => M.MVar a -> (a -> m b) -> m b
236+
withMVar var f = withRunIO $ \run -> M.withMVar var (run . f)

‎src/Data/Store/VersionTagged.hs‎

Lines changed: 3 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -15,10 +15,8 @@ module Data.Store.VersionTagged
1515
) where
1616

1717
import Control.Applicative
18-
import Control.Exception.Lifted (catch, IOException, assert)
19-
import Control.Monad.IO.Class (MonadIO, liftIO)
18+
import Control.Monad.IO.Unlift
2019
import Control.Monad.Logger
21-
import Control.Monad.Trans.Control (MonadBaseControl)
2220
import qualified Data.ByteString as BS
2321
import Data.Data (Data)
2422
import qualified Data.Map as M
@@ -61,7 +59,7 @@ storeEncodeFile pokeFunc peekFunc fp x = do
6159
-- | Read from the given file. If the read fails, run the given action and
6260
-- write that back to the file. Always starts the file off with the
6361
-- version tag.
64-
versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
62+
versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadUnliftIO m, MonadLogger m)
6563
=> (a -> (Int, Poke ()))
6664
-> Peek a
6765
-> Path Abs File
@@ -81,7 +79,7 @@ versionedDecodeOrLoadImpl pokeFunc peekFunc fp mx = do
8179
storeEncodeFile pokeFunc peekFunc fp x
8280
return x
8381

84-
versionedDecodeFileImpl :: (Store a, MonadIO m, MonadLogger m, MonadBaseControl IO m)
82+
versionedDecodeFileImpl :: (Store a, MonadUnliftIO m, MonadLogger m)
8583
=> Peek a
8684
-> Path loc File
8785
-> m (Maybe a)

‎src/Network/HTTP/Download.hs‎

Lines changed: 2 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -20,14 +20,11 @@ module Network.HTTP.Download
2020
, setGithubHeaders
2121
) where
2222

23-
import Control.Exception (Exception)
24-
import Control.Exception.Safe (handleIO)
2523
import Control.Monad (void)
26-
import Control.Monad.Catch (throwM)
27-
import Control.Monad.IO.Class (MonadIO, liftIO)
24+
import Control.Monad.IO.Unlift
2825
import Control.Monad.Logger (MonadLogger, logDebug)
2926
import qualified Data.ByteString.Lazy as L
30-
import Data.Conduit (runConduit, runConduitRes, (.|), yield)
27+
import Data.Conduit (runConduit, (.|), yield)
3128
import Data.Conduit.Binary (sourceHandle)
3229
import qualified Data.Conduit.Binary as CB
3330
import Data.Foldable (forM_)

‎src/Network/HTTP/Download/Verified.hs‎

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -30,8 +30,8 @@ import qualified Data.Text.Encoding as Text
3030

3131
import Control.Applicative
3232
import Control.Monad
33-
import Control.Monad.Catch
34-
import Control.Monad.IO.Class
33+
import Control.Monad.Catch (Handler (..))
34+
import Control.Monad.IO.Unlift hiding (Handler (..)) -- FIXME when safe-exceptions uses exceptions's Handler, we can get rid of this and the dependency on exceptions
3535
import Control.Monad.Logger (logDebug, MonadLogger)
3636
import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)
3737
import Crypto.Hash
@@ -188,15 +188,17 @@ hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteStr
188188
hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req)
189189

190190
-- 'Control.Retry.recovering' customized for HTTP failures
191-
recoveringHttp :: (MonadMask m, MonadIO m)
191+
recoveringHttp :: MonadUnliftIO m
192192
=> RetryPolicy -> m a -> m a
193193
recoveringHttp retryPolicy =
194194
#if MIN_VERSION_retry(0,7,0)
195-
recovering retryPolicy handlers . const
195+
helper $ recovering retryPolicy handlers . const
196196
#else
197-
recovering retryPolicy handlers
197+
helper $ recovering retryPolicy handlers
198198
#endif
199199
where
200+
helper wrapper action = withRunIO $ \run -> wrapper (run action)
201+
200202
handlers = [const $ Handler alwaysRetryHttp,const $ Handler retrySomeIO]
201203

202204
alwaysRetryHttp :: Monad m => HttpException -> m Bool

‎src/Options/Applicative/Builder/Extra.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -29,8 +29,8 @@ module Options.Applicative.Builder.Extra
2929
,unescapeBashArg
3030
) where
3131

32-
import Control.Exception (IOException, catch)
3332
import Control.Monad (when, forM)
33+
import Control.Monad.IO.Unlift
3434
import Data.Either.Combinators
3535
import Data.List (isPrefixOf)
3636
import Data.Maybe

‎src/Path/Extra.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -20,8 +20,7 @@ import qualified Data.ByteString.Char8 as BS
2020
import qualified Data.Text as T
2121
import qualified Data.Text.Encoding as T
2222
import Control.Monad (liftM)
23-
import Control.Monad.Catch
24-
import Control.Monad.IO.Class
23+
import Control.Monad.IO.Unlift
2524
import Data.Bool (bool)
2625
import Path
2726
import Path.IO

‎src/Path/Find.hs‎

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -9,11 +9,9 @@ module Path.Find
99
,findInParents)
1010
where
1111

12-
import Control.Exception (evaluate)
1312
import Control.DeepSeq (force)
1413
import Control.Monad
15-
import Control.Monad.Catch
16-
import Control.Monad.IO.Class
14+
import Control.Monad.IO.Unlift
1715
import System.IO.Error (isPermissionError)
1816
import Data.List
1917
import Path

0 commit comments

Comments
 (0)