git.iko.soy/effectful
on b42e0dc help sign in
effectful/tests/Main.hs
191 lines 5.5 kB history raw
1module Main (main) where
3import Control.Monad.IO.Class
4import Test.Tasty
5import Test.Tasty.HUnit
6import qualified Control.Monad.Catch as E
7import qualified Control.Exception.Lifted as LE
8import GHC.Stack (getCallStack)
9import qualified UnliftIO.Exception as UE
11import Effectful.Async
12import Effectful.Error
13import Effectful.Interpreter
14import Effectful.State.Dynamic
15import Effectful.Monad
17main :: IO ()
18main = 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 ]
29 ]
31test_runState :: Assertion
32test_runState = runIOE $ do
33 (end, len) <- runState (0::Int) . execState collatzStart $ collatz
34 assertEqual_ "correct end" 1 end
35 assertEqual_ "correct len" collatzLength len
37test_evalState :: Assertion
38test_evalState = runIOE $ do
39 len <- evalState (0::Int) . evalState collatzStart $ collatz *> get @Int
40 assertEqual_ "correct len" collatzLength len
42test_stateM :: Assertion
43test_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
48test_deepStack :: Assertion
49test_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
60test_exceptions :: Assertion
61test_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
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
89 action :: State Int :> es => Eff es ()
90 action = do
91 modify @Int (+1)
92 _ <- E.throwM Ex
93 modify @Int (+2)
95test_concurrentState :: Assertion
96test_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
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
113test_localEffects :: Assertion
114test_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
124test_errorFromInterpret :: Assertion
125test_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"
133----------------------------------------
134-- Helpers
136data NestedErr :: Effect where
137 NestedErr :: NestedErr m ()
139nestedErr :: (HasCallStack, NestedErr :> es) => Eff es ()
140nestedErr = send NestedErr
142runNestedErr :: Error String :> es => Eff (NestedErr : es) a -> Eff es a
143runNestedErr = interpret $ \NestedErr -> throwError "nested error"
145----------------------------------------
147data HasInt :: Effect where
148 GetInt :: HasInt m Int
149 PutInt :: Int -> HasInt m ()
151getInt :: HasInt :> es => Eff es Int
152getInt = send GetInt
154putInt :: HasInt :> es => Int -> Eff es ()
155putInt = send . PutInt
157runHasInt :: Int -> Eff (HasInt : es) a -> Eff es a
158runHasInt n =
159 -- reinterpret with redundant local effects
160 reinterpret (evalState () . evalState n . evalState True) $ \case
161 GetInt -> get
162 PutInt i -> put i
164----------------------------------------
166data Ex = Ex deriving (Eq, Show)
167instance E.Exception Ex
169assertEqual_ :: (Eq a, Show a, IOE :> es) => String -> a -> a -> Eff es ()
170assertEqual_ msg expected given = liftIO $ assertEqual msg expected given
172----------------------------------------
174collatzStart :: Integer
175collatzStart = 9780657630
177collatzLength :: Int
178collatzLength = 1132
180-- | Tests multiple 'State'S, 'put', 'get' and 'modify'.
181collatz :: (State Integer :> es, State Int :> es) => Eff es ()
182collatz = 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 #-}