Timeout.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE FlexibleContexts #-}

module Control.Concurrent.STM.Timeout
  ( registerDelay
  ) where

import Data.Timeout
import Control.Monad (void)
import Control.Monad.Base
import Control.Monad.STM
import Control.Concurrent.STM.TVar hiding (registerDelay)
import GHC.Event (registerTimeout)
#if MIN_VERSION_base(4,7,0)
import GHC.Event (getSystemTimerManager)
#else
import GHC.Event (getSystemEventManager)
#endif

registerDelay ∷ MonadBase IO μ ⇒ Timeout → μ (TVar Bool)
registerDelay tt = liftBase $
  if tt == instantly
    then newTVarIO True
    else do
      ttv ← newTVarIO False
#if MIN_VERSION_base(4,7,0)
      tmm ← getSystemTimerManager
#else
      Just tmm ← getSystemEventManager
#endif
      let us = tt #> MicroSecond
          maxUs = fromIntegral (maxBound ∷ Int)
          us' = maxUs `min` us
          rearm passed =
            case us - passed of
              0 → atomically $ writeTVar ttv True
              left → do
                let us'' = maxUs `min` left
                void $ registerTimeout tmm (fromIntegral us'') $
                  rearm $ passed + us''
      void $ registerTimeout tmm (fromIntegral us') $ rearm us'
      return ttv