{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeOperators, DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
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
assertOutput "Test tl1r" [show 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
(actualResult, actualOutput) <- catchOutput tMd'
let expected = (output, map show input)
assertEqual "Test mapMdebug using Lift" expected (actualResult, lines actualOutput)
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)
test1 m = do runLift (tf m True) >>= print; runLift (tf m False) >>= print
tf m x = runReader (x::Bool) . runState ([]::[String]) $ m
runErrorStr = runError @String
case_catchDynE_test1 :: Assertion
case_catchDynE_test1 = do
((), actual) <- catchOutput $ test1 (testc m)
let expected = [ "(\"thrown\",[\"begin\"])"
, "(\"True\",[\"end\",\"begin\"])"]
assertOutput "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!
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 (runErrorStr (testc m))
let expected' = [ "(Left \"thrown\",[\"begin\"])"
, "(Right \"True\",[\"end\",\"begin\"])"]
assertOutput "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!
m = do
modify ("begin":)
x <- ask
r <- exfn x
modify ("end":)
return r
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 $ test1 (runErrorStr (testc m))
let expected = [ "(Left \"thrown\",[\"begin\"])"
, "(Right \"True\",[\"end\",\"begin\"])"]
assertOutput "catchDynE: test2: Error shouldn't drop Writer's state"
expected actual
where
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 $ test1 (runErrorStr (testc m))
let expected = [ "(Right \"False\",[\"end\",\"begin\"])"
, "(Right \"True\",[\"end\",\"begin\"])"]
assertOutput "catchDynE: test2': Fully recover from errors"
expected actual
where
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 $ test1 (runErrorStr (testc m))
let expected = [ "(Right \"rethrow:thrown\",[\"begin\"])"
, "(Right \"True\",[\"end\",\"begin\"])"]
assertOutput "catchDynE: test3: Throwing within a handler"
expected actual
where
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
((), actual1) <- catchOutput $ test1 m1
((), actual2) <- catchOutput $ test1 m2
let expected1 = ["(\"thrown\",[\"init\"])"
,"(\"True\",[\"end\",\"begin\",\"init\"])"]
let expected2 = ["(\"thrown\",[\"begin\",\"init\"])"
,"(\"True\",[\"end\",\"begin\",\"init\"])"]
assertOutput "catchDynE: tran: Transactional behaviour" expected1 actual1
>> assertOutput "catchDynE: tran: usual behaviour" expected2 actual2
where
m1 = do
modify ("init":)
testc (transactionState (TxState :: TxState [String]) m)
m2 = do
modify ("init":)
testc m
m = do
modify ("begin":)
x <- ask
r <- exfn x
modify ("end":)
return r