@@ -1,4 +1,5 @@
11{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GADTs #-}
23{-# LANGUAGE RecursiveDo #-}
34{-# LANGUAGE ScopedTypeVariables #-}
45module Main where
@@ -6,6 +7,9 @@ module Main where
67import Control.Lens
78import Control.Monad
89import Control.Monad.Fix
10+import qualified Data.Dependent.Map as DMap
11+import Data.Functor.Misc
12+import qualified Data.Map as M
913import Data.These
1014
1115import Reflex
@@ -28,6 +32,10 @@ main = do
2832 print os2
2933 os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]
3034 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
3139 return ()
3240
3341unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
@@ -59,7 +67,48 @@ testMoribundTellEvent
5967 => Event t ()
6068 -> EventWriterT t [Int] m ()
6169testMoribundTellEvent pulse = do
62− rec let tellIntOnReplce :: Int -> EventWriterT t [Int] m ()
63− tellIntOnReplce x = tellEvent $ [x] <$ rwrFinished
64− (_, rwrFinished) <- runWithReplace (tellIntOnReplce 1) $ tellIntOnReplce 2 <$ pulse
70+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
71+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
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)
65114 return ()