git.iko.soy/patch
on f565bee help sign in
patch/src/Reflex/Class.hs
366 lines 17 kB history raw
1{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase #-}
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
23import Data.Traversable
25-- Note: must come last to silence warnings due to AMP on GHC < 7.10
26import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
28import Debug.Trace (trace)
30class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Functor (Event t), Functor (Behavior t)) => Reflex t where
31 -- | 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
32 data Behavior t :: * -> *
33 -- | 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")
34 data Event t :: * -> *
35 -- | An Event with no occurrences
36 never :: Event t a
37 -- | Create a Behavior that always has the given value
38 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
39 -- | 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
40 push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
41 -- | A monad for doing complex push-based calculations efficiently
42 type PushM t :: * -> *
43 -- | Create a Behavior by reading from other Behaviors; the result will be recomputed whenever any of the read Behaviors changes
44 pull :: PullM t a -> Behavior t a
45 -- | A monad for doing complex pull-based calculations efficiently
46 type PullM t :: * -> *
47 -- | 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
48 merge :: GCompare k => DMap (WrapArg (Event t) k) -> Event t (DMap k) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
49 -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events
50 fan :: GCompare k => Event t (DMap k) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it
51 -- | Create an Event that will occur whenever the currently-selected input Event occurs
52 switch :: Behavior t (Event t a) -> Event t a
53 -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring
54 coincidence :: Event t (Event t a) -> Event t a
56class (Applicative m, Monad m) => MonadSample t m | m -> t where
57 -- | Get the current value in the Behavior
58 sample :: Behavior t a -> m a
60class MonadSample t m => MonadHold t m where
61 -- | Create a new Behavior whose value will initially be equal to the given value and will be updated whenever the given Event occurs
62 hold :: a -> Event t a -> m (Behavior t a)
64newtype EventSelector t k = EventSelector { select :: forall a. k a -> Event t a }
66--------------------------------------------------------------------------------
67-- Instances
68--------------------------------------------------------------------------------
70instance MonadSample t m => MonadSample t (ReaderT r m) where
71 sample = lift . sample
73instance MonadHold t m => MonadHold t (ReaderT r m) where
74 hold a0 = lift . hold a0
76instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
77 sample = lift . sample
79instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
80 hold a0 = lift . hold a0
82instance MonadSample t m => MonadSample t (StateT s m) where
83 sample = lift . sample
85instance MonadHold t m => MonadHold t (StateT s m) where
86 hold a0 = lift . hold a0
88instance MonadSample t m => MonadSample t (ExceptT e m) where
89 sample = lift . sample
91instance MonadHold t m => MonadHold t (ExceptT e m) where
92 hold a0 = lift . hold a0
94instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
95 sample = lift . sample
97instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
98 hold a0 = lift . hold a0
100instance MonadSample t m => MonadSample t (ContT r m) where
101 sample = lift . sample
103instance MonadHold t m => MonadHold t (ContT r m) where
104 hold a0 = lift . hold a0
106--------------------------------------------------------------------------------
107-- Convenience functions
108--------------------------------------------------------------------------------
110-- | Create an Event from another Event.
111-- The provided function can sample 'Behavior's and hold 'Event's.
112pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
113pushAlways f = push (liftM Just . f)
115-- | Flipped version of 'fmap'.
116ffor :: Functor f => f a -> (a -> b) -> f b
117ffor = flip fmap
119instance Reflex t => Functor (Behavior t) where
120 fmap f = pull . liftM f . sample
122instance Reflex t => Applicative (Behavior t) where
123 pure = constant
124 f <*> x = pull $ sample f `ap` sample x
125 _ *> b = b
126 a <* _ = a
128instance Reflex t => Monad (Behavior t) where
129 a >>= f = pull $ sample a >>= sample . f
130 -- 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.
131 return = constant
132 fail = error "Monad (Behavior t) does not support fail"
134instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
135 a <> b = pull $ liftM2 (<>) (sample a) (sample b)
136 sconcat = pull . liftM sconcat . mapM sample
137 times1p n = fmap $ times1p n
139instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
140 mempty = constant mempty
141 mappend a b = pull $ liftM2 mappend (sample a) (sample b)
142 mconcat = pull . liftM mconcat . mapM sample
144--TODO: See if there's a better class in the standard libraries already
145-- | A class for values that combines filtering and mapping using 'Maybe'.
146class FunctorMaybe f where
147 -- | Combined mapping and filtering function.
148 fmapMaybe :: (a -> Maybe b) -> f a -> f b
150-- | Flipped version of 'fmapMaybe'.
151fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
152fforMaybe = flip fmapMaybe
154-- | Filter 'f a' using the provided predicate.
155-- Relies on 'fforMaybe'.
156ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
157ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
159instance Reflex t => FunctorMaybe (Event t) where
160 fmapMaybe f = push $ return . f
162instance Reflex t => Functor (Event t) where
163 fmap f = fmapMaybe $ Just . f
165-- | Create a new 'Event' by combining each occurence with the next value
166-- of the list using the supplied function. If the list runs out of items,
167-- all subsequent 'Event' occurrences will be ignored.
168zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
169zipListWithEvent f l e = do
170 rec lb <- hold l eTail
171 let eBoth = flip push e $ \o -> do
172 l' <- sample lb
173 return $ case l' of
174 (h : t) -> Just (f h o, t)
175 [] -> Nothing
176 let eTail = fmap snd eBoth
177 lb `seq` eBoth `seq` eTail `seq` return ()
178 return $ fmap fst eBoth
180-- | Replace each occurrence value of the 'Event' with the value of the
181-- 'Behavior' at the time of that occurrence.
182tag :: Reflex t => Behavior t b -> Event t a -> Event t b
183tag b = pushAlways $ \_ -> sample b
185-- | Create a new 'Event' that combines occurences of supplied 'Event'
186-- with the current value of the 'Behavior'.
187attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
188attach = attachWith (,)
190-- | Create a new 'Event' that occurs when the supplied 'Event' occurs
191-- by combining it with the current value of the 'Behavior'.
192attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
193attachWith f = attachWithMaybe $ \a b -> Just $ f a b
195-- | Create a new 'Event' by combining each occurence with the current
196-- value of the 'Behavior'. The occurrence is discarded if the combining function
197-- returns Nothing
198attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
199attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b
201-- | Alias for 'headE'
202onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
203onceE = headE
205-- | Create a new 'Event' that only occurs on the first occurence of
206-- the supplied 'Event'.
207headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
208headE e = do
209 rec be <- hold e $ fmap (const never) e'
210 let e' = switch be
211 e' `seq` return ()
212 return e'
214-- | Create a new 'Event' that occurs on all but the first occurence
215-- of the supplied 'Event'.
216tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
217tailE e = liftM snd $ headTailE e
219-- | Create a tuple of two 'Event's with the first one occuring only
220-- the first time the supplied 'Event' occurs and the second occuring
221-- on all but the first occurence.
222headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
223headTailE e = do
224 eHead <- headE e
225 be <- hold never $ fmap (const e) eHead
226 return (eHead, switch be)
228-- | Split the supplied 'Event' into two individual 'Event's occuring
229-- at the same time with the respective values from the tuple.
230splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
231splitE e = (fmap fst e, fmap snd e)
233-- | Print the supplied 'String' and the value of the 'Event' on each
234-- occurence. This should /only/ be used for debugging.
235--
236-- Note: As with Debug.Trace.trace, the message will only be printed if
237-- the 'Event' is actually used.
238traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
239traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
241-- | Print the output of the supplied function on each occurence of
242-- the 'Event'. This should /only/ be used for debugging.
243--
244-- Note: As with Debug.Trace.trace, the message will only be printed if
245-- the 'Event' is actually used.
246traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
247traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
249-- | Tag type for 'Either' to use it as a 'DSum'.
250data EitherTag l r a where
251 LeftTag :: EitherTag l r l
252 RightTag :: EitherTag l r r
254instance GEq (EitherTag l r) where
255 geq a b = case (a, b) of
256 (LeftTag, LeftTag) -> Just Refl
257 (RightTag, RightTag) -> Just Refl
258 _ -> Nothing
260instance GCompare (EitherTag l r) where
261 gcompare a b = case (a, b) of
262 (LeftTag, LeftTag) -> GEQ
263 (LeftTag, RightTag) -> GLT
264 (RightTag, LeftTag) -> GGT
265 (RightTag, RightTag) -> GEQ
267instance GShow (EitherTag l r) where
268 gshowsPrec _ a = case a of
269 LeftTag -> showString "LeftTag"
270 RightTag -> showString "RightTag"
272instance (Show l, Show r) => ShowTag (EitherTag l r) where
273 showTaggedPrec t n a = case t of
274 LeftTag -> showsPrec n a
275 RightTag -> showsPrec n a
277-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
278eitherToDSum :: Either a b -> DSum (EitherTag a b)
279eitherToDSum = \case
280 Left a -> LeftTag :=> a
281 Right b -> RightTag :=> b
283-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
284dsumToEither :: DSum (EitherTag a b) -> Either a b
285dsumToEither = \case
286 LeftTag :=> a -> Left a
287 RightTag :=> b -> Right b
289-- | Extract the values of a 'DMap' of 'EitherTag's.
290dmapToThese :: DMap (EitherTag a b) -> Maybe (These a b)
291dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
292 (Nothing, Nothing) -> Nothing
293 (Just a, Nothing) -> Just $ This a
294 (Nothing, Just b) -> Just $ That b
295 (Just a, Just b) -> Just $ These a b
297-- | Create a new 'Event' that occurs if at least one of the supplied
298-- 'Event's occurs. If both occur at the same time they are combined
299-- using 'mappend'.
300appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
301appendEvents e1 e2 = mergeThese mappend <$> align e1 e2
303{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
304sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
305sequenceThese t = case t of
306 This ma -> liftM This ma
307 These ma mb -> liftM2 These ma mb
308 That mb -> liftM That mb
310instance (Semigroup a, Reflex t) => Monoid (Event t a) where
311 mempty = never
312 mappend a b = mconcat [a, b]
313 mconcat = fmap sconcat . mergeList
315-- | Create a new 'Event' that occurs if at least one of the 'Event's
316-- in the list occurs. If multiple occur at the same time they are
317-- folded from the left with the given function.
318mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
319mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) $ merge $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
321-- | Create a new 'Event' that occurs if at least one of the 'Event's
322-- in the list occurs. If multiple occur at the same time the value is
323-- the value of the leftmost event.
324leftmost :: Reflex t => [Event t a] -> Event t a
325leftmost = mergeWith const
327-- | Create a new 'Event' that occurs if at least one of the 'Event's
328-- in the list occurs and has a list of the values of all 'Event's
329-- occuring at that time.
330mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
331mergeList [] = never
332mergeList es = mergeWith (<>) $ map (fmap (:|[])) es
334-- | Create a new 'Event' combining the map of 'Event's into an
335-- 'Event' that occurs if at least one of them occurs and has a map of
336-- values of all 'Event's occuring at that time.
337mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
338mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
340-- | Split the event into an 'EventSelector' that allows efficient
341-- selection of the individual 'Event's.
342fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
343fanMap = fan . fmap mapToDMap
345-- | Switches to the new event whenever it receives one; the new event is used immediately, on the same frame that it is switched to
346switchPromptly :: forall t m a. (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
347switchPromptly ea0 eea = do
348 bea <- hold ea0 eea
349 let eLag = switch bea
350 eCoincidences = coincidence eea
351 return $ leftmost [eCoincidences, eLag]
353instance Reflex t => Align (Event t) where
354 nil = never
355 align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [WrapArg LeftTag :=> ea, WrapArg RightTag :=> eb]
357-- | Create a new 'Event' that only occurs if the supplied 'Event'
358-- occurs and the 'Behavior' is true at the time of occurence.
359gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
360gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
362-- | Create a new behavior given a starting behavior and switch to a the
363-- behvior carried by the event when it fires.
364switcher :: (Reflex t, MonadHold t m)
365 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
366switcher b eb = pull . (sample <=< sample) <$> hold b eb