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