diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,142 +0,0 @@ -# This Travis job script has been generated by a script via -# -# haskell-ci 'timer-wheel.cabal' -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.3.20190418 -# -language: c -dist: xenial -git: - # whether to recursively clone submodules - submodules: false -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store -before_cache: - - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - - rm -rfv $CABALHOME/packages/head.hackage -matrix: - include: - - compiler: ghc-8.6.5 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} - - compiler: ghc-8.4.4 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}} - - compiler: ghc-8.2.2 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} - - compiler: ghc-8.0.2 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} -before_install: - - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - - HCPKG="$HC-pkg" - - unset CC - - CABAL=/opt/ghc/bin/cabal - - CABALHOME=$HOME/.cabal - - export PATH="$CABALHOME/bin:$PATH" - - TOP=$(pwd) - - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap+markoutput" - - set -o pipefail - - | - echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk - echo 'BEGIN { state = "output"; }' >> .colorful.awk - echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk - echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk - echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk - echo ' if (state == "cabal") {' >> .colorful.awk - echo ' print blue($0)' >> .colorful.awk - echo ' } else {' >> .colorful.awk - echo ' print $0' >> .colorful.awk - echo ' }' >> .colorful.awk - echo '}' >> .colorful.awk - - cat .colorful.awk - - | - color_cabal_output () { - awk -f $TOP/.colorful.awk - } - - echo text | color_cabal_output -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - TEST=--enable-tests - - BENCH=--enable-benchmarks - - GHCHEAD=${GHCHEAD-false} - - rm -f $CABALHOME/config - - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local cabal.project.freeze - - travis_retry ${CABAL} v2-update -v - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo 'packages: "."' >> cabal.project - - | - echo "write-ghc-environment-files: always" >> cabal.project - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(timer-wheel)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - - ${CABAL} v2-freeze -w ${HC} ${TEST} ${BENCH} | color_cabal_output - - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze - - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all | color_cabal_output - - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output -script: - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - # Packaging... - - ${CABAL} v2-sdist all | color_cabal_output - # Unpacking... - - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo 'packages: "timer-wheel-*/*.cabal"' >> cabal.project - - | - echo "write-ghc-environment-files: always" >> cabal.project - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(timer-wheel)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - # Building... - # this builds all libraries and executables (without tests/benchmarks) - - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks all | color_cabal_output - # Building with tests and benchmarks... - # build & run tests, build benchmarks - - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} all | color_cabal_output - # Testing... - - ${CABAL} v2-test -w ${HC} ${TEST} ${BENCH} all | color_cabal_output - # cabal check... - - (cd timer-wheel-* && ${CABAL} -vnormal check) - # haddock... - - ${CABAL} v2-haddock -w ${HC} ${TEST} ${BENCH} all | color_cabal_output - # Building without installed constraints for packages in global-db... - - rm -f cabal.project.local - - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks all | color_cabal_output - -# REGENDATA ["timer-wheel.cabal"] -# EOF diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,16 +5,35 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/) and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.3.0] - 2020-06-18 + +### Added +- Add `with` +- Add support for GHC 8.8, GHC 8.10 + +### Changed +- Change type of `spokes` from `Natural` to `Int` +- Change order of delay and action arguments in `register`, `register_`, `recurring`, and `recurring_` +- Simplify `cancel` to return `True` at most once +- Throw an error if a negative delay is provided to `register`, `register_`, `recurring`, or `recurring_` +- Fix underflow bug that affected recurring timers + +### Removed +- Remove `create`, `destroy` +- Remove `TimerWheelDied` exception. `with` now simply re-throws the exception that the timer wheel thread throws +- Remove `InvalidTimerWheelConfig` exception. `error` is used instead +- Remove support for GHC < 8.6 + ## [0.2.0.1] - 2019-05-19 ### Changed -- Swapped out `ghc-prim` and `primitive` for `vector` +- Swap out `ghc-prim` and `primitive` for `vector` ## [0.2.0] - 2019-02-03 ### Added -- `destroy` function, for reaping the background thread -- `recurring_` function +- Add `destroy` function, for reaping the background thread +- Add `recurring_` function ### Changed - If the timer wheel reaper thread crashes, it will propagate the exception to diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# `timer-wheel` + +[![GitHub CI](https://github.com/mitchellwrosen/timer-wheel/workflows/CI/badge.svg)](https://github.com/mitchellwrosen/timer-wheel/actions) +[![Hackage](https://img.shields.io/hackage/v/timer-wheel.svg)](https://hackage.haskell.org/package/timer-wheel) +[![Stackage LTS](https://stackage.org/package/timer-wheel/badge/lts)](https://www.stackage.org/lts/package/timer-wheel) +[![Stackage Nightly](https://stackage.org/package/timer-wheel/badge/nightly)](https://www.stackage.org/nightly/package/timer-wheel) +[![Dependencies](https://img.shields.io/hackage-deps/v/timer-wheel)](https://packdeps.haskellers.com/reverse/timer-wheel) diff --git a/cabal.project b/cabal.project new file mode 100644 --- /dev/null +++ b/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/src/Data/TimerWheel.hs b/src/Data/TimerWheel.hs --- a/src/Data/TimerWheel.hs +++ b/src/Data/TimerWheel.hs @@ -1,261 +1,263 @@ +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StrictData #-} {-# OPTIONS_GHC -funbox-strict-fields #-} +-- | A simple, hashed timer wheel. module Data.TimerWheel ( -- * Timer wheel - TimerWheel - , create - , destroy - , Config(..) - , register - , register_ - , recurring - , recurring_ - , InvalidTimerWheelConfig(..) - , TimerWheelDied(..) - ) where - -import Supply (Supply) -import Wheel (Wheel) - -import qualified Supply -import qualified Wheel + TimerWheel, + with, + Config (..), + register, + register_, + recurring, + recurring_, + ) +where -import Control.Concurrent (ThreadId, forkIOWithUnmask, killThread, myThreadId, - throwTo) -import Control.Exception (AsyncException(ThreadKilled), - Exception(fromException, toException), SomeException, - asyncExceptionFromException, - asyncExceptionToException, catch, throwIO) -import Control.Monad (join, void, when) -import Data.Coerce (coerce) -import Data.Fixed (E6, Fixed(MkFixed)) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.Word (Word64) -import GHC.Generics (Generic) -import Numeric.Natural (Natural) +import Control.Concurrent +import Control.Exception +import Control.Monad (join, void) +import Data.Bool (bool) +import Data.Fixed (E6, Fixed) +import Data.Function (fix) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.TimerWheel.Internal.Config (Config) +import qualified Data.TimerWheel.Internal.Config as Config +import Data.TimerWheel.Internal.Micros (Micros (Micros)) +import qualified Data.TimerWheel.Internal.Micros as Micros +import Data.TimerWheel.Internal.Supply (Supply) +import qualified Data.TimerWheel.Internal.Supply as Supply +import Data.TimerWheel.Internal.Wheel (Wheel) +import qualified Data.TimerWheel.Internal.Wheel as Wheel --- | A 'TimerWheel' is a vector-of-collections-of timers to fire. It is --- configured with a /spoke count/ and /resolution/. Timers may be scheduled --- arbitrarily far in the future. A timeout thread is spawned to step through --- the timer wheel and fire expired timers at regular intervals. +-- | A timer wheel is a vector-of-collections-of timers to fire. It is configured with a /spoke count/ and /resolution/. +-- Timers may be scheduled arbitrarily far in the future. A timeout thread is spawned to step through the timer wheel +-- and fire expired timers at regular intervals. -- -- * The /spoke count/ determines the size of the timer vector. -- --- * A __larger spoke count__ will result in __less insert contention__ at --- each spoke and will require __more memory__ to store the timer wheel. +-- * A __larger spoke count__ will result in __less insert contention__ at each spoke and will require +-- __more memory__ to store the timer wheel. -- --- * A __smaller spoke count__ will result in __more insert contention__ at --- each spoke and will require __less memory__ to store the timer wheel. +-- * A __smaller spoke count__ will result in __more insert contention__ at each spoke and will require +-- __less memory__ to store the timer wheel. -- --- * The /resolution/ determines both the duration of time that each spoke --- corresponds to, and how often the timeout thread wakes. For example, with a --- resolution of __@1s@__, a timer that expires at __@2.5s@__ will not fire --- until the timeout thread wakes at __@3s@__. +-- * The /resolution/ determines both the duration of time that each spoke corresponds to, and how often the timeout +-- thread wakes. For example, with a resolution of __@1s@__, a timer that expires at __@2.5s@__ will not fire until +-- the timeout thread wakes at __@3s@__. -- --- * A __larger resolution__ will result in __more insert contention__ at --- each spoke, __less accurate__ timers, and will require --- __fewer wakeups__ by the timeout thread. +-- * A __larger resolution__ will result in __more insert contention__ at each spoke, __less accurate__ timers, and +-- will require __fewer wakeups__ by the timeout thread. -- --- * A __smaller resolution__ will result in __less insert contention__ at --- each spoke, __more accurate__ timers, and will require __more wakeups__ --- by the timeout thread. +-- * A __smaller resolution__ will result in __less insert contention__ at each spoke, __more accurate__ timers, and +-- will require __more wakeups__ by the timeout thread. -- -- * The timeout thread has some important properties: -- --- * There is only one, and it fires expired timers synchronously. If your --- timer actions execute quicky, 'register' them directly. Otherwise, --- consider registering an action that enqueues the /real/ action to be --- performed on a job queue. +-- * There is only one, and it fires expired timers synchronously. If your timer actions execute quicky, 'register' +-- them directly. Otherwise, consider registering an action that enqueues the /real/ action to be performed on a +-- job queue. -- --- * Synchronous exceptions thrown by enqueued @IO@ actions will bring the --- thread down, which will cause it to asynchronously throw a --- 'TimerWheelDied' exception to the thread that 'create'd it. If you want --- to catch exceptions and log them, for example, you will have to bake --- this into the registered actions yourself. +-- * Synchronous exceptions thrown by enqueued @IO@ actions will bring the thread down, and the exception will be +-- propagated to the thread that created the timer wheel. If you want to catch exceptions and log them, for +-- example, you will have to bake this into the registered actions yourself. -- --- Below is a depiction of a timer wheel with @6@ timers inserted across @8@ --- spokes, and a resolution of @0.1s@. +-- As an example, below is a depiction of a timer wheel with @6@ timers inserted across @8@ spokes, and a resolution of +-- @.1s@. It depicts a cursor at @.3s@, which indicates where the timeout thread currently is. -- -- @ --- 0s .1s .2s .3s .4s .5s .6s .7s .8s --- +-----+-----+-----+-----+-----+-----+-----+-----+ --- | | A | | B,C | D | | | E,F | --- +-----+-----+-----+-----+-----+-----+-----+-----+ +-- 0 .1 .2 .3 .4 .5 .6 .7 +-- ┌───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┐ +-- │ │ A⁰ │ │ B¹ C⁰ │ D⁰ │ │ │ E² F⁰ │ +-- └───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┘ +-- ↑ -- @ -data TimerWheel = TimerWheel - { wheelSupply :: !Supply - -- ^ A supply of unique ints. - , wheelWheel :: !Wheel - -- ^ The array of collections of timers. - , wheelThread :: !ThreadId +-- +-- After @.1s@, the timeout thread will advance to the next spoke and process all of the timers it passed over. In +-- this case, __C__ will fire, and __B__ will be put back with its count decremented to @0@. This is how the timer wheel +-- can schedule a timer to fire arbitrarily far in the future: its count is simply the number of times its delay wraps +-- the entire duration of the timer wheel. +-- +-- @ +-- 0 .1 .2 .3 .4 .5 .6 .7 +-- ┌───────┬───────┬───────┬───────┬───────┬───────┬───────┬───────┐ +-- │ │ A⁰ │ │ B⁰ │ D⁰ │ │ │ E² F⁰ │ +-- └───────┴───────┴───────┴───────┴───────┴───────┴───────┴───────┘ +-- ↑ +-- @ +data TimerWheel = TimerWheel + { -- | A supply of unique ints. + supply :: Supply, + -- | The array of collections of timers. + wheel :: Wheel, + thread :: ThreadId } -data Config - = Config - { spokes :: !Natural -- ^ Spoke count. - , resolution :: !(Fixed E6) -- ^ Resolution, in seconds. - } deriving (Generic, Show) - -- | The timeout thread died. newtype TimerWheelDied = TimerWheelDied SomeException - deriving (Show) + deriving stock (Show) instance Exception TimerWheelDied where toException = asyncExceptionToException fromException = asyncExceptionFromException --- | The timer wheel config was invalid. --- --- * @spokes@ must be positive, and less than @maxBound@ of @Int@. --- * @resolution@ must be positive. -data InvalidTimerWheelConfig - = InvalidTimerWheelConfig !Config - deriving (Show) - -instance Exception InvalidTimerWheelConfig - --- | Create a timer wheel. +-- | Perform an action with a timer wheel. -- --- /Throws./ If the config is invalid, throws 'InvalidTimerWheelConfig'. +-- /Throws./ -- --- /Throws./ If the timeout thread dies, asynchronously throws 'TimerWheelDied' --- to the thread that called 'create'. -create :: Config -> IO TimerWheel -create config@(Config { spokes, resolution }) = do - when (invalidConfig config) - (throwIO (InvalidTimerWheelConfig config)) - - wheel :: Wheel <- - Wheel.create - (fromIntegral spokes) - (fromIntegral (coerce resolution :: Integer)) - - supply :: Supply <- - Supply.new - - thread <- myThreadId +-- * Calls 'error' if the config is invalid +-- * Throws the exception the given action throws, if any +-- * Throws the exception the timer wheel thread throws, if any +with :: Config -> (TimerWheel -> IO a) -> IO a +with config action = + case validateConfig config of + () -> _with config action - reaperThread <- - forkIOWithUnmask $ \unmask -> - unmask (Wheel.reap wheel) - `catch` \e -> +_with :: Config -> (TimerWheel -> IO a) -> IO a +_with config action = do + wheel <- Wheel.create (Config.spokes config) (Micros.fromFixed (Config.resolution config)) + supply <- Supply.new + parentThread <- myThreadId + uninterruptibleMask \restore -> do + thread <- + forkIOWithUnmask $ \unmask -> + unmask (Wheel.reap wheel) `catch` \e -> case fromException e of Just ThreadKilled -> pure () - _ -> throwTo thread (TimerWheelDied e) - - pure TimerWheel - { wheelSupply = supply - , wheelWheel = wheel - , wheelThread = reaperThread - } - --- | Tear down a timer wheel by killing the timeout thread. -destroy :: TimerWheel -> IO () -destroy wheel = - killThread (wheelThread wheel) + _ -> throwTo parentThread (TimerWheelDied e) + let cleanup = killThread thread + let handler :: SomeException -> IO void + handler ex = do + cleanup + case fromException ex of + Just (TimerWheelDied ex') -> throwIO ex' + _ -> throwIO ex + result <- restore (action TimerWheel {supply, wheel, thread}) `catch` handler + cleanup + pure result -invalidConfig :: Config -> Bool -invalidConfig Config { spokes, resolution } = - or - [ spokes == 0 - , spokes > fromIntegral (maxBound :: Int) - , resolution <= 0 - ] +validateConfig :: Config -> () +validateConfig config + | invalid = error ("[timer-wheel] invalid config: " ++ show config) + | otherwise = () + where + invalid :: Bool + invalid = + Config.spokes config <= 0 || Config.resolution config <= 0 --- | @register wheel action delay@ registers an action __@action@__ in timer --- wheel __@wheel@__ to fire after __@delay@__ seconds. +-- | @register wheel delay action@ registers an action __@action@__ in timer wheel __@wheel@__ to fire after __@delay@__ +-- seconds. -- --- Returns an action that, when called, attempts to cancel the timer, and --- returns whether or not it was successful (@False@ means the timer has already --- fired). +-- Returns an action that, when called, attempts to cancel the timer, and returns whether or not it was successful +-- (@False@ means the timer has already fired, or was already cancelled). -- --- Subsequent calls to the cancel action have no effect, and continue to return --- whatever the first result was. +-- /Throws/. +-- +-- * Calls 'error' if the given number of seconds is negative. register :: - TimerWheel -- ^ - -> IO () -- ^ Action - -> Fixed E6 -- ^ Delay, in seconds - -> IO (IO Bool) -register wheel action (MkFixed (fromIntegral -> delay)) = - _register wheel action delay + -- | + TimerWheel -> + -- | Delay, in seconds + Fixed E6 -> + -- | Action + IO () -> + IO (IO Bool) +register wheel (Micros.fromSeconds -> delay) = + _register wheel delay -- | Like 'register', but for when you don't intend to cancel the timer. +-- +-- /Throws/. +-- +-- * Calls 'error' if the given number of seconds is negative. register_ :: - TimerWheel -- ^ - -> IO () -- ^ Action - -> Fixed E6 -- ^ Delay, in seconds - -> IO () -register_ wheel action delay = - void (register wheel action delay) - -_register :: TimerWheel -> IO () -> Word64 -> IO (IO Bool) -_register wheel action delay = do - key <- Supply.next (wheelSupply wheel) - Wheel.insert (wheelWheel wheel) key action delay + -- | + TimerWheel -> + -- | Delay, in seconds + Fixed E6 -> + -- | Action + IO () -> + IO () +register_ wheel delay action = + void (register wheel delay action) -_register_ :: TimerWheel -> IO () -> Word64 -> IO () -_register_ wheel action delay = - void (_register wheel action delay) +_register :: TimerWheel -> Micros -> IO () -> IO (IO Bool) +_register TimerWheel {supply, wheel} delay action = do + key <- Supply.next supply + Wheel.insert wheel key delay action --- | @recurring wheel action delay@ registers an action __@action@__ in timer --- wheel __@wheel@__ to fire every __@delay@__ seconds. +-- | @recurring wheel action delay@ registers an action __@action@__ in timer wheel __@wheel@__ to fire every +-- __@delay@__ seconds (or every /resolution/ seconds, whichever is smaller). -- -- Returns an action that, when called, cancels the recurring timer. +-- +-- /Throws/. +-- +-- * Calls 'error' if the given number of seconds is negative. recurring :: - TimerWheel - -> IO () -- ^ Action - -> Fixed E6 -- ^ Delay, in seconds - -> IO (IO ()) -recurring wheel action (MkFixed (fromIntegral -> delay)) = mdo - let - doAction :: IO () - doAction = do - -- Re-register one bucket early, to account for the fact that timers are - -- expired at the *end* of a bucket. - -- - -- +---+---+---+---+ - -- { A | | | } - -- +---+---+---+---+ - -- | - -- The reaper thread fires 'A' approximately here, so if it's meant - -- to be repeated every two buckets, and we just re-register it at - -- this time, three buckets will pass before it's run again. So, we - -- act as if it's still "one bucket ago" at the moment we re-register - -- it. - writeIORef cancelRef =<< - _register - wheel - doAction - (delay - Wheel.resolution (wheelWheel wheel)) - action - - cancel :: IO Bool <- - _register wheel doAction delay - - cancelRef :: IORef (IO Bool) <- - newIORef cancel - + TimerWheel -> + -- | Delay, in seconds + Fixed E6 -> + -- | Action + IO () -> + IO (IO ()) +recurring wheel (Micros.fromSeconds -> delay) action = mdo + let doAction :: IO () + doAction = do + writeIORef cancelRef =<< _reregister wheel delay doAction + action + cancel <- _register wheel delay doAction + cancelRef <- newIORef cancel pure (untilTrue (join (readIORef cancelRef))) + where + -- Repeat an IO action until it returns 'True'. + untilTrue :: IO Bool -> IO () + untilTrue m = + fix \again -> + m >>= bool again (pure ()) -- | Like 'recurring', but for when you don't intend to cancel the timer. +-- +-- /Throws/. +-- +-- * Calls 'error' if the given number of seconds is negative. recurring_ :: - TimerWheel - -> IO () -- ^ Action - -> Fixed E6 -- ^ Delay, in seconds - -> IO () -recurring_ wheel action (MkFixed (fromIntegral -> delay)) = - _register_ wheel doAction delay - + TimerWheel -> + -- | Delay, in seconds + Fixed E6 -> + -- | Action + IO () -> + IO () +recurring_ wheel (Micros.fromSeconds -> delay) action = + void (_register wheel delay doAction) where doAction :: IO () doAction = do - _register_ wheel doAction (delay - Wheel.resolution (wheelWheel wheel)) + _ <- _reregister wheel delay doAction action --- Repeat an IO action until it returns 'True'. -untilTrue :: IO Bool -> IO () -untilTrue action = - action >>= \case - True -> pure () - False -> untilTrue action +-- Re-register one bucket early, to account for the fact that timers are +-- expired at the *end* of a bucket. +-- +-- +---+---+---+---+ +-- { A | | | } +-- +---+---+---+---+ +-- | +-- The reaper thread fires 'A' approximately here, so if it's meant +-- to be repeated every two buckets, and we just re-register it at +-- this time, three buckets will pass before it's run again. So, we +-- act as if it's still "one bucket ago" at the moment we re-register +-- it. +_reregister :: TimerWheel -> Micros -> IO () -> IO (IO Bool) +_reregister wheel delay = + _register wheel (if reso > delay then Micros 0 else delay `Micros.minus` reso) + where + reso :: Micros + reso = + resolution wheel + +resolution :: TimerWheel -> Micros +resolution = + Wheel.resolution . wheel diff --git a/src/Data/TimerWheel/Internal/Config.hs b/src/Data/TimerWheel/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimerWheel/Internal/Config.hs @@ -0,0 +1,19 @@ +module Data.TimerWheel.Internal.Config + ( Config (..), + ) +where + +import Data.Fixed (E6, Fixed) +import GHC.Generics (Generic) + +-- | Timer wheel config. +-- +-- * @spokes@ must be ∈ @(0, maxBound]@ +-- * @resolution@ must ∈ @(0, ∞]@ +data Config = Config + { -- | Spoke count. + spokes :: Int, + -- | Resolution, in seconds. + resolution :: Fixed E6 + } + deriving stock (Generic, Show) diff --git a/src/Data/TimerWheel/Internal/Entries.hs b/src/Data/TimerWheel/Internal/Entries.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimerWheel/Internal/Entries.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TypeApplications #-} + +module Data.TimerWheel.Internal.Entries + ( Entries, + empty, + Data.TimerWheel.Internal.Entries.null, + size, + insert, + delete, + partition, + ) +where + +import Data.Coerce +import Data.IntPSQ (IntPSQ) +import qualified Data.IntPSQ as IntPSQ +import Data.Word (Word64) + +newtype Entries + = Entries (IntPSQ Word64 (IO ())) + +-- | An empty collection. +empty :: Entries +empty = + Entries IntPSQ.empty +{-# INLINEABLE empty #-} + +null :: Entries -> Bool +null = + coerce (IntPSQ.null @Word64 @(IO ())) +{-# INLINEABLE null #-} + +-- | The number of timers in the collection. +size :: Entries -> Int +size = + coerce (IntPSQ.size @Word64 @(IO ())) +{-# INLINEABLE size #-} + +-- | @insert i n m x@ inserts callback @m@ into collection @x@ with unique +-- identifier @i@ and "count" @n@. The +insert :: Int -> Word64 -> IO () -> Entries -> Entries +insert i n m = + coerce (IntPSQ.unsafeInsertNew i n m) +{-# INLINEABLE insert #-} + +-- | Delete a timer by id. Returns 'Nothing' if the timer was not found. +delete :: Int -> Entries -> Maybe Entries +delete = + coerce delete_ +{-# INLINEABLE delete #-} + +delete_ :: Int -> IntPSQ Word64 (IO ()) -> Maybe (IntPSQ Word64 (IO ())) +delete_ i xs = + (\(_, _, ys) -> ys) <$> IntPSQ.deleteView i xs + +-- | Extract expired timers. +partition :: Entries -> ([IO ()], Entries) +partition (Entries entries) = + case IntPSQ.atMostView 0 entries of + (expired, alive) -> + (map f expired, Entries (IntPSQ.unsafeMapMonotonic g alive)) + where + f :: (Int, Word64, IO ()) -> IO () + f (_, _, m) = + m + g :: Int -> Word64 -> IO () -> (Word64, IO ()) + g _ n m = + (n -1, m) +{-# INLINEABLE partition #-} diff --git a/src/Data/TimerWheel/Internal/Micros.hs b/src/Data/TimerWheel/Internal/Micros.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimerWheel/Internal/Micros.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TypeApplications #-} + +module Data.TimerWheel.Internal.Micros + ( Micros (..), + fromFixed, + fromSeconds, + Data.TimerWheel.Internal.Micros.div, + minus, + scale, + sleep, + ) +where + +import Control.Concurrent (threadDelay) +import Data.Coerce +import Data.Fixed +import Data.Word + +newtype Micros = Micros {unMicros :: Word64} + deriving stock (Eq, Ord) + +-- | Precondition: input is >= 0 +fromFixed :: Fixed E6 -> Micros +fromFixed = + coerce @(Integer -> Word64) fromIntegral + +fromSeconds :: Fixed E6 -> Micros +fromSeconds seconds@(MkFixed micros) + | micros < 0 = error ("[timer-wheel] invalid seconds: " ++ show seconds) + | otherwise = Micros (fromIntegral micros) + +div :: Micros -> Micros -> Micros +div = + coerce (Prelude.div @Word64) + +minus :: Micros -> Micros -> Micros +minus = + coerce ((-) @Word64) + +scale :: Int -> Micros -> Micros +scale n (Micros w) = + Micros (fromIntegral n * w) + +sleep :: Micros -> IO () +sleep (Micros micros) = + threadDelay (fromIntegral micros) diff --git a/src/Data/TimerWheel/Internal/Supply.hs b/src/Data/TimerWheel/Internal/Supply.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimerWheel/Internal/Supply.hs @@ -0,0 +1,21 @@ +module Data.TimerWheel.Internal.Supply + ( Supply, + new, + next, + ) +where + +import Data.Atomics.Counter (AtomicCounter, incrCounter, newCounter) +import Data.Coerce (coerce) + +newtype Supply + = Supply AtomicCounter + +new :: IO Supply +new = + coerce (newCounter 0) + +next :: Supply -> IO Int +next = + coerce (incrCounter 1) +{-# INLINE next #-} diff --git a/src/Data/TimerWheel/Internal/Timestamp.hs b/src/Data/TimerWheel/Internal/Timestamp.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimerWheel/Internal/Timestamp.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TypeApplications #-} + +module Data.TimerWheel.Internal.Timestamp + ( Timestamp (..), + epoch, + minus, + now, + plus, + Data.TimerWheel.Internal.Timestamp.rem, + ) +where + +import Data.Coerce (coerce) +import Data.TimerWheel.Internal.Micros (Micros (..)) +import Data.Word (Word64) +import GHC.Clock (getMonotonicTimeNSec) + +newtype Timestamp + = Timestamp Word64 + deriving stock (Eq, Ord) + +-- Which epoch does this correspond to, if they are measured in chunks of the given number of milliseconds? +epoch :: Micros -> Timestamp -> Word64 +epoch (Micros chunk) (Timestamp timestamp) = + timestamp `div` chunk + +minus :: Timestamp -> Timestamp -> Micros +minus = + coerce ((-) @Word64) + +now :: IO Timestamp +now = do + nanos <- getMonotonicTimeNSec + pure (Timestamp (nanos `div` 1000)) + +plus :: Timestamp -> Micros -> Timestamp +plus = + coerce ((+) @Word64) + +rem :: Timestamp -> Micros -> Micros +rem = + coerce (Prelude.rem @Word64) diff --git a/src/Data/TimerWheel/Internal/Wheel.hs b/src/Data/TimerWheel/Internal/Wheel.hs new file mode 100644 --- /dev/null +++ b/src/Data/TimerWheel/Internal/Wheel.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE StrictData #-} + +module Data.TimerWheel.Internal.Wheel + ( Wheel (resolution), + create, + lenMicros, + insert, + reap, + ) +where + +import Control.Monad (join, when) +import Data.IORef +import Data.TimerWheel.Internal.Entries (Entries) +import qualified Data.TimerWheel.Internal.Entries as Entries +import Data.TimerWheel.Internal.Micros (Micros (..)) +import qualified Data.TimerWheel.Internal.Micros as Micros +import Data.TimerWheel.Internal.Timestamp (Timestamp) +import qualified Data.TimerWheel.Internal.Timestamp as Timestamp +import Data.Vector (Vector) +import qualified Data.Vector as Vector + +data Wheel = Wheel + { buckets :: Vector (IORef Entries), + resolution :: Micros + } + +create :: Int -> Micros -> IO Wheel +create spokes resolution = do + buckets <- Vector.replicateM spokes (newIORef Entries.empty) + pure Wheel {buckets, resolution} + +numSpokes :: Wheel -> Int +numSpokes wheel = + Vector.length (buckets wheel) + +lenMicros :: Wheel -> Micros +lenMicros wheel = + Micros.scale (numSpokes wheel) (resolution wheel) + +bucket :: Wheel -> Timestamp -> IORef Entries +bucket wheel timestamp = + Vector.unsafeIndex (buckets wheel) (index wheel timestamp) + +index :: Wheel -> Timestamp -> Int +index wheel@Wheel {resolution} timestamp = + fromIntegral (Timestamp.epoch resolution timestamp) `rem` numSpokes wheel + +insert :: Wheel -> Int -> Micros -> IO () -> IO (IO Bool) +insert wheel key delay action = do + bucketRef <- do + now <- Timestamp.now + pure (bucket wheel (now `Timestamp.plus` delay)) + + atomicModifyIORef' bucketRef (\entries -> (insertEntry entries, ())) + + pure do + atomicModifyIORef' bucketRef \entries -> + case Entries.delete key entries of + Nothing -> (entries, False) + Just entries' -> (entries', True) + where + insertEntry :: Entries -> Entries + insertEntry = + Entries.insert key (unMicros (delay `Micros.div` lenMicros wheel)) action + +reap :: Wheel -> IO () +reap wheel@Wheel {buckets, resolution} = do + now <- Timestamp.now + let remainingBucketMicros = resolution `Micros.minus` (now `Timestamp.rem` resolution) + Micros.sleep remainingBucketMicros + loop (now `Timestamp.plus` remainingBucketMicros `Timestamp.plus` resolution) (index wheel now) + where + loop :: Timestamp -> Int -> IO () + loop nextTime i = do + join (atomicModifyIORef' (Vector.unsafeIndex buckets i) expire) + afterTime <- Timestamp.now + when (afterTime < nextTime) (Micros.sleep (nextTime `Timestamp.minus` afterTime)) + loop (nextTime `Timestamp.plus` resolution) ((i + 1) `rem` numSpokes wheel) + expire :: Entries -> (Entries, IO ()) + expire entries + | Entries.null entries = (entries, pure ()) + | otherwise = (alive, sequence_ expired) + where + (expired, alive) = Entries.partition entries diff --git a/src/Entries.hs b/src/Entries.hs deleted file mode 100644 --- a/src/Entries.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# language LambdaCase #-} -{-# language TypeApplications #-} - -module Entries - ( Entries - , empty - , Entries.null - , size - , insert - , delete - , partition - ) where - -import Data.Coerce -import Data.IntPSQ (IntPSQ) -import Data.Word (Word64) - -import qualified Data.IntPSQ as IntPSQ - -newtype Entries - = Entries (IntPSQ Word64 (IO ())) - --- | An empty collection. -empty :: Entries -empty = - Entries IntPSQ.empty -{-# INLINABLE empty #-} - -null :: Entries -> Bool -null = - coerce (IntPSQ.null @Word64 @(IO ())) -{-# INLINABLE null #-} - --- | The number of timers in the collection. -size :: Entries -> Int -size = - coerce (IntPSQ.size @Word64 @(IO ())) -{-# INLINABLE size #-} - --- | @insert i n m x@ inserts callback @m@ into collection @x@ with unique --- identifier @i@ and "count" @n@. The -insert :: Int -> Word64 -> IO () -> Entries -> Entries -insert i n m = - coerce (IntPSQ.unsafeInsertNew i n m) -{-# INLINABLE insert #-} - --- | Delete a timer by id. Returns 'Nothing' if the timer was not found. -delete :: Int -> Entries -> Maybe Entries -delete = - coerce delete_ -{-# INLINABLE delete #-} - -delete_ :: Int -> IntPSQ Word64 (IO ()) -> Maybe (IntPSQ Word64 (IO ())) -delete_ i xs = - (\(_, _, ys) -> ys) <$> IntPSQ.deleteView i xs - --- | Extract expired timers. -partition :: Entries -> ([IO ()], Entries) -partition (Entries entries) = - case IntPSQ.atMostView 0 entries of - (expired, alive) -> - (map f expired, Entries (IntPSQ.unsafeMapMonotonic g alive)) - where - f :: (Int, Word64, IO ()) -> IO () - f (_, _, m) = - m - - g :: Int -> Word64 -> IO () -> (Word64, IO ()) - g _ n m = - (n-1, m) -{-# INLINABLE partition #-} diff --git a/src/Supply.hs b/src/Supply.hs deleted file mode 100644 --- a/src/Supply.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Supply - ( Supply - , new - , next - ) where - -import Data.Atomics.Counter (AtomicCounter, incrCounter, newCounter) - -newtype Supply - = Supply AtomicCounter - -new :: IO Supply -new = - Supply <$> newCounter 0 - -next :: Supply -> IO Int -next (Supply counter) = - incrCounter 1 counter -{-# INLINE next #-} diff --git a/src/Wheel.hs b/src/Wheel.hs deleted file mode 100644 --- a/src/Wheel.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Wheel - ( Wheel(resolution) - , create - , lenMicros - , insert - , reap - ) where - -import Entries (Entries) - -import qualified Entries as Entries - -import Control.Concurrent (threadDelay) -import Control.Concurrent.MVar -import Control.Monad (join, when) -import Data.IORef -import Data.Vector (Vector) -import Data.Word (Word64) -import System.IO.Unsafe (unsafeInterleaveIO) - -#if MIN_VERSION_base(4,11,0) -import GHC.Clock (getMonotonicTimeNSec) -#else -import System.Clock (Clock(Monotonic), getTime, toNanoSecs) -#endif - -import qualified Data.Vector as Vector - - - -data Wheel - = Wheel - { buckets :: !(Vector (IORef Entries)) - , resolution :: !Word64 -- micros - } - -create :: - Int - -> Word64 - -> IO Wheel -create spokes resolution = do - buckets :: Vector (IORef Entries) <- - Vector.replicateM spokes (newIORef Entries.empty) - - pure Wheel - { buckets = buckets - , resolution = resolution - } - -numSpokes :: Wheel -> Int -numSpokes wheel = - Vector.length (buckets wheel) - -lenMicros :: Wheel -> Word64 -lenMicros wheel = - fromIntegral (numSpokes wheel) * resolution wheel - -bucket :: Wheel -> Word64 -> IORef Entries -bucket wheel time = - Vector.unsafeIndex - (buckets wheel) - (index wheel time) - -index :: Wheel -> Word64 -> Int -index wheel@Wheel{resolution} time = - fromIntegral (time `div` resolution) `rem` numSpokes wheel - -insert :: - Wheel - -> Int - -> IO () - -> Word64 - -> IO (IO Bool) -insert wheel key action delay = do - now :: Word64 <- - getMonotonicMicros - - let - time :: Word64 - time = - now + delay - - let - count :: Word64 - count = - delay `div` lenMicros wheel - - let - bucketRef :: IORef Entries - bucketRef = - bucket wheel time - - atomicModifyIORef' bucketRef - (\entries -> - (Entries.insert key count action entries, ())) - - canceledVar :: MVar (Maybe Bool) <- - unsafeInterleaveIO (newMVar Nothing) - - pure $ do - modifyMVar canceledVar $ \result -> do - canceled <- - maybe - (atomicModifyIORef' bucketRef - (\entries -> - maybe - (entries, False) - (, True) - (Entries.delete key entries))) - pure - result - pure (Just canceled, canceled) - - -reap :: Wheel -> IO () -reap wheel@Wheel{buckets, resolution} = do - now :: Word64 <- - getMonotonicMicros - - let - -- How far in time are we into the very first bucket? Sleep until it's over. - elapsedBucketMicros :: Word64 - elapsedBucketMicros = - now `rem` resolution - - let - remainingBucketMicros :: Word64 - remainingBucketMicros = - resolution - elapsedBucketMicros - - threadDelay (fromIntegral remainingBucketMicros) - - loop - (now + remainingBucketMicros + resolution) - (index wheel now) - - where - loop :: Word64 -> Int -> IO () - loop nextTime i = do - join - (atomicModifyIORef' (Vector.unsafeIndex buckets i) - (\entries -> - if Entries.null entries - then - (entries, pure ()) - else - case Entries.partition entries of - (expired, alive) -> - (alive, sequence_ expired))) - - afterTime :: Word64 <- - getMonotonicMicros - - when (afterTime < nextTime) $ - (threadDelay (fromIntegral (nextTime - afterTime))) - - loop (nextTime + resolution) ((i+1) `rem` numSpokes wheel) - -getMonotonicMicros :: IO Word64 -getMonotonicMicros = -#if MIN_VERSION_base(4,11,0) - (`div` 1000) <$> getMonotonicTimeNSec -#else - ((`div` 1000) . fromIntegral . toNanoSecs <$> getTime Monotonic) -#endif diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,83 +1,77 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE BlockArguments, DeriveAnyClass, DerivingStrategies, FlexibleInstances, MultiParamTypeClasses #-} import Control.Concurrent import Control.Exception import Control.Monad -import Data.Fixed (E6, Fixed(..)) import Data.IORef +import Data.Maybe (isJust) import Data.TimerWheel -import System.Random +import System.Mem (performGC) +import System.Mem.Weak (deRefWeak) main :: IO () main = do do putStrLn "Timer wheel runs scheduled actions" - let n = 10000 - ref <- newIORef (0::Int) - wheel <- create Config { spokes = 4, resolution = 0.25 } - putStrLn ("> Inserting " ++ show n ++ " timers") - replicateM_ n $ do - delay <- randomRIO (0, 4*1000*1000) - register_ wheel (modifyIORef' ref (+1)) (MkFixed delay) - putStrLn "> Sleeping for 5s" - sleep 5 - readIORef ref `is` n - destroy wheel + with Config { spokes = 4, resolution = 0.05 } \wheel -> do + var <- newEmptyMVar + let n = 1000 + replicateM_ n (register_ wheel 0 (putMVar var ())) + replicateM_ n (takeMVar var) do putStrLn "Timers can be canceled" - let n = 10000 - ref <- newIORef (0::Int) - wheel <- create Config { spokes = 4, resolution = 0.25 } - putStrLn ("> Inserting " ++ show n ++ " timers") - cancels <- - replicateM n $ do - delay <- randomRIO (0, 4*1000*1000) - register wheel (modifyIORef' ref (+1)) (MkFixed delay) - putStrLn "> Sleeping for 2s" - sleep 2 - putStrLn "> Canceling all timers" - successes <- sequence cancels - readIORef ref `is` (n - length (filter id successes)) - destroy wheel + var <- newEmptyMVar + with Config { spokes = 4, resolution = 0.05 } \wheel -> do + let n = 1000 + cancels <- replicateM n (register wheel 0 (putMVar var ())) + successes <- sequence (take (n `div` 2) cancels) + replicateM_ (n - length (filter id successes)) (takeMVar var) do - putStrLn "Re-calling a successful cancel works" - wheel <- create Config { spokes = 4, resolution = 0.25 } - cancel <- register wheel (pure ()) 1 - cancel `is` True - cancel `is` True - destroy wheel + putStrLn "Successful `cancel` returns True (then False)" + with Config { spokes = 4, resolution = 0.05 } \wheel -> do + cancel <- register wheel 1 (pure ()) + cancel `is` True + cancel `is` False do - putStrLn "Re-calling a failed cancel works" - wheel <- create Config { spokes = 4, resolution = 0.25 } - cancel <- register wheel (pure ()) 0.5 - sleep 1 - cancel `is` False - cancel `is` False - destroy wheel + putStrLn "Unsuccessful `cancel` returns False" + with Config { spokes = 4, resolution = 0.05 } \wheel -> do + var <- newEmptyMVar + cancel <- register wheel 0 (putMVar var ()) + takeMVar var + cancel `is` False do putStrLn "Recurring timers work" - ref <- newIORef (0::Int) - wheel <- create Config { spokes = 4, resolution = 0.05 } - recurring_ wheel (modifyIORef' ref (+1)) 0.15 - sleep 1 - readIORef ref `is` (6::Int) - destroy wheel + with Config { spokes = 4, resolution = 0.05 } \wheel -> do + canary <- newIORef () -- kept alive only by timer + weakCanary <- mkWeakIORef canary (pure ()) + var <- newEmptyMVar + cancel <- recurring wheel 0 (readIORef canary >> putMVar var ()) + replicateM_ 2 (takeMVar var) + cancel -- should drop reference canary after a GC + performGC + (isJust <$> deRefWeak weakCanary) `is` False do - putStrLn "Recurring timers can be canceled" - ref <- newIORef (0::Int) - wheel <- create Config { spokes = 4, resolution = 0.05 } - cancel <- recurring wheel (modifyIORef' ref (+1)) 0.15 - sleep 1 - cancel - sleep 1 - readIORef ref `is` (6::Int) - destroy wheel + putStrLn "`with` re-throws exception from background thread" + catch + (with Config { spokes = 4, resolution = 0.05 } \wheel -> do + var <- newEmptyMVar + register_ wheel 0 (throwIO Bye >> putMVar var ()) + takeMVar var + throwIO (userError "fail")) + (\ex -> + case fromException ex of + Just Bye -> pure () + _ -> throwIO ex) +data Bye = Bye + deriving stock (Show) + deriving anyclass (Exception) + class Assert a b where is :: a -> b -> IO () @@ -85,6 +79,3 @@ is mx y = do x <- mx unless (x == y) (throwIO (userError (show x ++ " /= " ++ show y))) - -sleep :: Fixed E6 -> IO () -sleep (MkFixed micro) = threadDelay (fromIntegral micro) diff --git a/timer-wheel.cabal b/timer-wheel.cabal --- a/timer-wheel.cabal +++ b/timer-wheel.cabal @@ -1,41 +1,31 @@ cabal-version: 2.0 name: timer-wheel -version: 0.2.0.1 +version: 0.3.0 category: Data description: This library provides a timer wheel data structure for . - * /O(1)/ registering @IO@ actions to fire after a given amount of time + * (Almost) /O(1)/ registering @IO@ actions to fire after a given amount of time * /O(1)/ canceling registered actions . - It is similar to @TimerManager@ from "GHC.Event", but can scale much better - under concurrent access patterns. + It is similar to @TimerManager@ from "GHC.Event", but supports recurring + timers, can scale to handle many more registered timers. . - An unreleased version of this library has a @backpack@-based signature for - selecting from a variety of different data structures used internally. - However, until @backpack@ has broader support on Hackage, and in Haddocks, - etc, I decided to just hard-code something decent (a priority search queue). - This makes the @O(1)@ claims above a bit of a lie, as these rely on using a - linked list data structure internally. synopsis: A timer wheel author: Mitchell Rosen maintainer: Mitchell Rosen homepage: https://github.com/mitchellwrosen/timer-wheel bug-reports: https://github.com/mitchellwrosen/timer-wheel/issues -copyright: (c) 2018, Mitchell Rosen +copyright: (c) 2018-2020, Mitchell Rosen license: BSD3 license-file: LICENSE build-type: Simple -tested-with: - GHC == 8.0.2 - , GHC == 8.2.2 - , GHC == 8.4.4 - , GHC == 8.6.5 extra-source-files: - .travis.yml CHANGELOG.md + README.md + cabal.project source-repository head type: git @@ -44,15 +34,15 @@ library build-depends: atomic-primops ^>= 0.8, - base ^>= 4.9 || ^>= 4.10 || ^>= 4.11 || ^>= 4.12, + base ^>= 4.9 || ^>= 4.10 || ^>= 4.11 || ^>= 4.12 || ^>= 4.13 || ^>= 4.14, psqueues ^>= 0.2.7, vector ^>= 0.10 || ^>= 0.11 || ^>= 0.12 - if !impl(ghc >= 8.4) - build-depends: - clock ^>= 0.7 default-extensions: + BlockArguments + DeriveAnyClass DeriveGeneric + DerivingStrategies GeneralizedNewtypeDeriving LambdaCase NamedFieldPuns @@ -69,36 +59,30 @@ Data.TimerWheel ghc-options: - -fprint-expanded-synonyms - -fprint-explicit-foralls - -fprint-explicit-kinds - -fprint-unicode-syntax - -Wall - -Wcompat - -Widentities - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wmissing-local-signatures - -Wnoncanonical-monad-instances - -Wnoncanonical-monadfail-instances - -Wredundant-constraints - if impl(ghc >= 8.4) + -Weverything + -Wno-all-missed-specialisations + -Wno-implicit-prelude + -Wno-missing-import-lists + -Wno-unsafe + if impl(ghc >= 8.10) ghc-options: - -Wpartial-fields - -Wmissing-export-lists + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module hs-source-dirs: src other-modules: - Entries - Supply - Wheel + Data.TimerWheel.Internal.Config + Data.TimerWheel.Internal.Entries + Data.TimerWheel.Internal.Micros + Data.TimerWheel.Internal.Supply + Data.TimerWheel.Internal.Timestamp + Data.TimerWheel.Internal.Wheel test-suite tests build-depends: base, - random, timer-wheel default-language: