From aa8ea07249eae1b144384d053b66684ee55c7b0b Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 25 Aug 2026 11:27:18 +0300 Subject: [PATCH] Tests --- home-assistant-controller.cabal | 3 +- src/AFRP.hs | 4 +- test/AFRPSpec.hs | 216 ++++++++++++++++++++++++++++++++ test/Main.hs | 2 + 4 files changed, 222 insertions(+), 3 deletions(-) create mode 100644 test/AFRPSpec.hs diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 866a768..2f75c1c 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -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 diff --git a/src/AFRP.hs b/src/AFRP.hs index fe8f2b4..719d057 100644 --- a/src/AFRP.hs +++ b/src/AFRP.hs @@ -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)) diff --git a/test/AFRPSpec.hs b/test/AFRPSpec.hs new file mode 100644 index 0000000..1206a57 --- /dev/null +++ b/test/AFRPSpec.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs index 73d06ea..429ca51 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -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