{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-}

-- from base:

#if !MIN_VERSION_base(4,6,0)

import Prelude hiding (catch)

#endif

import Data.IORef

import Data.Maybe

import Data.Typeable (Typeable)

-- from transformers-base:

import Control.Monad.Base (liftBase)

-- from transformers:

import Control.Monad.Trans.Identity

import Control.Monad.Trans.List

import Control.Monad.Trans.Maybe

import Control.Monad.Trans.Reader

import Control.Monad.Trans.Writer

import Control.Monad.Trans.Except

import Control.Monad.Trans.State

import qualified Control.Monad.Trans.RWS as RWS

-- from monad-control:

import Control.Monad.Trans.Control (MonadBaseControl)

-- from lifted-base (this package):

import Control.Exception.Lifted

-- from test-framework:

import Test.Framework (defaultMain, testGroup, Test)

 -- from test-framework-hunit:

import Test.Framework.Providers.HUnit

-- from hunit:

import Test.HUnit hiding (Test)

main :: IO ()

main = defaultMain

    [ testSuite "IdentityT" runIdentityT

    , testSuite "ListT" $ fmap head . runListT

    , testSuite "MaybeT" $ fmap fromJust . runMaybeT

    , testSuite "ReaderT" $ flip runReaderT "reader state"

    , testSuite "WriterT" runWriterT'

    , testSuite "ExceptT" runExceptT'

    , testSuite "StateT" $ flip evalStateT "state state"

    , testSuite "RWST" $ \m -> runRWST' m "RWS in" "RWS state"

    , testCase "ExceptT throwE" case_throwE

    , testCase "WriterT tell" case_tell

    ]

  where

    runWriterT' :: Functor m => WriterT [Int] m a -> m a

    runWriterT' = fmap fst . runWriterT

    runExceptT' :: Functor m => ExceptT String m () -> m ()

    runExceptT' = fmap (either (const ()) id) . runExceptT

    runRWST' :: (Monad m, Functor m) => RWS.RWST r [Int] s m a -> r -> s -> m a

    runRWST' m r s = fmap fst $ RWS.evalRWST m r s

testSuite :: MonadBaseControl IO m => String -> (m () -> IO ()) -> Test

testSuite s run = testGroup s

    [ testCase "finally" $ case_finally run

    , testCase "catch" $ case_catch run

    , testCase "bracket" $ case_bracket run

    , testCase "bracket_" $ case_bracket_ run

    , testCase "onException" $ case_onException run

    ]

ignore :: IO () -> IO ()

ignore x =

    catch x go

  where

    go :: SomeException -> IO ()

    go _ = return ()

data Exc = Exc

    deriving (Show, Typeable)

instance Exception Exc

one :: Int

one = 1

case_finally :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion

case_finally run = do

    i <- newIORef one

    ignore

        (run $ (do

            liftBase $ writeIORef i 2

            error "error") `finally` (liftBase $ writeIORef i 3))

    j <- readIORef i

    j @?= 3

case_catch :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion

case_catch run = do

    i <- newIORef one

    run $ (do

        liftBase $ writeIORef i 2

        throw Exc) `catch` (\Exc -> liftBase $ writeIORef i 3)

    j <- readIORef i

    j @?= 3

case_bracket :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion

case_bracket run = do

    i <- newIORef one

    ignore $ run $ bracket

        (liftBase $ writeIORef i 2)

        (\() -> liftBase $ writeIORef i 4)

        (\() -> liftBase $ writeIORef i 3)

    j <- readIORef i

    j @?= 4

case_bracket_ :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion

case_bracket_ run = do

    i <- newIORef one

    ignore $ run $ bracket_

        (liftBase $ writeIORef i 2)

        (liftBase $ writeIORef i 4)

        (liftBase $ writeIORef i 3)

    j <- readIORef i

    j @?= 4

case_onException :: MonadBaseControl IO m => (m () -> IO ()) -> Assertion

case_onException run = do

    i <- newIORef one

    ignore $ run $ onException

        (liftBase (writeIORef i 2) >> error "ignored")

        (liftBase $ writeIORef i 3)

    j <- readIORef i

    j @?= 3

    ignore $ run $ onException

        (liftBase $ writeIORef i 4)

        (liftBase $ writeIORef i 5)

    k <- readIORef i

    k @?= 4

case_throwE :: Assertion

case_throwE = do

    i <- newIORef one

    Left "throwE" <- runExceptT $

        (liftBase (writeIORef i 2) >> throwE "throwE")

        `finally`

        (liftBase $ writeIORef i 3)

    j <- readIORef i

    j @?= 3

case_tell :: Assertion

case_tell = do

    i <- newIORef one

    ((), w) <- runWriterT $ bracket_

        (liftBase (writeIORef i 2) >> tell [1 :: Int])

        (liftBase (writeIORef i 4) >> tell [3])

        (liftBase (writeIORef i 3) >> tell [2])

    j <- readIORef i

    j @?= 4

    w @?= [2]

    ((), w') <- runWriterT $ bracket

        (liftBase (writeIORef i 5) >> tell [5 :: Int])

        (const $ liftBase (writeIORef i 7) >> tell [7])

        (const $ liftBase (writeIORef i 6) >> tell [6])

    j' <- readIORef i

    j' @?= 7

    w' @?= [5, 6]