{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}
module GHC.Event.Windows.Clock (
    Clock,
    Seconds,
    getTime,
    getClock,

    -- * Specific implementations
    queryPerformanceCounter,
    getTickCount64
) where

import qualified GHC.Event.Windows.FFI as FFI

import Data.Maybe
import GHC.Base
import GHC.Real

-- | Monotonic clock
newtype Clock = Clock (IO Seconds)

type Seconds = Double

-- | Get the current time, in seconds since some fixed time in the past.
getTime :: Clock -> IO Seconds
getTime :: Clock -> IO Seconds
getTime (Clock IO Seconds
io) = IO Seconds
io

-- | Figure out what time API to use, and return a 'Clock' for accessing it.
getClock :: IO Clock
getClock :: IO Clock
getClock = [IO (Maybe Clock)] -> IO Clock
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m a
tryInOrder
           [ IO (Maybe Clock)
queryPerformanceCounter
           , (Clock -> Maybe Clock) -> IO Clock -> IO (Maybe Clock)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Clock -> Maybe Clock
forall a. a -> Maybe a
Just IO Clock
getTickCount64
           ]

tryInOrder :: Monad m => [m (Maybe a)] -> m a
tryInOrder :: forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m a
tryInOrder (m (Maybe a)
x:[m (Maybe a)]
xs) = m (Maybe a)
x m (Maybe a) -> (Maybe a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([m (Maybe a)] -> m a
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m a
tryInOrder [m (Maybe a)]
xs) a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
tryInOrder []     = m a
forall a. HasCallStack => a
undefined

mapJust :: Monad m => m (Maybe a) -> (a -> b) -> m (Maybe b)
mapJust :: forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> b) -> m (Maybe b)
mapJust m (Maybe a)
m a -> b
f = (Maybe a -> Maybe b) -> m (Maybe a) -> m (Maybe b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((a -> b) -> Maybe a -> Maybe b
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) m (Maybe a)
m

queryPerformanceCounter :: IO (Maybe Clock)
queryPerformanceCounter :: IO (Maybe Clock)
queryPerformanceCounter =
    IO (Maybe Int64)
FFI.queryPerformanceFrequency IO (Maybe Int64) -> (Int64 -> Clock) -> IO (Maybe Clock)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> b) -> m (Maybe b)
`mapJust` \Int64
freq ->
    IO Seconds -> Clock
Clock (IO Seconds -> Clock) -> IO Seconds -> Clock
forall a b. (a -> b) -> a -> b
$! do
        Int64
count <- IO Int64
FFI.queryPerformanceCounter
        let !secs :: Seconds
secs = Int64 -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
count Seconds -> Seconds -> Seconds
forall a. Fractional a => a -> a -> a
/ Int64 -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
freq
        Seconds -> IO Seconds
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Seconds
secs

getTickCount64 :: IO Clock
getTickCount64 :: IO Clock
getTickCount64 =
    Clock -> IO Clock
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clock -> IO Clock) -> Clock -> IO Clock
forall a b. (a -> b) -> a -> b
$! IO Seconds -> Clock
Clock (IO Seconds -> Clock) -> IO Seconds -> Clock
forall a b. (a -> b) -> a -> b
$! do
      Word64
msecs <- IO Word64
FFI.getTickCount64
      Seconds -> IO Seconds
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds -> IO Seconds) -> Seconds -> IO Seconds
forall a b. (a -> b) -> a -> b
$! Word64 -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
msecs Seconds -> Seconds -> Seconds
forall a. Fractional a => a -> a -> a
/ Seconds
1000