test-control.hs

#!/usr/bin/env stack
-- stack --resolver lts-8.12 script
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Control.Monad.Base
import Control.Monad.Except
import qualified Control.Exception
import System.Exit
import System.Posix.Process
import Data.IORef

newtype Bad a = Bad { runBad :: IO a }
  deriving (Functor, Applicative, Monad)
instance MonadBase IO Bad where
  liftBase = Bad
instance MonadBaseControl IO Bad where
  type StM Bad a = IO a
  liftBaseWith f = Bad $ f (return . runBad)
  restoreM = Bad

main :: IO ()
main = do
  checkControl
  runReaderT checkControl ()
  runExceptT checkControl >>= (print :: Either () () -> IO ())
  runBad checkControl

checkControl :: MonadBaseControl IO m => m ()
checkControl = control $ \run -> do
  ref <- liftBase $ newIORef (0 :: Int)
  let ensureIs :: MonadBase IO m => Int -> m ()
      ensureIs expected = liftBase $ do
        putStrLn $ "ensureIs " ++ show expected
        curr <- atomicModifyIORef ref $ \curr -> (curr + 1, curr)
        unless (curr == expected) $ do
          print ("sanityCheckBalances checkControl, (curr, expected): " :: String, curr, expected)
          exitImmediately (ExitFailure 43)

  ensureIs 0
  Control.Exception.mask $ \restore -> do
    ensureIs 1
    res <- restore (ensureIs 2 >> run (ensureIs 3) `Control.Exception.finally` ensureIs 4)
    ensureIs 5
    return res