MonadUnliftIO

Early.hs

{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Early where

-- https://chrisdone.com/posts/exceptt-vs-early-do/
-- https://hackage.haskell.org/package/unliftio-core-0.2.0.1/docs/src/Control.Monad.IO.Unlift.html#MonadUnliftIO
-- https://hackage.haskell.org/package/unliftio-0.2.14/docs/src/UnliftIO.Internals.Async.html#concurrently

import Control.Monad.IO.Class
import Control.Monad.Trans
import Control.Monad.Trans.Except
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Reader
import qualified Control.Concurrent.Async as A (concurrently)

class MonadIO m => MonadUnliftIO m where
  withRunInIO :: ((forall a. m a -> IO a) -> IO b) -> m b

instance MonadUnliftIO IO where
  withRunInIO inner = inner id

instance MonadUnliftIO m => MonadUnliftIO (IdentityT m) where
  withRunInIO :: forall b. ((forall a. IdentityT m a -> IO a) -> IO b)
              -> IdentityT m b
  withRunInIO inner = IdentityT $ withRunInIO inner'
    where
    inner' :: (forall a. m a -> IO a) -> IO b
    inner' run = inner (run . runIdentityT)

instance MonadUnliftIO m => MonadUnliftIO (ReaderT r m) where
  withRunInIO :: forall b. ((forall a. ReaderT r m a -> IO a) -> IO b)
              -> ReaderT r m b
  withRunInIO inner = ReaderT $ \r -> withRunInIO (inner' r)
    where
    inner' :: r -> (forall a. m a -> IO a) -> IO b
    inner' r run = inner (run . flip runReaderT r)

concurrently :: MonadUnliftIO m => m a -> m b -> m (a, b)
concurrently a b = withRunInIO $ \run -> A.concurrently (run a) (run b)

type RIO r a = ReaderT r IO a

foo :: Int -> RIO () (Either () ())
foo i = runExceptT $ do
  ExceptT $ bar (i + 1)
  ExceptT $ zot (i + 2)

bar :: Int -> RIO () (Either () ((), ()))
bar i = runExceptT $ do
  ExceptT $ zot 0
  r <- ExceptT $ fmap Right ask
  ExceptT $ fmap
    (\(x, y) -> (,) <$> x <*> y)
    (concurrently
      (foo (i + 1))
      (zot (i + 2)))

zot :: Int -> RIO () (Either () ())
zot i = runExceptT $ do
  ExceptT $ bar (i + 1)
  ExceptT $ zot (i + 2)