@@ -1,191 +1,14 @@
11module Main (main) where
22
3−import Control.Monad.IO.Class
43import Test.Tasty
5−import Test.Tasty.HUnit
6−import qualified Control.Monad.Catch as E
7−import qualified Control.Exception.Lifted as LE
8−import GHC.Stack (getCallStack)
9−import qualified UnliftIO.Exception as UE
104
11−import Effectful.Async
12−import Effectful.Error
13−import Effectful.Interpreter
14−import Effectful.State.Dynamic
15−import Effectful.Monad
5+import AsyncTests
6+import ErrorTests
7+import StateTests
168
179main :: IO ()
1810main = defaultMain $ testGroup "effectful"
19− [ testGroup "state"
20− [ testCase "runState & execState" test_runState
21− , testCase "evalState" test_evalState
22− , testCase "stateM" test_stateM
23− , testCase "deep stack" test_deepStack
24− , testCase "exceptions" test_exceptions
25− , testCase "concurrency" test_concurrentState
26− , testCase "local effects" test_localEffects
27− , testCase "error from interpret" test_errorFromInterpret
28− ]
11+ [ asyncTests
12+ , errorTests
13+ , stateTests
2914 ]
30−
31−test_runState :: Assertion
32−test_runState = runIOE $ do
33− (end, len) <- runState (0::Int) . execState collatzStart $ collatz
34− assertEqual_ "correct end" 1 end
35− assertEqual_ "correct len" collatzLength len
36−
37−test_evalState :: Assertion
38−test_evalState = runIOE $ do
39− len <- evalState (0::Int) . evalState collatzStart $ collatz *> get @Int
40− assertEqual_ "correct len" collatzLength len
41−
42−test_stateM :: Assertion
43−test_stateM = runIOE $ do
44− (a, b) <- runState "hi" . stateM $ \s -> pure (s, s ++ "!!!")
45− assertEqual_ "correct a" "hi" a
46− assertEqual_ "correct b" "hi!!!" b
47−
48−test_deepStack :: Assertion
49−test_deepStack = runIOE $ do
50− n <- evalState () . execState (0::Int) $ do
51− evalState () . evalState () $ do
52− evalState () $ do
53− evalState () . evalState () . evalState () $ do
54− modify @Int (+1)
55− modify @Int (+2)
56− modify @Int (+4)
57− modify @Int (+8)
58− assertEqual_ "n" 15 n
59−
60−test_exceptions :: Assertion
61−test_exceptions = runIOE $ do
62− testTry "exceptions" E.try
63− testCatch "exceptions" E.catch
64− testTry "lifted-base" LE.try
65− testCatch "lifted-base" LE.catch
66− testTry "unliftio" UE.try
67− testCatch "unliftio" UE.catch
68− where
69− testTry
70− :: String
71− -> (forall a es. IOE :> es => Eff es a -> Eff es (Either Ex a))
72− -> Eff '[IOE] ()
73− testTry lib tryImpl = do
74− e <- tryImpl $ runState (0::Int) action
75− assertEqual_ (lib ++ " - exception caught") e (Left Ex)
76− s <- execState (0::Int) $ tryImpl action
77− assertEqual_ (lib ++ " - state partially updated") s 1
78−
79− testCatch
80− :: String
81− -> (forall a es. IOE :> es => Eff es a -> (Ex -> Eff es a) -> Eff es a)
82− -> Eff '[IOE] ()
83− testCatch lib catchImpl = do
84− s <- execState (0::Int) $ do
85− _ <- (evalState () action) `catchImpl` \Ex -> modify @Int (+4)
86− modify @Int (+8)
87− assertEqual_ (lib ++ " - state correctly updated") s 13
88−
89− action :: State Int :> es => Eff es ()
90− action = do
91− modify @Int (+1)
92− _ <- E.throwM Ex
93− modify @Int (+2)
94−
95−test_concurrentState :: Assertion
96−test_concurrentState = runIOE . evalState x $ do
97− runAsyncE . replicateConcurrently_ 2 $ do
98− r <- goDownward 0
99− assertEqual_ "x = n" x r
100− where
101− x :: Int
102− x = 1000000
103−
104− goDownward :: State Int :> es => Int -> Eff es Int
105− goDownward acc = do
106− end <- state @Int $ \case
107− 0 -> (True, 0)
108− n -> (False, n - 1)
109− if end
110− then pure acc
111− else goDownward $ acc + 1
112−
113−test_localEffects :: Assertion
114−test_localEffects = runIOE $ do
115− x <- runHasInt 0 $ do
116− putInt 1
117− execState () $ do
118− putInt 2
119− execState () $ do
120− putInt 4
121− getInt
122− assertEqual_ "correct x" 4 x
123−
124−test_errorFromInterpret :: Assertion
125−test_errorFromInterpret = runIOE $ do
126− result <- runError @String . runNestedErr $ do
127− runError @String nestedErr
128− liftIO $ case result of
129− Left (cs, _) -> assertBool "stack trace points to the correct action" $
130− "nestedErr" == fst (last $ getCallStack cs)
131− Right _ -> assertFailure "error caught by the wrong (inner) handler"
132−
133−----------------------------------------
134−-- Helpers
135−
136−data NestedErr :: Effect where
137− NestedErr :: NestedErr m ()
138−
139−nestedErr :: (HasCallStack, NestedErr :> es) => Eff es ()
140−nestedErr = send NestedErr
141−
142−runNestedErr :: Error String :> es => Eff (NestedErr : es) a -> Eff es a
143−runNestedErr = interpret $ \NestedErr -> throwError "nested error"
144−
145−----------------------------------------
146−
147−data HasInt :: Effect where
148− GetInt :: HasInt m Int
149− PutInt :: Int -> HasInt m ()
150−
151−getInt :: HasInt :> es => Eff es Int
152−getInt = send GetInt
153−
154−putInt :: HasInt :> es => Int -> Eff es ()
155−putInt = send . PutInt
156−
157−runHasInt :: Int -> Eff (HasInt : es) a -> Eff es a
158−runHasInt n =
159− -- reinterpret with redundant local effects
160− reinterpret (evalState () . evalState n . evalState True) $ \case
161− GetInt -> get
162− PutInt i -> put i
163−
164−----------------------------------------
165−
166−data Ex = Ex deriving (Eq, Show)
167−instance E.Exception Ex
168−
169−assertEqual_ :: (Eq a, Show a, IOE :> es) => String -> a -> a -> Eff es ()
170−assertEqual_ msg expected given = liftIO $ assertEqual msg expected given
171−
172−----------------------------------------
173−
174−collatzStart :: Integer
175−collatzStart = 9780657630
176−
177−collatzLength :: Int
178−collatzLength = 1132
179−
180−-- | Tests multiple 'State'S, 'put', 'get' and 'modify'.
181−collatz :: (State Integer :> es, State Int :> es) => Eff es ()
182−collatz = get @Integer >>= \case
183− 1 -> pure ()
184− n -> if even n
185− then do put $ n `div` 2
186− modify @Int (+1)
187− collatz
188− else do put $ 3*n + 1
189− modify @Int (+1)
190− collatz
191−{-# NOINLINE collatz #-}