si-timers: round difftime to microseconds in IOSim

This makes `threadDelay` and `MonadTimer` from `si-timers` sublibrary behave the same way
for `IOSim` and `IO`.

Author: coot

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
 

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,6 +55,19 @@ 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

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

io-sim/CHANGELOG.md

@@ -8,6 +8,7 @@
 
 * Added support for unique symbol generation à la `Data.Unique`.
 * Removed a misleading internal comment.
+* Round `si-timers` `threadDelay` to microsecond to match `IO` behaviour.
 
 ## 1.8.0.1
 

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