diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,21 +1,21 @@ # Changelog -## next release - -### Breaking changes +## 1.4.0.0 ### Non-breaking changes +* Prevent underflows in `threadDelay` (issue #129) + ## 1.3.0.0 -- `io-sim-1.3.0.0`. +* `io-sim-1.3.0.0`. * Support `ghc-9.8`. ## 1.2.0.0 ## Non breaking changes -- Added NFData & NoThunks instances for `Time` +* Added NFData & NoThunks instances for `Time` ## 1.1.0.0 diff --git a/NOTICE b/NOTICE --- a/NOTICE +++ b/NOTICE @@ -1,4 +1,4 @@ -Copyright 2019-2023 Input Output Global Inc (IOG) +Copyright 2019-2024 Input Output Global Inc (IOG) Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/si-timers.cabal b/si-timers.cabal --- a/si-timers.cabal +++ b/si-timers.cabal @@ -1,13 +1,13 @@ cabal-version: 3.0 name: si-timers -version: 1.3.0.0 +version: 1.4.0.0 synopsis: timers using SI units (seconds) description: Timers using SI units (seconds) which are safe on 32-bit platforms and compatible with [io-sim](https://hackage.haskell.org/package/io-sim). license: Apache-2.0 license-files: LICENSE NOTICE -copyright: 2022-2023 Input Output Global Inc (IOG) +copyright: 2022-2024 Input Output Global Inc (IOG) author: Duncan Coutts, Neil Davis, Marcin Szamotulski maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me category: Time @@ -44,6 +44,7 @@ Control.Monad.Class.MonadTimer.SI other-modules: Control.Monad.Class.MonadTimer.NonStandard default-language: Haskell2010 + default-extensions: ImportQualifiedPost other-extensions: BangPatterns, CPP, ConstraintKinds, @@ -59,7 +60,7 @@ stm, time >=1.9.1 && <1.13, - io-classes ^>=1.3 + io-classes ^>=1.4 if flag(asserts) ghc-options: -fno-ignore-asserts @@ -73,6 +74,7 @@ main-is: Main.hs other-modules: Test.MonadTimer default-language: Haskell2010 + default-extensions: ImportQualifiedPost build-depends: base, QuickCheck, diff --git a/src/Control/Monad/Class/MonadTime/SI.hs b/src/Control/Monad/Class/MonadTime/SI.hs --- a/src/Control/Monad/Class/MonadTime/SI.hs +++ b/src/Control/Monad/Class/MonadTime/SI.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE NumericUnderscores #-} module Control.Monad.Class.MonadTime.SI ( MonadTime (..) @@ -20,20 +20,19 @@ , NominalDiffTime ) where -import Control.Monad.Reader -import Control.DeepSeq (NFData (..)) +import Control.DeepSeq (NFData (..)) +import Control.Monad.Reader -import Control.Monad.Class.MonadTime ( MonadMonotonicTimeNSec, - MonadTime (..), NominalDiffTime, UTCTime, diffUTCTime, - addUTCTime) -import qualified Control.Monad.Class.MonadTime as MonadTime +import Control.Monad.Class.MonadTime (MonadMonotonicTimeNSec, MonadTime (..), + NominalDiffTime, UTCTime, addUTCTime, diffUTCTime) +import Control.Monad.Class.MonadTime qualified as MonadTime -import NoThunks.Class (NoThunks (..)) +import NoThunks.Class (NoThunks (..)) -import Data.Word (Word64) -import Data.Time.Clock (DiffTime) -import qualified Data.Time.Clock as Time -import GHC.Generics (Generic (..)) +import Data.Time.Clock (DiffTime) +import Data.Time.Clock qualified as Time +import Data.Word (Word64) +import GHC.Generics (Generic (..)) -- | A point in time in a monotonic clock. diff --git a/src/Control/Monad/Class/MonadTimer/NonStandard.hs b/src/Control/Monad/Class/MonadTimer/NonStandard.hs --- a/src/Control/Monad/Class/MonadTimer/NonStandard.hs +++ b/src/Control/Monad/Class/MonadTimer/NonStandard.hs @@ -36,17 +36,17 @@ , AwaitTimeout ) where -import qualified Control.Concurrent.STM as STM +import Control.Concurrent.STM qualified as STM #ifndef GHC_TIMERS_API -import Control.Monad (when) +import Control.Monad (when) #endif -import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadSTM #ifdef GHC_TIMERS_API -import qualified GHC.Event as GHC (TimeoutKey, getSystemTimerManager, - registerTimeout, unregisterTimeout) +import GHC.Event qualified as GHC (TimeoutKey, getSystemTimerManager, + registerTimeout, unregisterTimeout) #else -import qualified GHC.Conc.IO as GHC (registerDelay) +import GHC.Conc.IO qualified as GHC (registerDelay) #endif @@ -93,7 +93,7 @@ -- You should consider the cancelled state if you plan to use 'cancelTimeout'. -- readTimeout :: ReadTimeout IO Timeout -type ReadTimeout m timeout = timeout -> STM m TimeoutState +type ReadTimeout m timeout = timeout -> STM m TimeoutState -- | Cancel a timeout (unless it has already fired), putting it into the diff --git a/src/Control/Monad/Class/MonadTimer/SI.hs b/src/Control/Monad/Class/MonadTimer/SI.hs --- a/src/Control/Monad/Class/MonadTimer/SI.hs +++ b/src/Control/Monad/Class/MonadTimer/SI.hs @@ -19,22 +19,22 @@ , TimeoutState (..) -- * Default implementations , defaultRegisterDelay - , defaultRegisterDelayCancellable + , defaultRegisterDelayCancellable ) where -import Control.Concurrent.Class.MonadSTM -import Control.Exception (assert) -import Control.Monad.Class.MonadFork -import Control.Monad.Class.MonadTime.SI -import qualified Control.Monad.Class.MonadTimer as MonadTimer -import Control.Monad.Class.MonadTimer.NonStandard (TimeoutState (..)) -import qualified Control.Monad.Class.MonadTimer.NonStandard as NonStandard +import Control.Concurrent.Class.MonadSTM +import Control.Exception (assert) +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer qualified as MonadTimer +import Control.Monad.Class.MonadTimer.NonStandard (TimeoutState (..)) +import Control.Monad.Class.MonadTimer.NonStandard qualified as NonStandard -import Control.Monad.Reader +import Control.Monad.Reader -import Data.Bifunctor (bimap) -import Data.Functor (($>)) -import Data.Time.Clock (diffTimeToPicoseconds) +import Data.Bifunctor (bimap) +import Data.Functor (($>)) +import Data.Time.Clock (diffTimeToPicoseconds) @@ -42,11 +42,16 @@ -- -- Note that on 32bit systems it can only represent `2^31-1` seconds, which is -- only ~35 minutes. +-- +-- It doesn't prevent under- or overflows; when assertions are on it will thrown +-- an assertion exception. +-- diffTimeToMicrosecondsAsInt :: DiffTime -> Int diffTimeToMicrosecondsAsInt d = let usec :: Integer usec = diffTimeToPicoseconds d `div` 1_000_000 in - assert (usec <= fromIntegral (maxBound :: Int)) $ + assert (usec <= fromIntegral (maxBound :: Int) + && usec >= fromIntegral (minBound :: Int)) $ fromIntegral usec @@ -60,15 +65,21 @@ ) => MonadDelay m where threadDelay :: DiffTime -> m () --- | Thread delay. When the delay is smaller than what `Int` can represent it --- will use the `Control.Monad.Class.MonadTimer.threadDelay` (e.g. for the `IO` --- monad it will use `Control.Concurrent.threadDelay`); otherwise it will --- recursively call `Control.Monad.Class.MonadTimer.threadDelay`. +-- | Thread delay. This implementation will not over- or underflow. -- +-- For delay larger than what `Int` can represent (see +-- `diffTimeToMicrosecondsAsInt`), it will recursively call +-- `Control.Monad.Class.MonadTimer.threadDelay`. +-- +-- For delays smaller than `minBound :: Int` seconds, `minBound :: Int` will be +-- used instead. +-- instance MonadDelay IO where threadDelay :: forall m. MonadDelay m => DiffTime -> m () + threadDelay d | d <= 0 = return () + threadDelay d | d <= maxDelay = MonadTimer.threadDelay (diffTimeToMicrosecondsAsInt d) where @@ -248,7 +259,7 @@ maxDelay = microsecondsAsIntToDiffTime maxBound registerDelayCancellable = - defaultRegisterDelayCancellable + defaultRegisterDelayCancellable NonStandard.newTimeout NonStandard.readTimeout NonStandard.cancelTimeout diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,8 +1,8 @@ module Main (main) where -import Test.Tasty +import Test.Tasty -import qualified Test.MonadTimer +import Test.MonadTimer qualified main :: IO () main = defaultMain tests diff --git a/test/Test/MonadTimer.hs b/test/Test/MonadTimer.hs --- a/test/Test/MonadTimer.hs +++ b/test/Test/MonadTimer.hs @@ -3,12 +3,12 @@ module Test.MonadTimer (tests) where -import Control.Monad.Class.MonadTimer.SI -import GHC.Real +import Control.Monad.Class.MonadTimer.SI +import GHC.Real -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) tests :: TestTree tests =