diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md index 7b00811c..968e319f 100644 --- a/io-classes/CHANGELOG.md +++ b/io-classes/CHANGELOG.md @@ -4,14 +4,15 @@ ### Breaking changes -+* Changed `Time` show instance, which now is designed for pasting -+ counterexamples from terminal to an editor. +* Changed `Time` show instance, which now is designed for pasting +* counterexamples from terminal to an editor. ### Non-breaking changes * Improved performance of `tryReadTBQueueDefault`. * Added module `Control.Monad.Class.MonadUnique` generalising `Data.Unique`. * mtl: Added module `Control.Monad.Class.MonadUnique.Trans` providing monad transformer instances for `MonadUnique`. +* Added `roundDiffTimeToMicroseconds` utility function to `si-timers` package (in the `MonadTimer.SI` module). ## 1.8.0.1 diff --git a/io-classes/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs b/io-classes/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs index 2e253233..fb6998e1 100644 --- a/io-classes/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs +++ b/io-classes/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs @@ -5,6 +5,7 @@ module Control.Monad.Class.MonadTimer.SI -- * Auxiliary functions , diffTimeToMicrosecondsAsInt , microsecondsAsIntToDiffTime + , roundDiffTimeToMicroseconds -- * Re-exports , DiffTime , MonadFork @@ -54,9 +55,24 @@ diffTimeToMicrosecondsAsInt d = microsecondsAsIntToDiffTime :: Int -> DiffTime microsecondsAsIntToDiffTime = (/ 1_000_000) . fromIntegral +-- | Round to microseconds. +-- +-- For negative diff times it rounds towards negative infinity, which is +-- desirable for `MonadTimer` API. +-- +roundDiffTimeToMicroseconds :: DiffTime -> DiffTime +roundDiffTimeToMicroseconds d = fromIntegral usec / 1_000_000 + where + -- microseconds + usec :: Integer + usec = diffTimeToPicoseconds d `div` 1_000_000 + + class ( MonadTimer.MonadDelay m , MonadMonotonicTime m ) => MonadDelay m where + -- | All instances SHOULD round delays down to the nearest microsecond so the + -- behaviour matches the `IO` instance. threadDelay :: DiffTime -> m () -- | Thread delay. This implementation will not over- or underflow. @@ -68,6 +84,9 @@ class ( MonadTimer.MonadDelay m -- For delays smaller than `minBound :: Int` seconds, `minBound :: Int` will be -- used instead. -- +-- NOTE: since `MonadTimer.threadDelay` uses microsecond precision (as does +-- GHC), so does this instance. +-- instance MonadDelay IO where threadDelay :: forall m. MonadDelay m @@ -103,6 +122,11 @@ instance MonadDelay IO where instance MonadDelay m => MonadDelay (ReaderT r m) where threadDelay = lift . threadDelay +-- | `MonadTimer` API based on SI units (seconds). +-- +-- NOTE: all instances SHOULD round delays down to the nearest microsecond so +-- the behaviour matches the `IO` instance. +-- class ( MonadTimer.MonadTimer m , MonadMonotonicTime m ) => MonadTimer m where diff --git a/io-classes/si-timers/test/Test/MonadTimer.hs b/io-classes/si-timers/test/Test/MonadTimer.hs index 4f8a5740..1ff8d8f5 100644 --- a/io-classes/si-timers/test/Test/MonadTimer.hs +++ b/io-classes/si-timers/test/Test/MonadTimer.hs @@ -17,6 +17,8 @@ tests = prop_diffTimeToMicrosecondsAsIntLeftInverse , testProperty "diffTimeToMicroseconds right inverse" prop_diffTimeToMicrosecondsAsIntRightInverse + , testProperty "roundToMicroseconds" + prop_roundDiffTimeToMicroseconds ] newtype IntDistr = IntDistr Int @@ -88,3 +90,21 @@ prop_diffTimeToMicrosecondsAsIntRightInverse (DiffTimeDistr a) = -> "large" | otherwise -> "average" + + +prop_roundDiffTimeToMicroseconds :: DiffTimeDistr -> Property +prop_roundDiffTimeToMicroseconds (DiffTimeDistr d) = + -- rounded is less or equal to d + -- + -- NOTE: this guarantees that if `d < 0` then `d' < 0` which is + -- important for `MonadTimer (IOSim s)` instance. + d' <= d + .&&. + -- difference is less than 1 microsecond + abs (d - d') < 0.000_001 + .&&. + -- rounded has no fractional microseconds + case properFraction (d' * 1_000_000) of + (_ :: Integer, f) -> f === 0 + where + d' = roundDiffTimeToMicroseconds d diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index 1b2bb104..5e93b826 100644 --- a/io-sim/CHANGELOG.md +++ b/io-sim/CHANGELOG.md @@ -12,6 +12,8 @@ which are based on it: `runSim`, `runSimOrThrow`, or `runSimStrictShutdown`) with `within` or `discardAfter` from `QuickCheck`. See the test suite how to use `discardAfter` with `IOSim`. +* Round `si-timers` API (`MonadDelay`, `MonadTimer`) to microsecond to match + `IO` behaviour. ## 1.8.0.1 diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs index 273c0aef..c084826d 100644 --- a/io-sim/src/Control/Monad/IOSim/Types.hs +++ b/io-sim/src/Control/Monad/IOSim/Types.hs @@ -725,7 +725,8 @@ instance MonadDelay (IOSim s) where instance SI.MonadDelay (IOSim s) where threadDelay d = - IOSim $ oneShot $ \k -> ThreadDelay d (k ()) + IOSim $ oneShot $ \k -> ThreadDelay (SI.roundDiffTimeToMicroseconds d) + (k ()) data Timeout s = Timeout !(TVar s TimeoutState) !TimeoutId -- ^ a timeout @@ -765,11 +766,15 @@ instance SI.MonadTimer (IOSim s) where timeout d action | d < 0 = Just <$> action | d == 0 = return Nothing - | otherwise = IOSim $ oneShot $ \k -> StartTimeout d (runIOSim action) k + | otherwise = IOSim $ oneShot $ \k -> + StartTimeout (SI.roundDiffTimeToMicroseconds d) + (runIOSim action) + k - registerDelay d = IOSim $ oneShot $ \k -> RegisterDelay d k + registerDelay d = IOSim $ oneShot $ \k -> + RegisterDelay (SI.roundDiffTimeToMicroseconds d) k registerDelayCancellable d = do - t <- newTimeout d + t <- newTimeout (SI.roundDiffTimeToMicroseconds d) return (readTimeout t, cancelTimeout t) newtype TimeoutException = TimeoutException TimeoutId deriving Eq