git.iko.soy/patch
on 832580f help sign in
patch/src/Reflex/Class.hs
238 lines 10 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 Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)
6import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
7import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
8import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
9import Data.List.NonEmpty (NonEmpty (..))
10import Data.These
11import Data.Align
12import Data.GADT.Compare (GEq (..), (:~:) (..))
13import Data.GADT.Show (GShow (..))
14import Data.Dependent.Sum (ShowTag (..))
15import Data.Map (Map)
16import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))
17import qualified Data.Dependent.Map as DMap
18import Data.Functor.Misc
19import Data.Semigroup
21import Debug.Trace (trace)
23class (MonadHold t (PushM t), MonadSample t (PullM t), Functor (Event t), Functor (Behavior t)) => Reflex t where
24 -- | 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
25 data Behavior t :: * -> *
26 -- | 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")
27 data Event t :: * -> *
28 -- | An Event with no occurrences
29 never :: Event t a
30 -- | Create a Behavior that always has the given value
31 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
32 -- | 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
33 push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
34 -- | A monad for doing complex push-based calculations efficiently
35 type PushM t :: * -> *
36 -- | Create a Behavior by reading from other Behaviors; the result will be recomputed whenever any of the read Behaviors changes
37 pull :: PullM t a -> Behavior t a
38 -- | A monad for doing complex pull-based calculations efficiently
39 type PullM t :: * -> *
40 -- | 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
41 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
42 -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events
43 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
44 -- | Create an Event that will occur whenever the currently-selected input Event occurs
45 switch :: Behavior t (Event t a) -> Event t a
46 -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring
47 coincidence :: Event t (Event t a) -> Event t a
49class Monad m => MonadSample t m | m -> t where
50 -- | Get the current value in the Behavior
51 sample :: Behavior t a -> m a
53class MonadSample t m => MonadHold t m where
54 -- | Create a new Behavior whose value will initially be equal to the given value and will be updated whenever the given Event occurs
55 hold :: a -> Event t a -> m (Behavior t a)
57newtype EventSelector t k = EventSelector { select :: forall a. k a -> Event t a }
59--------------------------------------------------------------------------------
60-- Instances
61--------------------------------------------------------------------------------
63instance MonadSample t m => MonadSample t (ReaderT r m) where
64 sample = lift . sample
66instance MonadHold t m => MonadHold t (ReaderT r m) where
67 hold a0 = lift . hold a0
69--------------------------------------------------------------------------------
70-- Convenience functions
71--------------------------------------------------------------------------------
73pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
74pushAlways f e = push (liftM Just . f) e
76ffor :: Functor f => f a -> (a -> b) -> f b
77ffor = flip fmap
79instance Reflex t => Functor (Behavior t) where
80 fmap f = pull . liftM f . sample
82--TODO: See if there's a better class in the standard libraries already
83class FunctorMaybe f where
84 fmapMaybe :: (a -> Maybe b) -> f a -> f b
86fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
87fforMaybe = flip fmapMaybe
89ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
90ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
92instance Reflex t => FunctorMaybe (Event t) where
93 fmapMaybe f = push $ return . f
95instance Reflex t => Functor (Event t) where
96 fmap f = fmapMaybe $ Just . f
98zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
99zipListWithEvent f l e = do
100 rec lb <- hold l eTail
101 let eBoth = flip push e $ \o -> do
102 l' <- sample lb
103 return $ case l' of
104 (h : t) -> Just (f h o, t)
105 [] -> Nothing
106 let eTail = fmap snd eBoth
107 lb `seq` eBoth `seq` eTail `seq` return ()
108 return $ fmap fst eBoth
110-- | Replace the occurrence value of the Event with the value of the Behavior at the time of the occurrence
111tag :: Reflex t => Behavior t b -> Event t a -> Event t b
112tag b = pushAlways $ \_ -> sample b
114attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
115attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b
117attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
118attachWith f = attachWithMaybe $ \a b -> Just $ f a b
120attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
121attach = attachWith (,)
123onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
124onceE = headE
126headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
127headE e = do
128 rec be <- hold e $ fmap (const never) e'
129 let e' = switch be
130 e' `seq` return ()
131 return e'
133tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
134tailE e = liftM snd $ headTailE e
136headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
137headTailE e = do
138 eHead <- headE e
139 be <- hold never $ fmap (const e) eHead
140 return (eHead, switch be)
142splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
143splitE e = (fmap fst e, fmap snd e)
145traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
146traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
148traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
149traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
151data EitherTag l r a where
152 LeftTag :: EitherTag l r l
153 RightTag :: EitherTag l r r
155instance GEq (EitherTag l r) where
156 geq a b = case (a, b) of
157 (LeftTag, LeftTag) -> Just Refl
158 (RightTag, RightTag) -> Just Refl
159 _ -> Nothing
161instance GCompare (EitherTag l r) where
162 gcompare a b = case (a, b) of
163 (LeftTag, LeftTag) -> GEQ
164 (LeftTag, RightTag) -> GLT
165 (RightTag, LeftTag) -> GGT
166 (RightTag, RightTag) -> GEQ
168instance GShow (EitherTag l r) where
169 gshowsPrec _ a = case a of
170 LeftTag -> showString "LeftTag"
171 RightTag -> showString "RightTag"
173instance (Show l, Show r) => ShowTag (EitherTag l r) where
174 showTaggedPrec t n a = case t of
175 LeftTag -> showsPrec n a
176 RightTag -> showsPrec n a
178eitherToDSum :: Either a b -> DSum (EitherTag a b)
179eitherToDSum = \case
180 Left a -> LeftTag :=> a
181 Right b -> RightTag :=> b
183dsumToEither :: DSum (EitherTag a b) -> Either a b
184dsumToEither = \case
185 LeftTag :=> a -> Left a
186 RightTag :=> b -> Right b
188dmapToThese :: DMap (EitherTag a b) -> Maybe (These a b)
189dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
190 (Nothing, Nothing) -> Nothing
191 (Just a, Nothing) -> Just $ This a
192 (Nothing, Just b) -> Just $ That b
193 (Just a, Just b) -> Just $ These a b
195appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
196appendEvents e1 e2 = fmap (mergeThese mappend) $ align e1 e2
198sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
199sequenceThese t = case t of
200 This ma -> liftM This ma
201 These ma mb -> liftM2 These ma mb
202 That mb -> liftM That mb
204instance (Semigroup a, Reflex t) => Monoid (Event t a) where
205 mempty = never
206 mappend a b = mconcat [a, b]
207 mconcat = fmap sconcat . mergeList
209mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
210mergeWith 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
212leftmost :: Reflex t => [Event t a] -> Event t a
213leftmost = mergeWith const
215mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
216mergeList [] = never
217mergeList es = mergeWith (<>) $ map (fmap (:|[])) es
219mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
220mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
222fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
223fanMap = fan . fmap mapToDMap
225-- | Switches to the new event whenever it receives one; the new event is used immediately, on the same frame that it is switched to
226switchPromptly :: forall t m a. (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
227switchPromptly ea0 eea = do
228 bea <- hold ea0 eea
229 let eLag = switch bea
230 eCoincidences = coincidence eea
231 return $ leftmost [eCoincidences, eLag]
233instance Reflex t => Align (Event t) where
234 nil = never
235 align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [WrapArg LeftTag :=> ea, WrapArg RightTag :=> eb]
237gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
238gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing