Test rest of the AFRP

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