git.iko.soy/patch
on develop help sign in
Add traverseDMapWithKeyWithAdjust test for EventWriterT
6ddfb78Ken Micklas
reflex.cabal+1
compare with develop
unifiedsplit
@@ -208,6 +208,7 @@ test-suite EventWriterT
208 build-depends: base
208 build-depends: base
209 , containers
209 , containers
210 , deepseq >= 1.3 && < 1.5
210 , deepseq >= 1.3 && < 1.5
211+ , dependent-map
211 , dependent-sum
212 , dependent-sum
212 , lens
213 , lens
213 , mtl
214 , mtl
test/EventWriterT.hs+52−3
@@ -1,4 +1,5 @@
1{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GADTs #-}
2{-# LANGUAGE RecursiveDo #-}
3{-# LANGUAGE RecursiveDo #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
4module Main where
5module Main where
@@ -6,6 +7,9 @@ module Main where
6import Control.Lens
7import Control.Lens
7import Control.Monad
8import Control.Monad
8import Control.Monad.Fix
9import Control.Monad.Fix
10+import qualified Data.Dependent.Map as DMap
11+import Data.Functor.Misc
12+import qualified Data.Map as M
9import Data.These
13import Data.These
10
14
11import Reflex
15import Reflex
@@ -28,6 +32,10 @@ main = do
28 print os2
32 print os2
29 os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]
33 os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]
30 print os3
34 print os3
35+ os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]
36+ print os4
37+ os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]
38+ print os5
31 return ()
39 return ()
32
40
33unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
41unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
@@ -59,7 +67,48 @@ testMoribundTellEvent
59 => Event t ()
67 => Event t ()
60 -> EventWriterT t [Int] m ()
68 -> EventWriterT t [Int] m ()
61testMoribundTellEvent pulse = do
69testMoribundTellEvent pulse = do
62− rec let tellIntOnReplce :: Int -> EventWriterT t [Int] m ()
70+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
63− tellIntOnReplce x = tellEvent $ [x] <$ rwrFinished
71+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
64− (_, rwrFinished) <- runWithReplace (tellIntOnReplce 1) $ tellIntOnReplce 2 <$ pulse
72+ (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse
73+ return ()
74+
75+-- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'.
76+testMoribundTellEventDMap
77+ :: forall t m
78+ . ( Reflex t
79+ , Adjustable t m
80+ , MonadHold t m
81+ , MonadFix m
82+ )
83+ => Event t ()
84+ -> EventWriterT t [Int] m ()
85+testMoribundTellEventDMap pulse = do
86+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
87+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
88+ (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-
89+ traverseDMapWithKeyWithAdjust
90+ (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v)
91+ (mapToDMap $ M.singleton () 1)
92+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)
93+ return ()
94+
95+-- | Ensures that elements which are _not_ removed can still fire 'tellEvent's
96+-- during the same frame as other elements are updated.
97+testLiveTellEventDMap
98+ :: forall t m
99+ . ( Reflex t
100+ , Adjustable t m
101+ , MonadHold t m
102+ , MonadFix m
103+ )
104+ => Event t ()
105+ -> EventWriterT t [Int] m ()
106+testLiveTellEventDMap pulse = do
107+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
108+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
109+ (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-
110+ traverseDMapWithKeyWithAdjust
111+ (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k)
112+ (mapToDMap $ M.singleton 1 ())
113+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
65 return ()
114 return ()