{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Control.Effects.Async where
import Import
import Control.Effects
import qualified Control.Concurrent.Async as Async
import Control.Monad.Runnable
data Async m = AsyncMethods
{ _async :: forall a. m a -> m (AsyncThread m a)
, _waitAsync :: forall a. AsyncThread m a -> m a }
newtype AsyncThread m a = AsyncThread (Async.Async (m a))
deriving (Functor, Eq, Ord)
instance Effect Async where
type CanLift Async t = RunnableTrans t
mergeContext mm = AsyncMethods
(\a -> mm >>= ($ a) . _async)
(\a -> mm >>= ($ a) . _waitAsync)
liftThrough (AsyncMethods f g) = AsyncMethods
(\tma -> do
st <- currentTransState
!res <- lift (f (runTransformer tma st))
return $ mapAsync (lift >=> restoreTransState) res
)
(\a -> do
st <- currentTransState
res <- lift (g (mapAsync (`runTransformer` st) a))
restoreTransState res
)
where
mapAsync :: (m a -> n b) -> AsyncThread m a -> AsyncThread n b
mapAsync f' (AsyncThread as) = AsyncThread (fmap f' as)
instance MonadEffect Async IO where
effect = AsyncMethods
(fmap (AsyncThread . fmap return) . Async.async)
(\(AsyncThread as) -> join (Async.wait as))
async :: MonadEffect Async m => m a -> m (AsyncThread m a)
waitAsync :: MonadEffect Async m => AsyncThread m a -> m a
AsyncMethods async waitAsync = effect
implementAsyncViaIO :: IO a -> IO a
implementAsyncViaIO = id