delay-0: tests/test.hs

module Main where

import qualified Control.Exception as E
import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.Monad
import Control.Time
import Data.Fixed
import Data.Int
import Numeric.Units.Dimensional ((*~))
import qualified Numeric.Units.Dimensional as D
import qualified Numeric.Units.Dimensional.SIUnits as D
import Data.Time
import Data.Word
import Numeric.Natural

assert :: Bool -> String -> IO ()
assert True _ = return ()
assert False err = E.throwIO . E.AssertionFailed $ err

-- Delay an amount, and see what time it is when we're done.
delayTest :: AsMicro w => w -> IO UTCTime
delayTest w = delay w >> getCurrentTime

microInSecond :: Integer
microInSecond = 10^(6::Int)

main :: IO ()
main = do
   assert (toMicro (1::Uni) == microInSecond) "Uni conversion"
   assert (toMicro (1::Deci) == microInSecond) "Deci conversion"
   assert (toMicro (1::Centi) == microInSecond) "Centi conversion"
   assert (toMicro (1::Milli) == microInSecond) "Milli conversion"
   assert (toMicro (1::Micro) == microInSecond) "Micro conversion"
   assert (toMicro (1::Nano) == microInSecond) "Nano conversion"
   assert (toMicro (1::Pico) == microInSecond) "Pico conversion"
   assert (toMicro ((1::Double) *~ D.second) == microInSecond) "Second conversion"
   assert (toMicro ((1/60::Float) *~ D.minute) == microInSecond) "Minute conversion"
   assert (toMicro ((1/3600::Double) *~ D.hour) == microInSecond) "Hour conversion"
   assert (toMicro ((1::Double) *~ D.day) == 24*60*60*microInSecond) "Day conversion"
   assert (toMicro (((1::Double) *~ D.minute) D.+ (1 *~ D.second)) == 61*microInSecond) "Dim math conversion"

   testDelays secondTests 1 0.1
   testDelays halfSecondTests 0.5 0.1

   Just True <- timeout (0.5::DiffTime) (delay (0.25::DiffTime) >> return True)
   Nothing <- timeout (0.5::DiffTime) (delay (0.75::DiffTime) >> return True)
   n <- getCurrentTime
   Just True <- timeoutAt (addUTCTime 0.5 n) (delay (0.25::DiffTime) >> return True)
   Nothing <- timeoutAt (addUTCTime 0.5 n) (delay (0.75::DiffTime) >> return True)

   -- Make sure we're not subject to https://ghc.haskell.org/trac/ghc/ticket/7719
   Just True <- join <$> (timeout (0.5::DiffTime) . timeout (0.25::DiffTime) $
               (delay (0.15::DiffTime) >> return True))

   Just Nothing <- timeout (0.5::DiffTime) . timeout (0.25::DiffTime) $
               (delay (0.75::DiffTime) >> return True)

   Nothing <- timeout (0.25::DiffTime) . timeout (0.5::DiffTime) $
               (delay (0.75::DiffTime) >> return True)

   void $ mapConcurrently id
       [ testCBAfter
       , testCBAt
       , testCBAfterUpAfter
       , testCBAfterUpAt
       , testCBAtUpAfter
       , testCBAtUpAt
       , testCBCancelAfter
       , testCBCancelAt
       , testCBCancelCancel
       , testCBCancelExecutedAfter
       , testCBCancelExecutedAt
       , testCBUpdateAfterCanceled
       , testCBUpdateAtCanceled
       ]

   return ()
 where
  testDelays :: [IO UTCTime] -> NominalDiffTime -> NominalDiffTime -> IO ()
  testDelays ds l v = do
    st <- getCurrentTime
    ets <- mapConcurrently id ds
    let ots = map (`diffUTCTime` st) ets
    assert (minimum ots >= l) "Returned before delay time passed!"
    assert (maximum ots - minimum ots <= v) "Too much variance."
  secondTests =
      [ delayTest (1::Int)
      , delayTest (1::Int8)
      , delayTest (1::Int16)
      , delayTest (1::Int32)
      , delayTest (1::Int64)
      , delayTest (1::Integer)
      , delayTest (1::Word)
      , delayTest (1::Word8)
      , delayTest (1::Word16)
      , delayTest (1::Word32)
      , delayTest (1::Word64)
      , delayTest (1::Natural)
      , delayTest (1::Float)
      , delayTest (1::Double)
      , delayTest (1::DiffTime)
      , delayTest (1::Uni)
      , delayTest (1::Deci)
      , delayTest (1::Centi)
      , delayTest (1::Milli)
      , delayTest (1::Micro)
      , delayTest (1::Nano)
      , delayTest (1::Pico)
      , delayTest $ (1::Float) *~ D.second
      , delayTest $ (1::Double) *~ D.second
      , delayTest $ (1/60::Double) *~ D.minute
      , delayTest $ (1/60/60::Double) *~ D.hour
      , delayTest $ (1/60/60/24::Double) *~ D.day
      ]
  halfSecondTests =
      [ delayTest (0.5::Float)
      , delayTest (0.5::Double)
      , delayTest (0.5::DiffTime)
      , delayTest (0.5::Deci)
      , delayTest (0.5::Centi)
      , delayTest (0.5::Milli)
      , delayTest (0.5::Micro)
      , delayTest (0.5::Nano)
      , delayTest (0.5::Pico)
      , delayTest $ (0.5::Float) *~ D.second
      , delayTest $ (0.5::Double) *~ D.second
      , delayTest $ (0.5/60::Double) *~ D.minute
      , delayTest $ (0.5/60/60::Double) *~ D.hour
      , delayTest $ (0.5/60/60/24::Double) *~ D.day
      ]

  writeMVar :: MVar a -> a -> IO ()
  writeMVar m v = void $ swapMVar m v

  testCBAfter = do
    cbm <- newMVar False
    void $ callbackAfter (0.5::DiffTime) (writeMVar cbm True)
    delay (0.4::DiffTime)
    False <- readMVar cbm
    delay (0.2::DiffTime)
    True <- readMVar cbm
    return ()

  testCBAt = do
    cbm <- newMVar False
    n <- getCurrentTime
    void $ callbackAt (addUTCTime 0.5 n) (writeMVar cbm True)
    delay (0.4::DiffTime)
    False <- readMVar cbm
    delay (0.2::DiffTime)
    True <- readMVar cbm
    return ()

  testCBAfterUpAfter = do
    cbm <- newMVar False
    ck <- callbackAfter (0.5::DiffTime) (writeMVar cbm True)
    updateCallbackToAfter ck (1::DiffTime)
    delay (0.75::DiffTime)
    False <- readMVar cbm
    delay (0.5::DiffTime)
    True <- readMVar cbm
    return ()

  testCBAfterUpAt = do
    cbm <- newMVar False
    n <- getCurrentTime
    ck <- callbackAfter (0.5::DiffTime) (writeMVar cbm True)
    updateCallbackTo ck (addUTCTime 1.0 n)
    delay (0.75::DiffTime)
    False <- readMVar cbm
    delay (0.5::DiffTime)
    True <- readMVar cbm
    return ()

  testCBAtUpAfter = do
    cbm <- newMVar False
    n <- getCurrentTime
    ck <- callbackAt (addUTCTime 0.5 n) (writeMVar cbm True)
    updateCallbackToAfter ck (1::DiffTime)
    delay (0.75::DiffTime)
    False <- readMVar cbm
    delay (0.5::DiffTime)
    True <- readMVar cbm
    return ()

  testCBAtUpAt = do
    cbm <- newMVar False
    n <- getCurrentTime
    ck <- callbackAt (addUTCTime 0.5 n) (writeMVar cbm True)
    updateCallbackTo ck (addUTCTime 1.0 n)
    delay (0.75::DiffTime)
    False <- readMVar cbm
    delay (0.5::DiffTime)
    True <- readMVar cbm
    return ()

  testCBCancelAfter = do
    cbm <- newMVar False
    ck <- callbackAfter (0.5::DiffTime) (writeMVar cbm True)
    cancelCallback ck
    delay (0.75::DiffTime)
    False <- readMVar cbm
    return ()

  testCBCancelAt = do
    cbm <- newMVar False
    n <- getCurrentTime
    ck <- callbackAt (addUTCTime 0.5 n) (writeMVar cbm True)
    cancelCallback ck
    delay (0.75::DiffTime)
    False <- readMVar cbm
    return ()

  testCBCancelCancel = do
    cbm <- newMVar False
    n <- getCurrentTime
    ck <- callbackAt (addUTCTime 0.5 n) (writeMVar cbm True)
    cancelCallback ck
    delay (0.75::DiffTime)
    cancelCallback ck
    False <- readMVar cbm
    return ()

  testCBUpdateAfterCanceled = do
    cbm <- newMVar False
    n <- getCurrentTime
    ck <- callbackAt (addUTCTime 0.5 n) (writeMVar cbm True)
    cancelCallback ck
    updateCallbackToAfter ck (0.6::DiffTime)
    delay (0.75::DiffTime)
    cancelCallback ck
    False <- readMVar cbm
    return ()

  testCBUpdateAtCanceled = do
    cbm <- newMVar False
    n <- getCurrentTime
    ck <- callbackAt (addUTCTime 0.5 n) (writeMVar cbm True)
    cancelCallback ck
    updateCallbackTo ck (addUTCTime 0.6 n)
    delay (0.75::DiffTime)
    cancelCallback ck
    False <- readMVar cbm
    return ()

  testCBCancelExecutedAfter = do
    cbm <- newMVar False
    ck <- callbackAfter (0.5::DiffTime) (writeMVar cbm True)
    delay (0.75::DiffTime)
    cancelCallback ck
    True <- readMVar cbm
    return ()

  testCBCancelExecutedAt = do
    cbm <- newMVar False
    n <- getCurrentTime
    ck <- callbackAt (addUTCTime 0.5 n) (writeMVar cbm True)
    delay (0.75::DiffTime)
    cancelCallback ck
    True <- readMVar cbm
    return ()