A lot of internals as I tried to do a switch based logic

test/AFRPSpec.hs

@@ -11,7 +11,7 @@ import Data.Functor.Identity (Identity (..))
 import Data.List (sort)
 import qualified Data.Set as S
 import qualified Data.Text as T
-import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime)
+import Data.Time (NominalDiffTime, UTCTime (..), utc)
 import Data.UUID (nil)
 import Hedgehog
 import qualified Hedgehog.Gen as Gen
@@ -20,7 +20,7 @@ import Test.Hspec
 import Test.Hspec.Hedgehog
 
 fakeRequest :: Request
-fakeRequest = Request (sec 0) nil
+fakeRequest = Request (sec 0) utc nil
 
 sec :: Integer -> UTCTime
 sec n = UTCTime (toEnum 0) (fromIntegral n)
@@ -34,7 +34,7 @@ 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 (sec s) nil) a) of
+  case runIdentity (AFRP.runMealy m id (Request (sec s) utc nil) a) of
     (b, m') -> b : runTimed m' as
 
 -- | A minimal State monad for observing effectful arrows (e.g. whenA gating).
@@ -72,6 +72,7 @@ spec = describe "AFRP" $ do
   lMergeSpec
   changesSpec
   edgeSpec
+  dropFirstSpec
   filterASpec
   slidingSpec
   mapAccumSpec
@@ -139,6 +140,23 @@ lMergeSpec = describe "lMerge" $ do
   it "prefers right Event if left is Tick" $
     lMerge Tick (Event (2 :: Int)) `shouldBe` Event (2 :: Int)
 
+  it "Tick is a left identity" $
+    hedgehog $ do
+      e <- forAll eventGen
+      lMerge Tick e === e
+
+  it "Tick is a right identity" $
+    hedgehog $ do
+      e <- forAll eventGen
+      lMerge e Tick === e
+
+  it "is associative" $
+    hedgehog $ do
+      a <- forAll eventGen
+      b <- forAll eventGen
+      c <- forAll eventGen
+      lMerge a (lMerge b c) === lMerge (lMerge a b) c
+
 changesSpec :: Spec
 changesSpec = describe "changes" $ do
   it "first output is always Tick" $
@@ -193,6 +211,20 @@ edgeSpec = describe "edge" $ do
               else o' === Tick
         _ -> failure
 
+dropFirstSpec :: Spec
+dropFirstSpec = describe "dropFirst" $ do
+  it "drops the first Event, passes the rest" $
+    runPure dropFirst [Tick, Event 1, Event 2, Event 3]
+      `shouldBe` [Tick, Tick, Event 2, Event 3 :: Event Int]
+
+  it "passes Tick through untouched before first Event" $
+    runPure dropFirst [Tick, Tick, Tick :: Event Int]
+      `shouldBe` [Tick, Tick, Tick :: Event Int]
+
+  it "drops only the first Event, Ticks before it are inert" $
+    runPure dropFirst [Tick, Tick, Event 'a', Tick, Event 'b']
+      `shouldBe` [Tick, Tick, Tick, Tick, Event 'b' :: Event Char]
+
 filterASpec :: Spec
 filterASpec = describe "filterA" $ do
   it "lets through values matching predicate" $
@@ -250,7 +282,7 @@ mapAccumSpec = describe "mapAccum" $ do
       for_ (zip3 [0 ..] xs out) $ \(i, _x, cur) ->
         cur === sum (take (i + 1) xs)
 
-  preMapAccumSpec :: Spec
+preMapAccumSpec :: Spec
 preMapAccumSpec = describe "preMapAccum" $ do
   it "running sum with pre-state extraction" $
     runPure (preMapAccum (+) (0 :: Int) id) [1, 2, 3]
@@ -416,7 +448,7 @@ 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]
+      `shouldBe` [2 :: Int, 3, 4]
 
   it "output equals f(input) for every step" $
     hedgehog $ do
@@ -427,7 +459,7 @@ effSpec = describe "eff" $ do
 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)))
+    runPure (switch (arr (\x -> (x, if x >= (3 :: Int) then Event () else Tick)))
                      (const (arr (const 99))))
              [1, 2, 3, 4, 5]
       `shouldBe` [1, 2, 99, 99, 99]
@@ -436,14 +468,14 @@ switchSpec = describe "switch" $ do
     runPure (switch (arr (\x -> (x, Tick :: Event ())))
                      (const (arr (const 99))))
              [1, 2, 3]
-      `shouldBe` [1, 2, 3]
+      `shouldBe` [1, 2, 3 :: Int]
 
   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
+      let firstArr = arr (\x -> (x, if x >= threshold then Event () else Tick))
+          out = runPure (switch firstArr (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
@@ -513,7 +545,7 @@ thenASpec = describe "thenA" $ 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 ()
+            [ if odd x then Left ()
               else if x > 0 then Right x
               else Left ()
             | x <- xs ]
@@ -523,14 +555,14 @@ 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]
+      `shouldBe` [Tick, Event @Int 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)
+          ps = take n $ zip vals evs
           out = runPure sample ps
       for_ (zip ps out) $ \((v, ev), o) ->
         o === tag v ev
@@ -552,7 +584,7 @@ entitiesSpec = describe "entities" $ do
     entities (arr (+ 1) :: Mealy Identity Int Int) `shouldBe` S.empty
 
   it "eff carries no entities" $
-    entities (eff (\_ x -> Identity (x + 1))) `shouldBe` S.empty
+    entities (eff (\_ x -> Identity (x + 1 :: Int))) `shouldBe` S.empty
 
   it "primitive combinators carry no entities" $ do
     entities (hold 'a') `shouldBe` S.empty

test/BedroomSpec.hs

@@ -102,7 +102,7 @@ buttonSpec = describe "bedroomButtonController" $ do
 
   it "Masse off click turns the bedroom lights off" $
     services (runHASS bedroomButtonController [masseButton "2_short_release"])
-      `shouldBe` [[light [area] False]]
+      `shouldBe` [[light [area] Off]]
 
   it "Enishen single click turns on her nightstand scene (lowest)" $
     services (runHASS bedroomButtonController [enishenButton "1_short_release"])
@@ -118,7 +118,7 @@ buttonSpec = describe "bedroomButtonController" $ do
 
   it "Enishen off click turns the bedroom lights off" $
     services (runHASS bedroomButtonController [enishenButton "2_short_release"])
-      `shouldBe` [[light [area] False]]
+      `shouldBe` [[light [area] Off]]
 
   it "ignores the initial press (scene only fires on release)" $
     services (runHASS bedroomButtonController [masseButton "1_initial_press"])

test/BusSpec.hs

@@ -2,7 +2,7 @@
 
 module BusSpec (spec) where
 
-import AFRP (Request (..))
+import AFRP (Request (..), Event (..))
 import Control.Concurrent.STM
   ( atomically
   , dupTChan
@@ -10,7 +10,7 @@ import Control.Concurrent.STM
   , writeTChan
   )
 import Data.Aeson (Value (..))
-import Data.Time (UTCTime (..))
+import Data.Time (UTCTime (..), utc)
 import Data.UUID (nil)
 import HomeAssistant.Controller (HASSEff (..), Service (..), Target(..))
 import HomeAssistant.Runtime.Bus
@@ -22,15 +22,15 @@ spec = describe "Bus" $ do
   it "broadcasts inbound messages to every dup'd channel in order" $ withBus InfoS $ \bus -> do
     p1 <- atomically $ dupTChan (busInbound bus)
     p2 <- atomically $ dupTChan (busInbound bus)
-    atomically $ writeTChan (busInbound bus) (Number 1)
-    atomically $ writeTChan (busInbound bus) (Number 2)
+    atomically $ writeTChan (busInbound bus) (Event (Number 1))
+    atomically $ writeTChan (busInbound bus) (Event (Number 2))
     r1 <- atomically $ (,) <$> readTChan p1 <*> readTChan p1
     r2 <- atomically $ (,) <$> readTChan p2 <*> readTChan p2
-    r1 `shouldBe` (Number 1, Number 2)
-    r2 `shouldBe` (Number 1, Number 2)
+    r1 `shouldBe` (Event (Number 1), Event (Number 2))
+    r2 `shouldBe` (Event (Number 1), Event (Number 2))
 
   it "channelHassEval writes CallService to the outbound channel" $ withBus InfoS $ \bus -> do
-    let req = Request (UTCTime (toEnum 0) 0) nil
+    let req = Request (UTCTime (toEnum 0) 0) utc nil
         svc = Service "light" "turn_on" Nothing [EntityId "light.bedroom_masse"]
     runKatipContextT (busLogEnv bus) () (Namespace ["test"]) $
       channelHassEval bus (CallService req svc)

test/RuntimeSpec.hs

@@ -16,9 +16,9 @@ spec = pure ()
 --     putStrLn "Before the delay"
 --     threadDelay 100000 -- let the controller dup its inbound channel
 --     putStrLn "After the delay"
---     atomically $ writeTChan (busInbound bus) (doorEvent "on")  -- initial value: no change event
---     atomically $ writeTChan (busInbound bus) (doorEvent "off") -- door closes: lights on
---     atomically $ writeTChan (busInbound bus) (doorEvent "on")  -- door opens: lights off
+--     atomically $ writeTChan (busInbound bus) (Event (doorEvent "on"))  -- initial value: no change event
+--     atomically $ writeTChan (busInbound bus) (Event (doorEvent "off")) -- door closes: lights on
+--     atomically $ writeTChan (busInbound bus) (Event (doorEvent "on"))  -- door opens: lights off
 --     putStrLn "After the writes"
 --     Right (_, svc1) <- boundedRead (busOutbound bus)
 --     Right (_, svc2) <- boundedRead (busOutbound bus)

test/Support.hs

@@ -14,13 +14,13 @@ module Support
 import Control.Monad.Fix (MonadFix (..))
 import Data.Aeson (Value, object, (.=))
 import qualified Data.Text as T
-import Data.Time (UTCTime (..))
+import Data.Time (UTCTime (..), utc)
 import Data.UUID (nil)
 import AFRP (Mealy (..), Request (..))
 import HomeAssistant.Controller (HASSEff (..), Service)
 
 fakeRequest :: Request
-fakeRequest = Request (sec 0) nil
+fakeRequest = Request (sec 0) utc nil
 
 sec :: Integer -> UTCTime
 sec n = UTCTime (toEnum 0) (fromIntegral n)