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