{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeOperators, DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module Control.Eff.Test (testGroups) where
import Test.HUnit hiding (State)
import Test.QuickCheck
import Control.Eff
import Control.Eff.Reader.Strict
import Control.Eff.State.Strict
import Control.Eff.Exception
import qualified Control.Exception as Exc
import Utils
import Test.Framework.TH
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
testGroups = [ $(testGroupGenerator) ]
prop_NestedEff :: Property
prop_NestedEff = forAll arbitrary (\x -> property (qu x == x))
where
qu :: Bool -> Bool
qu x = run $ runReader readerId (readerAp x)
readerAp :: Bool -> Eff '[Reader (Eff '[Reader Bool] Bool)] Bool
readerAp x = do
f <- ask
return . run $ runReader x f
readerId :: Eff '[Reader Bool] Bool
readerId = do
x <- ask
return x
-- | Ensure that https://github.com/RobotGymnast/extensible-effects/issues/11 stays resolved.
case_Lift_building :: Assertion
case_Lift_building = runLift possiblyAmbiguous
where
possiblyAmbiguous :: (Monad m, Lifted m r) => Eff r ()
possiblyAmbiguous = lift $ return ()
case_Lift_tl1r :: Assertion
case_Lift_tl1r = do
((), output) <- catchOutput tl1r
assertEqual "Test tl1r" (showLn input) output
where
input = (5::Int)
-- tl1r :: IO ()
tl1r = runLift (runReader input tl1)
where
tl1 = ask >>= \(x::Int) -> lift . print $ x
case_Lift_tMd' :: Assertion
case_Lift_tMd' = do
actual <- catchOutput tMd'
let expected = (output, (showLines input))
assertEqual "Test mapMdebug using Lift" expected actual
where
input = [1..5]
val = (10::Int)
output = map (+ val) input
tMd' = runLift $ runReader val $ mapMdebug' f input
where f x = ask `add` return x
-- Re-implemenation of mapMdebug using Lifting
-- The signature is inferred
mapMdebug' :: (Show a, Lifted IO r) =>
(a -> Eff r b) -> [a] -> Eff r [b]
mapMdebug' _f [] = return []
mapMdebug' f (h:t) = do
lift $ print h
h' <- f h
t' <- mapMdebug' f t
return (h':t')
-- tests from <http://okmij.org/ftp/Haskell/misc.html#catch-MonadIO>
data MyException = MyException String deriving (Show)
instance Exc.Exception MyException
exfn :: Lifted IO r => Bool -> Eff r Bool
exfn True = lift . Exc.throw $ (MyException "thrown")
exfn False = return True
testc m = catchDynE (m >>= return . show) (\ (MyException s) -> return s)
case_catchDynE_test1 :: Assertion
case_catchDynE_test1 = do
((), actual) <- catchOutput test1
let expected = unlines [ "(\"thrown\",[\"begin\"])"
, "(\"True\",[\"end\",\"begin\"])"]
assertEqual "catchDynE: test1: exception shouldn't drop Writer's state"
expected actual
where
-- In CatchMonadIO, the result of tf True is ("thrown",[]) --
-- that is, an exception will drop the Writer's state, even if that
-- exception is caught. Here, the state is preserved!
-- So, this is an advantage over MTL!
test1 = do runLift (tf True) >>= print; runLift (tf False) >>= print
tf x = runReader (x::Bool) . runState ([]::[String]) $ testc m
m = do
modify ("begin":)
x <- ask
r <- exfn x
modify ("end":)
return r
-- Let us use an Error effect instead
case_catchDynE_test1' :: Assertion
case_catchDynE_test1' = do
((), actual') <- catchOutput test1'
let expected' = unlines [ "(Left \"thrown\",[\"begin\"])"
, "(Right \"True\",[\"end\",\"begin\"])"]
assertEqual "catchDynE: test1': Error shouldn't drop Writer's state"
expected' actual'
where
-- In CatchMonadIO, the result of tf True is ("thrown",[]) --
-- that is, an exception will drop the Writer's state, even if that
-- exception is caught. Here, the state is preserved!
-- So, this is an advantage over MTL!
test1' = do runLift (tf True) >>= print; runLift (tf False) >>= print
tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m)
m = do
modify ("begin":)
x <- ask
r <- exfn x
modify ("end":)
return r
runErrorStr = asEStr . runError
asEStr :: m (Either String a) -> m (Either String a)
asEStr = id
exfn True = throwError $ ("thrown")
exfn False = return True
-- Now, the behavior of the dynamic Exception and Error effect is consistent.
-- The state is preserved. Before it wasn't.
case_catchDynE_test2 :: Assertion
case_catchDynE_test2 = do
((), actual) <- catchOutput test2
let expected = unlines [ "(Left \"thrown\",[\"begin\"])"
, "(Right \"True\",[\"end\",\"begin\"])"]
assertEqual "catchDynE: test2: Error shouldn't drop Writer's state"
expected actual
where
test2 = do runLift (tf True) >>= print; runLift (tf False) >>= print
tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m)
runErrorStr = asEStr . runError
asEStr :: m (Either String a) -> m (Either String a)
asEStr = id
m = do
modify ("begin":)
x <- ask
r <- exfn x `catchDynE` (\ (MyException s) -> throwError s)
modify ("end":)
return r
-- Full recovery
case_catchDynE_test2' :: Assertion
case_catchDynE_test2' = do
((), actual) <- catchOutput test2'
let expected = unlines [ "(Right \"False\",[\"end\",\"begin\"])"
, "(Right \"True\",[\"end\",\"begin\"])"]
assertEqual "catchDynE: test2': Fully recover from errors"
expected actual
where
test2' = do runLift (tf True) >>= print; runLift (tf False) >>= print
tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m)
runErrorStr = asEStr . runError
asEStr :: m (Either String a) -> m (Either String a)
asEStr = id
m = do
modify ("begin":)
x <- ask
r <- exfn x `catchDynE` (\ (MyException _s) -> return False)
modify ("end":)
return r
-- Throwing within a handler
case_catchDynE_test3 :: Assertion
case_catchDynE_test3 = do
((), actual) <- catchOutput test3
let expected = unlines [ "(Right \"rethrow:thrown\",[\"begin\"])"
, "(Right \"True\",[\"end\",\"begin\"])"]
assertEqual "catchDynE: test3: Throwing within a handler"
expected actual
where
test3 = do runLift (tf True) >>= print; runLift (tf False) >>= print
tf x = runReader (x::Bool) . runState ([]::[String]) $ runErrorStr (testc m)
runErrorStr = asEStr . runError
asEStr :: m (Either String a) -> m (Either String a)
asEStr = id
m = do
modify ("begin":)
x <- ask
r <- exfn x `catchDynE` (\ (MyException s) ->
lift . Exc.throw . MyException $
("rethrow:" ++ s))
modify ("end":)
return r
-- Implement the transactional behavior: when the exception is raised,
-- the state is rolled back to what it existed at the entrance to
-- the catch block.
-- This is the ``scoping behavior'' of `Handlers in action'
case_catchDynE_tran :: Assertion
case_catchDynE_tran = do
((), actual) <- catchOutput tran
let expected = unlines ["(\"thrown\",[\"init\"])"
,"(\"True\",[\"end\",\"begin\",\"init\"])"]
assertEqual "catchDynE: tran: Transactional behaviour"
expected actual
where
tran = do runLift (tf True) >>= print; runLift (tf False) >>= print
tf x = runReader (x :: Bool) . runState ([]::[String]) $ m1
m1 = do
modify ("init":)
testc (transactionState (TxState :: TxState [String]) m)
m = do
modify ("begin":)
x <- ask
r <- exfn x
modify ("end":)
return r
{- -- without transaction
("thrown",["begin","init"])
("True",["end","begin","init"])
-}
-- With transaction
{-
("thrown",["init"])
("True",["end","begin","init"])
-}