git.iko.soy/reflex
on dc3bf44 help sign in
reflex/src/Reflex/EventWriter/Base.hs
309 lines 13 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 GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE Rank2Types #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE UndecidableInstances #-}
13#ifdef USE_REFLEX_OPTIMIZER
14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15#endif
16module Reflex.EventWriter.Base
17 ( EventWriterT (..)
18 , runEventWriterT
19 , runWithReplaceEventWriterTWith
20 , sequenceDMapWithAdjustEventWriterTWith
21 , mapEventWriterT
22 , withEventWriterT
23 ) where
25import Reflex.Adjustable.Class
26import Reflex.Class
27import Reflex.EventWriter.Class (EventWriter, tellEvent)
28import Reflex.DynamicWriter.Class (DynamicWriter, tellDyn)
29import Reflex.Host.Class
30import Reflex.PerformEvent.Class
31import Reflex.PostBuild.Class
32import Reflex.Query.Class
33import Reflex.Requester.Class
34import Reflex.TriggerEvent.Class
36import Control.Monad.Exception
37import Control.Monad.Identity
38import Control.Monad.Primitive
39import Control.Monad.Reader
40import Control.Monad.Ref
41import Control.Monad.State.Strict
42import Data.Dependent.Map (DMap)
43import qualified Data.Dependent.Map as DMap
44import Data.Dependent.Sum (DSum (..))
45import Data.Functor.Compose
46import Data.Functor.Misc
47import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
48import Data.IntMap.Strict (IntMap)
49import qualified Data.IntMap.Strict as IntMap
50import Data.List.NonEmpty (NonEmpty (..))
51import Data.Map (Map)
52import qualified Data.Map as Map
53import Data.Semigroup
54import Data.Some (Some)
55import Data.Tuple
56import Data.Type.Equality
58import Unsafe.Coerce
60{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
61newtype TellId w x
62 = TellId Int -- ^ WARNING: Do not construct this directly; use 'tellId' instead
63 deriving (Show, Eq, Ord, Enum)
65tellId :: Int -> TellId w w
66tellId = TellId
67{-# INLINE tellId #-}
69tellIdRefl :: TellId w x -> w :~: x
70tellIdRefl _ = unsafeCoerce Refl
72withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
73withTellIdRefl tid r = case tellIdRefl tid of
74 Refl -> r
76instance GEq (TellId w) where
77 a `geq` b =
78 withTellIdRefl a $
79 withTellIdRefl b $
80 if a == b
81 then Just Refl
82 else Nothing
84instance GCompare (TellId w) where
85 a `gcompare` b =
86 withTellIdRefl a $
87 withTellIdRefl b $
88 case a `compare` b of
89 LT -> GLT
90 EQ -> GEQ
91 GT -> GGT
93data EventWriterState t w = EventWriterState
94 { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
95 , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order
96 }
98-- | A basic implementation of 'EventWriter'.
99newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
100 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
102-- | Run a 'EventWriterT' action.
103runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
104runEventWriterT (EventWriterT a) = do
105 (result, requests) <- runStateT a $ EventWriterState (-1) []
106 let combineResults :: DMap (TellId w) Identity -> w
107 combineResults = sconcat
108 . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
109 . 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
110 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
112instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
113 tellEvent w = EventWriterT $ modify $ \old ->
114 let myId = _eventWriterState_nextId old
115 in EventWriterState
116 { _eventWriterState_nextId = pred myId
117 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
118 }
120instance MonadTrans (EventWriterT t w) where
121 lift = EventWriterT . lift
123instance MonadSample t m => MonadSample t (EventWriterT t w m) where
124 sample = lift . sample
126instance MonadHold t m => MonadHold t (EventWriterT t w m) where
127 {-# INLINABLE hold #-}
128 hold v0 = lift . hold v0
129 {-# INLINABLE holdDyn #-}
130 holdDyn v0 = lift . holdDyn v0
131 {-# INLINABLE holdIncremental #-}
132 holdIncremental v0 = lift . holdIncremental v0
133 {-# INLINABLE buildDynamic #-}
134 buildDynamic a0 = lift . buildDynamic a0
135 {-# INLINABLE headE #-}
136 headE = lift . headE
137 {-# INLINABLE now #-}
138 now = lift now
140instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
141 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
142 traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') mergeIntIncremental coincidencePatchIntMap
143 traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith mergeMapIncremental coincidencePatchMap
144 traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeMapIncrementalWithMove coincidencePatchMapWithMove
146instance Requester t m => Requester t (EventWriterT t w m) where
147 type Request (EventWriterT t w m) = Request m
148 type Response (EventWriterT t w m) = Response m
149 requesting = lift . requesting
150 requesting_ = lift . requesting_
152-- | Given a function like 'runWithReplace' for the underlying monad, implement
153-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
154-- monad doesn't have a 'Adjustable' instance or to override the default
155-- 'Adjustable' behavior.
156runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)
157 => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
158 -> EventWriterT t w m a
159 -> Event t (EventWriterT t w m b)
160 -> EventWriterT t w m (a, Event t b)
161runWithReplaceEventWriterTWith f a0 a' = do
162 (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
163 tellEvent =<< switchHoldPromptOnly (snd result0) (fmapCheap snd result')
164 return (fst result0, fmapCheap fst result')
166-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
167sequenceIntMapWithAdjustEventWriterTWith
168 :: forall t m p w v v'
169 . ( Reflex t
170 , MonadHold t m
171 , Semigroup w
172 , Functor p
173 , Patch (p (Event t w))
174 , PatchTarget (p (Event t w)) ~ IntMap (Event t w)
175 , Patch (p w)
176 , PatchTarget (p w) ~ IntMap w
177 )
178 => ( (IntMap.Key -> v -> m (Event t w, v'))
179 -> IntMap v
180 -> Event t (p v)
181 -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
182 )
183 -> (Incremental t (p (Event t w)) -> Event t (PatchTarget (p w)))
184 -> (Event t (p (Event t w)) -> Event t (p w))
185 -> (IntMap.Key -> v -> EventWriterT t w m v')
186 -> IntMap v
187 -> Event t (p v)
188 -> EventWriterT t w m (IntMap v', Event t (p v'))
189sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidencePatch f dm0 dm' = do
190 let f' :: IntMap.Key -> v -> m (Event t w, v')
191 f' k v = swap <$> runEventWriterT (f k v)
192 (children0, children') <- base f' dm0 dm'
193 let result0 = fmap snd children0
194 result' = fmapCheap (fmap snd) children'
195 requests0 :: IntMap (Event t w)
196 requests0 = fmap fst children0
197 requests' :: Event t (p (Event t w))
198 requests' = fmapCheap (fmap fst) children'
199 e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'
200 tellEvent $ fforMaybeCheap e $ \m ->
201 case IntMap.elems m of
202 [] -> Nothing
203 h : t -> Just $ sconcat $ h :| t
204 return (result0, result')
206-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
207sequenceDMapWithAdjustEventWriterTWith
208 :: forall t m p p' w k v v'
209 . ( Reflex t
210 , MonadHold t m
211 , Semigroup w
212 , Patch (p' (Some k) (Event t w))
213 , PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w)
214 , GCompare k
215 , Patch (p' (Some k) w)
216 , PatchTarget (p' (Some k) w) ~ Map (Some k) w
217 )
218 => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
219 -> DMap k v
220 -> Event t (p k v)
221 -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
222 )
223 -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
224 -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
225 -> (Incremental t (p' (Some k) (Event t w)) -> Event t (PatchTarget (p' (Some k) w)))
226 -> (Event t (p' (Some k) (Event t w)) -> Event t (p' (Some k) w))
227 -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
228 -> DMap k v
229 -> Event t (p k v)
230 -> EventWriterT t w m (DMap k v', Event t (p k v'))
231sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchIncremental coincidencePatch f dm0 dm' = do
232 let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
233 f' k v = Compose . swap <$> runEventWriterT (f k v)
234 (children0, children') <- base f' dm0 dm'
235 let result0 = DMap.map (snd . getCompose) children0
236 result' = fforCheap children' $ mapPatch $ snd . getCompose
237 requests0 :: Map (Some k) (Event t w)
238 requests0 = weakenDMapWith (fst . getCompose) children0
239 requests' :: Event t (p' (Some k) (Event t w))
240 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
241 e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'
242 tellEvent $ fforMaybeCheap e $ \m ->
243 case Map.elems m of
244 [] -> Nothing
245 h : t -> Just $ sconcat $ h :| t
246 return (result0, result')
248instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
249 type Performable (EventWriterT t w m) = Performable m
250 performEvent_ = lift . performEvent_
251 performEvent = lift . performEvent
253instance PostBuild t m => PostBuild t (EventWriterT t w m) where
254 getPostBuild = lift getPostBuild
256instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
257 newTriggerEvent = lift newTriggerEvent
258 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
259 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
261instance MonadReader r m => MonadReader r (EventWriterT t w m) where
262 ask = lift ask
263 local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
264 reader = lift . reader
266instance MonadRef m => MonadRef (EventWriterT t w m) where
267 type Ref (EventWriterT t w m) = Ref m
268 newRef = lift . newRef
269 readRef = lift . readRef
270 writeRef r = lift . writeRef r
272instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
273 atomicModifyRef r = lift . atomicModifyRef r
275instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
276 newEventWithTrigger = lift . newEventWithTrigger
277 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
279instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where
280 tellQueryIncremental = lift . tellQueryIncremental
281 askQueryResult = lift askQueryResult
282 queryIncremental = lift . queryIncremental
284instance DynamicWriter t w m => DynamicWriter t w (EventWriterT t v m) where
285 tellDyn = lift . tellDyn
287instance PrimMonad m => PrimMonad (EventWriterT t w m) where
288 type PrimState (EventWriterT t w m) = PrimState m
289 primitive = lift . primitive
291-- | Map a function over the output of a 'EventWriterT'.
292withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m)
293 => (w -> w')
294 -> EventWriterT t w m a
295 -> EventWriterT t w' m a
296withEventWriterT f ew = do
297 (r, e) <- lift $ do
298 (r, e) <- runEventWriterT ew
299 let e' = fmap f e
300 return (r, e')
301 tellEvent e
302 return r
304-- | Change the monad underlying an EventWriterT
305mapEventWriterT
306 :: (forall x. m x -> n x)
307 -> EventWriterT t w m a
308 -> EventWriterT t w n a
309mapEventWriterT f (EventWriterT a) = EventWriterT $ mapStateT f a