delay (empty) → 0
raw patch · 5 files changed
+645/−0 lines, 5 filesdep +asyncdep +basedep +delaysetup-changed
Dependencies added: async, base, delay, dimensional, exceptions, mtl, time, unbounded-delays
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- delay.cabal +48/−0
- src/Control/Time.hs +303/−0
- tests/test.hs +262/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014-2016, davean++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of davean nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ delay.cabal view
@@ -0,0 +1,48 @@+name: delay+version: 0+synopsis: More useful and humain delaying functions+license: BSD3+license-file: LICENSE+author: davean+maintainer: davean <davean@xkcd.com>+copyright: Copyright (C) 2014-2016 davean+stability: provisional+category: Concurrency, System+build-type: Simple+cabal-version: >=1.10+bug-reports: oss@xkcd.com+description:+ Functions to provide delays, timeouts, and callbacks where the target time is calculated either from a period as an offset from the initialization time, or at a specific 'UTCTime'.+ .+ Most standard Haskell types are supported for periods, based on the second as the base unit quantity. For more complicated period calculations, 'Dimensional's 'Time' type is supported.++source-repository head+ type: git+ location: http://git.xkrd.net/davean/delay.git++library+ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules:+ Control.Time+ build-depends:+ base >= 4.6 && <5,+ time >= 1.4,+ unbounded-delays >= 0.1,+ mtl >= 2.2,+ dimensional >= 1.0.1.1,+ exceptions >= 0.6++test-suite test+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ ghc-options: -threaded+ hs-source-dirs: tests+ main-is: test.hs+ build-depends:+ base,+ delay,+ time,+ async,+ dimensional,+ exceptions
+ src/Control/Time.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, LambdaCase #-}+module Control.Time (+ -- * Delays+ delay, delayTill+ -- * Timeouts+ , timeout, timeoutAt+ -- * Callbacks+ , CallbackKey+ , callbackAfter, callbackAt+ , updateCallbackToAfter, updateCallbackTo+ , cancelCallback+ -- * Time period conversion+ , AsMicro(..)+ ) where++-- Some writings on the problems with leap seconds:+-- http://www.madore.org/~david/computers/unix-leap-seconds.html+-- http://www.leapsecond.com/java/gpsclock.htm++import Control.Concurrent+import qualified Control.Concurrent.Thread.Delay as D+import qualified Control.Concurrent.Timeout as T+import qualified Control.Exception as E+import qualified Control.Monad.Catch as MC+import Control.Monad+import Control.Monad.Trans+import Data.Fixed+import Data.Int+import Data.Time+import Data.Typeable+import Data.Unique+import Data.Word+import qualified GHC.Event as Ev+import Numeric.Natural+import Numeric.Units.Dimensional ((/~))+import qualified Numeric.Units.Dimensional as D+import qualified Numeric.Units.Dimensional.SIUnits as D++-- | Delay a until at least the specified amount of time has passed.+delay :: (MonadIO m, AsMicro period) => period -> m ()+delay = liftIO . D.delay . toMicro++day :: NominalDiffTime+day = 86400++-- | Delay until a specific 'UTCTime' has occured (at least once).+-- This is slighly confusing, as we can't guarantee we don't return only after the second+-- occurence of the 'UTCTime' under certain leap second handling regimes. Consider for example+-- when 'delayTill' is called during a leap second occurence, where the system clock jumps back+-- and repeats the second. As there is no indication the time has already passed once, we must+-- wait until the second occurence.+delayTill :: (MonadIO m) => UTCTime -> m ()+delayTill t = liftIO $ do+ n <- getCurrentTime+ case n >= t of+ True -> return ()+ False -> do+ -- A maximum wait of 86400 seconds at a time, so we can't be off by more then one second in the case of+ -- backwards leap seconds.+ delay (realToFrac . min day . diffUTCTime t $ n::Pico)+ -- in the case of waits across leap seconds, we may not have waited long enough.+ delayTill t++-- 'timeout'/'timeoutAt' code based on 'timeout' in base, which is+-- (c) The University of Glasgow 2007.++newtype Timeout = Timeout Unique deriving (Eq, Typeable)++instance Show Timeout where+ show _ = "<<timeout>>"++-- Timeout is a child of SomeAsyncException+instance E.Exception Timeout where+ toException = E.asyncExceptionToException+ fromException = E.asyncExceptionFromException++-- | Run an monad action for at least a specific number of seconds, but not much more.+timeout :: (MonadIO m, MC.MonadMask m, AsMicro period) => period -> m a -> m (Maybe a)+timeout p a | 0 >= toMicro p = return Nothing+timeout p a = do+ pid <- liftIO myThreadId+ ex <- liftIO $ fmap Timeout newUnique+ MC.handleJust (\e -> if e == ex then Just () else Nothing)+ (\_ -> return Nothing)+ (MC.bracket (liftIO $ forkIOWithUnmask $ \unmask ->+ unmask $ delay p >> E.throwTo pid ex)+ (MC.uninterruptibleMask_ . liftIO . killThread)+ (\_ -> fmap Just a))++-- | Run a monadic action until it produces a result or a specific time occures.+-- Leap second handling as per delayTill.+timeoutAt :: (MonadIO m, MC.MonadMask m) => UTCTime -> m a -> m (Maybe a)+timeoutAt t a = do+ now <- liftIO $ getCurrentTime+ case now >= t of+ True -> return Nothing+ False -> do+ pid <- liftIO myThreadId+ ex <- liftIO $ fmap Timeout newUnique+ MC.handleJust (\e -> if e == ex then Just () else Nothing)+ (\_ -> return Nothing)+ (MC.bracket (liftIO $ forkIOWithUnmask $ \unmask ->+ unmask $ delayTill t >> E.throwTo pid ex)+ (MC.uninterruptibleMask_ . liftIO . killThread)+ (\_ -> fmap Just a))++-- Make it clear what units the Integer holds.+newtype MicroSeconds = MS Integer++-- | Our actual callback data.+-- CallbackCancel so that we can know if we're canceled even if we raced with execution.+data CallbackHandle =+ CallbackCanceled+ | CallbackAt Ev.TimeoutKey UTCTime (IO ())+ | CallbackAfter Ev.TimeoutKey MicroSeconds (IO ())++-- | We hold the CallbackHandle in an MVar so we don't race on update/cancelation+-- and executing the callback.+-- Updating or canceling holds the lock, which is also required to export the action.+type CallbackKey = MVar CallbackHandle++-- | Actually register our next wait, or actually execute the callback.+-- (or, realize we were cancled)+doCallback :: CallbackKey -> IO ()+doCallback ck = do+ mngr <- Ev.getSystemTimerManager+ delayedAction <- modifyMVarMasked ck $ \case+ CallbackCanceled -> return (CallbackCanceled, return ())+ CallbackAt _ t act -> do+ n <- getCurrentTime+ case t `diffUTCTime` n of+ w | w <= 0 -> return (CallbackCanceled, act)+ w -> do+ newKey <- Ev.registerTimeout mngr+ (fromInteger . toMicro $ (realToFrac . min day $ w::Pico))+ (doCallback ck)+ return (CallbackAt newKey t act, return ())+ CallbackAfter _ (MS w) act | w <= 0 -> return (CallbackCanceled, act)+ CallbackAfter _ (MS w) act -> do+ let stepAmount = min (toInteger (maxBound::Int)) w+ newKey <- Ev.registerTimeout mngr+ (fromInteger stepAmount)+ (doCallback ck)+ return (CallbackAfter newKey (MS $ w - stepAmount) act, return ())+ delayedAction++-- | Run a callback after a period of time has passed.+callbackAfter :: (MonadIO m, AsMicro period) => period -> IO () -> m CallbackKey+callbackAfter p act = liftIO $ do+ h <- newMVar (CallbackAfter undefined (MS . toMicro $ p) act)+ -- doCallback never looks at the Ev.TimeoutKey, but does set it, so its not undefined when we+ -- return, which is the first time someone could call an update or cancel.+ doCallback h+ return h++-- | Run a callback at a specific time.+callbackAt :: MonadIO m => UTCTime -> IO () -> m CallbackKey+callbackAt t act = liftIO $ do+ h <- newMVar (CallbackAt undefined t act)+ -- doCallback never looks at the Ev.TimeoutKey, but does set it, so its not undefined when we+ -- return, which is the first time someone could call an update or cancel.+ doCallback h+ return h++-- | Change an existing, unexecuted or canceled callbak to run after a specific period of time+-- from the call of 'updateCallbackToAfter'.+updateCallbackToAfter :: (MonadIO m, AsMicro period) => CallbackKey -> period -> m ()+updateCallbackToAfter ck p = liftIO $ do+ delayed <- modifyMVarMasked ck $ \case+ CallbackCanceled -> return (CallbackCanceled, return ())+ CallbackAt tk _ act -> reRegister tk act+ CallbackAfter tk _ act -> reRegister tk act+ delayed+ where+ p' :: Integer+ p' = toMicro p+ reRegister :: Ev.TimeoutKey -> IO () -> IO (CallbackHandle, IO ())+ reRegister tk act = do+ mngr <- Ev.getSystemTimerManager+ Ev.unregisterTimeout mngr tk+ let stepAmount = fromInteger . min (toInteger (maxBound::Int)) $ p'+ case stepAmount <= 0 of+ True -> return (CallbackCanceled, void . forkIO $ act)+ False -> do+ newKey <- Ev.registerTimeout mngr+ (fromInteger stepAmount)+ (doCallback ck)+ return (CallbackAfter newKey (MS $ p' - stepAmount) act, return ())++-- | Change an existing, unexecuted or canceled callbak to run after at a specific time.+updateCallbackTo :: MonadIO m => CallbackKey -> UTCTime -> m ()+updateCallbackTo ck t = liftIO $ do+ delayed <- modifyMVarMasked ck $ \case+ CallbackCanceled -> return (CallbackCanceled, return ())+ CallbackAt tk _ act -> reRegister tk act+ CallbackAfter tk _ act -> reRegister tk act+ delayed+ where+ reRegister :: Ev.TimeoutKey -> IO () -> IO (CallbackHandle, IO ())+ reRegister tk act = do+ mngr <- Ev.getSystemTimerManager+ Ev.unregisterTimeout mngr tk+ n <- getCurrentTime+ let w = t `diffUTCTime` n+ let stepAmount = fromInteger . toMicro $ (realToFrac . max 0 . min day $ w::Pico)+ case stepAmount <= 0 of+ True -> return (CallbackCanceled, void . forkIO $ act)+ False -> do+ newKey <- Ev.registerTimeout mngr stepAmount (doCallback ck)+ return (CallbackAt newKey t act, return ())++-- | Terminate an unexecuted callback.+cancelCallback :: MonadIO m => CallbackKey -> m ()+cancelCallback ck =+ liftIO . modifyMVarMasked_ ck $ \case+ CallbackCanceled -> return CallbackCanceled+ CallbackAt tk _ _ -> cancelCB tk+ CallbackAfter tk _ _ -> cancelCB tk+ where+ cancelCB :: Ev.TimeoutKey -> IO CallbackHandle+ cancelCB tk = do+ mngr <- Ev.getSystemTimerManager+ Ev.unregisterTimeout mngr tk+ return CallbackCanceled++microPrecision :: Num n => n+microPrecision = (10^(6::Int))++-- | Calculate the number of microseconds of delay a value represents.+-- Instances must round up for correctness.+class AsMicro d where+ toMicro :: d -> Integer++-- UTCTime and NominalDiffTime can't have an instance of AsMicro since we can't calculate the+-- number of microseconds until such a time actually occurs.+-- To be specific: over a long period there could be a decision to institute a leap second,+-- in either direction, for UTC. This could cause us to return early.++instance AsMicro DiffTime where+ toMicro = ceiling . (*) microPrecision++instance (Fractional n, AsMicro n) => AsMicro (D.Time n) where+ toMicro t = toMicro (t /~ D.second)++-- | As seconds.+instance AsMicro Integer where+ toMicro = (*) microPrecision++-- | As seconds.+instance AsMicro Natural where+ toMicro = toMicro . toInteger++-- | As seconds.+instance AsMicro Int where+ toMicro = toMicro . toInteger++-- | As seconds.+instance AsMicro Int8 where+ toMicro = toMicro . toInteger++-- | As seconds.+instance AsMicro Int16 where+ toMicro = toMicro . toInteger++-- | As seconds.+instance AsMicro Int32 where+ toMicro = toMicro . toInteger++-- | As seconds.+instance AsMicro Int64 where+ toMicro = toMicro . toInteger++-- | As seconds.+instance AsMicro Word where+ toMicro = toMicro . toInteger++-- | As seconds.+instance AsMicro Word8 where+ toMicro = toMicro . toInteger++-- | As seconds.+instance AsMicro Word16 where+ toMicro = toMicro . toInteger++-- | As seconds.+instance AsMicro Word32 where+ toMicro = toMicro . toInteger++-- | As seconds.+instance AsMicro Word64 where+ toMicro = toMicro . toInteger++-- | As seconds.+instance AsMicro Float where+ toMicro = ceiling . (*) microPrecision++-- | As seconds.+instance AsMicro Double where+ toMicro = ceiling . (*) microPrecision++-- | As seconds.+instance HasResolution d => AsMicro (Fixed d) where+ toMicro (d@(MkFixed v)) = (v * microPrecision) `div` (resolution d)
+ tests/test.hs view
@@ -0,0 +1,262 @@+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 ()