git.iko.soy/reflex
on cg-quickref help sign in
reflex/src/Reflex/EventWriter.hs
283 lines 14 kB history raw
1-- | This module provides 'EventWriterT', the standard implementation of
2-- 'EventWriter'.
3{-# LANGUAGE CPP #-}
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 #-}
16#endif
17module Reflex.EventWriter
18 ( EventWriterT (..)
19 , runEventWriterT
20 , EventWriter (..)
21 , runWithReplaceEventWriterTWith
22 , sequenceDMapWithAdjustEventWriterTWith
23 , withEventWriterT
24 ) where
26import Reflex.Class
27import Reflex.Host.Class
28import Reflex.PerformEvent.Class
29import Reflex.PostBuild.Class
30import Reflex.Query.Class
31import Reflex.Requester.Class
32import Reflex.TriggerEvent.Class
34import Control.Monad.Exception
35import Control.Monad.Identity
36import Control.Monad.Reader
37import Control.Monad.Ref
38import Control.Monad.State.Strict
39import Data.Dependent.Map (DMap, DSum (..))
40import qualified Data.Dependent.Map as DMap
41import Data.FastMutableIntMap
42import Data.Foldable
43import Data.Functor.Compose
44import Data.Functor.Misc
45import Data.GADT.Compare (GEq (..), GCompare (..), GOrdering (..))
46import Data.IntMap.Strict (IntMap)
47import qualified Data.IntMap.Strict as IntMap
48import Data.List.NonEmpty (NonEmpty (..))
49import Data.Map (Map)
50import Data.Semigroup
51import Data.Some (Some)
52import Data.Tuple
53import Data.Type.Equality
55import Unsafe.Coerce
57-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
58-- and combines them monoidally to provide an 'Event' result.
59class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
60 tellEvent :: Event t w -> m ()
62{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
63newtype TellId w x
64 = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead
65 deriving (Show, Eq, Ord, Enum)
67tellId :: Int -> TellId w w
68tellId = TellId
69{-# INLINE tellId #-}
71tellIdRefl :: TellId w x -> w :~: x
72tellIdRefl _ = unsafeCoerce Refl
74withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
75withTellIdRefl tid r = case tellIdRefl tid of
76 Refl -> r
78instance GEq (TellId w) where
79 a `geq` b =
80 withTellIdRefl a $
81 withTellIdRefl b $
82 if a == b
83 then Just Refl
84 else Nothing
86instance GCompare (TellId w) where
87 a `gcompare` b =
88 withTellIdRefl a $
89 withTellIdRefl b $
90 case a `compare` b of
91 LT -> GLT
92 EQ -> GEQ
93 GT -> GGT
95data EventWriterState t w = EventWriterState
96 { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
97 , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order
98 }
100-- | A basic implementation of 'EventWriter'.
101newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
102 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
104-- | Run a 'EventWriterT' action.
105runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
106runEventWriterT (EventWriterT a) = do
107 (result, requests) <- runStateT a $ EventWriterState (-1) []
108 let combineResults :: DMap (TellId w) Identity -> w
109 combineResults = sconcat
110 . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
111 . 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
112 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
114instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
115 tellEvent w = EventWriterT $ modify $ \old ->
116 let myId = _eventWriterState_nextId old
117 in EventWriterState
118 { _eventWriterState_nextId = pred myId
119 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
120 }
122instance EventWriter t w m => EventWriter t w (ReaderT r m) where
123 tellEvent = lift . tellEvent
125instance MonadTrans (EventWriterT t w) where
126 lift = EventWriterT . lift
128instance MonadSample t m => MonadSample t (EventWriterT t w m) where
129 sample = lift . sample
131instance MonadHold t m => MonadHold t (EventWriterT t w m) where
132 {-# INLINABLE hold #-}
133 hold v0 = lift . hold v0
134 {-# INLINABLE holdDyn #-}
135 holdDyn v0 = lift . holdDyn v0
136 {-# INLINABLE holdIncremental #-}
137 holdIncremental v0 = lift . holdIncremental v0
138 {-# INLINABLE buildDynamic #-}
139 buildDynamic a0 = lift . buildDynamic a0
140 {-# INLINABLE headE #-}
141 headE = lift . headE
143instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
144 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
145 traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental
146 traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
147 traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
149instance Requester t m => Requester t (EventWriterT t w m) where
150 type Request (EventWriterT t w m) = Request m
151 type Response (EventWriterT t w m) = Response m
152 requesting = lift . requesting
153 requesting_ = lift . requesting_
155-- | Given a function like 'runWithReplace' for the underlying monad, implement
156-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
157-- monad doesn't have a 'Adjustable' instance or to override the default
158-- 'Adjustable' behavior.
159runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)
160 => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
161 -> EventWriterT t w m a
162 -> Event t (EventWriterT t w m b)
163 -> EventWriterT t w m (a, Event t b)
164runWithReplaceEventWriterTWith f a0 a' = do
165 (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
166 request <- holdDyn (snd result0) $ fmapCheap snd result'
167 -- 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.)
168 tellEvent $ coincidence $ updated request
169 tellEvent $ switch $ current request
170 return (fst result0, fmapCheap fst result')
172-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
173sequenceIntMapWithAdjustEventWriterTWith :: 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))
174 => ( (IntMap.Key -> v -> m (Event t w, v'))
175 -> IntMap v
176 -> Event t (p v)
177 -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
178 )
179 -> (p (Event t w) -> [Event t w])
180 -> (Incremental t (p (Event t w)) -> Event t (IntMap w))
181 -> (IntMap.Key -> v -> EventWriterT t w m v')
182 -> IntMap v
183 -> Event t (p v)
184 -> EventWriterT t w m (IntMap v', Event t (p v'))
185sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
186 let f' :: IntMap.Key -> v -> m (Event t w, v')
187 f' k v = swap <$> runEventWriterT (f k v)
188 (children0, children') <- base f' dm0 dm'
189 let result0 = fmap snd children0
190 result' = fmapCheap (fmap snd) children'
191 requests0 :: IntMap (Event t w)
192 requests0 = fmap fst children0
193 requests' :: Event t (p (Event t w))
194 requests' = fmapCheap (fmap fst) children'
195 childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'
196 -- 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.)
197 tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
198 tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
199 [] -> Nothing
200 h : t -> Just $ sconcat $ h :| t
201 return (result0, result')
203-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
204sequenceDMapWithAdjustEventWriterTWith :: 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))
205 => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
206 -> DMap k v
207 -> Event t (p k v)
208 -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
209 )
210 -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
211 -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
212 -> (p' (Some k) (Event t w) -> [Event t w])
213 -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
214 -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
215 -> DMap k v
216 -> Event t (p k v)
217 -> EventWriterT t w m (DMap k v', Event t (p k v'))
218sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
219 let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
220 f' k v = Compose . swap <$> runEventWriterT (f k v)
221 (children0, children') <- base f' dm0 dm'
222 let result0 = DMap.map (snd . getCompose) children0
223 result' = fforCheap children' $ mapPatch $ snd . getCompose
224 requests0 :: Map (Some k) (Event t w)
225 requests0 = weakenDMapWith (fst . getCompose) children0
226 requests' :: Event t (p' (Some k) (Event t w))
227 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
228 childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
229 -- 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.)
230 tellEvent $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
231 tellEvent $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of
232 [] -> Nothing
233 h : t -> Just $ sconcat $ h :| t
234 return (result0, result')
236instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
237 type Performable (EventWriterT t w m) = Performable m
238 performEvent_ = lift . performEvent_
239 performEvent = lift . performEvent
241instance PostBuild t m => PostBuild t (EventWriterT t w m) where
242 getPostBuild = lift getPostBuild
244instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
245 newTriggerEvent = lift newTriggerEvent
246 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
247 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
249instance MonadReader r m => MonadReader r (EventWriterT t w m) where
250 ask = lift ask
251 local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
252 reader = lift . reader
254instance MonadRef m => MonadRef (EventWriterT t w m) where
255 type Ref (EventWriterT t w m) = Ref m
256 newRef = lift . newRef
257 readRef = lift . readRef
258 writeRef r = lift . writeRef r
260instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
261 atomicModifyRef r = lift . atomicModifyRef r
263instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
264 newEventWithTrigger = lift . newEventWithTrigger
265 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
267instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where
268 tellQueryIncremental = lift . tellQueryIncremental
269 askQueryResult = lift askQueryResult
270 queryIncremental = lift . queryIncremental
272-- | Map a function over the output of a 'EventWriterT'.
273withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m, MonadFix m)
274 => (w -> w')
275 -> EventWriterT t w m a
276 -> EventWriterT t w' m a
277withEventWriterT f ew = do
278 (r, e) <- lift $ do
279 (r, e) <- runEventWriterT ew
280 let e' = fmap f e
281 return (r, e')
282 tellEvent e
283 return r