reflex 0.6.4 → 0.6.4.1

raw patch · 4 files changed

+23/−10 lines, 4 files

Files

• ChangeLog.md +8/−0
• reflex.cabal +1/−1
• src/Reflex/Profiled.hs +2/−2
• test/Reflex/Test/CrossImpl.hs +12/−7

@@ -1,5 +1,13 @@ # Revision history for reflex +## 0.6.4.1++* Fix a bug in the Reflex Profiled transformer where+  `Reflex.Class.mergeIncrementalG` and+  `Reflex.Class.mergeIncrementalWithMoveG` implementations referenced+  itself instead of the inner transformed timeline, causing an+  infinite loop.+ ## 0.6.4  * Support GHC 8.8

@@ -1,5 +1,5 @@ Name: reflex-Version: 0.6.4+Version: 0.6.4.1 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3

@@ -147,8 +147,8 @@   updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d   unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'   unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'-  mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt-  mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt+  mergeIncrementalG nt res = Event_Profiled $ mergeIncrementalG (coerce nt) (coerce res)+  mergeIncrementalWithMoveG nt res = Event_Profiled $ mergeIncrementalWithMoveG (coerce nt) (coerce res)   currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i   updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i   incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

@@ -21,6 +21,7 @@ import Reflex.Host.Class import qualified Reflex.Pure as P import qualified Reflex.Spider.Internal as S+import qualified Reflex.Profiled as Prof  import Control.Arrow (second, (&&&)) import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)@@ -35,8 +36,6 @@ import System.Exit import System.Mem -import System.IO.Unsafe- mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of   Nothing -> error $ "mapToPureBehavior: no value for time " <> show t@@ -73,11 +72,14 @@ instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where   mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b) -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)-testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do+testTimeline+  :: (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)+  -> (forall m t. (MonadReflexHost t m, MonadIO m, MonadRef m, Ref m ~ Ref IO, MonadSample t m) => m (Map Int c, Map Int d))+testTimeline builder (bMap, eMap) = do   (re, reTrigger) <- newEventWithTriggerRef   (rb, rbTrigger) <- newEventWithTriggerRef-  b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb+  b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb   (b', e') <- runHostFrame $ builder (b, re)   e'Handle <- subscribeEvent e' --TODO: This should be unnecessary   let times = relevantTestingTimes (bMap, eMap)@@ -102,9 +104,11 @@ testAgreement builder inputs = do   let identityResult = testPure builder inputs   tracePerf "---------" $ return ()-  let spiderResult = testSpider builder inputs+  spiderResult <- S.runSpiderHost $ testTimeline builder inputs   tracePerf "---------" $ return ()-  let resultsAgree = identityResult == spiderResult+  profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs+  tracePerf "---------" $ return ()+  let resultsAgree = identityResult == spiderResult && identityResult == profiledResult   if resultsAgree     then do --putStrLn "Success:"             --print identityResult@@ -112,6 +116,7 @@     else do putStrLn "Failure:"             putStrLn $ "Pure result: " <> show identityResult             putStrLn $ "Spider result:   " <> show spiderResult+            putStrLn $ "Profiled result:   " <> show profiledResult   return resultsAgree  type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))