Test rest of the AFRP
This commit is contained in:
+160
-3
@@ -1,6 +1,8 @@
|
||||
module AFRPSpec (spec) where
|
||||
|
||||
import Control.Arrow (arr)
|
||||
import Control.Category ((>>>))
|
||||
import Control.Monad.Fix (MonadFix (..))
|
||||
import Data.Foldable (for_)
|
||||
import AFRP
|
||||
import Data.Functor.Identity (Identity (..))
|
||||
@@ -14,7 +16,10 @@ import Test.Hspec
|
||||
import Test.Hspec.Hedgehog
|
||||
|
||||
fakeRequest :: Request
|
||||
fakeRequest = Request (UTCTime (toEnum 0) 0) nil
|
||||
fakeRequest = Request (sec 0) nil
|
||||
|
||||
sec :: Integer -> UTCTime
|
||||
sec n = UTCTime (toEnum 0) (fromIntegral n)
|
||||
|
||||
runPure :: Mealy Identity a b -> [a] -> [b]
|
||||
runPure _ [] = []
|
||||
@@ -25,10 +30,32 @@ runPure m (a : as) = case runIdentity (AFRP.runMealy m id fakeRequest a) of
|
||||
runTimed :: Mealy Identity a b -> [(Integer, a)] -> [b]
|
||||
runTimed _ [] = []
|
||||
runTimed m ((s, a) : as) =
|
||||
case runIdentity (AFRP.runMealy m id (Request (t s) nil) a) of
|
||||
case runIdentity (AFRP.runMealy m id (Request (sec s) nil) a) of
|
||||
(b, m') -> b : runTimed m' as
|
||||
|
||||
-- | A minimal State monad for observing effectful arrows (e.g. whenA gating).
|
||||
newtype St a = St { unSt :: Int -> (a, Int) }
|
||||
|
||||
instance Functor St where
|
||||
fmap f (St g) = St $ \s -> let (a, s') = g s in (f a, s')
|
||||
|
||||
instance Applicative St where
|
||||
pure a = St (\s -> (a, s))
|
||||
St f <*> St x = St $ \s -> let (f', s') = f s; (a, s'') = x s' in (f' a, s'')
|
||||
|
||||
instance Monad St where
|
||||
St m >>= k = St $ \s -> let (a, s') = m s; (b, s'') = unSt (k a) s' in (b, s'')
|
||||
|
||||
instance MonadFix St where
|
||||
mfix f = St $ \s -> let (a, s') = unSt (f a) s in (a, s')
|
||||
|
||||
runStEff :: Mealy St a b -> Int -> [a] -> ([b], Int)
|
||||
runStEff m s0 as = go m s0 as
|
||||
where
|
||||
t n = UTCTime (toEnum 0) (fromIntegral n)
|
||||
go _ s [] = ([], s)
|
||||
go m' s (a : rest) =
|
||||
case unSt (AFRP.runMealy m' id fakeRequest a) s of
|
||||
((b, m''), s') -> let (bs, s'') = go m'' s' rest in (b : bs, s'')
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "AFRP" $ do
|
||||
@@ -49,6 +76,13 @@ spec = describe "AFRP" $ do
|
||||
debounceSpec
|
||||
rollupSpec
|
||||
fixedSpec
|
||||
effSpec
|
||||
switchSpec
|
||||
mapAccumRequestSpec
|
||||
preMapAccumRequestSpec
|
||||
whenASpec
|
||||
thenASpec
|
||||
sampleSpec
|
||||
|
||||
holdSpec :: Spec
|
||||
holdSpec = describe "hold" $ do
|
||||
@@ -372,3 +406,126 @@ eventGen = Gen.frequency
|
||||
[ (3, Event <$> Gen.alpha)
|
||||
, (1, pure Tick)
|
||||
]
|
||||
|
||||
effSpec :: Spec
|
||||
effSpec = describe "eff" $ do
|
||||
it "lifts a pure effect function into a stateless Mealy" $
|
||||
runPure (eff (\_ x -> Identity (x + 1))) [1, 2, 3]
|
||||
`shouldBe` [2, 3, 4]
|
||||
|
||||
it "output equals f(input) for every step" $
|
||||
hedgehog $ do
|
||||
xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int (Range.linear (-100) 100))
|
||||
let out = runPure (eff (\_ x -> Identity (x * 2))) xs
|
||||
out === map (* 2) xs
|
||||
|
||||
switchSpec :: Spec
|
||||
switchSpec = describe "switch" $ do
|
||||
it "switches to the continuation at the first Event" $
|
||||
runPure (switch (arr (\x -> (x, if x >= 3 then Event () else Tick)))
|
||||
(const (arr (const 99))))
|
||||
[1, 2, 3, 4, 5]
|
||||
`shouldBe` [1, 2, 99, 99, 99]
|
||||
|
||||
it "never switches if no Event is emitted" $
|
||||
runPure (switch (arr (\x -> (x, Tick :: Event ())))
|
||||
(const (arr (const 99))))
|
||||
[1, 2, 3]
|
||||
`shouldBe` [1, 2, 3]
|
||||
|
||||
it "prefix outputs come from the first arrow, suffix from the continuation" $
|
||||
hedgehog $ do
|
||||
threshold <- forAll $ Gen.int (Range.linear (-20) 20)
|
||||
xs <- forAll $ Gen.list (Range.linear 0 30) (Gen.int (Range.linear (-20) 20))
|
||||
let first = arr (\x -> (x, if x >= threshold then Event () else Tick))
|
||||
out = runPure (switch first (const (arr (const 99)))) xs
|
||||
(pre, _post) = break (>= threshold) xs
|
||||
take (length pre) out === pre
|
||||
drop (length pre) out === replicate (length xs - length pre) 99
|
||||
|
||||
mapAccumRequestSpec :: Spec
|
||||
mapAccumRequestSpec = describe "mapAccumRequest" $ do
|
||||
it "accumulates request times, post-state extraction" $
|
||||
runTimed (mapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
|
||||
[(0, 'a'), (5, 'b'), (10, 'c')]
|
||||
`shouldBe` [ [sec 0], [sec 0, sec 5], [sec 0, sec 5, sec 10] ]
|
||||
|
||||
it "output i is every request time seen so far" $
|
||||
hedgehog $ do
|
||||
secs' <- forAll $ Gen.list (Range.linear 0 30) (Gen.int (Range.linear 0 100))
|
||||
let out = runTimed (mapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
|
||||
[(fromIntegral s, ()) | s <- secs']
|
||||
expected = [ map (sec . fromIntegral) (take (i + 1) secs') | i <- [0 .. length secs' - 1] ]
|
||||
out === expected
|
||||
|
||||
preMapAccumRequestSpec :: Spec
|
||||
preMapAccumRequestSpec = describe "preMapAccumRequest" $ do
|
||||
it "accumulates request times, pre-state extraction" $
|
||||
runTimed (preMapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
|
||||
[(0, 'a'), (5, 'b'), (10, 'c')]
|
||||
`shouldBe` [ [], [sec 0], [sec 0, sec 5] ]
|
||||
|
||||
it "output i is every request time before the current step" $
|
||||
hedgehog $ do
|
||||
secs' <- forAll $ Gen.list (Range.linear 0 30) (Gen.int (Range.linear 0 100))
|
||||
let out = runTimed (preMapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
|
||||
[(fromIntegral s, ()) | s <- secs']
|
||||
expected = [ map (sec . fromIntegral) (take i secs') | i <- [0 .. length secs' - 1] ]
|
||||
out === expected
|
||||
|
||||
whenASpec :: Spec
|
||||
whenASpec = describe "whenA" $ do
|
||||
let counter = eff (\_ (_ :: Int) -> St (\s -> ((), s + 1)))
|
||||
|
||||
it "output is always () regardless of the predicate" $
|
||||
fst (runStEff (whenA (> 5) counter) 0 [1, 6, 2, 7])
|
||||
`shouldBe` [(), (), (), ()]
|
||||
|
||||
it "runs the inner arrow only when the predicate holds" $
|
||||
snd (runStEff (whenA (> 5) counter) 0 [1, 6, 2, 7])
|
||||
`shouldBe` 2
|
||||
|
||||
it "never runs the inner arrow when the predicate is always false" $
|
||||
snd (runStEff (whenA (const False) counter) 0 [1, 6, 2, 7])
|
||||
`shouldBe` 0
|
||||
|
||||
it "runs the inner arrow on every input when the predicate is always true" $
|
||||
snd (runStEff (whenA (const True) counter) 0 [1, 6, 2, 7])
|
||||
`shouldBe` 4
|
||||
|
||||
thenASpec :: Spec
|
||||
thenASpec = describe "thenA" $ do
|
||||
it "short-circuits on Left and continues on Right" $
|
||||
runPure (filterA (even @Int) `thenA` filterA (> 3)) [1..6]
|
||||
`shouldBe` [Left (), Left (), Left (), Right 4, Left (), Right 6]
|
||||
|
||||
it "(>>|) is an infix alias for thenA" $
|
||||
runPure (filterA (even @Int) >>| filterA (> 3)) [1..6]
|
||||
`shouldBe` [Left (), Left (), Left (), Right 4, Left (), Right 6]
|
||||
|
||||
it "second stage runs only when the first produces Right" $
|
||||
hedgehog $ do
|
||||
xs <- forAll $ Gen.list (Range.linear 0 30) (Gen.int (Range.linear (-20) 20))
|
||||
let out = runPure (filterA (even @Int) >>| filterA (> 0)) xs
|
||||
expected =
|
||||
[ if not (even x) then Left ()
|
||||
else if x > 0 then Right x
|
||||
else Left ()
|
||||
| x <- xs ]
|
||||
out === expected
|
||||
|
||||
sampleSpec :: Spec
|
||||
sampleSpec = describe "sample" $ do
|
||||
it "tags the current value onto the Event structure" $
|
||||
runPure sample [(1, Tick), (2, Event 'a'), (3, Tick)]
|
||||
`shouldBe` [Tick, Event 2, Tick]
|
||||
|
||||
it "output is Event a iff the input event is present" $
|
||||
hedgehog $ do
|
||||
vals <- forAll $ Gen.list (Range.linear 0 30) (Gen.int (Range.linear 0 100))
|
||||
evs <- forAll $ Gen.list (Range.linear 0 30) eventGen
|
||||
let n = min (length vals) (length evs)
|
||||
ps = zip (take n vals) (take n evs)
|
||||
out = runPure sample ps
|
||||
for_ (zip ps out) $ \((v, ev), o) ->
|
||||
o === tag v ev
|
||||
|
||||
Reference in New Issue
Block a user