packages feed

si-timers (empty) → 1.0.0.0

raw patch · 10 files changed

+904/−0 lines, 10 filesdep +QuickCheckdep +basedep +io-classes

Dependencies added: QuickCheck, base, io-classes, mtl, si-timers, stm, tasty, tasty-quickcheck, time

Files

+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Changelog++## 1.0.0.0++* initial version+
+ LICENSE view
@@ -0,0 +1,177 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS
+ NOTICE view
@@ -0,0 +1,14 @@+Copyright 2019-2023 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.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.+
+ README.md view
@@ -0,0 +1,21 @@+# [SI] Timers++The `si-timers` package provides delays & timeouts which are safe on 32-bit+systems; cancellable timeouts (see `registerDelayCancellable`); a refined+interface for monotonic `Time`.  `Time` is given with left monoid action of+`DiffTime` (which encodes the notion of time differences).  The+`MonadMonotonicTime`, `MonadDelay` type classes & `MonadTimers` (type synonym)+API provide a consistent interface for working with delays and timeouts.++`si-timers` package also defined a low level `MonadTimout` type class.  On+system with a native timer manager (e.g. `Linux`, `MacOS`, `FreeBSD`), it's+very efficient but for other platforms (e.g.  `Windows`), it might not be the+right API for low latency timeouts needed for example for low level networking+code, because it relies on `GHC`'s `RTS` thread scheduling.++`si-timers` are compatible with `io-sim`.++The `SI` comes from the [International System of Units][SI].++[SI]: https://www.wikiwand.com/en/International_System_of_Units+[`io-sim`]: https://hackage.haskell.org/package/io-sim
+ si-timers.cabal view
@@ -0,0 +1,82 @@+cabal-version:       3.0+name:                si-timers+version:             1.0.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)+author:              Duncan Coutts, Neil Davis, Marcin Szamotulski+maintainer:          Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me+category:            Control+build-type:          Simple+extra-source-files:  CHANGELOG.md+                     README.md+tested-with:         GHC == { 8.10, 9.2, 9.4 }++flag asserts+  description: Enable assertions+  manual:      False+  default:     False++source-repository head+  type:     git+  location: https://github.com/input-output-hk/io-sim+  subdir:   io-sim++common warnings+    ghc-options: -Wall+                 -Wcompat+                 -Widentities+                 -Wincomplete-record-updates+                 -Wincomplete-uni-patterns+                 -Wno-unticked-promoted-constructors+                 -Wpartial-fields+                 -Wredundant-constraints+                 -Wunused-packages++library+  import:              warnings+  hs-source-dirs:      src+  exposed-modules:     Control.Monad.Class.MonadTime.SI+                       Control.Monad.Class.MonadTimer.SI+  other-modules:       Control.Monad.Class.MonadTimer.NonStandard+  default-language:    Haskell2010+  other-extensions:    BangPatterns,+                       CPP,+                       ConstraintKinds,+                       DefaultSignatures,+                       DeriveGeneric,+                       NumericUnderscores,+                       ScopedTypeVariables,+                       TypeFamilies+  build-depends:       base              >=4.9 && <4.18,+                       mtl,+                       stm,+                       time              >=1.9.1 && <1.13,++                       io-classes       ^>=1.0+  if flag(asserts)+     ghc-options:      -fno-ignore-asserts++-- Since `io-sim` depends on `si-times` (`io-sim` depends on `Time`) some tests of+-- are in `io-sim:test`: this is a good enough reason to pull `io-sim:test`+-- into a seprate package.+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,++                       QuickCheck,+                       tasty,+                       tasty-quickcheck,++                       si-timers
+ src/Control/Monad/Class/MonadTime/SI.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DefaultSignatures  #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE NumericUnderscores #-}++module Control.Monad.Class.MonadTime.SI+  ( MonadTime (..)+  , MonadMonotonicTime (..)+    -- * 'DiffTime' and its action on 'Time'+  , Time (..)+  , diffTime+  , addTime+  , DiffTime+    -- * 'NominalTime' and its action on 'UTCTime'+  , UTCTime+  , diffUTCTime+  , addUTCTime+  , NominalDiffTime+  ) where++import           Control.Monad.Reader++import           Control.Monad.Class.MonadTime ( MonadMonotonicTimeNSec,+                     MonadTime (..), NominalDiffTime, UTCTime, diffUTCTime,+                     addUTCTime)+import qualified Control.Monad.Class.MonadTime as MonadTime++import           Data.Word (Word64)+import           Data.Time.Clock (DiffTime)+import qualified Data.Time.Clock as Time+import           GHC.Generics (Generic (..))+++-- | A point in time in a monotonic clock.+--+-- The epoch for this clock is arbitrary and does not correspond to any wall+-- clock or calendar, and is /not guaranteed/ to be the same epoch across+-- program runs. It is represented as the 'DiffTime' from this arbitrary epoch.+--+newtype Time = Time DiffTime+  deriving (Eq, Ord, Show, Generic)++-- | The time duration between two points in time (positive or negative).+diffTime :: Time -> Time -> DiffTime+diffTime (Time t) (Time t') = t - t'++-- | Add a duration to a point in time, giving another time.+addTime :: DiffTime -> Time -> Time+addTime d (Time t) = Time (d + t)++infixr 9 `addTime`++class MonadMonotonicTimeNSec m => MonadMonotonicTime m where+  getMonotonicTime :: m Time++  default getMonotonicTime :: m Time+  getMonotonicTime =+        conv <$> MonadTime.getMonotonicTimeNSec+      where+        conv :: Word64 -> Time+        conv = Time . Time.picosecondsToDiffTime . (* 1_000) . toInteger++instance MonadMonotonicTime IO where++--+-- MTL instances+--++instance MonadMonotonicTime m => MonadMonotonicTime (ReaderT r m) where+  getMonotonicTime = lift getMonotonicTime
+ src/Control/Monad/Class/MonadTimer/NonStandard.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE TypeFamilies       #-}++#if  defined(__GLASGOW_HASKELL__) && \+    !defined(mingw32_HOST_OS) && \+    !defined(__GHCJS__) && \+    !defined(js_HOST_ARCH) && \+    !defined(wasm32_HOST_ARCH)+#define GHC_TIMERS_API+#endif++-- | A non-standard interface for timer api.+--+-- This module also provides a polyfill which allows to use timer api also on+-- non-threaded RTS regardless of the architecture \/ OS.  Currently we support+-- `*nix`, `macOS`, `Windows` (and, unofficially `GHCJS`).+--+-- We use it to provide @'Control.Monad.Class.MonadTimer.MonadTimer' 'IO'@+-- instance and to implement a cancellable timers, see+-- 'Control.Monad.Class.MonadTimer.SI.registerDelayCancellable'.+--+-- You can expect we will deprecate it at some point (e.g. once GHC gets+-- a better support for timers especially across different execution+-- environments).+--+module Control.Monad.Class.MonadTimer.NonStandard+  ( TimeoutState (..)+  , newTimeout+  , readTimeout+  , cancelTimeout+  , awaitTimeout+  , NewTimeout+  , ReadTimeout+  , CancelTimeout+  , AwaitTimeout+  ) where++import qualified Control.Concurrent.STM as STM+#ifndef GHC_TIMERS_API+import           Control.Monad (when)+#endif+import           Control.Monad.Class.MonadSTM++#ifdef GHC_TIMERS_API+import qualified GHC.Event as GHC (TimeoutKey, getSystemTimerManager,+                     registerTimeout, unregisterTimeout)+#else+import qualified GHC.Conc.IO as GHC (registerDelay)+#endif+++-- | State of a timeout: pending, fired or cancelled.+--+data TimeoutState = TimeoutPending | TimeoutFired | TimeoutCancelled+  deriving (Eq, Ord, Show)+++-- | The type of the timeout handle, used with 'newTimeout', 'readTimeout', and+-- 'cancelTimeout'.+--+#ifdef GHC_TIMERS_API+data Timeout = TimeoutIO !(STM.TVar TimeoutState) !GHC.TimeoutKey+#else+data Timeout = TimeoutIO !(STM.TVar (STM.TVar Bool)) !(STM.TVar Bool)+#endif++-- | Create a new timeout which will fire at the given time duration in+-- the future.+--+-- The timeout will start in the 'TimeoutPending' state and either+-- fire at or after the given time leaving it in the 'TimeoutFired' state,+-- or it may be cancelled with 'cancelTimeout', leaving it in the+-- 'TimeoutCancelled' state.+--+-- Timeouts /cannot/ be reset to the pending state once fired or cancelled+-- (as this would be very racy). You should create a new timeout if you need+-- this functionality.+--+-- When native timer manager is supported (on `*nix` systems), it only holds+-- a `TVar` with `TimeoutState` and `GHC.TimeoutKey`.+--+newTimeout :: NewTimeout IO Timeout+type NewTimeout m timeout = Int -> m timeout+++-- | 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.+--+-- Alternatively you may wish to use the convenience utility 'awaitTimeout'+-- to wait for just the fired or cancelled outcomes.+--+-- You should consider the cancelled state if you plan to use 'cancelTimeout'.+--+readTimeout :: ReadTimeout IO Timeout+type ReadTimeout m timeout = timeout -> STM m TimeoutState +++-- | Cancel a timeout (unless it has already fired), putting it into the+-- 'TimeoutCancelled' state. Code reading and acting on the timeout state+-- need to handle such cancellation appropriately.+--+-- It is safe to race this concurrently against the timer firing. It will+-- have no effect if the timer fires first.+--+cancelTimeout :: CancelTimeout IO Timeout+type CancelTimeout m timeout = timeout -> m ()++-- | Returns @True@ when the timeout is fired, or @False@ if it is cancelled.+awaitTimeout :: AwaitTimeout IO Timeout+type AwaitTimeout m timeout = timeout -> STM m Bool+++#ifdef GHC_TIMERS_API++readTimeout (TimeoutIO var _key) = STM.readTVar var++newTimeout = \d -> do+    var <- STM.newTVarIO TimeoutPending+    mgr <- GHC.getSystemTimerManager+    key <- GHC.registerTimeout mgr d (STM.atomically (timeoutAction var))+    return (TimeoutIO var key)+  where+    timeoutAction var = do+      x <- STM.readTVar var+      case x of+        TimeoutPending   -> STM.writeTVar var TimeoutFired+        TimeoutFired     -> error "MonadTimer(IO): invariant violation"+        TimeoutCancelled -> return ()++cancelTimeout (TimeoutIO var key) = do+    STM.atomically $ do+      x <- STM.readTVar var+      case x of+        TimeoutPending   -> STM.writeTVar var TimeoutCancelled+        TimeoutFired     -> return ()+        TimeoutCancelled -> return ()+    mgr <- GHC.getSystemTimerManager+    GHC.unregisterTimeout mgr key++#else++readTimeout (TimeoutIO timeoutvarvar cancelvar) = do+  canceled <- STM.readTVar cancelvar+  fired    <- STM.readTVar =<< STM.readTVar timeoutvarvar+  case (canceled, fired) of+    (True, _)  -> return TimeoutCancelled+    (_, False) -> return TimeoutPending+    (_, True)  -> return TimeoutFired++newTimeout d = do+  timeoutvar    <- GHC.registerDelay d+  timeoutvarvar <- STM.newTVarIO timeoutvar+  cancelvar     <- STM.newTVarIO False+  return (TimeoutIO timeoutvarvar cancelvar)++cancelTimeout (TimeoutIO timeoutvarvar cancelvar) =+  STM.atomically $ do+    fired <- STM.readTVar =<< STM.readTVar timeoutvarvar+    when (not fired) $ STM.writeTVar cancelvar True++#endif++awaitTimeout t  = do s <- readTimeout t+                     case s of+                       TimeoutPending   -> retry+                       TimeoutFired     -> return True+                       TimeoutCancelled -> return False
+ src/Control/Monad/Class/MonadTimer/SI.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE InstanceSigs        #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NumericUnderscores  #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Control.Monad.Class.MonadTimer.SI+  ( -- * Type classes+    MonadDelay (..)+  , MonadTimer (..)+    -- * Auxiliary functions+  , diffTimeToMicrosecondsAsInt+  , microsecondsAsIntToDiffTime+    -- * Re-exports+  , DiffTime+  , MonadFork+  , MonadMonotonicTime+  , MonadTime+  , TimeoutState (..)+    -- * Default implementations+  , defaultRegisterDelay+  , 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.Monad.Reader++import           Data.Bifunctor (bimap)+import           Data.Functor (($>))+import           Data.Time.Clock (diffTimeToPicoseconds)++++-- | Convert 'DiffTime' in seconds to microseconds represented by an 'Int'.+--+-- Note that on 32bit systems it can only represent `2^31-1` seconds, which is+-- only ~35 minutes.+diffTimeToMicrosecondsAsInt :: DiffTime -> Int+diffTimeToMicrosecondsAsInt d =+    let usec :: Integer+        usec = diffTimeToPicoseconds d `div` 1_000_000 in+    assert (usec <= fromIntegral (maxBound :: Int)) $+    fromIntegral usec+++-- | Convert time in microseconds in 'DiffTime' (measured in seconds).+--+microsecondsAsIntToDiffTime :: Int -> DiffTime+microsecondsAsIntToDiffTime = (/ 1_000_000) . fromIntegral++class ( MonadTimer.MonadDelay m+      , MonadMonotonicTime m+      ) => 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`.+--+instance MonadDelay IO where+  threadDelay :: forall m.+                 MonadDelay m+              => DiffTime -> m ()+  threadDelay d | d <= maxDelay =+      MonadTimer.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 -> m ()+      go c u = do+        if d' >= maxDelay+          then do+            MonadTimer.threadDelay maxBound+            c' <- getMonotonicTime+            go  c' u+          else+            MonadTimer.threadDelay (diffTimeToMicrosecondsAsInt d')+        where+          d' = u `diffTime` c++instance MonadDelay m => MonadDelay (ReaderT r m) where+  threadDelay = lift . threadDelay++class ( MonadTimer.MonadTimer m+      , MonadMonotonicTime m+      ) => MonadTimer m where++  -- | A register delay function which safe on 32-bit systems.+  registerDelay            :: DiffTime -> m (TVar m Bool)++  -- | A cancellable register delay which is safe on 32-bit systems and efficient+  -- for delays smaller than what `Int` can represent (especially on systems which+  -- support native timer manager).+  --+  registerDelayCancellable :: DiffTime -> m (STM m TimeoutState, m ())++  -- | A timeout function.+  --+  -- TODO: 'IO' instance is not safe on 32-bit systems.+  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 systems where maximum+-- delay expressed in microseconds is around 35 minutes.+--+defaultRegisterDelay :: forall m timeout.+                        ( MonadFork m+                        , MonadMonotonicTime m+                        , MonadSTM m+                        )+                     => NonStandard.NewTimeout m timeout+                     -> NonStandard.AwaitTimeout m timeout+                     -> DiffTime+                     -> m (TVar m Bool)+defaultRegisterDelay newTimeout awaitTimeout d = do+    c <- getMonotonicTime+    v <- atomically $ newTVar False+    tid <- forkIO $ go v c (d `addTime` c)+    labelThread tid "delay-thread"+    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 maxBound >>= atomically . awaitTimeout+      c' <- getMonotonicTime+      go v c' u++    go v c u = do+      t <- newTimeout (diffTimeToMicrosecondsAsInt $ u `diffTime` c)+      atomically $ do+        _ <- awaitTimeout t+        writeTVar v True+++-- | A cancellable register delay which is safe on 32-bit systems and efficient+-- for delays smaller than what `Int` can represent (especially on systems which+-- support native timer manager).+--+defaultRegisterDelayCancellable :: forall m timeout.+                                   ( MonadFork m+                                   , MonadMonotonicTime m+                                   , MonadSTM m+                                   )+                                => NonStandard.NewTimeout    m timeout+                                -> NonStandard.ReadTimeout   m timeout+                                -> NonStandard.CancelTimeout m timeout+                                -> NonStandard.AwaitTimeout  m timeout+                                -> DiffTime+                                -> m (STM m TimeoutState, m ())++defaultRegisterDelayCancellable newTimeout readTimeout cancelTimeout _awaitTimeout d | d <= maxDelay = do+    t <- newTimeout (diffTimeToMicrosecondsAsInt d)+    return (readTimeout t, cancelTimeout t)+  where+    maxDelay :: DiffTime+    maxDelay = microsecondsAsIntToDiffTime maxBound++defaultRegisterDelayCancellable newTimeout _readTimeout _cancelTimeout awaitTimeout d = do+    -- current time+    c <- getMonotonicTime+    -- timeout state+    v <- newTVarIO TimeoutPending+    tid <- forkIO $ go v c (d `addTime` c)+    labelThread tid "delay-thread"+    let cancel = atomically $ readTVar v >>= \case+          TimeoutCancelled -> return ()+          TimeoutFired     -> return ()+          TimeoutPending   -> writeTVar v TimeoutCancelled+    return (readTVar v, cancel)+  where+    maxDelay :: DiffTime+    maxDelay = microsecondsAsIntToDiffTime maxBound++    go :: TVar m TimeoutState+       -> Time+       -> Time+       -> m ()+    go v c u | u `diffTime` c >= maxDelay = do+      t <- newTimeout maxBound+      ts <- atomically $ do+        (readTVar v >>= \case+           a@TimeoutCancelled -> return a+           TimeoutFired       -> error "registerDelayCancellable: invariant violation!"+           TimeoutPending     -> retry)+        `orElse`+        -- the overall timeout is still pending when 't' fires+        (awaitTimeout t $> TimeoutPending)+      case ts of+        TimeoutPending -> do+          c' <- getMonotonicTime+          go v c' u+        _ -> return ()++    go v c u = do+      t <- newTimeout (diffTimeToMicrosecondsAsInt $ u `diffTime` c)+      atomically $ do+        ts <- (readTVar v >>= \case+                 a@TimeoutCancelled -> return a+                 TimeoutFired       -> error "registerDelayCancellable: invariant violation!"+                 TimeoutPending     -> retry)+              `orElse`+              -- the overall timeout fires when 't' fires+              (awaitTimeout t $> TimeoutFired)+        case ts of+          TimeoutFired -> writeTVar v TimeoutFired+          _            -> return ()+++-- | Like 'GHC.Conc.registerDelay' but safe on 32-bit systems.  When the delay+-- is larger than what `Int` can represent it will fork a thread which will+-- write to the returned 'TVar' once the delay has passed.  When the delay is+-- small enough it will use the `MonadTimer`'s `registerDelay` (e.g. for `IO`+-- monad it will use the `GHC`'s `GHC.Conc.registerDelay`).+--+-- TODO: 'timeout' not safe on 32-bit systems.+instance MonadTimer IO where+  registerDelay d+      | d <= maxDelay =+        MonadTimer.registerDelay (diffTimeToMicrosecondsAsInt d)+      | otherwise =+        defaultRegisterDelay+          NonStandard.newTimeout+          NonStandard.awaitTimeout+          d+    where+      maxDelay :: DiffTime+      maxDelay = microsecondsAsIntToDiffTime maxBound++  registerDelayCancellable =+    defaultRegisterDelayCancellable +      NonStandard.newTimeout+      NonStandard.readTimeout+      NonStandard.cancelTimeout+      NonStandard.awaitTimeout++  timeout = MonadTimer.timeout . diffTimeToMicrosecondsAsInt++instance MonadTimer m => MonadTimer (ReaderT r m) where+  registerDelay            = lift . registerDelay+  registerDelayCancellable = fmap (bimap lift lift) . lift . registerDelayCancellable+  timeout d f              = ReaderT $ \r -> timeout d (runReaderT f r)
+ test/Main.hs view
@@ -0,0 +1,15 @@+module Main (main) where++import           Test.Tasty++import qualified Test.MonadTimer++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+  testGroup "io-classes"+    [ Test.MonadTimer.tests+    ]+
+ test/Test/MonadTimer.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE MultiWayIf         #-}+{-# LANGUAGE NumericUnderscores #-}++module Test.MonadTimer (tests) where++import           Control.Monad.Class.MonadTimer.SI+import           GHC.Real++import           Test.QuickCheck+import           Test.Tasty+import           Test.Tasty.QuickCheck (testProperty)++tests :: TestTree+tests =+    testGroup "Control.Monad.Class.MonadTimer"+    [ testProperty "diffTimeToMicroseconds left inverse"+        prop_diffTimeToMicrosecondsAsIntLeftInverse+    , testProperty "diffTimeToMicroseconds right inverse"+        prop_diffTimeToMicrosecondsAsIntRightInverse+    ]++newtype IntDistr = IntDistr Int+    deriving (Show, Eq)++instance Arbitrary IntDistr where+    arbitrary = oneof+      [ IntDistr <$> arbitrary+      , IntDistr . (maxBound - ) . getNonNegative <$> (arbitrary :: Gen (NonNegative Int))+      , IntDistr . (minBound + ) . getNonNegative <$> (arbitrary :: Gen (NonNegative Int))+      ]++    shrink (IntDistr a) = IntDistr `map` shrink a++prop_diffTimeToMicrosecondsAsIntLeftInverse :: IntDistr -> Bool+prop_diffTimeToMicrosecondsAsIntLeftInverse (IntDistr usec) =+    usec == diffTimeToMicrosecondsAsInt (microsecondsAsIntToDiffTime usec)+++newtype DiffTimeDistr = DiffTimeDistr DiffTime+    deriving (Show, Eq)++instance Arbitrary DiffTimeDistr where+    arbitrary = frequency+        [ -- arbitrary DiffTime+          (6, DiffTimeDistr . fromRational <$> arbitrary)+          -- large positive DiffTimes, but smaller than `maxBound :: Int` microseconds+        , (3, DiffTimeDistr+               . (fromRational (toRational (maxBound :: Int) / 1_000_000) - )+               . fromRational+               . getNonNegative+              <$> resize 100 arbitrary+          )+          -- large negative DiffTimes, but larger than `minBound :: Int` microseconds+        , (3, DiffTimeDistr+               . (fromRational (toRational (minBound :: Int) / 1_000_000) + )+               . fromRational+               . getNonNegative+              <$> arbitrary+          )+          -- smaller than 1 :% 1_000_000+        , (1, DiffTimeDistr . fromRational . (/ 1_000_000) <$> resize 1 arbitrary)+        ]++    shrink (DiffTimeDistr a) = (DiffTimeDistr . fromRational) `map` shrink (toRational a)++prop_diffTimeToMicrosecondsAsIntRightInverse :: DiffTimeDistr -> Property+prop_diffTimeToMicrosecondsAsIntRightInverse (DiffTimeDistr a) =+    label (labelRational (toRational a)) $+      abs (toRational a - a') < (1 :% 1_000_000)+      .&&.+      r === microsecondsAsIntToDiffTime (diffTimeToMicrosecondsAsInt r)+++  where+    a' = toRational (microsecondsAsIntToDiffTime (diffTimeToMicrosecondsAsInt a))++    -- 'a' rounded to microseconds+    r :: DiffTime+    r = fromRational (toRational x / 1_000_000)+      where+        x :: Integer+        x = round $ (toRational a * 1_000_000)++    labelRational x =+      if | abs x < 1 :% 1_000_000+         -> "small"+         | abs x > toRational (maxBound :: Int) / 1_000_000 - 100+         -> "large"+         | otherwise+         -> "average"