Update tests

src/AFRP.hs

@@ -23,6 +23,7 @@ module AFRP
   , lMerge
   , Pair(..)
   , Request(..)
+  , SerializeUTCTime(..)
   , edge
   , duration
   , tag
@@ -308,7 +309,7 @@ instance Monoid (Event a) where
   mempty = Tick
 
 hold :: (Serialize a, Eq a) => a -> Mealy m (Event a) a
-hold def = preMapAccum step def id
+hold def = mapAccum step def id
   where
     step prev = \case
       Tick -> prev

test/AFRPLawsSpec.hs

@@ -17,9 +17,11 @@ import Test.Hspec.Hedgehog (forAll, forAllWith, hedgehog, (===))
 -- sides on generated inputs.
 
 runPure :: Mealy Identity a b -> [a] -> [b]
-runPure _ [] = []
+runPure m = go (runMealy m id)
-runPure m (a : as) = case runIdentity (runMealy m id fakeRequest a) of
+  where
-  Pair b m' -> b : runPure m' as
+    go _ [] = []
+    go w (a : as) = case runIdentity (stepAuto w fakeRequest a) of
+      (b, w') -> b : go w' as
 
 -- | Machines wrap functions and have no Show; name them for forAll instead.
 forAllMealy :: Gen (Mealy Identity a b) -> PropertyT IO (Mealy Identity a b)

test/AFRPSpec.hs

@@ -25,17 +25,24 @@ fakeRequest = Request (sec 0) utc nil
 sec :: Integer -> UTCTime
 sec n = UTCTime (toEnum 0) (fromIntegral n)
 
+untime :: SerializeUTCTime -> UTCTime
+untime (SerializeUTCTime t) = t
+
 runPure :: Mealy Identity a b -> [a] -> [b]
-runPure _ [] = []
+runPure m = go (runMealy m id)
-runPure m (a : as) = case runIdentity (AFRP.runMealy m id fakeRequest a) of
+  where
-  Pair b m' -> b : runPure m' as
+    go _ [] = []
+    go w (a : as) = case runIdentity (stepAuto w fakeRequest a) of
+      (b, w') -> b : go w' as
 
 -- | Run a Mealy with a per-step wall clock (seconds since the day-0 epoch).
 runTimed :: Mealy Identity a b -> [(Integer, a)] -> [b]
-runTimed _ [] = []
+runTimed m = go (runMealy m id)
-runTimed m ((s, a) : as) =
+  where
-  case runIdentity (AFRP.runMealy m id (Request (sec s) utc nil) a) of
+    go _ [] = []
-    Pair b m' -> b : runTimed m' as
+    go w ((s, a) : as) =
+      case runIdentity (stepAuto w (Request (sec s) utc nil) a) of
+        (b, w') -> b : go w' as
 
 -- | A minimal State monad for observing effectful arrows (e.g. whenA gating).
 newtype St a = St { unSt :: Int -> (a, Int) }
@@ -54,12 +61,11 @@ 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
+runStEff m = go (runMealy m id)
   where
     go _ s [] = ([], s)
-    go m' s (a : rest) =
+    go w s (a : rest) = case unSt (stepAuto w fakeRequest a) s of
-      case unSt (AFRP.runMealy m' id fakeRequest a) s of
+      ((b, w'), s') -> let (bs, s'') = go w' s' rest in (b : bs, s'')
-        (Pair b m'', s') -> let (bs, s'') = go m'' s' rest in (b : bs, s'')
 
 spec :: Spec
 spec = describe "AFRP" $ do
@@ -81,7 +87,6 @@ spec = describe "AFRP" $ do
   debounceSpec
   rollupSpec
   effSpec
-  switchSpec
   mapAccumRequestSpec
   preMapAccumRequestSpec
   whenASpec
@@ -411,41 +416,17 @@ effSpec = describe "eff" $ do
       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 :: Int) 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 :: 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 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
-
 mapAccumRequestSpec :: Spec
 mapAccumRequestSpec = describe "mapAccumRequest" $ do
   it "accumulates request times, post-state extraction" $
-    runTimed (mapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
+    runTimed (mapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
              [(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)
+      let out = runTimed (mapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
                          [(fromIntegral s, ()) | s <- secs']
           expected = [ map (sec . fromIntegral) (take (i + 1) secs') | i <- [0 .. length secs' - 1] ]
       out === expected
@@ -453,14 +434,14 @@ mapAccumRequestSpec = describe "mapAccumRequest" $ do
 preMapAccumRequestSpec :: Spec
 preMapAccumRequestSpec = describe "preMapAccumRequest" $ do
   it "accumulates request times, pre-state extraction" $
-    runTimed (preMapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id)
+    runTimed (preMapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
              [(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)
+      let out = runTimed (preMapAccumRequest (\req s _ -> s ++ [SerializeUTCTime (requestTime req)]) [] (map untime))
                          [(fromIntegral s, ()) | s <- secs']
           expected = [ map (sec . fromIntegral) (take i secs') | i <- [0 .. length secs' - 1] ]
       out === expected
@@ -524,11 +505,11 @@ sampleSpec = describe "sample" $ do
 
 -- | A stateless arrow carrying a fixed entity set, for testing propagation.
 subscribed :: S.Set T.Text -> Mealy Identity Int Int
-subscribed ents = Mealy ents $ \_ _ a -> pure (Pair a (subscribed ents))
+subscribed ents = Mealy ents $ \_ -> Fun $ \_ a -> a
 
 -- | Same as 'subscribed' but yields a function, for testing '<*>'.
 subscribedF :: S.Set T.Text -> Mealy Identity Int (Int -> Int)
-subscribedF ents = Mealy ents $ \_ _ a -> pure (Pair (a +) (subscribedF ents))
+subscribedF ents = Mealy ents $ \_ -> Fun $ \_ a -> (a +)
 
 entitiesSpec :: Spec
 entitiesSpec = describe "entities" $ do
@@ -545,7 +526,7 @@ entitiesSpec = describe "entities" $ do
     entities (hold 'a') `shouldBe` S.empty
     entities (changes @Int) `shouldBe` S.empty
     entities edge `shouldBe` S.empty
-    entities (sliding (3 :: Int)) `shouldBe` S.empty
+    entities (sliding (3 :: Int) :: Mealy Identity (Event Int) [Int]) `shouldBe` S.empty
 
   it "Category (.) unions entity sets" $
     entities (subscribed (S.singleton "a") >>> subscribed (S.singleton "b"))

test/Support.hs

@@ -16,9 +16,8 @@ import Data.Aeson (Value, object, (.=))
 import qualified Data.Text as T
 import Data.Time (UTCTime (..), utc)
 import Data.UUID (nil)
-import AFRP (Mealy (..), Pair (..), Request (..))
+import AFRP (Mealy (..), Request (..), stepAuto)
 import HomeAssistant.Controller (HASSEff (..), Service)
-import AFRP (stepAuto)
 
 fakeRequest :: Request
 fakeRequest = Request (sec 0) utc nil
@@ -50,11 +49,12 @@ interp (Trace _ _) = pure ()
 
 -- | Run a HASS arrow over a list of inputs, collecting per-step emitted services.
 runHASS :: Mealy HASSEff a b -> [a] -> [(b, [Service])]
-runHASS _ [] = []
+runHASS m = go (runMealy m interp)
-runHASS m (a : as) =
+  where
-  let w = runMealy m interp
+    go _ [] = []
-  in case runAcc (stepAuto w fakeRequest a) [] of
+    go w (a : as) =
-    (Pair b m', svcs) -> (b, svcs) : runHASS m' as
+      case runAcc (stepAuto w fakeRequest a) [] of
+        ((b, w'), svcs) -> (b, svcs) : go w' as
 
 services :: [(b, [Service])] -> [[Service]]
 services = map snd