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