Naive Async Monad implementation Now without the extra-thread problem (paired with @ujihisa!!!!)

Monad.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Maestro.Control.Concurrent.Async
       ( AsyncM(..)
       , AsyncStep(..)
       , module Control.Concurrent.Async
       ) where

import Control.Monad.Trans (MonadIO(..))
import Control.Monad.Error (MonadError(..))
import Control.Concurrent.Async

data AsyncStep e a
  = TrulyAsync (Async (Either e a))
  | NonAsync   (Either e a)

newtype AsyncM e a = AsyncM { runAsync :: IO (AsyncStep e a) }

instance Monad (AsyncM e)  where
  return = AsyncM . return . NonAsync . Right
  (AsyncM m) >>= fn = AsyncM $ m >>= performAsync
    where
      performAsync (TrulyAsync m) = do
        eResult <- wait m
        performAsync (NonAsync eResult)
      performAsync (NonAsync eResult) =
        case eResult of
          Right result -> runAsync $ fn result
          Left e -> return $ NonAsync $ Left e

instance MonadIO (AsyncM e) where
  liftIO action = AsyncM $ do
    result <- action
    return $ NonAsync $ Right result

instance MonadError e (AsyncM e) where
  throwError = AsyncM . return . NonAsync . Left
  catchError (AsyncM m) handler = AsyncM $
      m >>= performAsync
    where
      performAsync (TrulyAsync m1) = do
        eResult <- wait m1
        performAsync (NonAsync eResult)
      performAsync (NonAsync eResult) =
        case eResult of
          Left e -> runAsync $ handler e
          Right result -> return $ NonAsync $ Right result

DISCLAIMER: Use it at your own risk, haven't tested the monad laws