ExceptT with resource handling, async, and exceptions

Main.hs

module Main where

import Control.Concurrent.Async (async, wait)
import Control.Exception (Exception, catch, throwIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
import Control.Monad.Trans.Resource (ResourceT, allocate, release, runResourceT)

newtype MyException = MyException String deriving Show
instance Exception MyException

err1 :: ResourceT IO (Either String Int)
-- err1 = lift (putStrLn "Calculating err1") >> pure (Left "No go")
err1 = lift (putStrLn "Calculating err1") >> pure (pure 5)

err2 :: IO (Either String Int)
-- err2 = putStrLn "Calculating err2" >> pure (Left "No go")
err2 = putStrLn "Calculating err2" >> pure (pure 6)

err3 :: IO (Either String Int)
-- err3 = putStrLn "Calculating err3" >> pure (Left "No go")
err3 = putStrLn "Calculating err3" >> pure (pure 7)

err4 :: IO (Either String Int)
-- err4 = putStrLn "Calculating err4" >> pure (Left "No go")
err4 = putStrLn "Calculating err4" >> pure (pure 8)

-- runExceptT inside ResourceT
doSomething1 :: IO (Either String Int)
doSomething1 = runResourceT $ runExceptT $ do
  blah <- ExceptT $ lift err2

  (key, resource) <- allocate
    (pure 0)
    (\i -> putStrLn $ "Freeing the number " ++ show i)
  a <- ExceptT err1
  liftIO $ throwIO $ MyException "This is an emergency!" -- Throws exception
  b <- ExceptT $ lift err4
  release key
  let bar = a * b

  foo <- ExceptT $ lift err3
  return $ blah + foo + bar

-- runResourceT inside ExceptT
doSomething2 :: IO (Either String Int)
doSomething2 = runExceptT $ do
  blah <- ExceptT err2

  bar <- ExceptT $ runResourceT $ runExceptT $ do
    (key, resource) <- allocate
      (pure 0)
      (\i -> putStrLn $ "Freeing the number " ++ show i)
    a <- ExceptT err1
    liftIO $ throwIO $ MyException "This is an emergency!" -- Throws exception
    b <- ExceptT $ lift err4
    release key
    return $ a * b

  foo <- ExceptT err3
  return $ blah + foo + bar

-- async
doSomething3 :: IO (Either String Int)
doSomething3 = do
  result <- async $ runExceptT $ do
    a <- ExceptT err2
    b <- ExceptT err3
    return $ a + b
  wait result

handleMyException :: IO (Either String a) -> IO (Either String a)
handleMyException io = io `catch` \(MyException e) -> do
  putStrLn $ "Caught exception: " ++ show e
  return $ Left e

main :: IO ()
main = do
  handleMyException doSomething1 >>= print
  handleMyException doSomething2 >>= print
  doSomething3 >>= print