mirror of https://github.com/voidlizard/hbs2
124 lines
3.3 KiB
Haskell
124 lines
3.3 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
module HBS2.Clock
|
|
( module HBS2.Clock
|
|
, module System.Clock
|
|
, POSIXTime, getPOSIXTime, getEpoch
|
|
)where
|
|
|
|
import Data.Functor
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Monad.IO.Class
|
|
import Data.Fixed
|
|
import Data.Int (Int64)
|
|
import Data.Proxy
|
|
import Data.Time
|
|
import Prettyprinter
|
|
import System.Clock
|
|
import Data.Time.Clock
|
|
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
|
|
import Data.Word
|
|
|
|
data TimeoutKind = MilliSeconds | Seconds | Minutes | NomDiffTime | TS
|
|
|
|
data family Timeout ( a :: TimeoutKind )
|
|
|
|
|
|
newtype Wait a = Wait a
|
|
deriving newtype (Eq,Show,Pretty)
|
|
|
|
newtype Delay a = Delay a
|
|
deriving newtype (Eq,Show,Pretty)
|
|
|
|
|
|
class IsTimeout a where
|
|
toNanoSeconds :: Timeout a -> Int64
|
|
|
|
toMicroSeconds :: Timeout a -> Int
|
|
toMicroSeconds x = fromIntegral $ toNanoSeconds x `div` 1000
|
|
|
|
toTimeSpec :: Timeout a -> TimeSpec
|
|
toTimeSpec x = fromNanoSecs (fromIntegral (toNanoSeconds x))
|
|
|
|
class Expired timeout interval where
|
|
expired :: timeout -> interval -> Bool
|
|
|
|
|
|
instance IsTimeout t => Expired (Timeout t) TimeSpec where
|
|
expired t ts = fromIntegral (toNanoSecs ts) > toNanoSeconds t
|
|
|
|
-- expired :: IsTimeout t => Timeout 't -> TimeSpec -> Bool
|
|
-- expired timeout ts = False
|
|
|
|
toNominalDiffTime :: IsTimeout t => Timeout t -> NominalDiffTime
|
|
toNominalDiffTime = fromRational . (/ (10^6)) . fromIntegral . toMicroSeconds
|
|
|
|
class IsTimeout a => MonadPause a m where
|
|
pause :: Timeout a -> m ()
|
|
|
|
instance (IsTimeout a, MonadIO m) => MonadPause a m where
|
|
pause x = liftIO $ threadDelay (toMicroSeconds x)
|
|
|
|
instance HasResolution a => Pretty (Fixed a) where
|
|
pretty = pretty . show
|
|
|
|
newtype instance Timeout 'MilliSeconds =
|
|
TimeoutMSec (Fixed E9)
|
|
deriving newtype (Eq,Ord,Num,Real,Fractional,Show,Pretty)
|
|
|
|
newtype instance Timeout 'Seconds =
|
|
TimeoutSec (Fixed E12)
|
|
deriving newtype (Eq,Ord,Num,Real,Fractional,Show,Pretty)
|
|
|
|
newtype instance Timeout 'Minutes =
|
|
TimeoutMin (Fixed E9)
|
|
deriving newtype (Eq,Ord,Num,Real,Fractional,Show,Pretty)
|
|
|
|
newtype instance Timeout 'NomDiffTime =
|
|
TimeoutNDT NominalDiffTime
|
|
deriving newtype (Eq,Ord,Num,Real,Fractional,Show,Pretty)
|
|
|
|
newtype instance Timeout 'TS =
|
|
TimeoutTS TimeSpec
|
|
deriving newtype (Eq,Ord,Num,Real,Show,Pretty)
|
|
|
|
instance Pretty NominalDiffTime where
|
|
pretty = viaShow
|
|
|
|
instance Pretty TimeSpec where
|
|
pretty = viaShow
|
|
|
|
instance IsTimeout 'MilliSeconds where
|
|
toNanoSeconds (TimeoutMSec x) = round (x * 1e6)
|
|
|
|
instance IsTimeout 'Seconds where
|
|
toNanoSeconds (TimeoutSec x) = round (x * 1e9)
|
|
|
|
instance IsTimeout 'Minutes where
|
|
toNanoSeconds (TimeoutMin x) = round (x * 60 * 1e9)
|
|
|
|
instance IsTimeout 'NomDiffTime where
|
|
toNanoSeconds (TimeoutNDT t) = round (realToFrac (nominalDiffTimeToSeconds t) * 1e9)
|
|
|
|
instance IsTimeout 'TS where
|
|
toNanoSeconds (TimeoutTS s) = fromIntegral $ toNanoSecs s
|
|
|
|
class Expires a where
|
|
expiresIn :: Proxy a -> Maybe (Timeout 'Seconds)
|
|
|
|
-- FIXME: dangerous!
|
|
expiresIn _ = Nothing
|
|
|
|
getEpoch :: MonadIO m => m Word64
|
|
getEpoch = liftIO getPOSIXTime <&> floor
|
|
|
|
-- | Use coarse clock timer. This timer has 1ms resolution but is much
|
|
-- faster comparing to the ordinary one. Is used on Linux, on MacOS
|
|
-- provides ordinary one.
|
|
getTimeCoarse :: MonadIO m => m TimeSpec
|
|
#ifdef linux_HOST_OS
|
|
getTimeCoarse = liftIO $ getTime MonotonicCoarse
|
|
#else
|
|
getTimeCoarse = liftIO $ getTime Monotonic
|
|
#endif
|
|
|