{-----------------------------------------------------------------------------
reactive-banana
Test cases and examples
------------------------------------------------------------------------------}
{-# LANGUAGE FlexibleContexts, Rank2Types, NoMonomorphismRestriction, RecursiveDo #-}
import Control.Arrow
import Control.Monad (when, join)
import Test.Tasty (defaultMain, testGroup, TestTree)
import Test.Tasty.HUnit (testCase, assertBool)
import Control.Applicative
import Plumbing
main = defaultMain $ testGroup "Tests"
[ testGroup "Simple"
[ testModelMatch "id" id
, testModelMatch "never1" never1
, testModelMatch "fmap1" fmap1
, testModelMatch "filter1" filter1
, testModelMatch "filter2" filter2
, testModelMatchM "accumE1" accumE1
]
, testGroup "Complex"
[ testModelMatchM "counter" counter
, testModelMatch "double" double
, testModelMatch "sharing" sharing
, testModelMatch "mergeFilter" mergeFilter
, testModelMatchM "recursive1A" recursive1A
, testModelMatchM "recursive1B" recursive1B
, testModelMatchM "recursive2" recursive2
, testModelMatchM "recursive3" recursive3
, testModelMatchM "recursive4a" recursive4a
-- , testModelMatchM "recursive4b" recursive4b
, testModelMatchM "accumBvsE" accumBvsE
]
, testGroup "Dynamic Event Switching"
[ testModelMatch "observeE_id" observeE_id
, testModelMatch "observeE_stepper" observeE_stepper
, testModelMatchM "valueB_immediate" valueB_immediate
-- , testModelMatchM "valueB_recursive1" valueB_recursive1
-- , testModelMatchM "valueB_recursive2" valueB_recursive2
, testModelMatchM "dynamic_apply" dynamic_apply
, testModelMatchM "switchE1" switchE1
, testModelMatchM "switchB1" switchB1
, testModelMatchM "switchB2" switchB2
]
, testGroup "Regression tests"
[ testModelMatchM "issue79" issue79
]
-- TODO:
-- * algebraic laws
-- * larger examples
-- * quickcheck
]
{-----------------------------------------------------------------------------
Testing
------------------------------------------------------------------------------}
matchesModel
:: (Show b, Eq b)
=> (Event a -> Moment (Event b)) -> [a] -> IO Bool
matchesModel f xs = do
bs1 <- return $ interpretModel f (singletons xs)
bs2 <- interpretGraph f (singletons xs)
-- bs3 <- interpretFrameworks f xs
let bs = [bs1,bs2]
let b = all (==bs1) bs
when (not b) $ mapM_ print bs
return b
singletons = map Just
-- test whether model matches
testModelMatchM
:: (Show b, Eq b)
=> String -> (Event Int -> Moment (Event b)) -> TestTree
testModelMatchM name f = testCase name $ assertBool "matchesModel" =<< matchesModel f [1..8::Int]
testModelMatch name f = testModelMatchM name (return . f)
-- individual tests for debugging
testModel :: (Event Int -> Event b) -> [Maybe b]
testModel f = interpretModel (return . f) $ singletons [1..8::Int]
testGraph f = interpretGraph (return . f) $ singletons [1..8::Int]
testModelM f = interpretModel f $ singletons [1..8::Int]
testGraphM f = interpretGraph f $ singletons [1..8::Int]
{-----------------------------------------------------------------------------
Tests
------------------------------------------------------------------------------}
never1 :: Event Int -> Event Int
never1 = const never
fmap1 = fmap (+1)
filterE p = filterJust . fmap (\e -> if p e then Just e else Nothing)
filter1 = filterE (>= 3)
filter2 = filterE (>= 3) . fmap (subtract 1)
accumE1 = accumE 0 . ((+1) <$)
counter e = do
bcounter <- accumB 0 $ fmap (\_ -> (+1)) e
return $ applyE (pure const <*> bcounter) e
merge e1 e2 = mergeWith id id (++) (list e1) (list e2)
where list = fmap (:[])
double e = merge e e
sharing e = merge e1 e1
where e1 = filterE (< 3) e
mergeFilter e1 = mergeWith id id (+) e2 e3
where
e3 = fmap (+1) $ filterE even e1
e2 = fmap (+1) $ filterE odd e1
recursive1A e1 = mdo
let e2 = applyE ((+) <$> b) e1
b <- stepperB 0 e2
return e2
recursive1B e1 = mdo
b <- stepperB 0 e2
let e2 = applyE ((+) <$> b) e1
return e2
recursive2 e1 = mdo
b <- fmap ((+) <$>) $ stepperB 0 e3
let e2 = applyE b e1
let e3 = applyE (id <$> b) e1 -- actually equal to e2
return e2
type Dummy = Int
-- Counter that can be decreased as long as it's >= 0 .
recursive3 :: Event Dummy -> Moment (Event Int)
recursive3 edec = mdo
bcounter <- accumB 4 $ (subtract 1) <$ ecandecrease
let ecandecrease = whenE ((>0) <$> bcounter) edec
return $ applyE (const <$> bcounter) ecandecrease
-- Recursive 4 is an example reported by Merijn Verstraaten
-- https://github.com/HeinrichApfelmus/reactive-banana/issues/56
-- Minimization:
recursive4a :: Event Int -> Moment (Event (Bool, Int))
recursive4a eInput = mdo
focus <- stepperB False $ fst <$> resultE
let resultE = resultB <@ eInput
let resultB = (,) <$> focus <*> pureB 0
return $ resultB <@ eInput
{-
-- Full example:
recursive4b :: Event Int -> Event (Bool, Int)
recursive4b eInput = result <@ eInput
where
focus = stepperB False $ fst <$> result <@ eInput
interface = (,) <$> focus <*> cntrVal
(cntrVal, focusChange) = counter eInput focus
result = stepperB id ((***id) <$> focusChange) <*> interface
filterApply :: Behavior (a -> Bool) -> Event a -> Event a
filterApply b e = filterJust $ sat <$> b <@> e
where sat p x = if p x then Just x else Nothing
counter :: Event Int -> Behavior Bool -> (Behavior Int, Event (Bool -> Bool))
counter input active = (result, not <$ eq)
where
result = accumB 0 $ (+) <$> neq
eq = filterApply ((==) <$> result) input
neq = filterApply ((/=) <$> result) input
-}
-- Test 'accumE' vs 'accumB'.
accumBvsE :: Event Dummy -> Moment (Event [Int])
accumBvsE e = mdo
e1 <- accumE 0 ((+1) <$ e)
b <- accumB 0 ((+1) <$ e)
let e2 = applyE (const <$> b) e
return $ merge e1 e2
observeE_id = observeE . fmap return -- = id
observeE_stepper :: Event Int -> Event Int
observeE_stepper e = observeE $ (valueB =<< mb) <$ e
where
mb :: Moment (Behavior Int)
mb = stepper 0 e
valueB_immediate e = do
x <- valueB =<< stepper 0 e
return $ x <$ e
{-- The following tests would need to use the valueBLater combinator
valueB_recursive1 e1 = mdo
_ <- initialB b
let b = stepper 0 e1
return $ b <@ e1
valueB_recursive2 e1 = mdo
x <- initialB b
let bf = const x <$ stepper 0 e1
let b = stepper 0 $ (bf <*> b) <@ e1
return $ b <@ e1
-}
dynamic_apply e = do
b <- stepper 0 e
return $ observeE $ (valueB b) <$ e
-- = stepper 0 e <@ e
switchE1 e = switchE e (e <$ e)
switchB1 e = do
b0 <- stepper 0 e
b1 <- stepper 0 e
b <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e
return $ b <@ e
switchB2 e = do
b0 <- stepper 0 $ filterE even e
b1 <- stepper 1 $ filterE odd e
b <- switchB b0 $ (\x -> if odd x then b1 else b0) <$> e
return $ b <@ e
{-----------------------------------------------------------------------------
Regression tests
------------------------------------------------------------------------------}
issue79 :: Event Dummy -> Moment (Event String)
issue79 inputEvent = mdo
let
appliedEvent = (\_ _ -> 1) <$> lastValue <@> inputEvent
filteredEvent = filterE (const True) appliedEvent
fmappedEvent = fmap id (filteredEvent)
lastValue <- stepper 1 $ fmappedEvent
let outputEvent = mergeWith id id (++)
(const "filtered event" <$> filteredEvent)
(((" and " ++) . show) <$> mergeWith id id (+) appliedEvent fmappedEvent)
return $ outputEvent