    {-# language ForeignFunctionInterface, ScopedTypeVariables #-}

    -- Implementation using qt
    -- and a heuristic to shorten the time span to be waited
    -- to get closer to the wanted time span.

    module Clocked (
        Timer,
        withTimer,
        waitTimer,
        getTimeDouble,
      ) where

    import Data.IORef
    import Data.Sequence

    import Control.Monad
    import Control.Monad.CatchIO
    import Control.Monad.IO.Class
    import Control.Applicative ((<$>))

    import Clocked.Common
    import Clocked.WinTimePeriod

    -- | The heuristic correction is calculated using a moving average
    -- of the time deviation. This is the size of the window for
    -- calculating the moving average.
    windowSize :: Double
    windowSize = 10

    -- | Estimate of the time deviation.
    -- Empiric data on linux (2.6.35-28)
    initialDeviation = 0.00018

    -- | the heuristic correction gets limited by a fraction of the wanted time span
    heuristicCorrectionFraction = 0.1

    foreign import ccall qtUSleep :: Int -> IO ()

    newtype Timer = Timer (IORef State)

    -- | Run a monadic action with a 'Timer'.
    withTimer :: MonadCatchIO m => (Timer -> m a) -> m a
    withTimer m = withTimePeriod 1 $
        (m =<< liftIO (Timer <$> (newIORef =<< mkState)))

    data State = State {
        lastTime :: Double,
        deviations :: Seq Double,
        deviationMovingAverage :: Double
      }

    mkState :: IO State
    mkState = do
        now <- getTimeDouble
        return $ State now (mkFullBuffer (round windowSize) initialDeviation) initialDeviation

    -- | Waits the given amount of seconds minus the elapsed time
    -- since the last call to 'waitTimer' (or the initialisation of the timer).
    waitTimer :: Timer -> Double -> IO ()
    waitTimer (Timer ref) waitSeconds = do
        state <- readIORef ref
        now <- getTimeDouble
        let heuristicCorrection = deviationMovingAverage state
            waitTime :: Double = waitSeconds - (now - lastTime state) - heuristicCorrection
            waitMicroSeconds = round (waitTime * 10 ^ 6)
        when (waitMicroSeconds > 0) $
            qtUSleep waitMicroSeconds
        after <- getTimeDouble
        let actuallyWaited = after - lastTime state
            deviation = min
                (actuallyWaited - waitSeconds + heuristicCorrection)
                (waitSeconds * heuristicCorrectionFraction)
            (droppedDeviation, newBuffer) = crank deviation (deviations state)
            newAverage = deviationMovingAverage state + ((deviation - droppedDeviation) / windowSize)
            state' = State after newBuffer newAverage
        writeIORef ref state'

    -- * buffer functions for Seq

    mkFullBuffer :: Int -> a -> Seq a
    mkFullBuffer = Data.Sequence.replicate

    crank :: a -> Seq a -> (a, Seq a)
    crank new buffer = case viewl buffer of
        head :< tail -> (head, tail |> new)
        EmptyL -> error "crank on empty buffer"