{-# 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 :: forall (μ :: * -> *). MonadBase IO μ => Timeout -> μ (TVar Bool)
registerDelay Timeout
tt = IO (TVar Bool) -> μ (TVar Bool)
forall α. IO α -> μ α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (TVar Bool) -> μ (TVar Bool))
-> IO (TVar Bool) -> μ (TVar Bool)
forall a b. (a -> b) -> a -> b
$
  if Timeout
tt Timeout -> Timeout -> Bool
forall a. Eq a => a -> a -> Bool
== Timeout
instantly
    then Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
True
    else do
      TVar Bool
ttv ← Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
#if MIN_VERSION_base(4,7,0)
      TimerManager
tmm ← IO TimerManager
getSystemTimerManager
#else
      Just tmm ← getSystemEventManager
#endif
      let us :: Word64
us = Timeout
tt Timeout -> TimeoutUnit -> Word64
#> TimeoutUnit
MicroSecond
          maxUs :: Word64
maxUs = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound ∷ Int)
          us' :: Word64
us' = Word64
maxUs Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
`min` Word64
us
          rearm :: Word64 -> TimeoutCallback
rearm Word64
passed =
            case Word64
us Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
passed of
              Word64
0 → STM () -> TimeoutCallback
forall a. STM a -> IO a
atomically (STM () -> TimeoutCallback) -> STM () -> TimeoutCallback
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
ttv Bool
True
              Word64
left → do
                let us'' :: Word64
us'' = Word64
maxUs Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
`min` Word64
left
                IO TimeoutKey -> TimeoutCallback
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO TimeoutKey -> TimeoutCallback)
-> IO TimeoutKey -> TimeoutCallback
forall a b. (a -> b) -> a -> b
$ TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey
registerTimeout TimerManager
tmm (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
us'') (TimeoutCallback -> IO TimeoutKey)
-> TimeoutCallback -> IO TimeoutKey
forall a b. (a -> b) -> a -> b
$
                  Word64 -> TimeoutCallback
rearm (Word64 -> TimeoutCallback) -> Word64 -> TimeoutCallback
forall a b. (a -> b) -> a -> b
$ Word64
passed Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
us''
      IO TimeoutKey -> TimeoutCallback
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO TimeoutKey -> TimeoutCallback)
-> IO TimeoutKey -> TimeoutCallback
forall a b. (a -> b) -> a -> b
$ TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey
registerTimeout TimerManager
tmm (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
us') (TimeoutCallback -> IO TimeoutKey)
-> TimeoutCallback -> IO TimeoutKey
forall a b. (a -> b) -> a -> b
$ Word64 -> TimeoutCallback
rearm Word64
us'
      TVar Bool -> IO (TVar Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TVar Bool
ttv