From 7051eaf244e132e9094320342e822ad37e26e5a4 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 25 Aug 2026 11:41:12 +0300 Subject: [PATCH] Test rest of the AFRP --- test/AFRPSpec.hs | 163 ++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 160 insertions(+), 3 deletions(-) diff --git a/test/AFRPSpec.hs b/test/AFRPSpec.hs index 7f0d23a..050795c 100644 --- a/test/AFRPSpec.hs +++ b/test/AFRPSpec.hs @@ -1,6 +1,8 @@ module AFRPSpec (spec) where +import Control.Arrow (arr) import Control.Category ((>>>)) +import Control.Monad.Fix (MonadFix (..)) import Data.Foldable (for_) import AFRP import Data.Functor.Identity (Identity (..)) @@ -14,7 +16,10 @@ import Test.Hspec import Test.Hspec.Hedgehog fakeRequest :: Request -fakeRequest = Request (UTCTime (toEnum 0) 0) nil +fakeRequest = Request (sec 0) nil + +sec :: Integer -> UTCTime +sec n = UTCTime (toEnum 0) (fromIntegral n) runPure :: Mealy Identity a b -> [a] -> [b] runPure _ [] = [] @@ -25,10 +30,32 @@ 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 (t s) nil) a) of + case runIdentity (AFRP.runMealy m id (Request (sec s) nil) a) of (b, m') -> b : runTimed m' as + +-- | A minimal State monad for observing effectful arrows (e.g. whenA gating). +newtype St a = St { unSt :: Int -> (a, Int) } + +instance Functor St where + fmap f (St g) = St $ \s -> let (a, s') = g s in (f a, s') + +instance Applicative St where + pure a = St (\s -> (a, s)) + St f <*> St x = St $ \s -> let (f', s') = f s; (a, s'') = x s' in (f' a, s'') + +instance Monad St where + St m >>= k = St $ \s -> let (a, s') = m s; (b, s'') = unSt (k a) s' in (b, s'') + +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 where - t n = UTCTime (toEnum 0) (fromIntegral n) + go _ s [] = ([], s) + go m' s (a : rest) = + case unSt (AFRP.runMealy m' id fakeRequest a) s of + ((b, m''), s') -> let (bs, s'') = go m'' s' rest in (b : bs, s'') spec :: Spec spec = describe "AFRP" $ do @@ -49,6 +76,13 @@ spec = describe "AFRP" $ do debounceSpec rollupSpec fixedSpec + effSpec + switchSpec + mapAccumRequestSpec + preMapAccumRequestSpec + whenASpec + thenASpec + sampleSpec holdSpec :: Spec holdSpec = describe "hold" $ do @@ -372,3 +406,126 @@ eventGen = Gen.frequency [ (3, Event <$> Gen.alpha) , (1, pure Tick) ] + +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] + + it "output equals f(input) for every step" $ + hedgehog $ do + xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int (Range.linear (-100) 100)) + 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 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] + + 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 + (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) + [(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) + [(fromIntegral s, ()) | s <- secs'] + expected = [ map (sec . fromIntegral) (take (i + 1) secs') | i <- [0 .. length secs' - 1] ] + out === expected + +preMapAccumRequestSpec :: Spec +preMapAccumRequestSpec = describe "preMapAccumRequest" $ do + it "accumulates request times, pre-state extraction" $ + runTimed (preMapAccumRequest (\req s _ -> s ++ [requestTime req]) [] id) + [(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) + [(fromIntegral s, ()) | s <- secs'] + expected = [ map (sec . fromIntegral) (take i secs') | i <- [0 .. length secs' - 1] ] + out === expected + +whenASpec :: Spec +whenASpec = describe "whenA" $ do + let counter = eff (\_ (_ :: Int) -> St (\s -> ((), s + 1))) + + it "output is always () regardless of the predicate" $ + fst (runStEff (whenA (> 5) counter) 0 [1, 6, 2, 7]) + `shouldBe` [(), (), (), ()] + + it "runs the inner arrow only when the predicate holds" $ + snd (runStEff (whenA (> 5) counter) 0 [1, 6, 2, 7]) + `shouldBe` 2 + + it "never runs the inner arrow when the predicate is always false" $ + snd (runStEff (whenA (const False) counter) 0 [1, 6, 2, 7]) + `shouldBe` 0 + + it "runs the inner arrow on every input when the predicate is always true" $ + snd (runStEff (whenA (const True) counter) 0 [1, 6, 2, 7]) + `shouldBe` 4 + +thenASpec :: Spec +thenASpec = describe "thenA" $ do + it "short-circuits on Left and continues on Right" $ + runPure (filterA (even @Int) `thenA` filterA (> 3)) [1..6] + `shouldBe` [Left (), Left (), Left (), Right 4, Left (), Right 6] + + it "(>>|) is an infix alias for thenA" $ + runPure (filterA (even @Int) >>| filterA (> 3)) [1..6] + `shouldBe` [Left (), Left (), Left (), Right 4, Left (), Right 6] + + it "second stage runs only when the first produces Right" $ + hedgehog $ 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 () + else if x > 0 then Right x + else Left () + | x <- xs ] + out === expected + +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] + + 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) + out = runPure sample ps + for_ (zip ps out) $ \((v, ev), o) -> + o === tag v ev