module AFRPSpec (spec) where

import Control.Category ((>>>))
import Data.Foldable (for_)
import AFRP
import Data.Functor.Identity (Identity (..))
import Data.List (sort)
import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime)
import Data.UUID (nil)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Hspec
import Test.Hspec.Hedgehog

fakeRequest :: Request
fakeRequest = Request (UTCTime (toEnum 0) 0) nil

runPure :: Mealy Identity a b -> [a] -> [b]
runPure _ [] = []
runPure m (a : as) = case runIdentity (AFRP.runMealy m id fakeRequest a) of
  (b, m') -> b : runPure m' 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 ((s, a) : as) =
  case runIdentity (AFRP.runMealy m id (Request (t s) nil) a) of
    (b, m') -> b : runTimed m' as
  where
    t n = UTCTime (toEnum 0) (fromIntegral n)

spec :: Spec
spec = describe "AFRP" $ do
  holdSpec
  eventsSpec
  isEventSpec
  tagSpec
  toEventSpec
  lMergeSpec
  changesSpec
  edgeSpec
  filterASpec
  slidingSpec
  mapAccumSpec
  preMapAccumSpec
  durationSpec
  delayEventSpec
  debounceSpec
  rollupSpec
  fixedSpec

holdSpec :: Spec
holdSpec = describe "hold" $ do
  it "holds initial value until an Event arrives" $
    runPure (hold 'a') [Tick, Event 'b', Tick, Event 'c']
      `shouldBe` ['a', 'b', 'b', 'c']

  it "never changes on Tick" $
    runPure (hold (0 :: Int)) (replicate 5 Tick) `shouldBe` replicate 5 (0 :: Int)

eventsSpec :: Spec
eventsSpec = describe "events" $ do
  it "converts Tick to Left () and Event a to Right a" $
    runPure events [Tick, Event 'a', Tick, Event 'b']
      `shouldBe` [Left (), Right 'a', Left (), Right 'b']

isEventSpec :: Spec
isEventSpec = describe "isEvent" $ do
  it "returns False for Tick" $
    isEvent Tick `shouldBe` False

  it "returns True for Event x" $
    isEvent (Event ()) `shouldBe` True

tagSpec :: Spec
tagSpec = describe "tag" $ do
  it "replaces value preserving structure" $ do
    tag 'b' Tick `shouldBe` Tick
    tag 'b' (Event 'a') `shouldBe` Event 'b'

toEventSpec :: Spec
toEventSpec = describe "toEvent" $ do
  it "round-trips through events" $
    runPure toEvent [Left (), Right 'a', Left ()]
      `shouldBe` [Tick, Event 'a', Tick]

  it "is inverse of events modulo Event/Either" $
    runPure (events >>> toEvent) [Tick, Event 'a', Event 'b']
      `shouldBe` [Tick, Event 'a', Event 'b']

lMergeSpec :: Spec
lMergeSpec = describe "lMerge" $ do
  it "both Tick gives Tick" $
    lMerge (Tick :: Event Int) (Tick :: Event Int) `shouldBe` Tick

  it "prefers left Event" $
    lMerge (Event (1 :: Int)) (Event (2 :: Int)) `shouldBe` Event (1 :: Int)

  it "prefers right Event if left is Tick" $
    lMerge Tick (Event (2 :: Int)) `shouldBe` Event (2 :: Int)

changesSpec :: Spec
changesSpec = describe "changes" $ do
  it "first output is always Tick" $
    runPure changes "hello" !! 0 `shouldBe` Tick

  it "outputs Event only on value change" $
    runPure changes "aaaabbbcca"
      `shouldBe` [Tick, Tick, Tick, Tick
                 , Event 'b', Tick, Tick
                 , Event 'c', Tick
                 , Event 'a'
                 ]

  it "first output is Tick, subsequent outputs are Event iff value changed" $
    hedgehog $ do
      xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha
      let out = runPure changes xs
      length out === length xs
      case out of
        [] -> pure ()
        (Tick : rest) -> do
          let triples = zip3 xs (drop 1 xs) rest
          for_ triples $ \(prev, curr, o) ->
            if prev /= curr
              then o === Event curr
              else o === Tick
        _ -> failure

edgeSpec :: Spec
edgeSpec = describe "edge" $ do
  it "emits Event () only on rising edge" $
    runPure edge [False, True, True, False, True]
      `shouldBe` [Tick, Event (), Tick, Tick, Event ()]

  it "starts from False, so first True is a rising edge" $
    runPure edge [True, False, True]
      `shouldBe` [Event (), Tick, Event ()]

  it "Event () only on False -> True transition" $
    hedgehog $ do
      bs <- forAll $ Gen.list (Range.linear 0 50) Gen.bool
      let out = runPure edge bs
      length out === length bs
      case (bs, out) of
        ([], []) -> pure ()
        (b : _, o : _) -> do
          if b then o === Event () else o === Tick
          let triples = zip3 bs (drop 1 bs) (drop 1 out)
          for_ triples $ \(prev, curr, o') ->
            if not prev && curr
              then o' === Event ()
              else o' === Tick
        _ -> failure

filterASpec :: Spec
filterASpec = describe "filterA" $ do
  it "lets through values matching predicate" $
    runPure (filterA (even @Int)) [1, 2, 3, 4]
      `shouldBe` [Left (), Right 2, Left (), Right 4]

  it "output is Right a iff predicate holds" $
    hedgehog $ do
      threshold <- forAll $ Gen.int (Range.linear (-10) 10)
      let p = (> threshold)
      xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int (Range.linear (-20) 20))
      let out = runPure (filterA p) xs
      length out === length xs
      for_ (zip xs out) $ \(x, o) ->
        if p x
          then o === Right x
          else o === Left ()

slidingSpec :: Spec
slidingSpec = describe "sliding" $ do
  it "accumulates events up to the window size" $
    runPure (sliding (3 :: Int)) [Event (1 :: Int), Event 2, Event 3, Event 4]
      `shouldBe` [[1], [1, 2], [1, 2, 3], [2, 3, 4]]

  it "Ticks don't change the accumulator" $
    runPure (sliding 2) [Event (1 :: Int), Tick, Event 2]
      `shouldBe` [[1], [1], [1, 2]]

  it "empty list stays empty" $
    runPure (sliding (5 :: Int)) ([] :: [Event Int]) `shouldBe` []

  it "output length never exceeds window size" $
    hedgehog $ do
      n <- forAll $ Gen.int (Range.constant 1 10)
      evs <- forAll $ Gen.list (Range.linear 0 20) (Gen.frequency
        [(3, Event <$> Gen.alpha), (1, pure Tick)])
      let out = runPure (sliding n) evs
      for_ out $ \xs -> assert (length xs <= n)

mapAccumSpec :: Spec
mapAccumSpec = describe "mapAccum" $ do
  it "running sum" $
    runPure (mapAccum (+) (0 :: Int) id) [1, 2, 3]
      `shouldBe` [1, 3, 6]

  it "post-state extraction: output uses state after applying f" $
    runPure (mapAccum (\s x -> s ++ [x]) ([] :: [Int]) id) [1, 2, 3]
      `shouldBe` [[1], [1, 2], [1, 2, 3]]

  it "output equals running sum of all inputs so far" $
    hedgehog $ do
      xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int (Range.linear (-100) 100))
      let out = runPure (mapAccum (+) (0 :: Int) id) xs
      length out === length xs
      for_ (zip3 [0 ..] xs out) $ \(i, _x, cur) ->
        cur === sum (take (i + 1) xs)

  preMapAccumSpec :: Spec
preMapAccumSpec = describe "preMapAccum" $ do
  it "running sum with pre-state extraction" $
    runPure (preMapAccum (+) (0 :: Int) id) [1, 2, 3]
      `shouldBe` [0, 1, 3]

  it "pre-state extraction: output uses state before applying f" $
    runPure (preMapAccum (\s x -> s ++ [x]) ([] :: [Int]) id) [1, 2, 3]
      `shouldBe` [[], [1], [1, 2]]

  it "output equals running sum before current input" $
    hedgehog $ do
      xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int (Range.linear (-100) 100))
      let out = runPure (preMapAccum (+) (0 :: Int) id) xs
      length out === length xs
      for_ (zip3 [0 ..] xs out) $ \(i, _x, cur) ->
        cur === sum (take i xs)

durationSpec :: Spec
durationSpec = describe "duration" $ do
  it "first sample is 0, then elapsed time since first sample" $
    runTimed duration [(0, 'a'), (5, 'b'), (10, 'c')]
      `shouldBe` [0, 5, 10]

  it "measures from the first observation, not the most recent" $
    runTimed duration [(2, 'a'), (3, 'b'), (7, 'c')]
      `shouldBe` [0, 1, 5]

  it "output i equals times[i] - times[0]" $
    hedgehog $ do
      secs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int (Range.linear 0 1000))
      let out = runTimed duration [(fromIntegral s, ()) | s <- secs]
      length out === length secs
      case secs of
        [] -> pure ()
        (t0 : _) -> for_ (zip secs out) $ \(s, d) ->
          d === fromIntegral (s - t0)

delayEventSpec :: Spec
delayEventSpec = describe "delayEvent" $ do
  let delay = 5 :: NominalDiffTime

  it "emits a queued event once the delay has elapsed" $
    runTimed (delayEvent delay)
             [(0, Event 'a'), (3, Tick), (6, Tick)]
      `shouldBe` [Tick, Tick, Event 'a']

  it "preserves order when multiple events are queued" $
    runTimed (delayEvent delay)
             [(0, Event 'a'), (1, Event 'b'), (10, Tick), (12, Tick)]
      `shouldBe` [Tick, Tick, Event 'a', Event 'b']

  it "emits nothing on pure Tick input" $
    runTimed (delayEvent delay) [(0, Tick :: Event Char), (10, Tick)]
      `shouldBe` [Tick, Tick]

  it "emits exactly one output Event per input Event" $
    hedgehog $ do
      evs <- forAll $ Gen.list (Range.linear 0 30) eventGen
      let evs' = evs ++ replicate 3 Tick
          n = length [() | Event _ <- evs]
          out = runTimed (delayEvent (1 :: NominalDiffTime))
                         (zip [0, 2 ..] evs')
      length [() | Event _ <- out] === n

debounceSpec :: Spec
debounceSpec = describe "debounce" $ do
  let delay = 5 :: NominalDiffTime

  it "fires the last event after the quiet period" $
    runTimed (debounce delay)
             [(0, Event 'a'), (3, Tick), (6, Tick)]
      `shouldBe` [Tick, Tick, Event 'a']

  it "a newer event before firing resets the timer" $
    runTimed (debounce delay)
             [(0, Event 'a'), (3, Event 'b'), (6, Tick), (8, Tick)]
      `shouldBe` [Tick, Tick, Tick, Event 'b']

  it "collapses a burst into a single emission" $
    runTimed (debounce delay)
             [(0, Event 'a'), (1, Event 'b'), (2, Event 'c'), (10, Tick)]
      `shouldBe` [Tick, Tick, Tick, Event 'c']

  it "emits no more output Events than input Events" $
    hedgehog $ do
      evs <- forAll $ Gen.list (Range.linear 0 30) eventGen
      let nIn = length [() | Event _ <- evs]
          out = runTimed (debounce (1 :: NominalDiffTime))
                         (zip [0, 2 ..] evs)
          nOut = length [() | Event _ <- out]
      assert (nOut <= nIn)

rollupSpec :: Spec
rollupSpec = describe "rollup" $ do
  it "passes the first `limit` events through immediately, then bursts" $
    runTimed (rollup 2 10)
             [ (0, Event 'a'), (1, Event 'b')
             , (2, Event 'c'), (3, Event 'd')
             , (12, Tick)
             ]
      `shouldBe` [ Event ['a'], Event ['b']
                 , Tick, Tick
                 , Event ['c', 'd']
                 ]

  it "flushes the accumulator when the window ends on a Tick" $
    runTimed (rollup 1 10)
             [(0, Event 'a'), (1, Event 'b'), (2, Tick), (12, Tick)]
      `shouldBe` [Event ['a'], Tick, Tick, Event ['b']]

  it "is idle (Tick) until the first Event" $
    runTimed (rollup 2 10) [(0, Tick :: Event Char), (1, Tick)]
      `shouldBe` [Tick, Tick]

  it "every input Event appears exactly once across the outputs" $
    hedgehog $ do
      limit <- forAll $ Gen.int (Range.constant 1 5)
      evs <- forAll $ Gen.list (Range.linear 0 30) eventGen
      let evs' = evs ++ replicate 10 Tick
          times = [0 ..]
          out = runTimed (rollup limit 5) (zip times evs')
          emitted = concat [xs | Event xs <- out]
      sort emitted === sort [x | Event x <- evs]

fixedSpec :: Spec
fixedSpec = describe "fixed" $ do
  it "accumulates events within a window and rolls over on expiry" $
    runTimed (fixed 10)
             [ (0, Event 'a'), (1, Event 'b'), (2, Tick)
             , (12, Event 'c'), (13, Tick)
             ]
      `shouldBe` [ ['a'], ['a', 'b'], ['a', 'b']
                 , ['c'], ['c']
                 ]

  it "starts a window even on a leading Tick" $
    runTimed (fixed 10)
             [ (0, Tick), (1, Event 'a')
             , (12, Tick), (13, Tick)
             , (25, Event 'b')
             ]
      `shouldBe` [ [], ['a'], [], [], ['b'] ]

  it "output is always the current window's accumulated list" $
    hedgehog $ do
      w <- forAll $ Gen.int (Range.constant 1 10)
      evs <- forAll $ Gen.list (Range.linear 0 30) eventGen
      let out = runTimed (fixed w) (zip [0 ..] evs)
          expected =
            [ [ x | Event x <- take (i - lo + 1) (drop lo evs) ]
            | i <- [0 .. length evs - 1]
            , let lo = (i `div` w) * w
            ]
      out === expected

eventGen :: Gen (Event Char)
eventGen = Gen.frequency
  [ (3, Event <$> Gen.alpha)
  , (1, pure Tick)
  ]