git.iko.soy/patch
on 6dfd512 help sign in
patch/src/Reflex/Class.hs
573 lines 26 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FunctionalDependencies #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE NoMonomorphismRestriction #-}
9{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RecursiveDo #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE UndecidableInstances #-}
15module Reflex.Class where
17import Control.Applicative
18import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
19import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
20import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
21import Control.Monad.Trans.Cont (ContT ())
22import Control.Monad.Trans.Except (ExceptT ())
23import Control.Monad.Trans.RWS (RWST ())
24import Control.Monad.Trans.Writer (WriterT ())
25import Data.Align
26import Data.Bifunctor
27import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))
28import qualified Data.Dependent.Map as DMap
29import Data.Dependent.Sum (ShowTag (..))
30import Data.Foldable
31import Data.Functor.Compose
32import Data.Functor.Constant
33import Data.Functor.Misc
34import Data.GADT.Compare ((:~:) (..), GEq (..))
35import Data.GADT.Show (GShow (..))
36import Data.List.NonEmpty (NonEmpty (..))
37import Data.Map (Map)
38import Data.Maybe
39import Data.Semigroup (Semigroup, sconcat, stimes, stimesIdempotentMonoid, (<>))
40import Data.These
41import Data.Traversable
43-- Note: must come last to silence warnings due to AMP on GHC < 7.10
44import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)
46import Debug.Trace (trace)
48class (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
49 -- | 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
50 data Behavior t :: * -> *
51 -- | 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")
52 data Event t :: * -> *
53 -- | A container for a value that can change over time and allows notifications on changes.
54 -- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will
55 -- change if and only if the Event fires.
56 data Dynamic t :: * -> *
57 -- | A container for a value that can change over time and allows notifications on changes.
58 -- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will
59 -- change if and only if the Event fires.
60 data Incremental t :: (* -> *) -> * -> *
61 -- | An Event with no occurrences
62 never :: Event t a
63 -- | Create a Behavior that always has the given value
64 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
65 -- | 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
66 push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
67 -- | A monad for doing complex push-based calculations efficiently
68 type PushM t :: * -> *
69 -- | Create a Behavior by reading from other Behaviors; the result will be recomputed whenever any of the read Behaviors changes
70 pull :: PullM t a -> Behavior t a
71 -- | A monad for doing complex pull-based calculations efficiently
72 type PullM t :: * -> *
73 -- | 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
74 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
75 -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events
76 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
77 -- | Create an Event that will occur whenever the currently-selected input Event occurs
78 switch :: Behavior t (Event t a) -> Event t a
79 -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring
80 coincidence :: Event t (Event t a) -> Event t a
81 -- | Extract the 'Behavior' of a 'Dynamic'.
82 current :: Dynamic t a -> Behavior t a
83 -- | Extract the 'Event' of the 'Dynamic'.
84 updated :: Dynamic t a -> Event t a
85 -- | Create a new 'Dynamic'. The given PullM must always return the most recent firing of the given Event, if any.
86 unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a
87 -- | 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.
88 unsafeBuildIncremental :: Patch p => PullM t a -> Event t (p a) -> Incremental t p a
89 -- | Create a merge whose parents can change over time
90 mergeIncremental :: GCompare k => Incremental t PatchDMap (DMap k (Event t)) -> Event t (DMap k Identity)
91 -- | Extract the 'Behavior' component of an 'Incremental'
92 currentIncremental :: Patch p => Incremental t p a -> Behavior t a
93 -- | Extract the 'Event' component of an 'Incremental'
94 updatedIncremental :: Patch p => Incremental t p a -> Event t (p a)
95 -- | Convert an 'Incremental' to a 'Dynamic'
96 incrementalToDynamic :: Patch p => Incremental t p a -> Dynamic t a
98class Patch p where
99 apply :: p a -> a -> Maybe a -- Return Nothing if no change is necessary
101instance Patch Identity where
102 apply (Identity a) _ = Just a
104data PatchDMap a where
105 PatchDMap :: GCompare k => DMap k (Compose Maybe v) -> PatchDMap (DMap k v)
107instance GCompare k => Semigroup (PatchDMap (DMap k v)) where
108 PatchDMap a <> PatchDMap b = PatchDMap $ a `mappend` b --TODO: Add a semigroup instance for DMap
109 -- PatchDMap is idempotent, so stimes n is id for every n
110#if MIN_VERSION_semigroups(0,17,0)
111 stimes = stimesIdempotentMonoid
112#else
113 times1p n x = case compare n 0 of
114 LT -> error "stimesIdempotentMonoid: negative multiplier"
115 EQ -> mempty
116 GT -> x
117#endif
119instance GCompare k => Monoid (PatchDMap (DMap k v)) where
120 mempty = PatchDMap mempty
121 mappend = (<>)
123instance Patch PatchDMap where
124 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?
125 where insertions = DMap.mapMaybeWithKey (const $ getCompose) diff
126 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getCompose) diff
127 nothingToJust = \case
128 Nothing -> Just $ Constant ()
129 Just _ -> Nothing
131unsafeDynamic :: Reflex t => Behavior t a -> Event t a -> Dynamic t a
132unsafeDynamic = unsafeBuildDynamic . sample
134constDyn :: Reflex t => a -> Dynamic t a
135constDyn = pure
137class (Applicative m, Monad m) => MonadSample t m | m -> t where
138 -- | Get the current value in the Behavior
139 sample :: Behavior t a -> m a
141class MonadSample t m => MonadHold t m where
142 -- | 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.
143 hold :: a -> Event t a -> m (Behavior t a)
144 -- | Create a 'Dynamic' value using the given initial value that changes every
145 -- time the 'Event' occurs.
146 holdDyn :: a -> Event t a -> m (Dynamic t a)
147 -- | Create an 'Incremental' value using the given initial value that changes every
148 -- time the 'Event' occurs.
149 holdIncremental :: Patch p => a -> Event t (p a) -> m (Incremental t p a)
151newtype EventSelector t k = EventSelector { select :: forall a. k a -> Event t a }
153--------------------------------------------------------------------------------
154-- Instances
155--------------------------------------------------------------------------------
157instance MonadSample t m => MonadSample t (ReaderT r m) where
158 sample = lift . sample
160instance MonadHold t m => MonadHold t (ReaderT r m) where
161 hold a0 = lift . hold a0
162 holdDyn a0 = lift . holdDyn a0
163 holdIncremental a0 = lift . holdIncremental a0
165instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
166 sample = lift . sample
168instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
169 hold a0 = lift . hold a0
170 holdDyn a0 = lift . holdDyn a0
171 holdIncremental a0 = lift . holdIncremental a0
173instance MonadSample t m => MonadSample t (StateT s m) where
174 sample = lift . sample
176instance MonadHold t m => MonadHold t (StateT s m) where
177 hold a0 = lift . hold a0
178 holdDyn a0 = lift . holdDyn a0
179 holdIncremental a0 = lift . holdIncremental a0
181instance MonadSample t m => MonadSample t (ExceptT e m) where
182 sample = lift . sample
184instance MonadHold t m => MonadHold t (ExceptT e m) where
185 hold a0 = lift . hold a0
186 holdDyn a0 = lift . holdDyn a0
187 holdIncremental a0 = lift . holdIncremental a0
189instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
190 sample = lift . sample
192instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
193 hold a0 = lift . hold a0
194 holdDyn a0 = lift . holdDyn a0
195 holdIncremental a0 = lift . holdIncremental a0
197instance MonadSample t m => MonadSample t (ContT r m) where
198 sample = lift . sample
200instance MonadHold t m => MonadHold t (ContT r m) where
201 hold a0 = lift . hold a0
202 holdDyn a0 = lift . holdDyn a0
203 holdIncremental a0 = lift . holdIncremental a0
205--------------------------------------------------------------------------------
206-- Convenience functions
207--------------------------------------------------------------------------------
209-- | Create an Event from another Event.
210-- The provided function can sample 'Behavior's and hold 'Event's.
211pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
212pushAlways f = push (fmap Just . f)
214-- | Flipped version of 'fmap'.
215ffor :: Functor f => f a -> (a -> b) -> f b
216ffor = flip fmap
218instance Reflex t => Functor (Behavior t) where
219 fmap f = pull . fmap f . sample
221instance Reflex t => Applicative (Behavior t) where
222 pure = constant
223 f <*> x = pull $ sample f `ap` sample x
224 _ *> b = b
225 a <* _ = a
227instance Reflex t => Monad (Behavior t) where
228 a >>= f = pull $ sample a >>= sample . f
229 -- 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.
230 return = constant
231 fail = error "Monad (Behavior t) does not support fail"
233instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
234 a <> b = pull $ liftM2 (<>) (sample a) (sample b)
235 sconcat = pull . fmap sconcat . mapM sample
236#if MIN_VERSION_semigroups(0,17,0)
237 stimes n = fmap $ stimes n
238#else
239 times1p n = fmap $ times1p n
240#endif
242instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
243 mempty = constant mempty
244 mappend a b = pull $ liftM2 mappend (sample a) (sample b)
245 mconcat = pull . fmap mconcat . mapM sample
247--TODO: See if there's a better class in the standard libraries already
248-- | A class for values that combines filtering and mapping using 'Maybe'.
249class FunctorMaybe f where
250 -- | Combined mapping and filtering function.
251 fmapMaybe :: (a -> Maybe b) -> f a -> f b
253instance FunctorMaybe [] where
254 fmapMaybe f = catMaybes . fmap f
256-- | Flipped version of 'fmapMaybe'.
257fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
258fforMaybe = flip fmapMaybe
260-- | Filter 'f a' using the provided predicate.
261-- Relies on 'fforMaybe'.
262ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
263ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
265instance Reflex t => FunctorMaybe (Event t) where
266 fmapMaybe f = push $ return . f
268instance Reflex t => Functor (Event t) where
269 fmap f = fmapMaybe $ Just . f
271-- | Replace each occurrence value of the 'Event' with the value of the
272-- 'Behavior' at the time of that occurrence.
273tag :: Reflex t => Behavior t b -> Event t a -> Event t b
274tag b = pushAlways $ \_ -> sample b
276-- | Create a new 'Event' that combines occurences of supplied 'Event'
277-- with the current value of the 'Behavior'.
278attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
279attach = attachWith (,)
281-- | Create a new 'Event' that occurs when the supplied 'Event' occurs
282-- by combining it with the current value of the 'Behavior'.
283attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
284attachWith f = attachWithMaybe $ \a b -> Just $ f a b
286-- | Create a new 'Event' by combining each occurence with the current
287-- value of the 'Behavior'. The occurrence is discarded if the combining function
288-- returns Nothing
289attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
290attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b
292-- | Alias for 'headE'
293onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
294onceE = headE
296-- | Create a new 'Event' that only occurs on the first occurence of
297-- the supplied 'Event'.
298headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
299headE e = do
300 rec be <- hold e $ fmap (const never) e'
301 let e' = switch be
302 e' `seq` return ()
303 return e'
305-- | Create a new 'Event' that occurs on all but the first occurence
306-- of the supplied 'Event'.
307tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
308tailE e = snd <$> headTailE e
310-- | Create a tuple of two 'Event's with the first one occuring only
311-- the first time the supplied 'Event' occurs and the second occuring
312-- on all but the first occurence.
313headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
314headTailE e = do
315 eHead <- headE e
316 be <- hold never $ fmap (const e) eHead
317 return (eHead, switch be)
319-- | Split the supplied 'Event' into two individual 'Event's occuring
320-- at the same time with the respective values from the tuple.
321splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
322splitE e = (fmap fst e, fmap snd e)
324-- | Print the supplied 'String' and the value of the 'Event' on each
325-- occurence. This should /only/ be used for debugging.
326--
327-- Note: As with Debug.Trace.trace, the message will only be printed if
328-- the 'Event' is actually used.
329traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
330traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
332-- | Print the output of the supplied function on each occurence of
333-- the 'Event'. This should /only/ be used for debugging.
334--
335-- Note: As with Debug.Trace.trace, the message will only be printed if
336-- the 'Event' is actually used.
337traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
338traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
340-- | Tag type for 'Either' to use it as a 'DSum'.
341data EitherTag l r a where
342 LeftTag :: EitherTag l r l
343 RightTag :: EitherTag l r r
345instance GEq (EitherTag l r) where
346 geq a b = case (a, b) of
347 (LeftTag, LeftTag) -> Just Refl
348 (RightTag, RightTag) -> Just Refl
349 _ -> Nothing
351instance GCompare (EitherTag l r) where
352 gcompare a b = case (a, b) of
353 (LeftTag, LeftTag) -> GEQ
354 (LeftTag, RightTag) -> GLT
355 (RightTag, LeftTag) -> GGT
356 (RightTag, RightTag) -> GEQ
358instance GShow (EitherTag l r) where
359 gshowsPrec _ a = case a of
360 LeftTag -> showString "LeftTag"
361 RightTag -> showString "RightTag"
363instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
364 showTaggedPrec t n (Identity a) = case t of
365 LeftTag -> showsPrec n a
366 RightTag -> showsPrec n a
368-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
369eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
370eitherToDSum = \case
371 Left a -> (LeftTag :=> Identity a)
372 Right b -> (RightTag :=> Identity b)
374-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
375dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
376dsumToEither = \case
377 (LeftTag :=> Identity a) -> Left a
378 (RightTag :=> Identity b) -> Right b
380-- | Extract the values of a 'DMap' of 'EitherTag's.
381dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
382dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
383 (Nothing, Nothing) -> Nothing
384 (Just (Identity a), Nothing) -> Just $ This a
385 (Nothing, Just (Identity b)) -> Just $ That b
386 (Just (Identity a), Just (Identity b)) -> Just $ These a b
388-- | Create a new 'Event' that occurs if at least one of the supplied
389-- 'Event's occurs. If both occur at the same time they are combined
390-- using 'mappend'.
391appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
392appendEvents e1 e2 = mergeThese mappend <$> align e1 e2
394{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
395sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
396sequenceThese t = case t of
397 This ma -> fmap This ma
398 These ma mb -> liftM2 These ma mb
399 That mb -> fmap That mb
401instance (Semigroup a, Reflex t) => Semigroup (Event t a) where
402 (<>) = alignWith (mergeThese (<>))
403 sconcat = fmap sconcat . mergeList . toList
404#if MIN_VERSION_semigroups(0,17,0)
405 stimes n = fmap $ stimes n
406#else
407 times1p n = fmap $ times1p n
408#endif
410instance (Semigroup a, Reflex t) => Monoid (Event t a) where
411 mempty = never
412 mappend = (<>)
413 mconcat = fmap sconcat . mergeList
415-- | Create a new 'Event' that occurs if at least one of the 'Event's
416-- in the list occurs. If multiple occur at the same time they are
417-- folded from the left with the given function.
418mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
419mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)
420 . merge
421 . DMap.fromDistinctAscList
422 . map (\(k, v) -> Const2 k :=> v)
423 $ zip [0 :: Int ..] es
425-- | Create a new 'Event' that occurs if at least one of the 'Event's
426-- in the list occurs. If multiple occur at the same time the value is
427-- the value of the leftmost event.
428leftmost :: Reflex t => [Event t a] -> Event t a
429leftmost = mergeWith const
431-- | Create a new 'Event' that occurs if at least one of the 'Event's
432-- in the list occurs and has a list of the values of all 'Event's
433-- occuring at that time.
434mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
435mergeList [] = never
436mergeList es = mergeWith (<>) $ map (fmap (:|[])) es
438-- | Create a new 'Event' combining the map of 'Event's into an
439-- 'Event' that occurs if at least one of them occurs and has a map of
440-- values of all 'Event's occuring at that time.
441mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
442mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
444-- | Split the event into an 'EventSelector' that allows efficient
445-- selection of the individual 'Event's.
446fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
447fanMap = fan . fmap mapToDMap
449-- | Switches to the new event whenever it receives one; the new event is used immediately, on the same frame that it is switched to
450switchPromptly :: forall t m a. (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
451switchPromptly ea0 eea = do
452 bea <- hold ea0 eea
453 let eLag = switch bea
454 eCoincidences = coincidence eea
455 return $ leftmost [eCoincidences, eLag]
457instance Reflex t => Align (Event t) where
458 nil = never
459 align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
461-- | Create a new 'Event' that only occurs if the supplied 'Event'
462-- occurs and the 'Behavior' is true at the time of occurence.
463gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
464gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
466-- | Create a new behavior given a starting behavior and switch to a the
467-- behvior carried by the event when it fires.
468switcher :: (Reflex t, MonadHold t m)
469 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
470switcher b eb = pull . (sample <=< sample) <$> hold b eb
472zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c
473zipDynWith f da db =
474 let eab = align (updated da) (updated db)
475 ec = flip push eab $ \o -> do
476 (a, b) <- case o of
477 This a -> do
478 b <- sample $ current db
479 return (a, b)
480 That b -> do
481 a <- sample $ current da
482 return (a, b)
483 These a b -> return (a, b)
484 return $ Just $ f a b
485 in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec
487instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
488 mconcat = fmap (mconcat . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]
489 mempty = constDyn mempty
490 mappend = zipDynWith mappend
492distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
493distributeDMapOverDynPure dm = case DMap.toList dm of
494 [] -> constDyn DMap.empty
495 [k :=> v] -> fmap (DMap.singleton k . Identity) v
496 _ ->
497 let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
498 edmPre = merge $ rewrapDMap updated dm
499 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
500 olds <- sample $ current result
501 return $ DMap.unionWithKey (\_ _ new -> new) olds news
502 in result
504class Reflex t => Accumulator t f | f -> t where
505 accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a)
506 accum f = accumMaybe $ \v o -> Just $ f v o
507 accumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (f a)
508 accumM f = accumMaybeM $ \v o -> Just <$> f v o
509 accumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (f a)
510 accumMaybe f = accumMaybeM $ \v o -> return $ f v o
511 accumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (f a)
512 mapAccum :: (MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (f a, Event t c)
513 mapAccum f = mapAccumMaybe $ \v o -> bimap Just Just $ f v o
514 mapAccumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (f a, Event t c)
515 mapAccumM f = mapAccumMaybeM $ \v o -> bimap Just Just <$> f v o
516 mapAccumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
517 mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o
518 mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
520mapAccum_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Event t c)
521mapAccum_ f z e = do
522 (_ :: Behavior t a, result) <- mapAccum f z e
523 return result
525mapAccumMaybe_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)
526mapAccumMaybe_ f z e = do
527 (_ :: Behavior t a, result) <- mapAccumMaybe f z e
528 return result
530mapAccumM_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Event t c)
531mapAccumM_ f z e = do
532 (_ :: Behavior t a, result) <- mapAccumM f z e
533 return result
535mapAccumMaybeM_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)
536mapAccumMaybeM_ f z e = do
537 (_ :: Behavior t a, result) <- mapAccumMaybeM f z e
538 return result
540instance Reflex t => Accumulator t (Dynamic t) where
541 accumMaybeM f z e = do
542 rec let e' = flip push e $ \o -> do
543 v <- sample $ current d'
544 f v o
545 d' <- holdDyn z e'
546 return d'
547 mapAccumMaybeM f z e = do
548 rec let e' = flip push e $ \o -> do
549 v <- sample $ current d'
550 result <- f v o
551 return $ case result of
552 (Nothing, Nothing) -> Nothing
553 _ -> Just result
554 d' <- holdDyn z $ fmapMaybe fst e'
555 return (d', fmapMaybe snd e')
557instance Reflex t => Accumulator t (Behavior t) where
558 accumMaybeM f z e = current <$> accumMaybeM f z e
559 mapAccumMaybeM f z e = first current <$> mapAccumMaybeM f z e
561instance Reflex t => Accumulator t (Event t) where
562 accumMaybeM f z e = updated <$> accumMaybeM f z e
563 mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e
565-- | Create a new 'Event' by combining each occurence with the next value
566-- of the list using the supplied function. If the list runs out of items,
567-- all subsequent 'Event' occurrences will be ignored.
568zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
569zipListWithEvent f l e = do
570 let f' a b = case a of
571 h:t -> (Just t, Just $ f h b)
572 _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?
573 mapAccumMaybe_ f' l e