Tests

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

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))

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)

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