@@ -21,6 +21,7 @@ import Reflex.Dynamic
21import Reflex.Host.Class
21import Reflex.Host.Class
22import qualified Reflex.Pure as P
22import qualified Reflex.Pure as P
23import qualified Reflex.Spider.Internal as S
23import qualified Reflex.Spider.Internal as S
24+import qualified Reflex.Profiled as Prof
25import Control.Arrow (second, (&&&))
26import Control.Arrow (second, (&&&))
26import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
27import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
@@ -73,11 +74,14 @@ instance MapMSignals (Event t a) (Event t' a) t t' where
73instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
74instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
74 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
75 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
76−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)
78+ :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))
79+ -> (Map Int a, Map Int b)
80+ -> (forall m t. (MonadReflexHost t m, MonadIO m, MonadRef m, Ref m ~ Ref IO, MonadSample t m) => m (Map Int c, Map Int d))
77−testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
81+testTimeline builder (bMap, eMap) = do
78 (re, reTrigger) <- newEventWithTriggerRef
82 (re, reTrigger) <- newEventWithTriggerRef
79 (rb, rbTrigger) <- newEventWithTriggerRef
83 (rb, rbTrigger) <- newEventWithTriggerRef
80− b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
84+ b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb
81 (b', e') <- runHostFrame $ builder (b, re)
85 (b', e') <- runHostFrame $ builder (b, re)
82 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
86 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
83 let times = relevantTestingTimes (bMap, eMap)
87 let times = relevantTestingTimes (bMap, eMap)
@@ -102,9 +106,11 @@ testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint
102testAgreement builder inputs = do
106testAgreement builder inputs = do
103 let identityResult = testPure builder inputs
107 let identityResult = testPure builder inputs
104 tracePerf "---------" $ return ()
108 tracePerf "---------" $ return ()
105− let spiderResult = testSpider builder inputs
109+ let spiderResult = unsafePerformIO $ S.runSpiderHost $ testTimeline builder inputs
106 tracePerf "---------" $ return ()
110 tracePerf "---------" $ return ()
111+ let profiledResult = unsafePerformIO $ S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs
112+ tracePerf "---------" $ return ()
107− let resultsAgree = identityResult == spiderResult
113+ let resultsAgree = identityResult == spiderResult && identityResult == profiledResult
108 if resultsAgree
114 if resultsAgree
109 then do --putStrLn "Success:"
115 then do --putStrLn "Success:"
110 --print identityResult
116 --print identityResult
@@ -112,6 +118,7 @@ testAgreement builder inputs = do
112 else do putStrLn "Failure:"
118 else do putStrLn "Failure:"
113 putStrLn $ "Pure result: " <> show identityResult
119 putStrLn $ "Pure result: " <> show identityResult
114 putStrLn $ "Spider result: " <> show spiderResult
120 putStrLn $ "Spider result: " <> show spiderResult
121+ putStrLn $ "Profiled result: " <> show profiledResult
115 return resultsAgree
122 return resultsAgree
117type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
124type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))