Instantly share code, notes, and snippets.

Embed
What would you like to do?
#!/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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment