Tests
This commit is contained in:
@@ -129,7 +129,8 @@ test-suite home-assistant-controller-test
|
||||
default-language: GHC2024
|
||||
|
||||
-- Modules included in this executable, other than Main.
|
||||
other-modules: BusSpec
|
||||
other-modules: AFRPSpec
|
||||
, BusSpec
|
||||
, ConnectionSpec
|
||||
, RuntimeSpec
|
||||
, SupervisorSpec
|
||||
|
||||
+2
-2
@@ -94,7 +94,7 @@ instance Applicative (Mealy eff a) where
|
||||
data Event a
|
||||
= Tick
|
||||
| Event a
|
||||
deriving (Show, Functor, Foldable, Traversable)
|
||||
deriving (Show, Eq, Functor, Foldable, Traversable)
|
||||
|
||||
hold :: a -> Mealy eff (Event a) a
|
||||
hold a = Mealy $ \_ _ -> \case
|
||||
@@ -274,7 +274,7 @@ sliding size = mapAccum go [] id
|
||||
where
|
||||
go :: [a] -> Event a -> [a]
|
||||
go acc Tick = acc
|
||||
go acc (Event a) = take size (acc ++ [a])
|
||||
go acc (Event a) = let xs = acc ++ [a] in drop (max 0 (length xs - size)) xs
|
||||
|
||||
fixed :: Int -> Mealy eff (Event a) [a]
|
||||
fixed seconds = mapAccumRequest go Nothing (maybe [] ((`appEndo` []) . snd))
|
||||
|
||||
@@ -0,0 +1,216 @@
|
||||
module AFRPSpec (spec) where
|
||||
|
||||
import Control.Category ((>>>))
|
||||
import Data.Foldable (for_)
|
||||
import AFRP
|
||||
import Data.Functor.Identity (Identity (..))
|
||||
import Data.Time (UTCTime (..))
|
||||
import Data.UUID (nil)
|
||||
import Hedgehog
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Hedgehog
|
||||
|
||||
fakeRequest :: Request
|
||||
fakeRequest = Request (UTCTime (toEnum 0) 0) nil
|
||||
|
||||
runPure :: Mealy Identity a b -> [a] -> [b]
|
||||
runPure _ [] = []
|
||||
runPure m (a : as) = case runIdentity (AFRP.runMealy m id fakeRequest a) of
|
||||
(b, m') -> b : runPure m' as
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "AFRP" $ do
|
||||
holdSpec
|
||||
eventsSpec
|
||||
isEventSpec
|
||||
tagSpec
|
||||
toEventSpec
|
||||
lMergeSpec
|
||||
changesSpec
|
||||
edgeSpec
|
||||
filterASpec
|
||||
slidingSpec
|
||||
mapAccumSpec
|
||||
preMapAccumSpec
|
||||
-- time-dependent: delayEvent, debounce, rollup, fixed — skipped for now
|
||||
|
||||
holdSpec :: Spec
|
||||
holdSpec = describe "hold" $ do
|
||||
it "holds initial value until an Event arrives" $
|
||||
runPure (hold 'a') [Tick, Event 'b', Tick, Event 'c']
|
||||
`shouldBe` ['a', 'b', 'b', 'c']
|
||||
|
||||
it "never changes on Tick" $
|
||||
runPure (hold (0 :: Int)) (replicate 5 Tick) `shouldBe` replicate 5 (0 :: Int)
|
||||
|
||||
eventsSpec :: Spec
|
||||
eventsSpec = describe "events" $ do
|
||||
it "converts Tick to Left () and Event a to Right a" $
|
||||
runPure events [Tick, Event 'a', Tick, Event 'b']
|
||||
`shouldBe` [Left (), Right 'a', Left (), Right 'b']
|
||||
|
||||
isEventSpec :: Spec
|
||||
isEventSpec = describe "isEvent" $ do
|
||||
it "returns False for Tick" $
|
||||
isEvent Tick `shouldBe` False
|
||||
|
||||
it "returns True for Event x" $
|
||||
isEvent (Event ()) `shouldBe` True
|
||||
|
||||
tagSpec :: Spec
|
||||
tagSpec = describe "tag" $ do
|
||||
it "replaces value preserving structure" $ do
|
||||
tag 'b' Tick `shouldBe` Tick
|
||||
tag 'b' (Event 'a') `shouldBe` Event 'b'
|
||||
|
||||
toEventSpec :: Spec
|
||||
toEventSpec = describe "toEvent" $ do
|
||||
it "round-trips through events" $
|
||||
runPure toEvent [Left (), Right 'a', Left ()]
|
||||
`shouldBe` [Tick, Event 'a', Tick]
|
||||
|
||||
it "is inverse of events modulo Event/Either" $
|
||||
runPure (events >>> toEvent) [Tick, Event 'a', Event 'b']
|
||||
`shouldBe` [Tick, Event 'a', Event 'b']
|
||||
|
||||
lMergeSpec :: Spec
|
||||
lMergeSpec = describe "lMerge" $ do
|
||||
it "both Tick gives Tick" $
|
||||
lMerge (Tick :: Event Int) (Tick :: Event Int) `shouldBe` Tick
|
||||
|
||||
it "prefers left Event" $
|
||||
lMerge (Event (1 :: Int)) (Event (2 :: Int)) `shouldBe` Event (1 :: Int)
|
||||
|
||||
it "prefers right Event if left is Tick" $
|
||||
lMerge Tick (Event (2 :: Int)) `shouldBe` Event (2 :: Int)
|
||||
|
||||
changesSpec :: Spec
|
||||
changesSpec = describe "changes" $ do
|
||||
it "first output is always Tick" $
|
||||
runPure changes "hello" !! 0 `shouldBe` Tick
|
||||
|
||||
it "outputs Event only on value change" $
|
||||
runPure changes "aaaabbbcca"
|
||||
`shouldBe` [Tick, Tick, Tick, Tick
|
||||
, Event 'b', Tick, Tick
|
||||
, Event 'c', Tick
|
||||
, Event 'a'
|
||||
]
|
||||
|
||||
it "first output is Tick, subsequent outputs are Event iff value changed" $
|
||||
hedgehog $ do
|
||||
xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha
|
||||
let out = runPure changes xs
|
||||
length out === length xs
|
||||
case out of
|
||||
[] -> pure ()
|
||||
(Tick : rest) -> do
|
||||
let triples = zip3 xs (drop 1 xs) rest
|
||||
for_ triples $ \(prev, curr, o) ->
|
||||
if prev /= curr
|
||||
then o === Event curr
|
||||
else o === Tick
|
||||
_ -> failure
|
||||
|
||||
edgeSpec :: Spec
|
||||
edgeSpec = describe "edge" $ do
|
||||
it "emits Event () only on rising edge" $
|
||||
runPure edge [False, True, True, False, True]
|
||||
`shouldBe` [Tick, Event (), Tick, Tick, Event ()]
|
||||
|
||||
it "starts from False, so first True is a rising edge" $
|
||||
runPure edge [True, False, True]
|
||||
`shouldBe` [Event (), Tick, Event ()]
|
||||
|
||||
it "Event () only on False -> True transition" $
|
||||
hedgehog $ do
|
||||
bs <- forAll $ Gen.list (Range.linear 0 50) Gen.bool
|
||||
let out = runPure edge bs
|
||||
length out === length bs
|
||||
case (bs, out) of
|
||||
([], []) -> pure ()
|
||||
(b : _, o : _) -> do
|
||||
if b then o === Event () else o === Tick
|
||||
let triples = zip3 bs (drop 1 bs) (drop 1 out)
|
||||
for_ triples $ \(prev, curr, o') ->
|
||||
if not prev && curr
|
||||
then o' === Event ()
|
||||
else o' === Tick
|
||||
_ -> failure
|
||||
|
||||
filterASpec :: Spec
|
||||
filterASpec = describe "filterA" $ do
|
||||
it "lets through values matching predicate" $
|
||||
runPure (filterA (even @Int)) [1, 2, 3, 4]
|
||||
`shouldBe` [Left (), Right 2, Left (), Right 4]
|
||||
|
||||
it "output is Right a iff predicate holds" $
|
||||
hedgehog $ do
|
||||
threshold <- forAll $ Gen.int (Range.linear (-10) 10)
|
||||
let p = (> threshold)
|
||||
xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int (Range.linear (-20) 20))
|
||||
let out = runPure (filterA p) xs
|
||||
length out === length xs
|
||||
for_ (zip xs out) $ \(x, o) ->
|
||||
if p x
|
||||
then o === Right x
|
||||
else o === Left ()
|
||||
|
||||
slidingSpec :: Spec
|
||||
slidingSpec = describe "sliding" $ do
|
||||
it "accumulates events up to the window size" $
|
||||
runPure (sliding (3 :: Int)) [Event (1 :: Int), Event 2, Event 3, Event 4]
|
||||
`shouldBe` [[1], [1, 2], [1, 2, 3], [2, 3, 4]]
|
||||
|
||||
it "Ticks don't change the accumulator" $
|
||||
runPure (sliding 2) [Event (1 :: Int), Tick, Event 2]
|
||||
`shouldBe` [[1], [1], [1, 2]]
|
||||
|
||||
it "empty list stays empty" $
|
||||
runPure (sliding (5 :: Int)) ([] :: [Event Int]) `shouldBe` []
|
||||
|
||||
it "output length never exceeds window size" $
|
||||
hedgehog $ do
|
||||
n <- forAll $ Gen.int (Range.constant 1 10)
|
||||
evs <- forAll $ Gen.list (Range.linear 0 20) (Gen.frequency
|
||||
[(3, Event <$> Gen.alpha), (1, pure Tick)])
|
||||
let out = runPure (sliding n) evs
|
||||
for_ out $ \xs -> assert (length xs <= n)
|
||||
|
||||
mapAccumSpec :: Spec
|
||||
mapAccumSpec = describe "mapAccum" $ do
|
||||
it "running sum" $
|
||||
runPure (mapAccum (+) (0 :: Int) id) [1, 2, 3]
|
||||
`shouldBe` [1, 3, 6]
|
||||
|
||||
it "post-state extraction: output uses state after applying f" $
|
||||
runPure (mapAccum (\s x -> s ++ [x]) ([] :: [Int]) id) [1, 2, 3]
|
||||
`shouldBe` [[1], [1, 2], [1, 2, 3]]
|
||||
|
||||
it "output equals running sum of all inputs so far" $
|
||||
hedgehog $ do
|
||||
xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int (Range.linear (-100) 100))
|
||||
let out = runPure (mapAccum (+) (0 :: Int) id) xs
|
||||
length out === length xs
|
||||
for_ (zip3 [0 ..] xs out) $ \(i, _x, cur) ->
|
||||
cur === sum (take (i + 1) xs)
|
||||
|
||||
preMapAccumSpec :: Spec
|
||||
preMapAccumSpec = describe "preMapAccum" $ do
|
||||
it "running sum with pre-state extraction" $
|
||||
runPure (preMapAccum (+) (0 :: Int) id) [1, 2, 3]
|
||||
`shouldBe` [0, 1, 3]
|
||||
|
||||
it "pre-state extraction: output uses state before applying f" $
|
||||
runPure (preMapAccum (\s x -> s ++ [x]) ([] :: [Int]) id) [1, 2, 3]
|
||||
`shouldBe` [[], [1], [1, 2]]
|
||||
|
||||
it "output equals running sum before current input" $
|
||||
hedgehog $ do
|
||||
xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int (Range.linear (-100) 100))
|
||||
let out = runPure (preMapAccum (+) (0 :: Int) id) xs
|
||||
length out === length xs
|
||||
for_ (zip3 [0 ..] xs out) $ \(i, _x, cur) ->
|
||||
cur === sum (take i xs)
|
||||
@@ -1,6 +1,7 @@
|
||||
module Main (main) where
|
||||
|
||||
import Test.Hspec (hspec)
|
||||
import qualified AFRPSpec
|
||||
import qualified BackoffProp
|
||||
import qualified BusSpec
|
||||
import qualified ConnectionSpec
|
||||
@@ -9,6 +10,7 @@ import qualified SupervisorSpec
|
||||
|
||||
main :: IO ()
|
||||
main = hspec $ do
|
||||
AFRPSpec.spec
|
||||
BusSpec.spec
|
||||
ConnectionSpec.spec
|
||||
RuntimeSpec.spec
|
||||
|
||||
Reference in New Issue
Block a user