@@ -0,0 +1,221 @@
1+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, BangPatterns, ConstraintKinds #-}
2+module Reflex.Test.CrossImpl (test) where
3+
4+import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
5+
6+import Reflex.Class
7+import Reflex.Host.Class
8+import Reflex.Dynamic
9+import qualified Reflex.Spider.Internal as S
10+import qualified Reflex.Pure as P
11+import Control.Monad.Ref
12+
13+import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
14+import qualified Data.Set as Set
15+import Data.Map.Strict (Map)
16+import qualified Data.Map.Strict as Map
17+import Control.Arrow (second, (&&&))
18+import Data.Traversable
19+import Data.Foldable
20+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
21+import Control.Monad.Writer hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
22+import Data.Dependent.Map (DSum (..))
23+import System.Mem
24+
25+import System.IO.Unsafe
26+
27+mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
28+mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
29+ Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
30+ Just (_, v) -> v
31+
32+mapToPureEvent :: Map Int a -> Event PureReflexDomain a
33+mapToPureEvent m = P.Event $ flip Map.lookup m
34+
35+relevantTestingTimes :: (Map Int a, Map Int b) -> [Int]
36+relevantTestingTimes (b, e) = case Set.minView &&& Set.maxView $ Map.keysSet b `Set.union` Map.keysSet e of
37+ (Just (t0, _), Just (t1, _)) -> [t0..t1+1] -- We need to go to b+1 to see the result of the final event
38+ _ -> [] -- Doesn't actually make much sense
39+
40+type PureReflexDomain = P.Pure Int
41+type TimeM = (->) Int
42+
43+testPure :: (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)
44+testPure builder (b, e) =
45+ let (P.Behavior b', P.Event e') = ($ 0) $ builder (mapToPureBehavior b, mapToPureEvent e)
46+ relevantTimes = relevantTestingTimes (b, e)
47+ e'' = Map.mapMaybe id $ Map.fromList $ map (id &&& e') relevantTimes
48+ b'' = Map.fromList $ map (id &&& b') relevantTimes
49+ in (b'', e'')
50+
51+class MapMSignals a a' t t' | a -> t, a' -> t', a t' -> a', a' t -> a where
52+ mapMSignals :: Monad m => (forall b. Behavior t b -> m (Behavior t' b)) -> (forall b. Event t b -> m (Event t' b)) -> a -> m a'
53+
54+instance MapMSignals (Behavior t a) (Behavior t' a) t t' where
55+ mapMSignals fb _ = fb
56+
57+instance MapMSignals (Event t a) (Event t' a) t t' where
58+ mapMSignals _ fe = fe
59+
60+instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
61+ mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
62+
63+testSpider :: (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)
64+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
65+ (re, reTrigger) <- newEventWithTriggerRef
66+ (rb, rbTrigger) <- newEventWithTriggerRef
67+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
68+ (b', e') <- runHostFrame $ builder (b, re)
69+ e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
70+ let times = relevantTestingTimes (bMap, eMap)
71+ liftIO performGC
72+ outputs <- forM times $ \t -> do
73+ forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> val]) =<< readRef rbTrigger
74+ bOutput <- sample b'
75+ eOutput <- liftM join $ forM (Map.lookup t eMap) $ \val -> do
76+ mret <- readRef reTrigger
77+ let firing = case mret of
78+ Just ret -> [ret :=> val]
79+ Nothing -> []
80+ fireEventsAndRead firing $ sequence =<< readEvent e'Handle
81+ liftIO performGC
82+ return (t, (bOutput, eOutput))
83+ return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs)
84+
85+tracePerf :: Show a => a -> b -> b
86+tracePerf = flip const
87+
88+testAgreement :: (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 ()
89+testAgreement builder inputs = do
90+ let identityResult = testPure builder inputs
91+ tracePerf "---------" $ return ()
92+ let spiderResult = testSpider builder inputs
93+ tracePerf "---------" $ return ()
94+ if identityResult == spiderResult then putStrLn "Success:" >> print identityResult else do
95+ putStrLn "Failure:"
96+ putStrLn $ "Pure result: " <> show identityResult
97+ putStrLn $ "Spider result: " <> show spiderResult
98+
99+type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
100+
101+data 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))
102+
103+testCases :: [(String, TestCase)]
104+testCases =
105+ [ (,) "hold" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do
106+ b' <- hold "123" e
107+ return (b', e)
108+ , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do
109+ e' <- liftM updated $ count e
110+ b' <- hold (0 :: Int) e'
111+ return (b', e')
112+ , (,) "onceE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
113+ e' <- onceE $ leftmost [e, e]
114+ return (b, e')
115+ , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
116+ let e' = fmap (const e) e
117+ b' <- hold never e'
118+ let e'' = switch b'
119+ return (b, e'')
120+ , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
121+ let e' = flip pushAlways e $ const $ do
122+ let ea = fmap (const "a") e
123+ let eb = fmap (const "b") e
124+ let eab = leftmost [ea, eb]
125+ liftM switch $ hold eab never
126+ e'' = coincidence e'
127+ return (b, e'')
128+ , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
129+ let e' = flip pushAlways e $ const $ do
130+ let ea = fmap (const "a") e
131+ let eb = fmap (const "b") e
132+ let eab = leftmost [ea, eb]
133+ liftM switch $ hold eab (fmap (const e) e)
134+ e'' = coincidence e'
135+ return (b, e'')
136+ , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
137+ let e' = leftmost [e, e]
138+ e'' <- liftM switch $ hold e' (fmap (const e) e)
139+ return (b, e'')
140+ , (,) "switchPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
141+ let e' = fmap (const e) e
142+ e'' <- switchPromptly never e'
143+ return (b, e'')
144+ , (,) "switchPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
145+ let e' = fmap (const e) e
146+ e'' <- switchPromptly never $ leftmost [e', e']
147+ return (b, e'')
148+ , (,) "switchPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
149+ let e' = leftmost [e, e]
150+ e'' <- switchPromptly never (fmap (const e) e')
151+ return (b, e'')
152+ , (,) "switchPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
153+ let e' = leftmost [e, e]
154+ e'' <- switchPromptly never (fmap (const e') e)
155+ return (b, e'')
156+ , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
157+ let e' = leftmost [e, e]
158+ e'' <- liftM switch $ hold never (fmap (const e') e)
159+ return (b, e'')
160+ , (,) "switchPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
161+ let e' = flip push e $ \_ -> do
162+ return . Just =<< onceE e
163+ e'' <- switchPromptly never e'
164+ return (b, e'')
165+ , (,) "switchPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
166+ let e' = flip pushAlways e $ \_ -> do
167+ switchPromptly e never
168+ e'' <- switchPromptly never e'
169+ return (b, e'')
170+ , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
171+ let e' = flip pushAlways e $ \_ -> return $ fmap id e
172+ e'' = coincidence e'
173+ return (b, e'')
174+ , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
175+ let e' = flip pushAlways e $ \_ -> return $ leftmost [e, e]
176+ e'' = coincidence e'
177+ return (b, e'')
178+ , (,) "coincidence-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
179+ let e' = flip pushAlways e $ \_ -> return $ coincidence $ fmap (const e) e
180+ e'' = coincidence e'
181+ return (b, e'')
182+ , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
183+ let e' = flip pushAlways e $ \_ -> onceE e
184+ e'' = coincidence e'
185+ return (b, e'')
186+ , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
187+ let eChild = flip pushAlways e $ const $ do
188+ let eNewValues = leftmost [e, e]
189+ return $ coincidence $ fmap (const eNewValues) eNewValues
190+ e' = coincidence eChild
191+ return (b, e')
192+ , (,) "coincidence-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
193+ let eChild = flip pushAlways e $ const $ do
194+ let e' = coincidence $ fmap (const e) e
195+ return $ leftmost [e', e']
196+ e'' = coincidence eChild
197+ return (b, e'')
198+ , (,) "coincidence-7" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
199+ let e' = leftmost [e, e]
200+ eCoincidences = coincidence $ fmap (const e') e
201+ return (b, eCoincidences)
202+ , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
203+ eo <- onceE e
204+ bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo
205+ let b' = pull $ sample =<< sample bb
206+ return (b', e)
207+ , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
208+ bb <- hold "b" e
209+ bd <- hold never . fmap (const e) =<< onceE e
210+ eOuter <- liftM (pushAlways sample . fmap (const bb)) $ onceE e
211+ let eInner = switch bd
212+ e' = leftmost [eOuter, eInner]
213+ return (b, e')
214+ ]
215+
216+test :: IO ()
217+test = do
218+ forM_ testCases $ \(name, TestCase inputs builder) -> do
219+ putStrLn $ "Test: " <> name
220+ testAgreement builder inputs
221+ return ()