@@ -1,3 +1,4 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
@@ -12,6 +13,7 @@
12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
15module Reflex.Class where
17module Reflex.Class where
17import Control.Applicative
19import Control.Applicative
@@ -28,16 +30,20 @@ import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))
28import qualified Data.Dependent.Map as DMap
30import qualified Data.Dependent.Map as DMap
29import Data.Dependent.Sum (ShowTag (..))
31import Data.Dependent.Sum (ShowTag (..))
30import Data.Foldable
32import Data.Foldable
33+import qualified Data.Functor.Bind as Bind
34+import Data.Functor.Bind hiding (join)
31import Data.Functor.Compose
35import Data.Functor.Compose
32import Data.Functor.Constant
36import Data.Functor.Constant
33import Data.Functor.Misc
37import Data.Functor.Misc
38+import Data.Functor.Plus
34import Data.GADT.Compare ((:~:) (..), GEq (..))
39import Data.GADT.Compare ((:~:) (..), GEq (..))
35import Data.GADT.Show (GShow (..))
40import Data.GADT.Show (GShow (..))
36import Data.List.NonEmpty (NonEmpty (..))
41import Data.List.NonEmpty (NonEmpty (..))
37import Data.Map (Map)
42import Data.Map (Map)
38import Data.Maybe
43import Data.Maybe
39−import Data.Monoid hiding ((<>))
44+import Data.Monoid hiding (Alt, (<>))
40import Data.Semigroup (Semigroup, sconcat, stimes, stimesIdempotentMonoid, (<>))
45import Data.Semigroup (Semigroup, sconcat, stimes, stimesIdempotentMonoid, (<>))
41import Data.These
47import Data.These
42import Data.Traversable
48import Data.Traversable
@@ -224,21 +230,49 @@ pushAlways f = push (fmap Just . f)
224ffor :: Functor f => f a -> (a -> b) -> f b
230ffor :: Functor f => f a -> (a -> b) -> f b
225ffor = flip fmap
231ffor = flip fmap
227−instance Reflex t => Functor (Behavior t) where
228− fmap f = pull . fmap f . sample
230instance Reflex t => Applicative (Behavior t) where
233instance Reflex t => Applicative (Behavior t) where
231 pure = constant
234 pure = constant
232 f <*> x = pull $ sample f `ap` sample x
235 f <*> x = pull $ sample f `ap` sample x
233 _ *> b = b
236 _ *> b = b
234 a <* _ = a
237 a <* _ = a
239+instance Reflex t => Apply (Behavior t) where
242+instance Reflex t => Bind (Behavior t) where
245+instance (Reflex t, Fractional a) => Fractional (Behavior t a) where
247+ fromRational = pure . fromRational
250+instance Reflex t => Functor (Behavior t) where
251+ fmap f = pull . fmap f . sample
253+instance (Reflex t, IsString a) => IsString (Behavior t a) where
254+ fromString = pure . fromString
236instance Reflex t => Monad (Behavior t) where
256instance Reflex t => Monad (Behavior t) where
237 a >>= f = pull $ sample a >>= sample . f
257 a >>= f = pull $ sample a >>= sample . f
238 -- 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.
258 -- 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.
239 return = constant
259 return = constant
240 fail = error "Monad (Behavior t) does not support fail"
260 fail = error "Monad (Behavior t) does not support fail"
262+instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
263+ mempty = constant mempty
264+ mappend a b = pull $ liftM2 mappend (sample a) (sample b)
265+ mconcat = pull . fmap mconcat . mapM sample
267+instance (Reflex t, Num a) => Num (Behavior t a) where
272+ fromInteger = pure . fromInteger
273+ negate = fmap negate
274+ signum = fmap signum
242instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
276instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
243 a <> b = pull $ liftM2 (<>) (sample a) (sample b)
277 a <> b = pull $ liftM2 (<>) (sample a) (sample b)
244 sconcat = pull . fmap sconcat . mapM sample
278 sconcat = pull . fmap sconcat . mapM sample
@@ -248,11 +282,6 @@ instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
248 times1p n = fmap $ times1p n
282 times1p n = fmap $ times1p n
251−instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
252− mempty = constant mempty
253− mappend a b = pull $ liftM2 mappend (sample a) (sample b)
254− mconcat = pull . fmap mconcat . mapM sample
256--TODO: See if there's a better class in the standard libraries already
285--TODO: See if there's a better class in the standard libraries already
257-- | A class for values that combines filtering and mapping using 'Maybe'.
286-- | A class for values that combines filtering and mapping using 'Maybe'.
258class FunctorMaybe f where
287class FunctorMaybe f where
@@ -271,12 +300,27 @@ fforMaybe = flip fmapMaybe
271ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
300ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
272ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
301ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
303+-- | Left-biased event union (prefers left event on simultaneous
274−instance Reflex t => FunctorMaybe (Event t) where
305+instance Reflex t => Alt (Event t) where
275− fmapMaybe f = push $ return . f
306+ ev1 <!> ev2 = leftmost [ev1, ev2]
308+instance Reflex t => Apply (Event t) where
309+ evf <.> evx = coincidence (fmap (<$> evx) evf)
311+instance Reflex t => Bind (Event t) where
312+ evx >>- f = coincidence (f <$> evx)
277instance Reflex t => Functor (Event t) where
315instance Reflex t => Functor (Event t) where
278 fmap f = fmapMaybe $ Just . f
316 fmap f = fmapMaybe $ Just . f
318+instance Reflex t => FunctorMaybe (Event t) where
319+ fmapMaybe f = push $ return . f
321+instance Reflex t => Plus (Event t) where
280-- | Replace each occurrence value of the 'Event' with the value of the
324-- | Replace each occurrence value of the 'Event' with the value of the
281-- 'Behavior' at the time of that occurrence.
325-- 'Behavior' at the time of that occurrence.
282tag :: Reflex t => Behavior t b -> Event t a -> Event t b
326tag :: Reflex t => Behavior t b -> Event t a -> Event t b