si-timers: interface to time & timers using SI units

.github/workflows/cabal.project.local

@@ -13,3 +13,7 @@ package strict-stm
 package io-sim
   ghc-options: -Werror
   flags: +asserts
+
+package si-timers
+  ghc-options: -Werror
+  flags: +asserts

.github/workflows/haskell.yml

@@ -119,12 +119,12 @@ jobs:
     - name: Build projects [build]
       run: cabal build all
 
-    - name: io-classes [test]
-      run: cabal run io-classes:test
-
     - name: io-sim [test]
       run: cabal run io-sim:test
 
+    - name: si-timers [test]
+      run: cabal run si-timers:test
+
   stylish-haskell:
     runs-on: ubuntu-22.04
 

cabal.project

@@ -17,6 +17,7 @@ index-state:
 packages: ./io-sim
           ./io-classes
           ./strict-stm
+          ./si-timers
 
 package io-sim
   flags: +asserts

io-classes/io-classes.cabal

@@ -83,17 +83,3 @@ library
 
   if flag(asserts)
     ghc-options: -fno-ignore-asserts
-
-test-suite test
-  import:              warnings
-  type:                exitcode-stdio-1.0
-  hs-source-dirs:      test
-  main-is:             Main.hs
-  other-modules:       Test.MonadTimer
-  default-language:    Haskell2010
-  build-depends:       base,
-                       io-classes,
-
-                       QuickCheck,
-                       tasty,
-                       tasty-quickcheck

io-classes/src/Control/Monad/Class/MonadTimer.hs

@@ -9,16 +9,12 @@ module Control.Monad.Class.MonadTimer
   , MonadTimer (..)
   , registerDelayCancellable
   , TimeoutState (..)
-  , DiffTime
-  , diffTimeToMicrosecondsAsInt
-  , microsecondsAsIntToDiffTime
   ) where
 
 import qualified Control.Concurrent as IO
 import           Control.Concurrent.Class.MonadSTM
 import qualified Control.Concurrent.STM.TVar as STM
 
-import           Control.Monad (when)
 import           Control.Monad.Cont (ContT (..))
 import           Control.Monad.Except (ExceptT (..))
 import           Control.Monad.RWS (RWST (..))
@@ -28,132 +24,34 @@ import           Control.Monad.Trans (lift)
 import           Control.Monad.Writer (WriterT (..))
 
 import           Data.Functor (void)
-import           Data.Foldable (traverse_)
 
-import           Control.Monad.Class.MonadFork
-import           Control.Monad.Class.MonadTime
 import           Control.Monad.Class.MonadTimer.NonStandard
 
 import qualified System.Timeout as IO
 
 class Monad m => MonadDelay m where
-  threadDelay :: DiffTime -> m ()
+  threadDelay :: Int -> m ()
 
-  default threadDelay :: MonadTimer m => DiffTime -> m ()
-  threadDelay d   = void . atomically . awaitTimeout =<< newTimeout d
+  default threadDelay :: MonadTimer m => Int -> m ()
+  threadDelay d = void . atomically . awaitTimeout =<< newTimeout d
 
 class (MonadDelay m, MonadTimeout m) => MonadTimer m where
 
-  registerDelay :: DiffTime -> m (TVar m Bool)
+  registerDelay :: Int -> m (TVar m Bool)
 
-  timeout :: DiffTime -> m a -> m (Maybe a)
-
-
-
--- | A default implementation of `registerDelay` which supports delays longer
--- then `Int`; this is especially important on 32-bit architectures where
--- maximum delay expressed in microseconds is around 35 minutes.
---
-defaultRegisterDelay :: forall m.
-                        ( MonadTimer m
-                        , MonadTime  m
-                        , MonadFork  m
-                        )
-                     => DiffTime
-                     -> m (TVar m Bool)
-defaultRegisterDelay d = do
-    c <- getMonotonicTime
-    v <- atomically $ newTVar False
-    _ <- forkIO $ go v c (d `addTime` c)
-    return v
-  where
-    maxDelay :: DiffTime
-    maxDelay = microsecondsAsIntToDiffTime maxBound
-
-    go :: TVar m Bool -> Time -> Time -> m ()
-    go v c u | u `diffTime` c >= maxDelay = do
-      _ <- newTimeout maxDelay >>= atomically . awaitTimeout
-      c' <- getMonotonicTime
-      go v c' u
-
-    go v c u = do
-      t <- newTimeout (u `diffTime` c)
-      atomically $ do
-        _ <- awaitTimeout t
-        writeTVar v True
+  timeout :: Int -> m a -> m (Maybe a)
 
 --
 -- Cancellable Timers
 --
 
-
-registerDelayCancellable :: forall m.
-                            ( MonadFork  m
-                            , MonadTime  m
-                            , MonadTimer m
-                            )
-                         => DiffTime
+registerDelayCancellable :: forall m.  MonadTimer m
+                         => Int
                          -> m (STM m TimeoutState, m ())
 
-registerDelayCancellable d | d <= maxDelay = do
+registerDelayCancellable d = do
     t <- newTimeout d
     return (readTimeout t, cancelTimeout t)
-  where
-    maxDelay :: DiffTime
-    maxDelay = microsecondsAsIntToDiffTime maxBound
-
-registerDelayCancellable d = do
-    -- current time
-    c <- getMonotonicTime
-    -- timeout state
-    v <- newTVarIO TimeoutPending
-    -- current timer
-    m <- newTVarIO Nothing
-    tid <- forkIO $ go m v c (d `addTime` c)
-    let cancel = do
-          t <- atomically $ do
-            a <- readTVar v
-            case a of
-              TimeoutCancelled -> return Nothing
-              TimeoutFired     -> return Nothing
-              TimeoutPending   -> do
-                writeTVar v TimeoutCancelled
-                mt  <- readTVar m
-                case mt of
-                  Nothing -> retry
-                  Just t  -> return (Just t)
-          traverse_ cancelTimeout t
-          killThread tid
-    return (readTVar v, cancel)
-  where
-    maxDelay :: DiffTime
-    maxDelay = microsecondsAsIntToDiffTime maxBound
-
-    -- The timeout thread, it might be killed by an async exception. In this
-    -- case the `cancel` action is responsible for updating state state of the
-    -- timeout (held in `v`).
-    go :: TVar m (Maybe (Timeout m))
-       -> TVar m TimeoutState
-       -> Time
-       -> Time
-       -> m ()
-    go tv v c u | u `diffTime` c >= maxDelay = do
-      t <- newTimeout maxDelay
-      _ <- atomically $ swapTVar tv $! Just t
-      fired <- atomically $ awaitTimeout t
-      when fired $ do
-        c' <- getMonotonicTime
-        go tv v c' u
-
-    go tv v c u = do
-      t <- newTimeout (u `diffTime` c)
-      _ <- atomically $ swapTVar tv $! Just t
-      atomically $ do
-        fired <- awaitTimeout t
-        ts <- readTVar v
-        when (fired && ts == TimeoutPending) $
-          writeTVar v TimeoutFired
-
 
 --
 -- Instances for IO
@@ -163,48 +61,13 @@ registerDelayCancellable d = do
 -- advantage over 'IO.threadDelay'.
 --
 instance MonadDelay IO where
-  threadDelay d | d <= maxDelay =
-      IO.threadDelay (diffTimeToMicrosecondsAsInt d)
-    where
-      maxDelay :: DiffTime
-      maxDelay = microsecondsAsIntToDiffTime maxBound
-
-  threadDelay d = do
-      c <- getMonotonicTime
-      let u = d `addTime` c
-      go c u
-    where
-      maxDelay :: DiffTime
-      maxDelay = microsecondsAsIntToDiffTime maxBound
-
-      go :: Time -> Time -> IO ()
-      go c u = do
-        if d' >= maxDelay
-          then do
-            IO.threadDelay maxBound
-            c' <- getMonotonicTime
-            go  c' u
-          else
-            IO.threadDelay (diffTimeToMicrosecondsAsInt d')
-        where
-          d' = u `diffTime` c
+  threadDelay = IO.threadDelay
 
 
 instance MonadTimer IO where
 
-  -- | For delays less (or equal) than @maxBound :: Int@ this is exactly the same as
-  -- 'STM.registerDaley'; for larger delays it will start a monitoring thread
-  -- which will update the 'TVar'.
-  registerDelay d
-      | d <= maxDelay =
-        STM.registerDelay (diffTimeToMicrosecondsAsInt d)
-      | otherwise =
-        defaultRegisterDelay d
-    where
-      maxDelay :: DiffTime
-      maxDelay = microsecondsAsIntToDiffTime maxBound
-
-  timeout = IO.timeout . diffTimeToMicrosecondsAsInt
+  registerDelay = STM.registerDelay
+  timeout = IO.timeout
 
 --
 -- Transformer's instances

io-classes/src/Control/Monad/Class/MonadTimer/NonStandard.hs

@@ -22,12 +22,9 @@
 module Control.Monad.Class.MonadTimer.NonStandard
   ( MonadTimeout (..)
   , TimeoutState (..)
-  , diffTimeToMicrosecondsAsInt
-  , microsecondsAsIntToDiffTime
   ) where
 
 import qualified Control.Concurrent.STM.TVar as STM
-import           Control.Exception (assert)
 #ifndef GHC_TIMERS_API
 import           Control.Monad (when)
 #endif
@@ -46,7 +43,6 @@ import qualified GHC.Event as GHC (TimeoutKey, getSystemTimerManager,
 #endif
 
 import           Data.Kind (Type)
-import           Data.Time.Clock (DiffTime, diffTimeToPicoseconds)
 
 
 data TimeoutState = TimeoutPending | TimeoutFired | TimeoutCancelled
@@ -70,7 +66,7 @@ class MonadSTM m => MonadTimeout m where
   -- (as this would be very racy). You should create a new timeout if you need
   -- this functionality.
   --
-  newTimeout     :: DiffTime -> m (Timeout m)
+  newTimeout     :: Int -> m (Timeout m)
 
   -- | Read the current state of a timeout. This does not block, but returns
   -- the current state. It is your responsibility to use 'retry' to wait.
@@ -90,7 +86,7 @@ class MonadSTM m => MonadTimeout m where
   -- The new time can be before or after the original expiry time, though
   -- arguably it is an application design flaw to move timeouts sooner.
   --
-  updateTimeout  :: Timeout m -> DiffTime -> m ()
+  updateTimeout  :: Timeout m -> Int -> m ()
 
   -- | Cancel a timeout (unless it has already fired), putting it into the
   -- 'TimeoutCancelled' state. Code reading and acting on the timeout state
@@ -118,8 +114,7 @@ instance MonadTimeout IO where
   newTimeout = \d -> do
       var <- STM.newTVarIO TimeoutPending
       mgr <- GHC.getSystemTimerManager
-      key <- GHC.registerTimeout mgr (diffTimeToMicrosecondsAsInt d)
-                                     (STM.atomically (timeoutAction var))
+      key <- GHC.registerTimeout mgr d (STM.atomically (timeoutAction var))
       return (TimeoutIO var key)
     where
       timeoutAction var = do
@@ -133,7 +128,7 @@ instance MonadTimeout IO where
   -- It is safe to race against the timer firing.
   updateTimeout (TimeoutIO _var key) d = do
       mgr <- GHC.getSystemTimerManager
-      GHC.updateTimeout mgr key (diffTimeToMicrosecondsAsInt d)
+      GHC.updateTimeout mgr key d
 
   cancelTimeout (TimeoutIO var key) = do
       STM.atomically $ do
@@ -157,13 +152,13 @@ instance MonadTimeout IO where
       (_, True)  -> return TimeoutFired
 
   newTimeout d = do
-    timeoutvar    <- STM.registerDelay (diffTimeToMicrosecondsAsInt d)
+    timeoutvar    <- STM.registerDelay d
     timeoutvarvar <- STM.newTVarIO timeoutvar
     cancelvar     <- STM.newTVarIO False
     return (TimeoutIO timeoutvarvar cancelvar)
 
   updateTimeout (TimeoutIO timeoutvarvar _cancelvar) d = do
-    timeoutvar' <- STM.registerDelay (diffTimeToMicrosecondsAsInt d)
+    timeoutvar' <- STM.registerDelay d
     STM.atomically $ STM.writeTVar timeoutvarvar timeoutvar'
 
   cancelTimeout (TimeoutIO timeoutvarvar cancelvar) =
@@ -172,19 +167,6 @@ instance MonadTimeout IO where
       when (not fired) $ STM.writeTVar cancelvar True
 #endif
 
-
-diffTimeToMicrosecondsAsInt :: DiffTime -> Int
-diffTimeToMicrosecondsAsInt d =
-    let usec :: Integer
-        usec = diffTimeToPicoseconds d `div` 1_000_000 in
-    -- Can only represent usec times that fit within an Int, which on 32bit
-    -- systems means 2^31 usec, which is only ~35 minutes.
-    assert (usec <= fromIntegral (maxBound :: Int)) $
-    fromIntegral usec
-
-microsecondsAsIntToDiffTime :: Int -> DiffTime
-microsecondsAsIntToDiffTime = (/ 1_000_000) . fromIntegral
-
 --
 -- Transformer's instances
 --

io-sim/io-sim.cabal

@@ -71,6 +71,7 @@ library
                        deque,
                        parallel,
                        psqueues          >=0.2 && <0.3,
+                       si-timers        ^>=0.4,
                        time              >=1.9.1 && <1.13,
                        quiet,
                        QuickCheck,
@@ -97,6 +98,7 @@ test-suite test
                        io-sim,
                        parallel,
                        QuickCheck,
+                       si-timers,
                        strict-stm,
                        tasty,
                        tasty-quickcheck,