@@ -1,282 +1,7 @@
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
171module Reflex.EventWriter
18− ( EventWriterT (..)
19− , runEventWriterT
20− , EventWriter (..)
21− , runWithReplaceEventWriterTWith
22− , sequenceDMapWithAdjustEventWriterTWith
23− , withEventWriterT
2+ {-# DEPRECATED "Use 'Reflex.EventWriter.Class' and 'Reflex.EventWriter.Base' instead, or just import 'Reflex'" #-}
3+ ( module X
244 ) where
255
26−import Reflex.Class
27−import Reflex.Host.Class
28−import Reflex.PerformEvent.Class
29−import Reflex.PostBuild.Class
30−import Reflex.Query.Class
31−import Reflex.Requester.Class
32−import Reflex.TriggerEvent.Class
33−
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
41−import Data.Foldable
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 (..))
48−import Data.Map (Map)
49−import Data.Semigroup
50−import Data.Some (Some)
51−import Data.Tuple
52−import Data.Type.Equality
53−
54−import Unsafe.Coerce
55−
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 ()
60−
61−{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
62−newtype TellId w x
63− = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead
64− deriving (Show, Eq, Ord, Enum)
65−
66−tellId :: Int -> TellId w w
67−tellId = TellId
68−{-# INLINE tellId #-}
69−
70−tellIdRefl :: TellId w x -> w :~: x
71−tellIdRefl _ = unsafeCoerce Refl
72−
73−withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
74−withTellIdRefl tid r = case tellIdRefl tid of
75− Refl -> r
76−
77−instance 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
84−
85−instance 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
93−
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
97− }
98−
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)
102−
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
112−
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
116− in EventWriterState
117− { _eventWriterState_nextId = pred myId
118− , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
119− }
120−
121−instance EventWriter t w m => EventWriter t w (ReaderT r m) where
122− tellEvent = lift . tellEvent
123−
124−instance MonadTrans (EventWriterT t w) where
125− lift = EventWriterT . lift
126−
127−instance MonadSample t m => MonadSample t (EventWriterT t w m) where
128− sample = lift . sample
129−
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
141−
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
147−
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_
153−
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')
170−
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'))
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'))
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
198− [] -> Nothing
199− h : t -> Just $ sconcat $ h :| t
200− return (result0, result')
201−
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))
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'))
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
231− [] -> Nothing
232− h : t -> Just $ sconcat $ h :| t
233− return (result0, result')
234−
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
239−
240−instance PostBuild t m => PostBuild t (EventWriterT t w m) where
241− getPostBuild = lift getPostBuild
242−
243−instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
244− newTriggerEvent = lift newTriggerEvent
245− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
246− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
247−
248−instance 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
252−
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
258−
259−instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
260− atomicModifyRef r = lift . atomicModifyRef r
261−
262−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
263− newEventWithTrigger = lift . newEventWithTrigger
264− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
265−
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
270−
271−-- | Map a function over the output of a 'EventWriterT'.
272−withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m, MonadFix m)
273− => (w -> w')
274− -> EventWriterT t w m a
275− -> EventWriterT t w' m a
276−withEventWriterT f ew = do
277− (r, e) <- lift $ do
278− (r, e) <- runEventWriterT ew
279− let e' = fmap f e
280− return (r, e')
281− tellEvent e
282− return r
6+import Reflex.EventWriter.Base as X
7+import Reflex.EventWriter.Class as X