Millisecond.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Clock.Millisecond where

-- base
import Control.Monad (when)
import System.Info (os)

-- tasty
import Test.Tasty (testGroup)

-- tasty-hunit
import Test.Tasty.HUnit (Assertion, assertBool, testCase)

-- rhine
import FRP.Rhine
import Util (runRhine)

-- | Milliseconds
newtype MS = MS Int
  deriving (Num, Show, Eq, Ord)

millisecondsSinceInit :: (Monad m) => ClSF m (Millisecond n) a MS
millisecondsSinceInit = sinceInitS >>> arr (MS . round . (* 1000))

tests =
  testGroup
    "Millisecond"
    [ testCase "Outputs milliseconds chronologically" $ do
        output <- runRhine (millisecondsSinceInit @@ (waitClock @1)) $ replicate 5 ()
        assertTiming output $ Just <$> [1, 2, 3, 4, 5]
    , testCase "Schedules chronologically" $ do
        output <- runRhine (millisecondsSinceInit @@ (waitClock @30) >-- collect --> (clId &&& millisecondsSinceInit) @@ (waitClock @50)) $ replicate 5 ()
        assertTiming
          output
          [ Nothing
          , Just ([30], 50)
          , Nothing
          , Nothing
          , Just ([90, 60], 100)
          ]
    ]

assertTiming :: (Show a, TimingSubsumes a) => a -> a -> Assertion
assertTiming observed expected =
  when (os /= "darwin") $
    assertBool ("Observed timing: " ++ show observed ++ "\nExpected timing: " ++ show expected) $
      timingSubsumes observed expected

class TimingSubsumes a where
  timingSubsumes :: a -> a -> Bool

instance TimingSubsumes MS where
  timingSubsumes tObserved tExpected = tExpected <= tObserved && tObserved <= 2 * tExpected + 10

instance (TimingSubsumes a) => TimingSubsumes (Maybe a) where
  timingSubsumes (Just aObserved) (Just aExpected) = timingSubsumes aObserved aExpected
  timingSubsumes Nothing Nothing = True
  timingSubsumes _ _ = False

instance (TimingSubsumes a, TimingSubsumes b) => TimingSubsumes (a, b) where
  timingSubsumes (aObserved, bObserved) (aExpected, bExpected) = timingSubsumes aObserved aExpected && timingSubsumes bObserved bExpected

instance (TimingSubsumes a) => TimingSubsumes [a] where
  timingSubsumes [] [] = True
  timingSubsumes (aObserved : aObserveds) (aExpected : aExpecteds) = timingSubsumes aObserved aExpected && timingSubsumes aObserveds aExpecteds
  timingSubsumes _ _ = False