diff --git a/nanotime.cabal b/nanotime.cabal new file mode 100644 --- /dev/null +++ b/nanotime.cabal @@ -0,0 +1,110 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: nanotime +version: 0.1.0 +synopsis: a tiny time library +description: Please see the README on GitHub at +homepage: https://github.com/ejconlon/nanotime#readme +bug-reports: https://github.com/ejconlon/nanotime/issues +author: Eric Conlon +maintainer: ejconlon@gmail.com +copyright: (c) 2024 Eric Conlon +license: BSD3 +build-type: Simple +tested-with: + GHC == 9.6.4 + +source-repository head + type: git + location: https://github.com/ejconlon/nanotime + +library + exposed-modules: + Nanotime + other-modules: + Paths_nanotime + hs-source-dirs: + src + default-extensions: + BangPatterns + ConstraintKinds + DataKinds + DeriveFunctor + DeriveFoldable + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + KindSignatures + MultiParamTypeClasses + MultiWayIf + PatternSynonyms + Rank2Types + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TupleSections + TypeApplications + TypeOperators + TypeFamilies + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds + build-depends: + base >=4.12 && <5 + , time >=1.12 && <1.14 + default-language: GHC2021 + +test-suite nanotime-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_nanotime + hs-source-dirs: + test + default-extensions: + BangPatterns + ConstraintKinds + DataKinds + DeriveFunctor + DeriveFoldable + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + KindSignatures + MultiParamTypeClasses + MultiWayIf + PatternSynonyms + Rank2Types + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TupleSections + TypeApplications + TypeOperators + TypeFamilies + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.12 && <5 + , nanotime + , tasty + , tasty-hunit + , time >=1.12 && <1.14 + default-language: GHC2021 diff --git a/src/Nanotime.hs b/src/Nanotime.hs new file mode 100644 --- /dev/null +++ b/src/Nanotime.hs @@ -0,0 +1,172 @@ +module Nanotime + ( TimeDelta (..) + , timeDeltaFromFracSecs + , timeDeltaFromNanos + , timeDeltaToFracSecs + , timeDeltaToNanos + , diffTimeDelta + , threadDelayDelta + , TimeLike (..) + , awaitDelta + , PosixTime (..) + , MonoTime (..) + , monoTimeToFracSecs + , monoTimeToNanos + , monoTimeFromFracSecs + , monoTimeFromNanos + , NtpTime (..) + , posixToNtp + , ntpToPosix + , assertingNonNegative + ) +where + +import Control.Concurrent (threadDelay) +import Data.Bits (Bits (..)) +import Data.Fixed (Fixed (..), Pico) +import Data.Semigroup (Sum (..)) +import Data.Time.Clock (nominalDiffTimeToSeconds) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Word (Word32, Word64) +import GHC.Clock (getMonotonicTimeNSec) +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) + +assertingNonNegative :: (HasCallStack, Ord a, Num a, Show a) => a -> a +assertingNonNegative a = + if a < 0 + then error ("Required non-negative value but got " ++ show a) + else a + +-- | Non-negative time difference in nanoseconds since last event +-- Like a 'Nano' (`Fixed E9`) but a machine word. +newtype TimeDelta = TimeDelta {unTimeDelta :: Word64} + deriving stock (Eq, Show, Ord, Generic, Bounded) + deriving newtype (Num) + deriving (Semigroup, Monoid) via (Sum Word64) + +-- | Return a 'TimeDelta' corresponding the the given number of fractional seconds. +-- (For example, 1.5 represents one and a half seconds.) +timeDeltaFromFracSecs :: (Real a, Show a) => a -> TimeDelta +timeDeltaFromFracSecs d = TimeDelta (round (1000000000 * toRational (assertingNonNegative d))) + +-- | Return a 'TimeDelta' corresponding the the given number of nanoseconds. +-- (For example, 1000000000 represends one second.) +timeDeltaFromNanos :: (Integral a, Show a) => a -> TimeDelta +timeDeltaFromNanos = TimeDelta . fromIntegral . assertingNonNegative + +timeDeltaToFracSecs :: (Fractional a) => TimeDelta -> a +timeDeltaToFracSecs (TimeDelta n) = fromIntegral n / 1000000000 + +timeDeltaToNanos :: TimeDelta -> Word64 +timeDeltaToNanos = unTimeDelta + +-- | Return the difference of two time deltas +diffTimeDelta + :: TimeDelta + -- ^ the "larger" delta + -> TimeDelta + -- ^ the "smaller" delta + -> Maybe TimeDelta + -- ^ difference between the two (Nothing if negative) +diffTimeDelta (TimeDelta big) (TimeDelta small) = + if big <= small + then Nothing + else Just (TimeDelta (big - small)) + +threadDelayDelta :: TimeDelta -> IO () +threadDelayDelta (TimeDelta td) = threadDelay (fromIntegral (div td 1000)) + +class (Ord t) => TimeLike t where + diffTime :: t -> t -> Maybe TimeDelta + addTime :: t -> TimeDelta -> t + currentTime :: IO t + +awaitDelta :: (TimeLike t) => t -> TimeDelta -> IO t +awaitDelta m t = do + let target = addTime m t + cur <- currentTime + case diffTime target cur of + Nothing -> pure cur + Just td -> target <$ threadDelayDelta td + +newtype PosixTime = PosixTime {unPosixTime :: Word64} + deriving stock (Eq, Show, Ord, Generic, Bounded) + +e9W :: Word64 +e9W = 1000000000 + +picoToNanoWord :: Pico -> Word64 +picoToNanoWord (MkFixed i) = fromInteger (div i 1000) + +picoFromNanoWord :: Word64 -> Pico +picoFromNanoWord j = MkFixed (1000 * toInteger j) + +instance TimeLike PosixTime where + diffTime (PosixTime t2) (PosixTime t1) = + if t2 <= t1 then Nothing else Just (TimeDelta (t2 - t1)) + addTime (PosixTime t) (TimeDelta d) = PosixTime (t + d) + currentTime = fmap (PosixTime . picoToNanoWord . nominalDiffTimeToSeconds) getPOSIXTime + +-- | Monotonic time in nanoseconds since some unspecified epoch (see 'getMonotonicTimeNs') +newtype MonoTime = MonoTime {unMonoTime :: Word64} + deriving stock (Eq, Show, Ord, Generic, Bounded) + +monoTimeFromFracSecs :: (Real a, Show a) => a -> MonoTime +monoTimeFromFracSecs d = MonoTime (round (1000000000 * toRational (assertingNonNegative d))) + +monoTimeFromNanos :: (Integral a, Show a) => a -> MonoTime +monoTimeFromNanos = MonoTime . fromIntegral . assertingNonNegative + +monoTimeToFracSecs :: (Fractional a) => MonoTime -> a +monoTimeToFracSecs (MonoTime n) = fromIntegral n / 1000000000 + +monoTimeToNanos :: MonoTime -> Word64 +monoTimeToNanos = unMonoTime + +instance TimeLike MonoTime where + diffTime (MonoTime t2) (MonoTime t1) = + if t2 <= t1 then Nothing else Just (TimeDelta (t2 - t1)) + addTime (MonoTime t) (TimeDelta d) = MonoTime (t + d) + currentTime = fmap MonoTime getMonotonicTimeNSec + +newtype NtpTime = NtpTime {unNtpTime :: Word64} + deriving stock (Eq, Show, Ord, Generic, Bounded) + +nanoWordToSplit :: Word64 -> (Word32, Word32) +nanoWordToSplit j = + let whole = div j e9W + part = j - e9W * whole + in (fromIntegral whole, fromIntegral part) + +nanoWordFromSplit :: Word32 -> Word32 -> Word64 +nanoWordFromSplit whole part = e9W * fromIntegral whole + fromIntegral part + +ntpFromSplit :: Word32 -> Word32 -> NtpTime +ntpFromSplit whole part = NtpTime (shiftL (fromIntegral whole) 32 .|. fromIntegral part) + +ntpToSplit :: NtpTime -> (Word32, Word32) +ntpToSplit (NtpTime k) = (fromIntegral (shiftR k 32), fromIntegral k) + +-- Difference in nano seconds between 1/1/1900 and 1/1/1970 +-- 1900 is the NTP epoch, 1970 is the unix epoch +ntpEpochDiffSeconds :: Word32 +ntpEpochDiffSeconds = 2208988800 + +posixToNtp :: PosixTime -> NtpTime +posixToNtp (PosixTime j) = + let (whole, part) = nanoWordToSplit j + whole' = whole + ntpEpochDiffSeconds + in ntpFromSplit whole' part + +ntpToPosix :: NtpTime -> PosixTime +ntpToPosix k = + let (whole, part) = ntpToSplit k + whole' = whole - ntpEpochDiffSeconds + in PosixTime (nanoWordFromSplit whole' part) + +-- Probably best to do time arithmetic directly on PosixTime +instance TimeLike NtpTime where + diffTime n2 n1 = diffTime (ntpToPosix n2) (ntpToPosix n1) + addTime n d = posixToNtp (addTime (ntpToPosix n) d) + currentTime = fmap posixToNtp currentTime diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,21 @@ +module Main + ( main + ) +where + +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +testDummy :: TestTree +testDummy = testCase "dummy" $ do + let actual = (1 + 1) :: Int + expected = 2 :: Int + actual @?= expected + +main :: IO () +main = + defaultMain $ + testGroup + "Nanotime" + [ testDummy + ]