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