nanotime (empty) → 0.1.0
raw patch · 3 files changed
+303/−0 lines, 3 filesdep +basedep +nanotimedep +tasty
Dependencies added: base, nanotime, tasty, tasty-hunit, time
Files
- nanotime.cabal +110/−0
- src/Nanotime.hs +172/−0
- test/Main.hs +21/−0
+ nanotime.cabal view
@@ -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 <https://github.com/ejconlon/nanotime#readme>+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
+ src/Nanotime.hs view
@@ -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
+ test/Main.hs view
@@ -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+ ]