Permalink
Switch branches/tags
Find file
Fetching contributors…
Cannot retrieve contributors at this time
124 lines (118 sloc) 4.96 KB
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
import Control.Applicative
import Control.Monad.Trans.Class
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Error (ErrorT(..),catchError,throwError)
import Control.Monad.Trans.State (StateT(..),execState,modify)
import Control.Monad.Trans.Writer (WriterT(..),tell,listen,pass,runWriter)
import Data.Functor.Identity
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit
import Test.QuickCheck
import Control.Monad.Trans.Abort
main = defaultMain
[testGroup "Functor"
[testGroup "Identity"
[testProperty "without Abort" $
\(x :: Int) (y :: Int) (== x+y) . runAbort . fmap (+y) . return $ x
,testProperty "with goto" $
\(x :: Int) (y :: Int) (== x) . runAbort . fmap (+y) . abort $ x
]
,testGroup "Maybe"
[testProperty "without Abort" $
\(x :: Int) (y :: Int) (== Just (x+y)) . runAbortT . fmap (+y) . lift . Just $ x
,testProperty "with Abort" $
\(x :: Int) (y :: Int) (== Just x) . runAbortT . fmap (+y) . (>>= abort) . lift . Just $ x
]
]
,testGroup "Applicative"
[testGroup "Identity"
[testProperty "without Abort" $
\(x :: Int) (y :: Int) runAbort (return (+y) <*> return x) == x+y
,testProperty "with Abort" $
\(x :: Int) (y :: Int) runAbort (return (+y) <*> abort x) == x
]
]
,testGroup "Monad"
[testGroup "Maybe"
[testGroup "Just"
[testProperty "without Abort" $
\(x :: Int) (y :: Int) (== Just (x+y)) . runAbortT $ do
a lift (Just x)
b lift (Just y)
return (a+b)
,testProperty "with Abort" $
\(x :: Int) (y :: Int) (== Just x) . runAbortT $ do
a lift (Just x)
abort a
b lift (Just y)
return (a+b)
]
,testGroup "Nothing"
[testProperty "without Abort" $
\(x :: Int) (y :: Int) (== Nothing) . runAbortT $ do
a lift (Just x)
b lift (Just y)
lift Nothing
return (a+b)
,testProperty "with Abort" $
\(x :: Int) (y :: Int) (== Just x) . runAbortT $ do
a lift (Just x)
abort a
b lift (Just y)
lift Nothing
return (a+b)
]
]
,testGroup "State"
[testProperty "without Abort" $
\(x :: Int) (y :: Int) (== x+y) . flip execState x . runAbortT $ do
lift (modify (+y))
,testProperty "with Abort" $
\(x :: Int) (y :: Int) (== x) . flip execState x . runAbortT $ do
abort ()
lift (modify (+y))
]
]
,testGroup "lifters"
[testGroup "liftCallCC"
[testCase "callCC bypasses abort" $
True @=? (flip runCont id . runAbortT . liftCallCC callCC $ \c (c True >> abort False))
,testCase "abort bypasses callCC" $
True @=? (flip runCont id . runAbortT . liftCallCC callCC $ \c (abort True >> c False))
]
,testGroup "liftCatch"
[testCase "throwError bypasses abort" $
Right True @=? (runIdentity . runErrorT . runAbortT $
liftCatch catchError
(lift (throwError "") >> abort False)
(\_ return True)
)
,testCase "abort bypasses throwError" $
Right True @=? (runIdentity . runErrorT . runAbortT $
liftCatch catchError
(abort True >> lift (throwError ""))
(\_ return False)
)
]
,testGroup "liftListen"
[testCase "abort before tell" $
((True,"right"),"") @=? (runWriter . runAbortT $ do
liftListen listen (abort (True,"right") >> lift (tell "wrong") >> return False)
)
,testCase "abort after tell" $
((True,"A"),"B") @=? (runWriter . runAbortT $ do
liftListen listen (lift (tell "B") >> abort (True,"A") >> return False)
)
]
,testGroup "liftPass"
[testCase "abort bypasses function" $
(True,"") @=? (runWriter . runAbortT $ do
liftPass pass (abort True >> return (False,const "wrong"))
)
]
]
]