git.iko.soy/reflex
on develop help sign in
reflex/test/Reflex/Test/CrossImpl.hs
267 lines 13 kB history raw
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE NoMonomorphismRestriction #-}
9{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RecursiveDo #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE UndecidableInstances #-}
16import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_)
18import Control.Monad.Ref
19import Reflex.Class
20import Reflex.Dynamic
21import Reflex.Host.Class
22import qualified Reflex.Pure as P
23import qualified Reflex.Spider.Internal as S
24import qualified Reflex.Profiled as Prof
26import Control.Arrow (second, (&&&))
27import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
28import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
29import Data.Dependent.Sum (DSum (..))
30import Data.Foldable
31import Data.Map.Strict (Map)
32import qualified Data.Map.Strict as Map
33import qualified Data.Set as Set
34import Data.Monoid
35import Data.Traversable
36import System.Exit
37import System.Mem
39mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
40mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
41 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
42 Just (_, v) -> v
44mapToPureEvent :: Map Int a -> Event PureReflexDomain a
45mapToPureEvent m = P.Event $ flip Map.lookup m
47relevantTestingTimes :: (Map Int a, Map Int b) -> [Int]
48relevantTestingTimes (b, e) = case Set.minView &&& Set.maxView $ Map.keysSet b `Set.union` Map.keysSet e of
49 (Just (t0, _), Just (t1, _)) -> [t0..t1+1] -- We need to go to b+1 to see the result of the final event
50 _ -> [] -- Doesn't actually make much sense
52type PureReflexDomain = P.Pure Int
53type TimeM = (->) Int
55testPure :: (t ~ PureReflexDomain, m ~ TimeM) => ((Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)
56testPure builder (b, e) =
57 let (P.Behavior b', P.Event e') = ($ 0) $ builder (mapToPureBehavior b, mapToPureEvent e)
58 relevantTimes = relevantTestingTimes (b, e)
59 e'' = Map.mapMaybe id $ Map.fromList $ map (id &&& e') relevantTimes
60 b'' = Map.fromList $ map (id &&& b') relevantTimes
61 in (b'', e'')
63class MapMSignals a a' t t' | a -> t, a' -> t', a t' -> a', a' t -> a where
64 mapMSignals :: Monad m => (forall b. Behavior t b -> m (Behavior t' b)) -> (forall b. Event t b -> m (Event t' b)) -> a -> m a'
66instance MapMSignals (Behavior t a) (Behavior t' a) t t' where
67 mapMSignals fb _ = fb
69instance MapMSignals (Event t a) (Event t' a) t t' where
70 mapMSignals _ fe = fe
72instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
73 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
75testTimeline
76 :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))
77 -> (Map Int a, Map Int b)
78 -> (forall m t. (MonadReflexHost t m, MonadIO m, MonadRef m, Ref m ~ Ref IO, MonadSample t m) => m (Map Int c, Map Int d))
79testTimeline builder (bMap, eMap) = do
80 (re, reTrigger) <- newEventWithTriggerRef
81 (rb, rbTrigger) <- newEventWithTriggerRef
82 b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb
83 (b', e') <- runHostFrame $ builder (b, re)
84 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
85 let times = relevantTestingTimes (bMap, eMap)
86 liftIO performGC
87 outputs <- forM times $ \t -> do
88 forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger
89 bOutput <- sample b'
90 eOutput <- fmap join $ forM (Map.lookup t eMap) $ \val -> do
91 mret <- readRef reTrigger
92 let firing = case mret of
93 Just ret -> [ret :=> Identity val]
94 Nothing -> []
95 fireEventsAndRead firing $ sequence =<< readEvent e'Handle
96 liftIO performGC
97 return (t, (bOutput, eOutput))
98 return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs)
100tracePerf :: Show a => a -> b -> b
101tracePerf = flip const
103testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> IO Bool
104testAgreement builder inputs = do
105 let identityResult = testPure builder inputs
106 tracePerf "---------" $ return ()
107 spiderResult <- S.runSpiderHost $ testTimeline builder inputs
108 tracePerf "---------" $ return ()
109 profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs
110 tracePerf "---------" $ return ()
111 let resultsAgree = identityResult == spiderResult && identityResult == profiledResult
112 if resultsAgree
113 then do --putStrLn "Success:"
114 --print identityResult
115 return ()
116 else do putStrLn "Failure:"
117 putStrLn $ "Pure result: " <> show identityResult
118 putStrLn $ "Spider result: " <> show spiderResult
119 putStrLn $ "Profiled result: " <> show profiledResult
120 return resultsAgree
122type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
124data TestCase = forall a b c d. (Eq c, Eq d, Show c, Show d) => TestCase (Map Int a, Map Int b) (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))
126testCases :: [(String, TestCase)]
127testCases =
128 [ (,) "hold" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do
129 b' <- hold "123" e
130 return (b', e)
131 , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do
132 e' <- updated <$> count e
133 b' <- hold (0 :: Int) e'
134 return (b', e')
135 , (,) "headE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
136 e' <- headE $ leftmost [e, e]
137 return (b, e')
138 , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
139 let e' = fmap (const e) e
140 b' <- hold never e'
141 let e'' = switch b'
142 return (b, e'')
143 , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
144 let e' = flip pushAlways e $ const $ do
145 let eab = splitRecombineEvent e
146 switch <$> hold eab never
147 e'' = coincidence e'
148 return (b, e'')
149 , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
150 let e' = flip pushAlways e $ const $ do
151 let eab = splitRecombineEvent e
152 switch <$> hold eab (fmap (const e) e)
153 e'' = coincidence e'
154 return (b, e'')
155 , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
156 let e' = leftmost [e, e]
157 e'' <- switch <$> hold e' (fmap (const e) e)
158 return (b, e'')
159 , (,) "switchHoldPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
160 let e' = fmap (const e) e
161 e'' <- switchHoldPromptly never e'
162 return (b, e'')
163 , (,) "switchHoldPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
164 let e' = fmap (const e) e
165 e'' <- switchHoldPromptly never $ leftmost [e', e']
166 return (b, e'')
167 , (,) "switchHoldPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
168 let e' = leftmost [e, e]
169 e'' <- switchHoldPromptly never (fmap (const e) e')
170 return (b, e'')
171 , (,) "switchHoldPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
172 let e' = leftmost [e, e]
173 e'' <- switchHoldPromptly never (fmap (const e') e)
174 return (b, e'')
175 , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
176 let e' = leftmost [e, e]
177 e'' <- switch <$> hold never (fmap (const e') e)
178 return (b, e'')
179 , (,) "switchHoldPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
180 let e' = flip push e $ \_ -> do
181 Just <$> headE e
182 e'' <- switchHoldPromptly never e'
183 return (b, e'')
184 , (,) "switchHoldPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
185 let e' = flip pushAlways e $ \_ -> do
186 switchHoldPromptly e never
187 e'' <- switchHoldPromptly never e'
188 return (b, e'')
189 , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
190 let e' = flip pushAlways e $ \_ -> return e
191 e'' = coincidence e'
192 return (b, e'')
193 , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
194 let e' = flip pushAlways e $ \_ -> return $ leftmost [e, e]
195 e'' = coincidence e'
196 return (b, e'')
197 , (,) "coincidence-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
198 let e' = flip pushAlways e $ \_ -> return $ coincidence $ fmap (const e) e
199 e'' = coincidence e'
200 return (b, e'')
201 , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
202 let e' = flip pushAlways e $ \_ -> headE e
203 e'' = coincidence e'
204 return (b, e'')
205 , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
206 let eChild = flip pushAlways e $ const $ do
207 let eNewValues = leftmost [e, e]
208 return $ coincidence $ fmap (const eNewValues) eNewValues
209 e' = coincidence eChild
210 return (b, e')
211 , (,) "coincidence-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
212 let eChild = flip pushAlways e $ const $ do
213 let e' = coincidence $ fmap (const e) e
214 return $ leftmost [e', e']
215 e'' = coincidence eChild
216 return (b, e'')
217 , (,) "coincidence-7" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
218 let e' = leftmost [e, e]
219 eCoincidences = coincidence $ fmap (const e') e
220 return (b, eCoincidences)
221 , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
222 eo <- headE e
223 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo
224 let b' = pull $ sample =<< sample bb
225 return (b', e)
226 , (,) "foldDynWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do
227 d <- foldDyn (:) [] $
228 pushAlways (\a -> foldDyn (:) [a] e) e
229 let b = current (join (fmap distributeListOverDynPure d))
230 return (b, e)
231 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
232 bb <- hold "b" e
233 bd <- hold never . fmap (const e) =<< headE e
234 eOuter <- pushAlways sample . fmap (const bb) <$> headE e
235 let eInner = switch bd
236 e' = leftmost [eOuter, eInner]
237 return (b, e')
238 , (,) "holdUniqDyn-laziness" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList (zip [1 :: Int ..] [1 :: Int, 2, 2, 3, 3, 3, 4, 4, 4, 4])) $ \(_, e :: Event t Int) -> do
239 rec result <- holdUniqDyn d
240 d <- holdDyn (0 :: Int) e
241 return (current result, updated result)
245 {-
246 , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do
247 x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e
248 let e' = mergeIncrementalWithMove x :: Event t (DMap (EitherTag () ()) Identity)
249 return (b, e')
250 -}
251 ]
253splitRecombineEvent :: Reflex t => Event t a -> Event t String
254splitRecombineEvent e =
255 let ea = "a" <$ e
256 eb = "b" <$ e
257 in leftmost [ea, eb]
260main :: IO ()
261main = do
262 results <- forM testCases $ \(name, TestCase inputs builder) -> do
263 putStrLn $ "Test: " <> name
264 testAgreement builder inputs
265 exitWith $ if and results
266 then ExitSuccess
267 else ExitFailure 1