git.iko.soy/patch
on 1150ac9 help sign in
patch/src/Reflex/EventWriter/Base.hs
287 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.Class
26import Reflex.Adjustable.Class
27import Reflex.EventWriter.Class (EventWriter, tellEvent)
28import Reflex.Host.Class
29import Reflex.PerformEvent.Class
30import Reflex.PostBuild.Class
31import Reflex.Query.Class
32import Reflex.Requester.Class
33import Reflex.TriggerEvent.Class
35import Control.Monad.Exception
36import Control.Monad.Identity
37import Control.Monad.Reader
38import Control.Monad.Ref
39import Control.Monad.State.Strict
40import Data.Dependent.Map (DMap, DSum (..))
41import qualified Data.Dependent.Map as DMap
42import Data.Foldable
43import Data.Functor.Compose
44import Data.Functor.Misc
45import Data.GADT.Compare (GCompare (..), GEq (..), 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{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
58newtype TellId w x
59 = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead
60 deriving (Show, Eq, Ord, Enum)
62tellId :: Int -> TellId w w
63tellId = TellId
64{-# INLINE tellId #-}
66tellIdRefl :: TellId w x -> w :~: x
67tellIdRefl _ = unsafeCoerce Refl
69withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
70withTellIdRefl tid r = case tellIdRefl tid of
71 Refl -> r
73instance GEq (TellId w) where
74 a `geq` b =
75 withTellIdRefl a $
76 withTellIdRefl b $
77 if a == b
78 then Just Refl
79 else Nothing
81instance GCompare (TellId w) where
82 a `gcompare` b =
83 withTellIdRefl a $
84 withTellIdRefl b $
85 case a `compare` b of
86 LT -> GLT
87 EQ -> GEQ
88 GT -> GGT
90data EventWriterState t w = EventWriterState
91 { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
92 , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order
93 }
95-- | A basic implementation of 'EventWriter'.
96newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
97 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
99-- | Run a 'EventWriterT' action.
100runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
101runEventWriterT (EventWriterT a) = do
102 (result, requests) <- runStateT a $ EventWriterState (-1) []
103 let combineResults :: DMap (TellId w) Identity -> w
104 combineResults = sconcat
105 . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
106 . 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
107 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
109instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
110 tellEvent w = EventWriterT $ modify $ \old ->
111 let myId = _eventWriterState_nextId old
112 in EventWriterState
113 { _eventWriterState_nextId = pred myId
114 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
115 }
117instance MonadTrans (EventWriterT t w) where
118 lift = EventWriterT . lift
120instance MonadSample t m => MonadSample t (EventWriterT t w m) where
121 sample = lift . sample
123instance MonadHold t m => MonadHold t (EventWriterT t w m) where
124 {-# INLINABLE hold #-}
125 hold v0 = lift . hold v0
126 {-# INLINABLE holdDyn #-}
127 holdDyn v0 = lift . holdDyn v0
128 {-# INLINABLE holdIncremental #-}
129 holdIncremental v0 = lift . holdIncremental v0
130 {-# INLINABLE buildDynamic #-}
131 buildDynamic a0 = lift . buildDynamic a0
132 {-# INLINABLE headE #-}
133 headE = lift . headE
135instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
136 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
137 traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental
138 traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
139 traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
141instance Requester t m => Requester t (EventWriterT t w m) where
142 type Request (EventWriterT t w m) = Request m
143 type Response (EventWriterT t w m) = Response m
144 requesting = lift . requesting
145 requesting_ = lift . requesting_
147-- | Given a function like 'runWithReplace' for the underlying monad, implement
148-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
149-- monad doesn't have a 'Adjustable' instance or to override the default
150-- 'Adjustable' behavior.
151runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)
152 => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
153 -> EventWriterT t w m a
154 -> Event t (EventWriterT t w m b)
155 -> EventWriterT t w m (a, Event t b)
156runWithReplaceEventWriterTWith f a0 a' = do
157 (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
158 tellEvent =<< switchHoldPromptOnly (snd result0) (fmapCheap snd result')
159 return (fst result0, fmapCheap fst result')
161-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
162sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))
163 => ( (IntMap.Key -> v -> m (Event t w, v'))
164 -> IntMap v
165 -> Event t (p v)
166 -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
167 )
168 -> (p (Event t w) -> [Event t w])
169 -> (Incremental t (p (Event t w)) -> Event t (IntMap w))
170 -> (IntMap.Key -> v -> EventWriterT t w m v')
171 -> IntMap v
172 -> Event t (p v)
173 -> EventWriterT t w m (IntMap v', Event t (p v'))
174sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
175 let f' :: IntMap.Key -> v -> m (Event t w, v')
176 f' k v = swap <$> runEventWriterT (f k v)
177 (children0, children') <- base f' dm0 dm'
178 let result0 = fmap snd children0
179 result' = fmapCheap (fmap snd) children'
180 requests0 :: IntMap (Event t w)
181 requests0 = fmap fst children0
182 requests' :: Event t (p (Event t w))
183 requests' = fmapCheap (fmap fst) children'
184 childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'
185 tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
186 return (result0, result')
188-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
189sequenceDMapWithAdjustEventWriterTWith :: 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))
190 => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
191 -> DMap k v
192 -> Event t (p k v)
193 -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
194 )
195 -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
196 -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
197 -> (p' (Some k) (Event t w) -> [Event t w])
198 -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
199 -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
200 -> DMap k v
201 -> Event t (p k v)
202 -> EventWriterT t w m (DMap k v', Event t (p k v'))
203sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
204 let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
205 f' k v = Compose . swap <$> runEventWriterT (f k v)
206 (children0, children') <- base f' dm0 dm'
207 let result0 = DMap.map (snd . getCompose) children0
208 result' = fforCheap children' $ mapPatch $ snd . getCompose
209 requests0 :: Map (Some k) (Event t w)
210 requests0 = weakenDMapWith (fst . getCompose) children0
211 requests' :: Event t (p' (Some k) (Event t w))
212 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
213 childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
214 tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
215 return (result0, result')
217tellEventsPromptly
218 :: ( Foldable f
219 , Reflex t
220 , MonadHold t m
221 , EventWriter t w m
222 )
223 => Event t a
224 -> (a -> [Event t w])
225 -> Event t (f w)
226 -> m ()
227tellEventsPromptly requests' patchNewElements mergedChildRequestMap = do
228 let patch0 = fforMaybeCheap mergedChildRequestMap $ \m -> case toList m of
229 [] -> Nothing
230 h : t -> Just $ sconcat $ h :| t
231 tellEvent =<< switchHoldPromptOnly patch0 (fmapCheap (mconcat . patchNewElements) requests')
233instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
234 type Performable (EventWriterT t w m) = Performable m
235 performEvent_ = lift . performEvent_
236 performEvent = lift . performEvent
238instance PostBuild t m => PostBuild t (EventWriterT t w m) where
239 getPostBuild = lift getPostBuild
241instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
242 newTriggerEvent = lift newTriggerEvent
243 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
244 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
246instance MonadReader r m => MonadReader r (EventWriterT t w m) where
247 ask = lift ask
248 local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
249 reader = lift . reader
251instance MonadRef m => MonadRef (EventWriterT t w m) where
252 type Ref (EventWriterT t w m) = Ref m
253 newRef = lift . newRef
254 readRef = lift . readRef
255 writeRef r = lift . writeRef r
257instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
258 atomicModifyRef r = lift . atomicModifyRef r
260instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
261 newEventWithTrigger = lift . newEventWithTrigger
262 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
264instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where
265 tellQueryIncremental = lift . tellQueryIncremental
266 askQueryResult = lift askQueryResult
267 queryIncremental = lift . queryIncremental
269-- | Map a function over the output of a 'EventWriterT'.
270withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m)
271 => (w -> w')
272 -> EventWriterT t w m a
273 -> EventWriterT t w' m a
274withEventWriterT f ew = do
275 (r, e) <- lift $ do
276 (r, e) <- runEventWriterT ew
277 let e' = fmap f e
278 return (r, e')
279 tellEvent e
280 return r
282-- | Change the monad underlying an EventWriterT
283mapEventWriterT
284 :: (forall x. m x -> n x)
285 -> EventWriterT t w m a
286 -> EventWriterT t w n a
287mapEventWriterT f (EventWriterT a) = EventWriterT $ mapStateT f a