si-timers: round difftime to microseconds in IOSim

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

Author: coot

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,16 @@ diffTimeToMicrosecondsAsInt d =
 microsecondsAsIntToDiffTime :: Int -> DiffTime
 microsecondsAsIntToDiffTime = (/ 1_000_000) . fromIntegral
 
+-- | Round to microseconds.
+--
+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,19 @@ prop_diffTimeToMicrosecondsAsIntRightInverse (DiffTimeDistr a) =
          -> "large"
          | otherwise
          -> "average"
+
+
+prop_roundDiffTimeToMicroseconds :: DiffTimeDistr -> Property
+prop_roundDiffTimeToMicroseconds (DiffTimeDistr d) =
+    -- rounded is less or equal to d
+    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/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