git.iko.soy/reflex
on develop help sign in
reflex/test/Reflex/Test/Micro.hs
352 lines 9.8 kB history raw
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE RecursiveDo #-}
11module Reflex.Test.Micro (testCases) where
13import Reflex
14import Reflex.TestPlan
16import Control.Applicative
17import Control.Monad
18import Control.Monad.Fix
19import Data.Char
20import Data.Foldable
21import Data.Functor.Misc
22import qualified Data.Map as Map
23import Data.Monoid
25import Prelude
27pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b)
28pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d))
30foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a)
31foldedDyn f d = fmap join $ flip buildDynamic never $ do
32 a <- sample (current d)
33 foldDyn f a (updated d)
35scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a])
36scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure
38scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a])
39scanInnerDyns d = do
40 scans <- scannedDyn d
41 return (join (fmap distributeListOverDynPure scans))
45{-# ANN testCases "HLint: ignore Functor law" #-}
46testCases :: [(String, TestCase)]
47testCases =
48 [ testB "hold" $ hold "0" =<< events1
50 , testB "count" $ do
51 b <- current <$> (count =<< events2)
52 return $ (+ (0::Int)) <$> b
54 , testB "pull-1" $ do
55 b <- hold "0" =<< events1
56 return (pull $ sample $ pull $ sample b)
58 , testB "pull-2" $ do
59 b1 <- behavior1
60 return (pull $ liftA2 (<>) (sample b1) (sample b1))
62 , testB "pull-3" $ do
63 b1 <- behavior1
64 b2 <- behavior2
65 return (pull $ liftA2 (<>) (sample b1) (sample b2))
67 , testB "pull-4" $ do
68 es <- planList ["a", "b", "c"]
69 e <- plan [(0, ())]
70 b <- hold (constant "") $
71 pushAlways (const $ hold "z" es) e
72 return (join b)
74 , testE "id" $ do
75 events2
77 , testE "fmap-id" $ do
78 e <- events2
79 return $ fmap id e
81 , testE "tag-1" $ do
82 b1 <- behavior1
83 e <- events2
84 return (tag b1 e)
86 , testE "tag-2" $ do
87 b1 <- behavior1
88 e <- events2
89 return (tag (map toUpper <$> b1) e)
91 , testE "attach-1" $ do
92 b1 <- behavior1
93 e <- events2
94 return (attachWith (++) (map toUpper <$> b1) e)
96 , testE "leftmost" $ liftA2 leftmost2 events1 events2
98 , testE "appendEvents-1" $ liftA2 mappend events1 events2
100 , testE "appendEvents-2" $ liftA2 mappend events3 events2
102 , testE "merge-1" $ do
103 e <- events1
104 return $ leftmost ["x" <$ e, "y" <$ e]
106 , testE "merge-2" $ do
107 e <- events1
108 let m = mergeMap $ Map.fromList [(1::Int, "y" <$ e), (2, "z" <$ e)]
109 let ee = flip pushAlways e $ const $ return m
110 return $ coincidence ee
112 , testE "headE-1" $ do
113 e <- events1
114 headE $ leftmost [e, e]
116 , testE "headE-2" $ do
117 e <- events1
118 b <- hold never (e <$ e)
119 headE $ switch b
121 , testE "switch-1" $ do
122 e <- events1
123 b <- hold never (e <$ e)
124 return $ switch b
126 , testE "switch-2" $ do
127 e <- events1
128 return $ coincidence $ flip pushAlways e $ const $ do
129 switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) (e <$ e)
131 , testE "switch-3" $ do
132 e <- events1
133 return $ coincidence $ flip pushAlways e $ const $ do
134 switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) never
136 , testE "switch-4" $ do
137 e <- events1
138 switch <$> hold (deep e) (e <$ e)
140 , testE "switch-5" $ do
141 e <- events1
142 return $ coincidence $ flip pushAlways e $ const $
143 return $ leftmost ["x" <$ e, "y" <$ e, "z" <$ e]
145 , testE "switch-6" $ do
146 e <- events1
147 return $ coincidence $ flip pushAlways e $ const $ do
148 switch <$> hold ("x" <$ e) (e <$ e)
150 , testE "switchHoldPromptly-1" $ do
151 e <- events1
152 let e' = e <$ e
153 switchHoldPromptly never $ e <$ e'
155 , testE "switchHoldPromptly-2" $ do
156 e <- events1
157 switchHoldPromptly never $ deep (e <$ e)
159 , testE "switchHoldPromptly-3" $ do
160 e <- events1
161 switchHoldPromptly never $ (e <$ deep e)
163 , testE "switchHoldPromptly-4" $ do
164 e <- events1
165 switchHoldPromptly never $ (deep e <$ e)
167 , testE "switch-5" $ do
168 e <- events1
169 switch <$> hold never (deep e <$ e)
171 , testE "switchHoldPromptly-5" $ do
172 e <- events1
173 switchHoldPromptly never $ flip push e $
174 const (Just <$> headE e)
176 , testE "switchHoldPromptly-6" $ do
177 e <- events1
178 switchHoldPromptly never $ flip pushAlways e $
179 const (switchHoldPromptly e never)
181 , testE "coincidence-1" $ do
182 e <- events1
183 return $ coincidence $ flip pushAlways e $
184 const $ return e
186 , testE "coincidence-2" $ do
187 e <- events1
188 return $ coincidence $ flip pushAlways e $
189 const $ return (deep e)
191 , testE "coincidence-3" $ do
192 e <- events1
193 return $ coincidence $ flip pushAlways e $
194 const $ return (coincidence (e <$ e))
196 , testE "coincidence-4" $ do
197 e <- events1
198 return $ coincidence $ flip pushAlways e $
199 const (headE e)
201 , testE "coincidence-5" $ do
202 e <- events1
203 return $ coincidence $ flip pushAlways e $ const $ do
204 let e' = deep e
205 return (coincidence (e' <$ e'))
207 , testE "coincidence-6" $ do
208 e <- events1
209 return $ coincidence $ flip pushAlways e $ const $ do
210 let e' = coincidence (e <$ e)
211 return $ deep e'
213 , testE "coincidence-7" $ do
214 e <- events1
215 return $ coincidence (deep e <$ e)
217 , testB "holdWhileFiring" $ do
218 e <- events1
219 eo <- headE e
220 bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo
221 return $ pull $ sample =<< sample bb
224 , testB "foldDynWhileFiring" $ do
225 e <- events1
226 d <- foldDyn (:) [] $
227 pushAlways (\a -> foldDyn (:) [a] e) e
229 return $ current (join (fmap distributeListOverDynPure d))
231 , testE "joinDyn" $ do
232 e <- events1
233 bb <- hold "b" e
234 bd <- hold never . fmap (const e) =<< headE e
236 eOuter <- pushAlways sample . fmap (const bb) <$> headE e
237 let eInner = switch bd
238 return $ leftmost [eOuter, eInner]
240 , testB "foldDyn" $ do
241 d <- foldDyn (++) "0" =<< events1
242 return (current d)
244 , testB "mapDyn" $ do
245 d <- foldDyn (++) "0" =<< events1
246 return $ current $ fmap (map toUpper) d
248 , testB "combineDyn" $ do
249 d1 <- foldDyn (++) "0" =<< events1
250 d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2
252 return $ current $ zipDynWith (<>) d1 d2
254 , testB "buildDynamicStrictness" $ do
255 rec
256 d'' <- pushDyn return d'
257 d' <- pushDyn return d
258 d <- holdDyn "0" =<< events1
260 _ <- sample (current d'')
261 return (current d'')
263 , testB "factorDyn" $ do
264 d <- holdDyn (Left "a") =<< eithers
266 eithers' <- eitherDyn d
267 let unFactor = either id id
268 return $ current (join (fmap unFactor eithers'))
270 , testB "pushDynDeep" $ do
271 _ <- events1
272 _ <- events2
274 d1 <- holdDyn "d1" =<< events1
275 d2 <- holdDyn "d2" =<< events2
277 d <- flip pushDyn d1 $ \a ->
278 flip pushDyn d2 $ \b ->
279 flip pushDyn d1 $ \c ->
280 return (a <> b <> c)
282 d' <- pushDyn scanInnerDyns d >>= scanInnerDyns
283 return $ current d'
285 , testE "fan-1" $ do
286 e <- fmap toMap <$> events1
287 let es = select (fanMap e) . Const2 <$> values
289 return (mergeList es)
291 , testE "fan-2" $ do
292 e <- fmap toMap <$> events3
293 let es = select (fanMap e) . Const2 <$> values
295 return (mergeList es)
297 , testE "fan-3" $ do
298 f <- fanMap . fmap toMap <$> events3
299 return $ select f (Const2 'c')
301 , testE "fan-4" $ do
302 e <- fmap toMap <$> events1
303 return $ toUpper <$> select (fanMap e) (Const2 'a')
305 , testE "fan-5" $ do
306 e <- fmap toMap <$> events2
307 return $ toUpper <$> select (fanMap e) (Const2 'c')
309 , testE "fan-6" $ do
310 f <- fanMap . fmap toMap <$> events1
311 return $ toList <$> mergeList [ select f (Const2 'b'), select f (Const2 'b'), select f (Const2 'e'), select f (Const2 'e') ]
313 , testE "difference" $ do
314 e1 <- events1
315 e2 <- events2
316 return $ e1 `difference ` e2
318 , testE "lazy-hold" $ do
319 let lazyHold :: forall t m. (Reflex t, MonadHold t m, MonadFix m) => m (Event t ())
320 lazyHold = do
321 rec !b <- hold never e
322 let e = never <$ switch b
323 return $ void e
324 lazyHold
325 , testE "now-1" $ do
326 e1 <- events1
327 switchHoldPromptly never . pushAlways (\a -> fmap (a <$) now) $ e1
328 , testE "now-2" $ do
329 e1 <- events1
330 let e = pushAlways (\a -> if a == "a" then now else return never) e1
331 x <- accumDyn (<>) never e
332 return . coincidence $ updated x
333 ] where
335 events1, events2, events3 :: TestPlan t m => m (Event t String)
336 events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]
337 events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]
338 events3 = liftA2 mappend events1 events2
340 eithers :: TestPlan t m => m (Event t (Either String String))
341 eithers = plan [(1, Left "e"), (3, Left "d"), (4, Right "c"), (6, Right "b"), (7, Left "a")]
344 values = "abcde"
345 toMap str = Map.fromList $ map (\c -> (c, c)) str
347 behavior1, behavior2 :: forall t m. TestPlan t m => m (Behavior t String)
348 behavior1 = hold "1" =<< events1
349 behavior2 = hold "2" =<< events2
351 deep e = leftmost [e, e]
352 leftmost2 e1 e2 = leftmost [e1, e2]