module FRP.Reactive.PrimReactive
(
EventG, ReactiveG
, stepper, switcher, withTimeGE, withTimeGR
, futuresE, listEG, atTimesG, atTimeG
, snapshotWith, accumE, accumR, once
, withRestE, untilE
, eventOcc
, joinMaybes, filterMP
, isMonotoneR
, batch, infE
) where
import Data.Monoid
import Control.Applicative
import Control.Monad
import Data.Function (on)
import Control.Concurrent (threadDelay)
import Control.Exception (evaluate)
import System.IO.Unsafe
import Test.QuickCheck hiding (evaluate)
import Test.QuickCheck.Instances
import Test.QuickCheck.Checkers
import Test.QuickCheck.Classes
import Control.Compose ((:.)(..), inO2, Monoid_f(..))
import Data.Pair
import Control.Instances ()
import Data.Unamb (race)
import Data.Max
import Data.AddBounds
import FRP.Reactive.Future hiding (batch)
import FRP.Reactive.Internal.Reactive
instance (Eq a, Eq b, EqProp a, EqProp b) => EqProp (EventG a b) where
a =-= b = foldr (.&.) (property True) $ zipWith (=-=) (f a) (f b)
where
f = take 20 . eFutures
arbitraryE :: (Num t, Ord t, Arbitrary t, Arbitrary u) => Gen (EventG t u)
arbitraryE = frequency
[ (1, liftA2 ((liftA. liftA) futuresE addStart) arbitrary futureList)
, (4, liftA futuresE futureList)
]
where
earliestFuture = Future . (,) (Max MinBound)
addStart = (:).earliestFuture
futureList = frequency [(10, futureListFinite), (1,futureListInf)]
futureListFinite = liftA2 (zipWith future) nondecreasing arbitrary
futureListInf =
liftA2 (zipWith future) (resize 10 nondecreasingInf)
(infiniteList arbitrary)
instance (Arbitrary t, Ord t, Num t, Arbitrary a) => Arbitrary (EventG t a) where
arbitrary = arbitraryE
coarbitrary = coarbitrary . eFuture
instance (Arbitrary t, Arbitrary a, Num t, Ord t) => Arbitrary (ReactiveG t a) where
arbitrary = liftA2 Stepper arbitrary arbitrary
coarbitrary (a `Stepper` e) = coarbitrary e . coarbitrary a
instance Ord t => Model (ReactiveG t a) (t -> a) where
model = rat
instance (Ord t, Arbitrary t, Show t, EqProp a) => EqProp (ReactiveG t a)
where
(=-=) = (=-=) `on` model
rInit :: ReactiveG t a -> a
rInit (a `Stepper` _) = a
instance Ord t => Monoid (EventG t a) where
mempty = Event mempty
mappend = inEvent2 merge
instance (Ord t, Monoid a) => Monoid (ReactiveG t a) where
mempty = pure mempty
mappend = liftA2 mappend
merge :: Ord t => Binop (FutureG t (ReactiveG t a))
Future (Max MaxBound,_) `merge` v = v
u `merge` Future (Max MaxBound,_) = u
u `merge` v =
(inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v)
instance Functor (EventG t) where
fmap f = inEvent $ (fmap.fmap) f
instance Functor (ReactiveG t) where
fmap f (a `Stepper` e) = f a `stepper` fmap f e
instance Ord t => Applicative (EventG t) where
pure = return
_ <*> (Event (Future (Max MaxBound,_))) = mempty
x <*> y = x `ap` y
instance Ord t => Alternative (EventG t) where
{ empty = mempty; (<|>) = mappend }
instance Ord t => Pair (ReactiveG t) where
(c `Stepper` ce) `pair` (d `Stepper` de) =
(c,d) `accumR` pairEdit (ce,de)
instance Ord t => Applicative (ReactiveG t) where
pure a = a `stepper` mempty
rf <*> rx = uncurry ($) <$> (rf `pair` rx)
instance Ord t => Monad (EventG t) where
return a = Event (pure (pure a))
e >>= f = joinE (fmap f e)
happy :: (Ord t) => EventG t a ->
Time t ->
EventG t a ->
EventG t a
happy a (Max MaxBound) _ = a
happy (Event (Future (Max MaxBound, _))) _ b = b
happy a@(Event (Future (t0, e `Stepper` ee'))) t b
| t0 <= t = (Event (Future (t0, e `Stepper` (happy ee' t b))))
| otherwise = a `mappend` b
joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a
joinE (Event (Future (Max MaxBound, _))) = mempty
joinE (Event (Future (t0h, e `Stepper` ((Event (Future (Max MaxBound, _)))))))
= adjustE t0h e
joinE (Event (Future (t0h, e `Stepper` ee'@((Event (Future (t1h, _)))))))
= happy (adjustE t0h e) t1h (adjustTopE t0h (joinE ee'))
adjustTopE :: Ord t => Time t -> EventG t t1 -> EventG t t1
adjustTopE t0h (Event (Future (tah, r))) =
Event (Future (t0h `max` tah,r))
adjustE :: Ord t => Time t -> EventG t t1 -> EventG t t1
adjustE _ e@(Event (Future (Max MaxBound, _))) = e
adjustE t0h (Event (Future (tah, a `Stepper` e))) =
Event (Future (t1h,a `Stepper` adjustE t1h e))
where
t1h = t0h `max` tah
instance Ord t => MonadPlus (EventG t) where { mzero = mempty; mplus = mappend }
instance Ord t => Monad (ReactiveG t) where
return = pure
r >>= f = joinR (f <$> r)
stepper :: a -> EventG t a -> ReactiveG t a
stepper = Stepper
switcher :: Ord t => ReactiveG t a -> EventG t (ReactiveG t a) -> ReactiveG t a
r `switcher` e = join (r `stepper` e)
joinR :: Ord t => ReactiveG t (ReactiveG t a) -> ReactiveG t a
joinR ((a `Stepper` Event ur) `Stepper` e'@(Event urr)) = a `stepper` Event u
where
u = ((`switcher` e') <$> ur) `mappend` (join <$> urr)
withTimeGE :: EventG t a -> EventG t (a, Time t)
withTimeGE = inEvent $ inFuture $ \ (t,r) -> (t, withTimeGR t r)
withTimeGR :: Time t -> ReactiveG t a -> ReactiveG t (a, Time t)
withTimeGR t (a `Stepper` e) = (a,t) `Stepper` withTimeGE e
listEG :: Ord t => [(t,a)] -> EventG t a
listEG = futuresE . map (uncurry future)
futuresE :: Ord t => [FutureG t a] -> EventG t a
futuresE [] = mempty
futuresE (Future (t,a) : futs) =
Event (Future (t, a `stepper` futuresE futs))
atTimesG :: Ord t => [t] -> EventG t ()
atTimesG = listEG . fmap (flip (,) ())
atTimeG :: Ord t => t -> EventG t ()
atTimeG = atTimesG . pure
snap :: forall a b t. Ord t =>
EventG t a -> ReactiveG t b -> EventG t (Maybe a, b)
ea `snap` (b0 `Stepper` eb) =
(Nothing, b0) `accumE` (fmap fa ea `mappend` fmap fb eb)
where
fa :: a -> Unop (Maybe a, b)
fb :: b -> Unop (Maybe a, b)
fa a (_,b) = (Just a , b)
fb b _ = (Nothing, b)
snapshotWith :: Ord t => (a -> b -> c) -> EventG t a -> ReactiveG t b -> EventG t c
snapshotWith f e r = joinMaybes $ fmap h (e `snap` r)
where
h (Nothing,_) = Nothing
h (Just a ,b) = Just (f a b)
accumE :: a -> EventG t (a -> a) -> EventG t a
accumE a = inEvent $ fmap $ \ (f `Stepper` e') -> f a `accumR` e'
accumR :: a -> EventG t (a -> a) -> ReactiveG t a
a `accumR` e = a `stepper` (a `accumE` e)
once :: Ord t => EventG t a -> EventG t a
once = inEvent $ fmap $ pure . rInit
eventOcc :: (Ord t) => EventG t a -> FutureG t (a, EventG t a)
eventOcc (Event fut) = (\ (Stepper a e) -> (a,e)) <$> fut
withRestE :: EventG t a -> EventG t (a, EventG t a)
withRestE = inEvent $ fmap $
\ (a `Stepper` e') -> (a,e') `stepper` withRestE e'
untilE :: Ord t => EventG t a -> EventG t b -> EventG t a
ea `untilE` Event (Future ~(tb,_)) = ea `untilET` tb
untilET :: Ord t => EventG t a -> Time t -> EventG t a
Event (Future ~(ta, a `Stepper` e')) `untilET` t =
Event (Future (ta', a `Stepper` (e' `untilET` t)))
where
ta' = (ta `min` t) `max` (if ta < t then ta else maxBound)
rats :: Ord t => ReactiveG t a -> [t] -> [a]
_ `rats` [] = []
r@(a `Stepper` Event (Future (tr',r'))) `rats` ts@(t:ts')
| ftime t <= tr' = a : r `rats` ts'
| otherwise = r' `rats` ts
rat :: Ord t => ReactiveG t a -> t -> a
rat r = head . rats r . (:[])
instance (Monoid_f f, Ord t) => Monoid_f (ReactiveG t :. f) where
{ mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) }
instance (Ord t, Pair f) => Pair (ReactiveG t :. f) where pair = apPair
instance Unpair (ReactiveG t) where {pfst = fmap fst; psnd = fmap snd}
instance Ord t => Monoid_f (EventG t) where
{ mempty_f = mempty ; mappend_f = mappend }
instance Ord t => Monoid ((EventG t :. f) a) where
{ mempty = O mempty; mappend = inO2 mappend }
instance Ord t => Monoid_f (EventG t :. f) where
{ mempty_f = mempty ; mappend_f = mappend }
instance (Ord t, Copair f) => Pair (EventG t :. f) where
pair = copair
instance Unpair (EventG t) where {pfst = fmap fst; psnd = fmap snd}
joinMaybes :: MonadPlus m => m (Maybe a) -> m a
joinMaybes = (>>= maybe mzero return)
filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a
filterMP p m = joinMaybes (liftM f m)
where
f a | p a = Just a
| otherwise = Nothing
type ApTy f a b = f (a -> b) -> f a -> f b
batch :: TestBatch
batch = ( "Reactive.PrimReactive"
, concatMap unbatch
[ ("monotonicity",
[ monotonicity2 "<*>"
((<*>) :: ApTy (EventG NumT) T T)
, monotonicity2 "adjustE" (adjustE
:: Time NumT
-> EventG NumT NumT
-> EventG NumT NumT)
, monotonicity "join" (join
:: EventG NumT (EventG NumT T)
-> EventG NumT T)
, monotonicity "withTimeGE" (withTimeGE
:: EventG NumT T
-> EventG NumT (T, Time NumT))
, monotonicity "once" (once
:: EventG NumT T
-> EventG NumT T)
, monotonicity2 "accumE" (accumE
:: T
-> EventG NumT (T -> T)
-> EventG NumT T)
, monotonicity2 "mappend" (mappend
:: EventG NumT T
-> EventG NumT T
-> EventG NumT T)
, monotonicity2 "mplus" (mplus
:: EventG NumT T
-> EventG NumT T
-> EventG NumT T)
, monotonicity2 "<|>" ((<|>)
:: EventG NumT T
-> EventG NumT T
-> EventG NumT T)
, monotonicity2 "fmap" (fmap
:: (T -> T)
-> EventG NumT T
-> EventG NumT T)
])
, ("order preservation",
[ simulEventOrder "once" (once
:: EventG NumT NumT
-> EventG NumT NumT)
])
, monad (undefined :: ReactiveG NumT (NumT,T,NumT))
, monoid (undefined :: EventG NumT T)
, monoid (undefined :: ReactiveG NumT [T])
]
)
monotonicity :: (Show a, Arbitrary a, Arbitrary t
,Num t, Ord t, Ord t')
=> String -> (EventG t a -> EventG t' a')
-> (String,Property)
monotonicity n f = (n, property $ monotoneTest f)
monotonicity2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t
,Num t, Ord t, Ord t')
=> String -> (b -> EventG t a -> EventG t' a')
-> (String,Property)
monotonicity2 n f = (n, property $ monotoneTest2 f)
monotoneTest :: (Ord t') => (EventG t a -> EventG t' a')
-> EventG t a
-> Bool
monotoneTest f e = unsafePerformIO ( (evaluate (isMonotoneE . f $ e))
`race` slowTrue)
monotoneTest2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t
,Num t, Ord t, Ord t')
=> (b -> EventG t a -> EventG t' a')
-> (b , EventG t a) -> Bool
monotoneTest2 f (x,e) =
unsafePerformIO ( (evaluate (isMonotoneE (x `f` e)))
`race` slowTrue)
slowTrue :: IO Bool
slowTrue = do threadDelay 10
return True
isMonotoneE :: (Ord t) => EventG t a -> Bool
isMonotoneE = liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
((uncurry isMonotoneR') . unFuture . eFuture)
isMonotoneE' :: (Ord t) => (Time t) -> EventG t a -> Bool
isMonotoneE' t =
liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
((\(t',r) -> t <= t' && isMonotoneR' t' r) . unFuture . eFuture)
isMonotoneR :: (Ord t) => ReactiveG t a -> Bool
isMonotoneR (_ `Stepper` e) = isMonotoneE e
isMonotoneR' :: (Ord t) => (Time t) -> ReactiveG t a -> Bool
isMonotoneR' t (_ `Stepper` e) = isMonotoneE' t e
simulEventOrder :: (Arbitrary t, Num t, Ord t
,Arbitrary t', Num t', Ord t'
,Num t'', Ord t'', Num t''', Ord t''')
=> String -> (EventG t t' -> EventG t'' t''')
-> (String, Property)
simulEventOrder n f =
(n,forAll genEvent (isStillOrderedE . f))
where
genEvent :: (Arbitrary t1, Num t1, Ord t1, Arbitrary t2, Num t2, Ord t2)
=> Gen (EventG t1 t2)
genEvent = liftA futuresE (liftA2 (zipWith future) nondecreasing
increasing)
isStillOrderedE :: (Num t1, Ord t1, Num t2, Ord t2) => EventG t1 t2 -> Bool
isStillOrderedE =
liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
(isStillOrderedR . futVal . eFuture)
isStillOrderedR (a `Stepper` e) =
isStillOrderedE' a e
isStillOrderedE' a =
liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
(isStillOrderedR' a . futVal . eFuture)
isStillOrderedR' a (b `Stepper` e) =
a < b && isStillOrderedE' b e
infE :: EventG NumT NumT
infE = futuresE (zipWith future [1..] [1..])