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 (..))
15import Data.GADT.Compare (GEq (..), (:~:) (..))
16import Data.GADT.Show (GShow (..))
17import Data.Dependent.Sum (ShowTag (..))
19import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))
20import qualified Data.Dependent.Map as DMap
21import Data.Functor.Misc
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
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 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
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 Identity) -> 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--------------------------------------------------------------------------------
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
119instance Reflex t => Functor (Behavior t) where
120 fmap f = pull . liftM f . sample
122instance Reflex t => Applicative (Behavior t) where
124 f <*> x = pull $ sample f `ap` sample x
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.
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#if MIN_VERSION_semigroups(0,17,0)
138 stimes n = fmap $ stimes n
140 times1p n = fmap $ times1p n
143instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
144 mempty = constant mempty
145 mappend a b = pull $ liftM2 mappend (sample a) (sample b)
146 mconcat = pull . liftM mconcat . mapM sample
148--TODO: See if there's a better class in the standard libraries already
149-- | A class for values that combines filtering and mapping using 'Maybe'.
150class FunctorMaybe f where
151 -- | Combined mapping and filtering function.
152 fmapMaybe :: (a -> Maybe b) -> f a -> f b
154-- | Flipped version of 'fmapMaybe'.
155fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
156fforMaybe = flip fmapMaybe
158-- | Filter 'f a' using the provided predicate.
159-- Relies on 'fforMaybe'.
160ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
161ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
163instance Reflex t => FunctorMaybe (Event t) where
164 fmapMaybe f = push $ return . f
166instance Reflex t => Functor (Event t) where
167 fmap f = fmapMaybe $ Just . f
169-- | Create a new 'Event' by combining each occurence with the next value
170-- of the list using the supplied function. If the list runs out of items,
171-- all subsequent 'Event' occurrences will be ignored.
172zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
173zipListWithEvent f l e = do
174 rec lb <- hold l eTail
175 let eBoth = flip push e $ \o -> do
178 (h : t) -> Just (f h o, t)
180 let eTail = fmap snd eBoth
181 lb `seq` eBoth `seq` eTail `seq` return ()
182 return $ fmap fst eBoth
184-- | Replace each occurrence value of the 'Event' with the value of the
185-- 'Behavior' at the time of that occurrence.
186tag :: Reflex t => Behavior t b -> Event t a -> Event t b
187tag b = pushAlways $ \_ -> sample b
189-- | Create a new 'Event' that combines occurences of supplied 'Event'
190-- with the current value of the 'Behavior'.
191attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
192attach = attachWith (,)
194-- | Create a new 'Event' that occurs when the supplied 'Event' occurs
195-- by combining it with the current value of the 'Behavior'.
196attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
197attachWith f = attachWithMaybe $ \a b -> Just $ f a b
199-- | Create a new 'Event' by combining each occurence with the current
200-- value of the 'Behavior'. The occurrence is discarded if the combining function
202attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
203attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b
205-- | Alias for 'headE'
206onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
209-- | Create a new 'Event' that only occurs on the first occurence of
210-- the supplied 'Event'.
211headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
213 rec be <- hold e $ fmap (const never) e'
218-- | Create a new 'Event' that occurs on all but the first occurence
219-- of the supplied 'Event'.
220tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
221tailE e = liftM snd $ headTailE e
223-- | Create a tuple of two 'Event's with the first one occuring only
224-- the first time the supplied 'Event' occurs and the second occuring
225-- on all but the first occurence.
226headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
229 be <- hold never $ fmap (const e) eHead
230 return (eHead, switch be)
232-- | Split the supplied 'Event' into two individual 'Event's occuring
233-- at the same time with the respective values from the tuple.
234splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
235splitE e = (fmap fst e, fmap snd e)
237-- | Print the supplied 'String' and the value of the 'Event' on each
238-- occurence. This should /only/ be used for debugging.
240-- Note: As with Debug.Trace.trace, the message will only be printed if
241-- the 'Event' is actually used.
242traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
243traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
245-- | Print the output of the supplied function on each occurence of
246-- the 'Event'. This should /only/ be used for debugging.
248-- Note: As with Debug.Trace.trace, the message will only be printed if
249-- the 'Event' is actually used.
250traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
251traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
253-- | Tag type for 'Either' to use it as a 'DSum'.
254data EitherTag l r a where
255 LeftTag :: EitherTag l r l
256 RightTag :: EitherTag l r r
258instance GEq (EitherTag l r) where
259 geq a b = case (a, b) of
260 (LeftTag, LeftTag) -> Just Refl
261 (RightTag, RightTag) -> Just Refl
264instance GCompare (EitherTag l r) where
265 gcompare a b = case (a, b) of
266 (LeftTag, LeftTag) -> GEQ
267 (LeftTag, RightTag) -> GLT
268 (RightTag, LeftTag) -> GGT
269 (RightTag, RightTag) -> GEQ
271instance GShow (EitherTag l r) where
272 gshowsPrec _ a = case a of
273 LeftTag -> showString "LeftTag"
274 RightTag -> showString "RightTag"
276instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
277 showTaggedPrec t n (Identity a) = case t of
278 LeftTag -> showsPrec n a
279 RightTag -> showsPrec n a
281-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
282eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
284 Left a -> (LeftTag :=> Identity a)
285 Right b -> (RightTag :=> Identity b)
287-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
288dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
290 (LeftTag :=> Identity a) -> Left a
291 (RightTag :=> Identity b) -> Right b
293-- | Extract the values of a 'DMap' of 'EitherTag's.
294dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
295dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
296 (Nothing, Nothing) -> Nothing
297 (Just (Identity a), Nothing) -> Just $ This a
298 (Nothing, Just (Identity b)) -> Just $ That b
299 (Just (Identity a), Just (Identity b)) -> Just $ These a b
301-- | Create a new 'Event' that occurs if at least one of the supplied
302-- 'Event's occurs. If both occur at the same time they are combined
304appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
305appendEvents e1 e2 = mergeThese mappend <$> align e1 e2
307{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
308sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
309sequenceThese t = case t of
310 This ma -> liftM This ma
311 These ma mb -> liftM2 These ma mb
312 That mb -> liftM That mb
314instance (Semigroup a, Reflex t) => Monoid (Event t a) where
316 mappend a b = mconcat [a, b]
317 mconcat = fmap sconcat . mergeList
319-- | Create a new 'Event' that occurs if at least one of the 'Event's
320-- in the list occurs. If multiple occur at the same time they are
321-- folded from the left with the given function.
322mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
323mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)
326 . map (\(k, v) -> (Const2 k) :=> v)
327 $ zip [0 :: Int ..] es
329-- | Create a new 'Event' that occurs if at least one of the 'Event's
330-- in the list occurs. If multiple occur at the same time the value is
331-- the value of the leftmost event.
332leftmost :: Reflex t => [Event t a] -> Event t a
333leftmost = mergeWith const
335-- | Create a new 'Event' that occurs if at least one of the 'Event's
336-- in the list occurs and has a list of the values of all 'Event's
337-- occuring at that time.
338mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
340mergeList es = mergeWith (<>) $ map (fmap (:|[])) es
342-- | Create a new 'Event' combining the map of 'Event's into an
343-- 'Event' that occurs if at least one of them occurs and has a map of
344-- values of all 'Event's occuring at that time.
345mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
346mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
348-- | Split the event into an 'EventSelector' that allows efficient
349-- selection of the individual 'Event's.
350fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
351fanMap = fan . fmap mapToDMap
353-- | Switches to the new event whenever it receives one; the new event is used immediately, on the same frame that it is switched to
354switchPromptly :: forall t m a. (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
355switchPromptly ea0 eea = do
357 let eLag = switch bea
358 eCoincidences = coincidence eea
359 return $ leftmost [eCoincidences, eLag]
361instance Reflex t => Align (Event t) where
363 align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
365-- | Create a new 'Event' that only occurs if the supplied 'Event'
366-- occurs and the 'Behavior' is true at the time of occurence.
367gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
368gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
370-- | Create a new behavior given a starting behavior and switch to a the
371-- behvior carried by the event when it fires.
372switcher :: (Reflex t, MonadHold t m)
373 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
374switcher b eb = pull . (sample <=< sample) <$> hold b eb
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list