Composing IO and Async in haskell

Whether based on MVar or TVar, async implementation are always based on operation on some underlying monad IO and STM.

Making Async a monad on its own, as in F# async computation builder, if done in a naïve way require littering with unsafePerformIO which does not feel very haskellish.

module Async2(Async, async, wait) where

import           Control.Concurrent (forkIO)
import Control.Monad
import Control.Concurrent.MVar
import System.IO.Unsafe

data Async a = Async (MVar a)

wait :: Async a -> IO a
wait  (Async m) = takeMVar m

-- we can't lift it without unsafeperformIO !
async :: IO a -> Async a
async action = unsafePerformIO $ do
  m <- newEmptyMVar
  forkIO $ do r <- action; putMVar m r
  return $ Async m

-- we can't make it a monad without unsafePerformIO !
instance Monad Async where
  return a = Async $ unsafePerformIO $ newMVar a
  m >>= f = let a = unsafePerformIO $ wait m
            in f a 

I can forego having a monad and rely on nested function composition, but that's not very nice compared to do notation. So instead I can try to add some MonadIO somewhere:

module Async3(Async, async, wait) where

import           Control.Concurrent.MVar
import           Control.Concurrent (forkIO)
import Control.Monad
import Control.Monad.IO.Class

data Async m a =  Async (m (MVar a))

async ::  MonadIO m =>  IO a -> (Async m a)
async action = Async $ liftIO $ do
  m <- newEmptyMVar
  forkIO $ do r <- action; putMVar m r
  return m


wait :: MonadIO m => Async m a -> m a
wait  (Async m) = do  mv <- m
                      liftIO $ readMVar mv


instance MonadIO m  =>  Monad (Async m) where
  return a = Async $ liftIO $ newMVar a
  ma >>= f = Async $ do
   r <- wait ma
   let (Async mv) = f r
   mv

-- automatic def
instance  MonadIO m => Functor (Async m) where
  fmap f a' = a' >>= pure . f

instance  MonadIO m => Applicative (Async m) where
  pure = return
  (<*>)  = ap

instance MonadIO m => MonadIO (Async m) where
  liftIO m = Async ( liftIO undefined)

When parametarized by such MonadIO, I can leverage my IO context to get the monadic do notation.

#!/usr/bin/env stack
-- stack --install-ghc --resolver lts-5.13 runghc --package http-conduit
module MainAsync3 where

import Control.Concurrent(forkIO, threadDelay)
import           Async3(Async, async, wait) 

main :: IO ()
main = do
    c <- wait $ do
           r <- do

                   async $ threadDelay 1000000
                   return "hello"
           s <- do
                   async $ threadDelay 1000000
                   return " world"
           return $ r ++ s

    print c 
    return ()

Except I can't perform IO from within Async m itself, so that motivates another round:

module Async4(Async, async, wait) where

import           Control.Concurrent.MVar
import           Control.Concurrent (forkIO)
import Control.Monad
import Control.Monad.IO.Class

data Async m a =  Async (m (Res a))
data Res a = RMVar (MVar a) | Done a

async ::  MonadIO m =>  IO a -> Async m a
async action = Async $ liftIO $ do
  m <- newEmptyMVar
  forkIO $ do r <- action; putMVar m r
  return $ RMVar m


wait :: MonadIO m => Async m a -> m a
wait  (Async m) = do  r <- m
                      case r of
                        RMVar mv -> liftIO $ readMVar mv
                        Done a -> return a


instance MonadIO m  =>  Monad (Async m) where
  return a = Async $ return $ Done a
  ma >>= f = Async $ do
   r <- wait ma
   let (Async mv) = f r
   mv


-- automatic def
instance  MonadIO m => Functor (Async m) where
  fmap f a' = a' >>= pure . f

instance  MonadIO m => Applicative (Async m) where
  pure = return
  (<*>)  = ap

instance MonadIO m => MonadIO (Async m) where
  liftIO m = Async ( liftIO $ Done <$> m)

Which we can call using:

#!/usr/bin/env stack
-- stack --install-ghc --resolver lts-5.13 runghc
module MainAsync4 where

import Control.Concurrent(forkIO, threadDelay)
import           Async4(Async, async, wait) 
import Control.Monad.IO.Class

main :: IO ()
main = do
    putStrLn "starting"
    c <- wait $ do  -- I can wait an async computation
           r <- do -- I can compose sequentially async
                   liftIO $ putStrLn "computing hello" -- I can do IO within async
                   async $ threadDelay 1000000
                   return "hello"
           s <- do
                   async $ threadDelay 1000000
                   return " world"
           return $ r ++ s 

    print c 
    return ()

I feel like it is quite complicated, though. What approaches are there to regain some sanity and nicely hide those calls so that I can get a monad modulo some IO and write nice imperative looking code while composing async operations?

In the end, I know that IO might launch missiles but when you don't launch missiles there must be ways to declare it somehow.

Are there ways known to be superior to deal with these situations? The same problem arises if we swap IO with STM. It's just that I build a new composable language on top of another.

Would effect handlers provide a better answer for instance?