git.iko.soy/reflex
on fast-weak-partial-requester help sign in
reflex/src/Reflex/EventWriter.hs
269 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 ) where
25import Reflex.Class
26import Reflex.Host.Class
27import Reflex.PerformEvent.Class
28import Reflex.PostBuild.Class
29import Reflex.Query.Class
30import Reflex.Requester.Class
31import Reflex.TriggerEvent.Class
33import Control.Monad.Exception
34import Control.Monad.Identity
35import Control.Monad.Reader
36import Control.Monad.Ref
37import Control.Monad.State.Strict
38import Data.Dependent.Map (DMap, DSum (..))
39import qualified Data.Dependent.Map as DMap
40import Data.FastMutableIntMap
41import Data.Foldable
42import Data.Functor.Compose
43import Data.Functor.Misc
44import Data.GADT.Compare (GEq (..), GCompare (..), GOrdering (..))
45import Data.IntMap.Strict (IntMap)
46import qualified Data.IntMap.Strict as IntMap
47import Data.List.NonEmpty (NonEmpty (..))
48import Data.Map (Map)
49import Data.Semigroup
50import Data.Some (Some)
51import Data.Tuple
52import Data.Type.Equality
54import Unsafe.Coerce
56-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
57-- and combines them monoidally to provide an 'Event' result.
58class (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" #-}
62newtype TellId w x
63 = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead
64 deriving (Show, Eq, Ord, Enum)
66tellId :: Int -> TellId w w
67tellId = TellId
68{-# INLINE tellId #-}
70tellIdRefl :: TellId w x -> w :~: x
71tellIdRefl _ = unsafeCoerce Refl
73withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
74withTellIdRefl tid r = case tellIdRefl tid of
75 Refl -> r
77instance GEq (TellId w) where
78 a `geq` b =
79 withTellIdRefl a $
80 withTellIdRefl b $
81 if a == b
82 then Just Refl
83 else Nothing
85instance GCompare (TellId w) where
86 a `gcompare` b =
87 withTellIdRefl a $
88 withTellIdRefl b $
89 case a `compare` b of
90 LT -> GLT
91 EQ -> GEQ
92 GT -> GGT
94data 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
97 }
99-- | A basic implementation of 'EventWriter'.
100newtype 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.
104runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
105runEventWriterT (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
113instance (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
116 in EventWriterState
117 { _eventWriterState_nextId = pred myId
118 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
119 }
121instance EventWriter t w m => EventWriter t w (ReaderT r m) where
122 tellEvent = lift . tellEvent
124instance MonadTrans (EventWriterT t w) where
125 lift = EventWriterT . lift
127instance MonadSample t m => MonadSample t (EventWriterT t w m) where
128 sample = lift . sample
130instance 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
142instance (Reflex t, MonadAdjust t m, MonadHold t m, Semigroup w) => MonadAdjust 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
148instance 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 'MonadAdjust' instance or to override the default
157-- 'MonadAdjust' behavior.
158runWithReplaceEventWriterTWith :: 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)
163runWithReplaceEventWriterTWith 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'.
172sequenceIntMapWithAdjustEventWriterTWith :: 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'))
174 -> IntMap v
175 -> Event t (p v)
176 -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
177 )
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')
181 -> IntMap v
182 -> Event t (p v)
183 -> EventWriterT t w m (IntMap v', Event t (p v'))
184sequenceIntMapWithAdjustEventWriterTWith 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
198 [] -> Nothing
199 h : t -> Just $ sconcat $ h :| t
200 return (result0, result')
202-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
203sequenceDMapWithAdjustEventWriterTWith :: 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))
205 -> DMap k v
206 -> Event t (p k v)
207 -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
208 )
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))
214 -> DMap k v
215 -> Event t (p k v)
216 -> EventWriterT t w m (DMap k v', Event t (p k v'))
217sequenceDMapWithAdjustEventWriterTWith 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
231 [] -> Nothing
232 h : t -> Just $ sconcat $ h :| t
233 return (result0, result')
235instance 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
240instance PostBuild t m => PostBuild t (EventWriterT t w m) where
241 getPostBuild = lift getPostBuild
243instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
244 newTriggerEvent = lift newTriggerEvent
245 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
246 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
248instance MonadReader r m => MonadReader r (EventWriterT t w m) where
249 ask = lift ask
250 local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
251 reader = lift . reader
253instance 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
259instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
260 atomicModifyRef r = lift . atomicModifyRef r
262instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
263 newEventWithTrigger = lift . newEventWithTrigger
264 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
266instance (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