git.iko.soy/patch
on e596bab help sign in
patch/src/Reflex/Class.hs
560 lines 26 kB history raw
1{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, CPP #-}
2module Reflex.Class where
4import Control.Applicative
5import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
6import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
7import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
8import Control.Monad.Trans.Writer (WriterT())
9import Control.Monad.Trans.Except (ExceptT())
10import Control.Monad.Trans.Cont (ContT())
11import Control.Monad.Trans.RWS (RWST())
12import Data.List.NonEmpty (NonEmpty (..))
13import Data.These
14import Data.Align
15import Data.GADT.Compare (GEq (..), (:~:) (..))
16import Data.GADT.Show (GShow (..))
17import Data.Dependent.Sum (ShowTag (..))
18import Data.Map (Map)
19import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))
20import qualified Data.Dependent.Map as DMap
21import Data.Functor.Misc
22import Data.Semigroup (Semigroup, (<>), sconcat, stimes, stimesIdempotentMonoid)
23import Data.Traversable
24import Data.Functor.Compose
25import Data.Functor.Constant
26import Data.Foldable
27import Data.Maybe
28import Data.Bifunctor
30-- Note: must come last to silence warnings due to AMP on GHC < 7.10
31import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
33import Debug.Trace (trace)
35class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Functor (Event t), Functor (Behavior t), Functor (Dynamic t), Monad (Dynamic t)) => Reflex t where
36 -- | A container for a value that can change over time. Behaviors can be sampled at will, but it is not possible to be notified when they change
37 data Behavior t :: * -> *
38 -- | A stream of occurrences. During any given frame, an Event is either occurring or not occurring; if it is occurring, it will contain a value of the given type (its "occurrence type")
39 data Event t :: * -> *
40 -- | A container for a value that can change over time and allows notifications on changes.
41 -- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will
42 -- change if and only if the Event fires.
43 data Dynamic t :: * -> *
44 -- | A container for a value that can change over time and allows notifications on changes.
45 -- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will
46 -- change if and only if the Event fires.
47 data Incremental t :: (* -> *) -> * -> *
48 -- | An Event with no occurrences
49 never :: Event t a
50 -- | Create a Behavior that always has the given value
51 constant :: a -> Behavior t a --TODO: Refactor to use 'pure' from Applicative instead; however, we need to make sure that encouraging Applicative-style use of Behaviors doesn't have a negative performance impact
52 -- | Create an Event from another Event; the provided function can sample Behaviors and hold Events, and use the results to produce a occurring (Just) or non-occurring (Nothing) result
53 push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
54 -- | A monad for doing complex push-based calculations efficiently
55 type PushM t :: * -> *
56 -- | Create a Behavior by reading from other Behaviors; the result will be recomputed whenever any of the read Behaviors changes
57 pull :: PullM t a -> Behavior t a
58 -- | A monad for doing complex pull-based calculations efficiently
59 type PullM t :: * -> *
60 -- | Merge a collection of events; the resulting Event will only occur if at least one input event is occuring, and will contain all of the input keys that are occurring simultaneously
61 merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
62 -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events
63 fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it
64 -- | Create an Event that will occur whenever the currently-selected input Event occurs
65 switch :: Behavior t (Event t a) -> Event t a
66 -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring
67 coincidence :: Event t (Event t a) -> Event t a
68 -- | Extract the 'Behavior' of a 'Dynamic'.
69 current :: Dynamic t a -> Behavior t a
70 -- | Extract the 'Event' of the 'Dynamic'.
71 updated :: Dynamic t a -> Event t a
72 -- | Create a new 'Dynamic'. The given PullM must always return the most recent firing of the given Event, if any.
73 unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a
74 -- | Create a new 'Incremental'. The given PullM's value must always change in the same way that the accumulated application of patches would change that value.
75 unsafeBuildIncremental :: Patch p => PullM t a -> Event t (p a) -> Incremental t p a
76 -- | Create a merge whose parents can change over time
77 mergeIncremental :: GCompare k => Incremental t PatchDMap (DMap k (Event t)) -> Event t (DMap k Identity)
78 -- | Extract the 'Behavior' component of an 'Incremental'
79 currentIncremental :: Patch p => Incremental t p a -> Behavior t a
80 -- | Extract the 'Event' component of an 'Incremental'
81 updatedIncremental :: Patch p => Incremental t p a -> Event t (p a)
82 -- | Convert an 'Incremental' to a 'Dynamic'
83 incrementalToDynamic :: Patch p => Incremental t p a -> Dynamic t a
85class Patch p where
86 apply :: p a -> a -> Maybe a -- Return Nothing if no change is necessary
88instance Patch Identity where
89 apply (Identity a) _ = Just a
91data PatchDMap a where
92 PatchDMap :: GCompare k => DMap k (Compose Maybe v) -> PatchDMap (DMap k v)
94instance GCompare k => Semigroup (PatchDMap (DMap k v)) where
95 PatchDMap a <> PatchDMap b = PatchDMap $ a `mappend` b --TODO: Add a semigroup instance for DMap
96 -- PatchDMap is idempotent, so stimes n is id for every n
97#if MIN_VERSION_semigroups(0,17,0)
98 stimes = stimesIdempotentMonoid
99#else
100 times1p n x = case compare n 0 of
101 LT -> error "stimesIdempotentMonoid: negative multiplier"
102 EQ -> mempty
103 GT -> x
104#endif
106instance GCompare k => Monoid (PatchDMap (DMap k v)) where
107 mempty = PatchDMap mempty
108 mappend = (<>)
110instance Patch PatchDMap where
111 apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
112 where insertions = DMap.mapMaybeWithKey (const $ id . getCompose) diff
113 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getCompose) diff
114 nothingToJust = \case
115 Nothing -> Just $ Constant ()
116 Just _ -> Nothing
118unsafeDynamic :: Reflex t => Behavior t a -> Event t a -> Dynamic t a
119unsafeDynamic = unsafeBuildDynamic . sample
121constDyn :: Reflex t => a -> Dynamic t a
122constDyn = pure
124class (Applicative m, Monad m) => MonadSample t m | m -> t where
125 -- | Get the current value in the Behavior
126 sample :: Behavior t a -> m a
128class MonadSample t m => MonadHold t m where
129 -- | Create a new Behavior whose value will initially be equal to the given value and will be updated whenever the given Event occurs. The update takes effect immediately after the Event occurs; if the occurrence that sets the Behavior (or one that is simultaneous with it) is used to sample the Behavior, it will see the *old* value of the Behavior, not the new one.
130 hold :: a -> Event t a -> m (Behavior t a)
131 -- | Create a 'Dynamic' value using the given initial value that changes every
132 -- time the 'Event' occurs.
133 holdDyn :: a -> Event t a -> m (Dynamic t a)
134 -- | Create an 'Incremental' value using the given initial value that changes every
135 -- time the 'Event' occurs.
136 holdIncremental :: Patch p => a -> Event t (p a) -> m (Incremental t p a)
138newtype EventSelector t k = EventSelector { select :: forall a. k a -> Event t a }
140--------------------------------------------------------------------------------
141-- Instances
142--------------------------------------------------------------------------------
144instance MonadSample t m => MonadSample t (ReaderT r m) where
145 sample = lift . sample
147instance MonadHold t m => MonadHold t (ReaderT r m) where
148 hold a0 = lift . hold a0
149 holdDyn a0 = lift . holdDyn a0
150 holdIncremental a0 = lift . holdIncremental a0
152instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
153 sample = lift . sample
155instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
156 hold a0 = lift . hold a0
157 holdDyn a0 = lift . holdDyn a0
158 holdIncremental a0 = lift . holdIncremental a0
160instance MonadSample t m => MonadSample t (StateT s m) where
161 sample = lift . sample
163instance MonadHold t m => MonadHold t (StateT s m) where
164 hold a0 = lift . hold a0
165 holdDyn a0 = lift . holdDyn a0
166 holdIncremental a0 = lift . holdIncremental a0
168instance MonadSample t m => MonadSample t (ExceptT e m) where
169 sample = lift . sample
171instance MonadHold t m => MonadHold t (ExceptT e m) where
172 hold a0 = lift . hold a0
173 holdDyn a0 = lift . holdDyn a0
174 holdIncremental a0 = lift . holdIncremental a0
176instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
177 sample = lift . sample
179instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
180 hold a0 = lift . hold a0
181 holdDyn a0 = lift . holdDyn a0
182 holdIncremental a0 = lift . holdIncremental a0
184instance MonadSample t m => MonadSample t (ContT r m) where
185 sample = lift . sample
187instance MonadHold t m => MonadHold t (ContT r m) where
188 hold a0 = lift . hold a0
189 holdDyn a0 = lift . holdDyn a0
190 holdIncremental a0 = lift . holdIncremental a0
192--------------------------------------------------------------------------------
193-- Convenience functions
194--------------------------------------------------------------------------------
196-- | Create an Event from another Event.
197-- The provided function can sample 'Behavior's and hold 'Event's.
198pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
199pushAlways f = push (liftM Just . f)
201-- | Flipped version of 'fmap'.
202ffor :: Functor f => f a -> (a -> b) -> f b
203ffor = flip fmap
205instance Reflex t => Functor (Behavior t) where
206 fmap f = pull . liftM f . sample
208instance Reflex t => Applicative (Behavior t) where
209 pure = constant
210 f <*> x = pull $ sample f `ap` sample x
211 _ *> b = b
212 a <* _ = a
214instance Reflex t => Monad (Behavior t) where
215 a >>= f = pull $ sample a >>= sample . f
216 -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail. Since we can't examine Behaviors other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above.
217 return = constant
218 fail = error "Monad (Behavior t) does not support fail"
220instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
221 a <> b = pull $ liftM2 (<>) (sample a) (sample b)
222 sconcat = pull . liftM sconcat . mapM sample
223#if MIN_VERSION_semigroups(0,17,0)
224 stimes n = fmap $ stimes n
225#else
226 times1p n = fmap $ times1p n
227#endif
229instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
230 mempty = constant mempty
231 mappend a b = pull $ liftM2 mappend (sample a) (sample b)
232 mconcat = pull . liftM mconcat . mapM sample
234--TODO: See if there's a better class in the standard libraries already
235-- | A class for values that combines filtering and mapping using 'Maybe'.
236class FunctorMaybe f where
237 -- | Combined mapping and filtering function.
238 fmapMaybe :: (a -> Maybe b) -> f a -> f b
240instance FunctorMaybe [] where
241 fmapMaybe f = catMaybes . fmap f
243-- | Flipped version of 'fmapMaybe'.
244fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
245fforMaybe = flip fmapMaybe
247-- | Filter 'f a' using the provided predicate.
248-- Relies on 'fforMaybe'.
249ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
250ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
252instance Reflex t => FunctorMaybe (Event t) where
253 fmapMaybe f = push $ return . f
255instance Reflex t => Functor (Event t) where
256 fmap f = fmapMaybe $ Just . f
258-- | Replace each occurrence value of the 'Event' with the value of the
259-- 'Behavior' at the time of that occurrence.
260tag :: Reflex t => Behavior t b -> Event t a -> Event t b
261tag b = pushAlways $ \_ -> sample b
263-- | Create a new 'Event' that combines occurences of supplied 'Event'
264-- with the current value of the 'Behavior'.
265attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
266attach = attachWith (,)
268-- | Create a new 'Event' that occurs when the supplied 'Event' occurs
269-- by combining it with the current value of the 'Behavior'.
270attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
271attachWith f = attachWithMaybe $ \a b -> Just $ f a b
273-- | Create a new 'Event' by combining each occurence with the current
274-- value of the 'Behavior'. The occurrence is discarded if the combining function
275-- returns Nothing
276attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
277attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b
279-- | Alias for 'headE'
280onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
281onceE = headE
283-- | Create a new 'Event' that only occurs on the first occurence of
284-- the supplied 'Event'.
285headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
286headE e = do
287 rec be <- hold e $ fmap (const never) e'
288 let e' = switch be
289 e' `seq` return ()
290 return e'
292-- | Create a new 'Event' that occurs on all but the first occurence
293-- of the supplied 'Event'.
294tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
295tailE e = liftM snd $ headTailE e
297-- | Create a tuple of two 'Event's with the first one occuring only
298-- the first time the supplied 'Event' occurs and the second occuring
299-- on all but the first occurence.
300headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
301headTailE e = do
302 eHead <- headE e
303 be <- hold never $ fmap (const e) eHead
304 return (eHead, switch be)
306-- | Split the supplied 'Event' into two individual 'Event's occuring
307-- at the same time with the respective values from the tuple.
308splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
309splitE e = (fmap fst e, fmap snd e)
311-- | Print the supplied 'String' and the value of the 'Event' on each
312-- occurence. This should /only/ be used for debugging.
313--
314-- Note: As with Debug.Trace.trace, the message will only be printed if
315-- the 'Event' is actually used.
316traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
317traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
319-- | Print the output of the supplied function on each occurence of
320-- the 'Event'. This should /only/ be used for debugging.
321--
322-- Note: As with Debug.Trace.trace, the message will only be printed if
323-- the 'Event' is actually used.
324traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
325traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
327-- | Tag type for 'Either' to use it as a 'DSum'.
328data EitherTag l r a where
329 LeftTag :: EitherTag l r l
330 RightTag :: EitherTag l r r
332instance GEq (EitherTag l r) where
333 geq a b = case (a, b) of
334 (LeftTag, LeftTag) -> Just Refl
335 (RightTag, RightTag) -> Just Refl
336 _ -> Nothing
338instance GCompare (EitherTag l r) where
339 gcompare a b = case (a, b) of
340 (LeftTag, LeftTag) -> GEQ
341 (LeftTag, RightTag) -> GLT
342 (RightTag, LeftTag) -> GGT
343 (RightTag, RightTag) -> GEQ
345instance GShow (EitherTag l r) where
346 gshowsPrec _ a = case a of
347 LeftTag -> showString "LeftTag"
348 RightTag -> showString "RightTag"
350instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
351 showTaggedPrec t n (Identity a) = case t of
352 LeftTag -> showsPrec n a
353 RightTag -> showsPrec n a
355-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
356eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
357eitherToDSum = \case
358 Left a -> (LeftTag :=> Identity a)
359 Right b -> (RightTag :=> Identity b)
361-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
362dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
363dsumToEither = \case
364 (LeftTag :=> Identity a) -> Left a
365 (RightTag :=> Identity b) -> Right b
367-- | Extract the values of a 'DMap' of 'EitherTag's.
368dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
369dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
370 (Nothing, Nothing) -> Nothing
371 (Just (Identity a), Nothing) -> Just $ This a
372 (Nothing, Just (Identity b)) -> Just $ That b
373 (Just (Identity a), Just (Identity b)) -> Just $ These a b
375-- | Create a new 'Event' that occurs if at least one of the supplied
376-- 'Event's occurs. If both occur at the same time they are combined
377-- using 'mappend'.
378appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
379appendEvents e1 e2 = mergeThese mappend <$> align e1 e2
381{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
382sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
383sequenceThese t = case t of
384 This ma -> liftM This ma
385 These ma mb -> liftM2 These ma mb
386 That mb -> liftM That mb
388instance (Semigroup a, Reflex t) => Semigroup (Event t a) where
389 (<>) = alignWith (mergeThese (<>))
390 sconcat = fmap sconcat . mergeList . toList
391#if MIN_VERSION_semigroups(0,17,0)
392 stimes n = fmap $ stimes n
393#else
394 times1p n = fmap $ times1p n
395#endif
397instance (Semigroup a, Reflex t) => Monoid (Event t a) where
398 mempty = never
399 mappend = (<>)
400 mconcat = fmap sconcat . mergeList
402-- | Create a new 'Event' that occurs if at least one of the 'Event's
403-- in the list occurs. If multiple occur at the same time they are
404-- folded from the left with the given function.
405mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
406mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)
407 . merge
408 . DMap.fromDistinctAscList
409 . map (\(k, v) -> (Const2 k) :=> v)
410 $ zip [0 :: Int ..] es
412-- | Create a new 'Event' that occurs if at least one of the 'Event's
413-- in the list occurs. If multiple occur at the same time the value is
414-- the value of the leftmost event.
415leftmost :: Reflex t => [Event t a] -> Event t a
416leftmost = mergeWith const
418-- | Create a new 'Event' that occurs if at least one of the 'Event's
419-- in the list occurs and has a list of the values of all 'Event's
420-- occuring at that time.
421mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
422mergeList [] = never
423mergeList es = mergeWith (<>) $ map (fmap (:|[])) es
425-- | Create a new 'Event' combining the map of 'Event's into an
426-- 'Event' that occurs if at least one of them occurs and has a map of
427-- values of all 'Event's occuring at that time.
428mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
429mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
431-- | Split the event into an 'EventSelector' that allows efficient
432-- selection of the individual 'Event's.
433fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
434fanMap = fan . fmap mapToDMap
436-- | Switches to the new event whenever it receives one; the new event is used immediately, on the same frame that it is switched to
437switchPromptly :: forall t m a. (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
438switchPromptly ea0 eea = do
439 bea <- hold ea0 eea
440 let eLag = switch bea
441 eCoincidences = coincidence eea
442 return $ leftmost [eCoincidences, eLag]
444instance Reflex t => Align (Event t) where
445 nil = never
446 align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
448-- | Create a new 'Event' that only occurs if the supplied 'Event'
449-- occurs and the 'Behavior' is true at the time of occurence.
450gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
451gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
453-- | Create a new behavior given a starting behavior and switch to a the
454-- behvior carried by the event when it fires.
455switcher :: (Reflex t, MonadHold t m)
456 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
457switcher b eb = pull . (sample <=< sample) <$> hold b eb
459zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c
460zipDynWith f da db =
461 let eab = align (updated da) (updated db)
462 ec = flip push eab $ \o -> do
463 (a, b) <- case o of
464 This a -> do
465 b <- sample $ current db
466 return (a, b)
467 That b -> do
468 a <- sample $ current da
469 return (a, b)
470 These a b -> return (a, b)
471 return $ Just $ f a b
472 in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec
474instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
475 mconcat = fmap (mconcat . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]
476 mempty = constDyn mempty
477 mappend = zipDynWith mappend
479distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
480distributeDMapOverDynPure dm = case DMap.toList dm of
481 [] -> constDyn DMap.empty
482 [k :=> v] -> fmap (DMap.singleton k . Identity) v
483 _ ->
484 let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
485 edmPre = merge $ rewrapDMap updated dm
486 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
487 olds <- sample $ current result
488 return $ DMap.unionWithKey (\_ _ new -> new) olds news
489 in result
491class Reflex t => Accumulator t f | f -> t where
492 accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a)
493 accum f = accumMaybe $ \v o -> Just $ f v o
494 accumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (f a)
495 accumM f = accumMaybeM $ \v o -> Just <$> f v o
496 accumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (f a)
497 accumMaybe f = accumMaybeM $ \v o -> return $ f v o
498 accumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (f a)
499 mapAccum :: (MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (f a, Event t c)
500 mapAccum f = mapAccumMaybe $ \v o -> bimap Just Just $ f v o
501 mapAccumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (f a, Event t c)
502 mapAccumM f = mapAccumMaybeM $ \v o -> bimap Just Just <$> f v o
503 mapAccumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
504 mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o
505 mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
507mapAccum_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Event t c)
508mapAccum_ f z e = do
509 (_ :: Behavior t a, result) <- mapAccum f z e
510 return result
512mapAccumMaybe_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)
513mapAccumMaybe_ f z e = do
514 (_ :: Behavior t a, result) <- mapAccumMaybe f z e
515 return result
517mapAccumM_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Event t c)
518mapAccumM_ f z e = do
519 (_ :: Behavior t a, result) <- mapAccumM f z e
520 return result
522mapAccumMaybeM_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)
523mapAccumMaybeM_ f z e = do
524 (_ :: Behavior t a, result) <- mapAccumMaybeM f z e
525 return result
527instance Reflex t => Accumulator t (Dynamic t) where
528 accumMaybeM f z e = do
529 rec let e' = flip push e $ \o -> do
530 v <- sample $ current d'
531 f v o
532 d' <- holdDyn z e'
533 return d'
534 mapAccumMaybeM f z e = do
535 rec let e' = flip push e $ \o -> do
536 v <- sample $ current d'
537 result <- f v o
538 return $ case result of
539 (Nothing, Nothing) -> Nothing
540 _ -> Just result
541 d' <- holdDyn z $ fmapMaybe fst e'
542 return (d', fmapMaybe snd e')
544instance Reflex t => Accumulator t (Behavior t) where
545 accumMaybeM f z e = current <$> accumMaybeM f z e
546 mapAccumMaybeM f z e = first current <$> mapAccumMaybeM f z e
548instance Reflex t => Accumulator t (Event t) where
549 accumMaybeM f z e = updated <$> accumMaybeM f z e
550 mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e
552-- | Create a new 'Event' by combining each occurence with the next value
553-- of the list using the supplied function. If the list runs out of items,
554-- all subsequent 'Event' occurrences will be ignored.
555zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
556zipListWithEvent f l e = do
557 let f' a b = case a of
558 h:t -> (Just t, Just $ f h b)
559 _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?
560 mapAccumMaybe_ f' l e