@@ -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_)
@@ -35,8 +36,6 @@ import Data.Traversable
35import System.Exit
36import System.Exit
36import System.Mem
37import System.Mem
38−import System.IO.Unsafe
40mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
39mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
41mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
40mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
42 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
41 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
@@ -73,11 +72,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
72instance (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)
73 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)
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))
77−testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
79+testTimeline builder (bMap, eMap) = do
78 (re, reTrigger) <- newEventWithTriggerRef
80 (re, reTrigger) <- newEventWithTriggerRef
79 (rb, rbTrigger) <- newEventWithTriggerRef
81 (rb, rbTrigger) <- newEventWithTriggerRef
80− b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
82+ b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb
81 (b', e') <- runHostFrame $ builder (b, re)
83 (b', e') <- runHostFrame $ builder (b, re)
82 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
84 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
83 let times = relevantTestingTimes (bMap, eMap)
85 let times = relevantTestingTimes (bMap, eMap)
@@ -102,9 +104,11 @@ testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint
102testAgreement builder inputs = do
104testAgreement builder inputs = do
103 let identityResult = testPure builder inputs
105 let identityResult = testPure builder inputs
104 tracePerf "---------" $ return ()
106 tracePerf "---------" $ return ()
105− let spiderResult = testSpider builder inputs
107+ spiderResult <- S.runSpiderHost $ testTimeline builder inputs
108+ tracePerf "---------" $ return ()
109+ profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs
106 tracePerf "---------" $ return ()
110 tracePerf "---------" $ return ()
107− let resultsAgree = identityResult == spiderResult
111+ let resultsAgree = identityResult == spiderResult && identityResult == profiledResult
108 if resultsAgree
112 if resultsAgree
109 then do --putStrLn "Success:"
113 then do --putStrLn "Success:"
110 --print identityResult
114 --print identityResult
@@ -112,6 +116,7 @@ testAgreement builder inputs = do
112 else do putStrLn "Failure:"
116 else do putStrLn "Failure:"
113 putStrLn $ "Pure result: " <> show identityResult
117 putStrLn $ "Pure result: " <> show identityResult
114 putStrLn $ "Spider result: " <> show spiderResult
118 putStrLn $ "Spider result: " <> show spiderResult
119+ putStrLn $ "Profiled result: " <> show profiledResult
115 return resultsAgree
120 return resultsAgree
117type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
122type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))