Merge pull request #266 from reflex-frp/ts-requestert-inconsistency

Tests showing RequesterT inconsistency with EventWriterT
reflex-frp · Mar 28, 2019 · 45123e1 · 45123e1
2 parents b1c9506 + baadc4c
commit 45123e1
Show file tree

Hide file tree

Showing 2 changed files with 119 additions and 1 deletion.
diff --git a/test/EventWriterT.hs b/test/EventWriterT.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RecursiveDo #-}
@@ -36,6 +37,9 @@ main = do
   print os4
   os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]
   print os5
+  os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
+  print os6
+  let ![[Nothing, Nothing]] = os6
   return ()
 
 unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
@@ -112,3 +116,17 @@ testLiveTellEventDMap pulse = do
           (mapToDMap $ M.singleton 1 ())
           ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
   return ()
+
+delayedPulse
+  :: forall t m
+  .  ( Reflex t
+     , Adjustable t m
+     , MonadHold t m
+     , MonadFix m
+     )
+  => Event t ()
+  -> EventWriterT t [Int] m ()
+delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do
+    -- This has the effect of delaying pulse' from pulse
+    (_, pulse') <- runWithReplace (pure ()) $ pure [1] <$ pulse
+    tellEvent pulse'
diff --git a/test/RequesterT.hs b/test/RequesterT.hs
@@ -2,13 +2,17 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Main where
 
 import Control.Lens
 import Control.Monad
+import Control.Monad.Fix
 import qualified Data.Dependent.Map as DMap
 import Data.Dependent.Sum
+import Data.Functor.Misc
+import qualified Data.Map as M
 import Data.These
 
 import Reflex
@@ -25,15 +29,27 @@ main = do
     [ Just ()
     ]
   print os1
-  let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1
   os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $
     [ This ()
     , That ()
     , This ()
     , These () ()
     ]
   print os2
+  os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]
+  print os3
+  os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()]
+  print os4
+  os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]
+  print os5
+  os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
+  print os6
+  let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1
   let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2
+  let ![[Nothing, Just [2]]] = os3
+  let ![[Nothing, Just [2]]] = os4
+  let ![[Nothing, Just [1, 2]]] = os5
+  let ![[Nothing, Nothing]] = os6
   return ()
 
 unwrapRequest :: DSum tag RequestInt -> Int
@@ -67,3 +83,87 @@ testSimultaneous pulse = do
       switchE = fmapMaybe (^? there) pulse
   forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
     requestingIdentity (RequestInt (i+1) <$ tellE)
+
+-- | Test that a widget requesting and event which fires at the same time it has been replaced
+-- doesn't count along with the new widget.
+testMoribundRequest
+  :: forall t m
+  .  ( Reflex t
+     , Adjustable t m
+     , MonadHold t m
+     , MonadFix m
+     , Response m ~ Identity
+     , Request m ~ RequestInt
+     , Requester t m
+     )
+  => Event t ()
+  -> m ()
+testMoribundRequest pulse = do
+  rec let requestIntOnReplace x = requestingIdentity $ RequestInt x <$ rwrFinished
+      (_, rwrFinished) <- runWithReplace (requestIntOnReplace 1) $ requestIntOnReplace 2 <$ pulse
+  return ()
+
+-- | The equivalent of 'testMoribundRequest' for 'traverseDMapWithKeyWithAdjust'.
+testMoribundRequestDMap
+  :: forall t m
+  .  ( Reflex t
+     , Adjustable t m
+     , MonadHold t m
+     , MonadFix m
+     , Response m ~ Identity
+     , Request m ~ RequestInt
+     , Requester t m
+     )
+  => Event t ()
+  -> m ()
+testMoribundRequestDMap pulse = do
+  rec let requestIntOnReplace :: Int -> m ()
+          requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
+      (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-
+        traverseDMapWithKeyWithAdjust
+          (\(Const2 ()) (Identity v) -> Identity . const v <$> requestIntOnReplace v)
+          (mapToDMap $ M.singleton () 1)
+          ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)
+  return ()
+
+-- | Ensures that elements which are _not_ removed can still fire requests
+-- during the same frame as other elements are updated.
+testLiveRequestDMap
+  :: forall t m
+  .  ( Reflex t
+     , Adjustable t m
+     , MonadHold t m
+     , MonadFix m
+     , Response m ~ Identity
+     , Request m ~ RequestInt
+     , Requester t m
+     )
+  => Event t ()
+  -> m ()
+testLiveRequestDMap pulse = do
+  rec let requestIntOnReplace :: Int -> m ()
+          requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
+      (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-
+        traverseDMapWithKeyWithAdjust
+          (\(Const2 k) (Identity ()) -> Identity <$> requestIntOnReplace k)
+          (mapToDMap $ M.singleton 1 ())
+          ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
+  return ()
+
+delayedPulse
+  :: forall t m
+  .  ( Reflex t
+     , Adjustable t m
+     , MonadHold t m
+     , MonadFix m
+     , Response m ~ Identity
+     , Request m ~ RequestInt
+     , PerformEvent t m
+     , Requester t m
+     )
+  => Event t ()
+  -> m ()
+delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do
+    -- This has the effect of delaying pulse' from pulse
+    (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse
+    requestingIdentity pulse'