Skip to content

Commit 6a16ecd

Browse files
cootcoot
committed
io-classes: use injective type families
By making STM and Async injective, we can simplify how STM and Async can be used: no need for MonadSTMTx or Proxy arguments. But we loose `ReaderT` instances.
1 parent 3435afa commit 6a16ecd

File tree

3 files changed

+156
-249
lines changed

3 files changed

+156
-249
lines changed

‎io-classes/src/Control/Monad/Class/MonadAsync.hs

Lines changed: 65 additions & 110 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,15 @@
1-
{-# LANGUAGE DefaultSignatures #-}
2-
{-# LANGUAGE FlexibleContexts #-}
3-
{-# LANGUAGE MultiParamTypeClasses #-}
4-
{-# LANGUAGE QuantifiedConstraints #-}
5-
{-# LANGUAGE ScopedTypeVariables #-}
6-
{-# LANGUAGE RankNTypes #-}
7-
{-# LANGUAGE TypeApplications #-}
8-
{-# LANGUAGE TypeFamilies #-}
1+
{-# LANGUAGE DefaultSignatures #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE MultiParamTypeClasses #-}
4+
{-# LANGUAGE QuantifiedConstraints #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
6+
{-# LANGUAGE RankNTypes #-}
7+
{-# LANGUAGE TypeApplications #-}
8+
{-# LANGUAGE TypeFamilies #-}
9+
{-# LANGUAGE TypeFamilyDependencies #-}
910

1011
module Control.Monad.Class.MonadAsync
1112
( MonadAsync (..)
12-
, MonadAsyncSTM (..)
1313
, AsyncCancelled(..)
1414
, ExceptionInLinkedThread(..)
1515
, link
@@ -30,40 +30,63 @@ import Control.Monad.Class.MonadFork
3030
import Control.Monad.Class.MonadSTM
3131
import Control.Monad.Class.MonadTimer
3232
import Control.Monad.Class.MonadThrow
33+
import Control.Monad (forever)
3334

3435
import Control.Concurrent.Async (AsyncCancelled (..))
3536
import qualified Control.Concurrent.Async as Async
3637
import qualified Control.Exception as E
37-
import Control.Monad.Reader
38-
import qualified Control.Monad.STM as STM
3938

4039
import Data.Foldable (fold)
40+
import Data.Functor (void)
4141
import Data.Kind (Type)
42-
import Data.Proxy
4342

44-
class (Functor async, MonadSTMTx stm) => MonadAsyncSTM async stm where
45-
{-# MINIMAL waitCatchSTM, pollSTM #-}
43+
class ( MonadSTM m
44+
, MonadThread m
45+
) => MonadAsync m where
4646

47-
waitSTM :: async a -> stm a
48-
pollSTM :: async a -> stm (Maybe (Either SomeException a))
49-
waitCatchSTM :: async a -> stm (Either SomeException a)
47+
{-# MINIMAL async, asyncThreadId, cancel, cancelWith, asyncWithUnmask,
48+
waitCatchSTM, pollSTM #-}
5049

51-
default waitSTM :: MonadThrow stm => async a -> stm a
50+
-- | An asynchronous action
51+
type Async m = (async :: Type -> Type) | async -> m
52+
53+
async :: m a -> m (Async m a)
54+
asyncThreadId :: Async m a -> ThreadId m
55+
withAsync :: m a -> (Async m a -> m b) -> m b
56+
57+
waitSTM :: Async m a -> STM m a
58+
pollSTM :: Async m a -> STM m (Maybe (Either SomeException a))
59+
waitCatchSTM :: Async m a -> STM m (Either SomeException a)
60+
61+
default waitSTM :: MonadThrow (STM m) => Async m a -> STM m a
5262
waitSTM action = waitCatchSTM action >>= either throwSTM return
5363

54-
waitAnySTM :: [async a] -> stm (async a, a)
55-
waitAnyCatchSTM :: [async a] -> stm (async a, Either SomeException a)
56-
waitEitherSTM :: async a -> async b -> stm (Either a b)
57-
waitEitherSTM_ :: async a -> async b -> stm ()
58-
waitEitherCatchSTM :: async a -> async b
59-
-> stm (Either (Either SomeException a)
64+
waitAnySTM :: [Async m a] -> STM m (Async m a, a)
65+
waitAnyCatchSTM :: [Async m a] -> STM m (Async m a, Either SomeException a)
66+
waitEitherSTM :: Async m a -> Async m b -> STM m (Either a b)
67+
waitEitherSTM_ :: Async m a -> Async m b -> STM m ()
68+
waitEitherCatchSTM :: Async m a -> Async m b
69+
-> STM m (Either (Either SomeException a)
6070
(Either SomeException b))
61-
waitBothSTM :: async a -> async b -> stm (a, b)
71+
waitBothSTM :: Async m a -> Async m b -> STM m (a, b)
72+
73+
wait :: Async m a -> m a
74+
poll :: Async m a -> m (Maybe (Either SomeException a))
75+
waitCatch :: Async m a -> m (Either SomeException a)
76+
cancel :: Async m a -> m ()
77+
cancelWith :: Exception e => Async m a -> e -> m ()
78+
uninterruptibleCancel :: Async m a -> m ()
6279

63-
default waitAnySTM :: MonadThrow stm => [async a] -> stm (async a, a)
64-
default waitEitherSTM :: MonadThrow stm => async a -> async b -> stm (Either a b)
65-
default waitEitherSTM_ :: MonadThrow stm => async a -> async b -> stm ()
66-
default waitBothSTM :: MonadThrow stm => async a -> async b -> stm (a, b)
80+
waitAny :: [Async m a] -> m (Async m a, a)
81+
waitAnyCatch :: [Async m a] -> m (Async m a, Either SomeException a)
82+
waitAnyCancel :: [Async m a] -> m (Async m a, a)
83+
waitAnyCatchCancel :: [Async m a] -> m (Async m a, Either SomeException a)
84+
waitEither :: Async m a -> Async m b -> m (Either a b)
85+
86+
default waitAnySTM :: MonadThrow (STM m) => [Async m a] -> STM m (Async m a, a)
87+
default waitEitherSTM :: MonadThrow (STM m) => Async m a -> Async m b -> STM m (Either a b)
88+
default waitEitherSTM_ :: MonadThrow (STM m) => Async m a -> Async m b -> STM m ()
89+
default waitBothSTM :: MonadThrow (STM m) => Async m a -> Async m b -> STM m (a, b)
6790

6891
waitAnySTM as =
6992
foldr orElse retry $
@@ -95,33 +118,6 @@ class (Functor async, MonadSTMTx stm) => MonadAsyncSTM async stm where
95118
b <- waitSTM right
96119
return (a,b)
97120

98-
class ( MonadSTM m
99-
, MonadThread m
100-
, MonadAsyncSTM (Async m) (STM m)
101-
) => MonadAsync m where
102-
103-
{-# MINIMAL async, asyncThreadId, cancel, cancelWith, asyncWithUnmask #-}
104-
105-
-- | An asynchronous action
106-
type Async m :: Type -> Type
107-
108-
async :: m a -> m (Async m a)
109-
asyncThreadId :: Proxy m -> Async m a -> ThreadId m
110-
withAsync :: m a -> (Async m a -> m b) -> m b
111-
112-
wait :: Async m a -> m a
113-
poll :: Async m a -> m (Maybe (Either SomeException a))
114-
waitCatch :: Async m a -> m (Either SomeException a)
115-
cancel :: Async m a -> m ()
116-
cancelWith :: Exception e => Async m a -> e -> m ()
117-
uninterruptibleCancel :: Async m a -> m ()
118-
119-
waitAny :: [Async m a] -> m (Async m a, a)
120-
waitAnyCatch :: [Async m a] -> m (Async m a, Either SomeException a)
121-
waitAnyCancel :: [Async m a] -> m (Async m a, a)
122-
waitAnyCatchCancel :: [Async m a] -> m (Async m a, Either SomeException a)
123-
waitEither :: Async m a -> Async m b -> m (Either a b)
124-
125121
-- | Note, IO-based implementations should override the default
126122
-- implementation. See the @async@ package implementation and comments.
127123
-- <http://hackage.haskell.org/package/async-2.2.1/docs/src/Control.Concurrent.Async.html#waitEitherCatch>
@@ -258,25 +254,25 @@ replicateConcurrently_ cnt = runConcurrently . fold . replicate cnt . Concurrent
258254
-- Instance for IO uses the existing async library implementations
259255
--
260256

261-
instance MonadAsyncSTM Async.Async STM.STM where
262-
waitSTM = Async.waitSTM
263-
pollSTM = Async.pollSTM
264-
waitCatchSTM = Async.waitCatchSTM
265-
waitAnySTM = Async.waitAnySTM
266-
waitAnyCatchSTM = Async.waitAnyCatchSTM
267-
waitEitherSTM = Async.waitEitherSTM
268-
waitEitherSTM_ = Async.waitEitherSTM_
269-
waitEitherCatchSTM = Async.waitEitherCatchSTM
270-
waitBothSTM = Async.waitBothSTM
271-
272257
instance MonadAsync IO where
273258

274259
type Async IO = Async.Async
275260

276261
async = Async.async
277-
asyncThreadId = \_proxy -> Async.asyncThreadId
262+
asyncThreadId = Async.asyncThreadId
278263
withAsync = Async.withAsync
279264

265+
waitSTM = Async.waitSTM
266+
pollSTM = Async.pollSTM
267+
waitCatchSTM = Async.waitCatchSTM
268+
269+
waitAnySTM = Async.waitAnySTM
270+
waitAnyCatchSTM = Async.waitAnyCatchSTM
271+
waitEitherSTM = Async.waitEitherSTM
272+
waitEitherSTM_ = Async.waitEitherSTM_
273+
waitEitherCatchSTM = Async.waitEitherCatchSTM
274+
waitBothSTM = Async.waitBothSTM
275+
280276
wait = Async.wait
281277
poll = Async.poll
282278
waitCatch = Async.waitCatch
@@ -302,47 +298,6 @@ instance MonadAsync IO where
302298

303299
asyncWithUnmask = Async.asyncWithUnmask
304300

305-
--
306-
-- Lift to ReaderT
307-
--
308-
309-
(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
310-
(f .: g) x y = f (g x y)
311-
312-
instance MonadAsync m => MonadAsync (ReaderT r m) where
313-
type Async (ReaderT r m) = Async m
314-
315-
asyncThreadId _ = asyncThreadId (Proxy @m)
316-
317-
async (ReaderT ma) = ReaderT $ \r -> async (ma r)
318-
withAsync (ReaderT ma) f = ReaderT $ \r -> withAsync (ma r) $ \a -> runReaderT (f a) r
319-
asyncWithUnmask f = ReaderT $ \r ->
320-
asyncWithUnmask $ \unmask ->
321-
runReaderT (f (liftF unmask)) r
322-
where
323-
liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a
324-
liftF g (ReaderT r) = ReaderT (g . r)
325-
326-
race (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race (ma r) (mb r)
327-
race_ (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race_ (ma r) (mb r)
328-
concurrently (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> concurrently (ma r) (mb r)
329-
330-
wait = lift . wait
331-
poll = lift . poll
332-
waitCatch = lift . waitCatch
333-
cancel = lift . cancel
334-
uninterruptibleCancel = lift . uninterruptibleCancel
335-
cancelWith = lift .: cancelWith
336-
waitAny = lift . waitAny
337-
waitAnyCatch = lift . waitAnyCatch
338-
waitAnyCancel = lift . waitAnyCancel
339-
waitAnyCatchCancel = lift . waitAnyCatchCancel
340-
waitEither = lift .: waitEither
341-
waitEitherCatch = lift .: waitEitherCatch
342-
waitEitherCancel = lift .: waitEitherCancel
343-
waitEitherCatchCancel = lift .: waitEitherCatchCancel
344-
waitEither_ = lift .: waitEither_
345-
waitBoth = lift .: waitBoth
346301

347302
--
348303
-- Linking
@@ -401,7 +356,7 @@ linkToOnly tid shouldThrow a = do
401356
_otherwise -> return ()
402357
where
403358
linkedThreadId :: ThreadId m
404-
linkedThreadId = asyncThreadId (Proxy @m) a
359+
linkedThreadId = asyncThreadId a
405360

406361
exceptionInLinkedThread :: SomeException -> ExceptionInLinkedThread
407362
exceptionInLinkedThread =

0 commit comments

Comments
 (0)