@@ -1,282 +1,7 @@
1−-- | This module provides 'EventWriterT', the standard implementation of
4−{-# LANGUAGE ExistentialQuantification #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE Rank2Types #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−#ifdef USE_REFLEX_OPTIMIZER
15−{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
17module Reflex.EventWriter
1module Reflex.EventWriter
18− ( EventWriterT (..)
2+ {-# DEPRECATED "Use 'Reflex.EventWriter.Class' and 'Reflex.EventWriter.Base' instead, or just import 'Reflex'" #-}
19− , runEventWriterT
3+ ( module X
21− , runWithReplaceEventWriterTWith
22− , sequenceDMapWithAdjustEventWriterTWith
26−import Reflex.Class
6+import Reflex.EventWriter.Base as X
27−import Reflex.Host.Class
28−import Reflex.PerformEvent.Class
29−import Reflex.PostBuild.Class
30−import Reflex.Query.Class
7+import Reflex.EventWriter.Class as X
31−import Reflex.Requester.Class
32−import Reflex.TriggerEvent.Class
34−import Control.Monad.Exception
35−import Control.Monad.Identity
36−import Control.Monad.Reader
37−import Control.Monad.Ref
38−import Control.Monad.State.Strict
39−import Data.Dependent.Map (DMap, DSum (..))
40−import qualified Data.Dependent.Map as DMap
42−import Data.Functor.Compose
43−import Data.Functor.Misc
44−import Data.GADT.Compare (GEq (..), GCompare (..), GOrdering (..))
45−import Data.IntMap.Strict (IntMap)
46−import qualified Data.IntMap.Strict as IntMap
47−import Data.List.NonEmpty (NonEmpty (..))
50−import Data.Some (Some)
52−import Data.Type.Equality
56−-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
57−-- and combines them monoidally to provide an 'Event' result.
58−class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
59− tellEvent :: Event t w -> m ()
61−{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
63− = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead
64− deriving (Show, Eq, Ord, Enum)
66−tellId :: Int -> TellId w w
70−tellIdRefl :: TellId w x -> w :~: x
71−tellIdRefl _ = unsafeCoerce Refl
73−withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
74−withTellIdRefl tid r = case tellIdRefl tid of
77−instance GEq (TellId w) where
85−instance GCompare (TellId w) where
89− case a `compare` b of
94−data EventWriterState t w = EventWriterState
95− { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
96− , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order
99−-- | A basic implementation of 'EventWriter'.
100−newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
101− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
103−-- | Run a 'EventWriterT' action.
104−runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
105−runEventWriterT (EventWriterT a) = do
106− (result, requests) <- runStateT a $ EventWriterState (-1) []
107− let combineResults :: DMap (TellId w) Identity -> w
108− combineResults = sconcat
109− . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
110− . DMap.foldlWithKey (\vs tid (Identity v) -> withTellIdRefl tid $ v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order
111− return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests) --TODO: We can probably make this fromDistinctAscList more efficient by knowing the length in advance, but this will require exposing internals of DMap; also converting it to use a strict list might help
113−instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
114− tellEvent w = EventWriterT $ modify $ \old ->
115− let myId = _eventWriterState_nextId old
117− { _eventWriterState_nextId = pred myId
118− , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
121−instance EventWriter t w m => EventWriter t w (ReaderT r m) where
122− tellEvent = lift . tellEvent
124−instance MonadTrans (EventWriterT t w) where
125− lift = EventWriterT . lift
127−instance MonadSample t m => MonadSample t (EventWriterT t w m) where
128− sample = lift . sample
130−instance MonadHold t m => MonadHold t (EventWriterT t w m) where
131− {-# INLINABLE hold #-}
132− hold v0 = lift . hold v0
133− {-# INLINABLE holdDyn #-}
134− holdDyn v0 = lift . holdDyn v0
135− {-# INLINABLE holdIncremental #-}
136− holdIncremental v0 = lift . holdIncremental v0
137− {-# INLINABLE buildDynamic #-}
138− buildDynamic a0 = lift . buildDynamic a0
139− {-# INLINABLE headE #-}
140− headE = lift . headE
142−instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
143− runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
144− traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental
145− traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
146− traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
148−instance Requester t m => Requester t (EventWriterT t w m) where
149− type Request (EventWriterT t w m) = Request m
150− type Response (EventWriterT t w m) = Response m
151− requesting = lift . requesting
152− requesting_ = lift . requesting_
154−-- | Given a function like 'runWithReplace' for the underlying monad, implement
155−-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
156−-- monad doesn't have a 'Adjustable' instance or to override the default
157−-- 'Adjustable' behavior.
158−runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)
159− => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
160− -> EventWriterT t w m a
161− -> Event t (EventWriterT t w m b)
162− -> EventWriterT t w m (a, Event t b)
163−runWithReplaceEventWriterTWith f a0 a' = do
164− (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
165− request <- holdDyn (snd result0) $ fmapCheap snd result'
166− -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
167− tellEvent $ coincidence $ updated request
168− tellEvent $ switch $ current request
169− return (fst result0, fmapCheap fst result')
171−-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
172−sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))
173− => ( (IntMap.Key -> v -> m (Event t w, v'))
176− -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
178− -> (p (Event t w) -> [Event t w])
179− -> (Incremental t (p (Event t w)) -> Event t (IntMap w))
180− -> (IntMap.Key -> v -> EventWriterT t w m v')
183− -> EventWriterT t w m (IntMap v', Event t (p v'))
184−sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
185− let f' :: IntMap.Key -> v -> m (Event t w, v')
186− f' k v = swap <$> runEventWriterT (f k v)
187− (children0, children') <- base f' dm0 dm'
188− let result0 = fmap snd children0
189− result' = fmapCheap (fmap snd) children'
190− requests0 :: IntMap (Event t w)
191− requests0 = fmap fst children0
192− requests' :: Event t (p (Event t w))
193− requests' = fmapCheap (fmap fst) children'
194− childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'
195− -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
196− tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
197− tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
199− h : t -> Just $ sconcat $ h :| t
200− return (result0, result')
202−-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
203−sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))
204− => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
207− -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
209− -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
210− -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
211− -> (p' (Some k) (Event t w) -> [Event t w])
212− -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
213− -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
216− -> EventWriterT t w m (DMap k v', Event t (p k v'))
217−sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
218− let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
219− f' k v = Compose . swap <$> runEventWriterT (f k v)
220− (children0, children') <- base f' dm0 dm'
221− let result0 = DMap.map (snd . getCompose) children0
222− result' = fforCheap children' $ mapPatch $ snd . getCompose
223− requests0 :: Map (Some k) (Event t w)
224− requests0 = weakenDMapWith (fst . getCompose) children0
225− requests' :: Event t (p' (Some k) (Event t w))
226− requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
227− childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
228− -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
229− tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
230− tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
232− h : t -> Just $ sconcat $ h :| t
233− return (result0, result')
235−instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
236− type Performable (EventWriterT t w m) = Performable m
237− performEvent_ = lift . performEvent_
238− performEvent = lift . performEvent
240−instance PostBuild t m => PostBuild t (EventWriterT t w m) where
241− getPostBuild = lift getPostBuild
243−instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
244− newTriggerEvent = lift newTriggerEvent
245− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
246− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
248−instance MonadReader r m => MonadReader r (EventWriterT t w m) where
250− local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
251− reader = lift . reader
253−instance MonadRef m => MonadRef (EventWriterT t w m) where
254− type Ref (EventWriterT t w m) = Ref m
255− newRef = lift . newRef
256− readRef = lift . readRef
257− writeRef r = lift . writeRef r
259−instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
260− atomicModifyRef r = lift . atomicModifyRef r
262−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
263− newEventWithTrigger = lift . newEventWithTrigger
264− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
266−instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where
267− tellQueryIncremental = lift . tellQueryIncremental
268− askQueryResult = lift askQueryResult
269− queryIncremental = lift . queryIncremental
271−-- | Map a function over the output of a 'EventWriterT'.
272−withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m, MonadFix m)
274− -> EventWriterT t w m a
275− -> EventWriterT t w' m a
276−withEventWriterT f ew = do
278− (r, e) <- runEventWriterT ew