[commit: packages/time] format-widths,master,tasty: add utcToSystemTime; add tests (5aae9ff)
git at git.haskell.org
git at git.haskell.org
Mon Feb 20 21:19:54 UTC 2017
Repository : ssh://git@git.haskell.org/time
On branches: format-widths,master,tasty
Link : http://git.haskell.org/packages/time.git/commitdiff/5aae9ff1e583667affb95ffb6c57ed5863a520d6
>---------------------------------------------------------------
commit 5aae9ff1e583667affb95ffb6c57ed5863a520d6
Author: Ashley Yakeley <ashley at yakeley.org>
Date: Fri Dec 23 23:59:28 2016 -0800
add utcToSystemTime; add tests
>---------------------------------------------------------------
5aae9ff1e583667affb95ffb6c57ed5863a520d6
lib/Data/Time/Clock/Internal/GetTime.hs | 2 +-
lib/Data/Time/Clock/POSIX.hs | 9 +++---
lib/Data/Time/Clock/System.hs | 57 ++++++++++++++++++++++++++-------
test/Test/ClockConversion.hs | 24 ++++++++++++++
test/Test/Tests.hs | 2 ++
time.cabal | 1 +
6 files changed, 79 insertions(+), 16 deletions(-)
diff --git a/lib/Data/Time/Clock/Internal/GetTime.hs b/lib/Data/Time/Clock/Internal/GetTime.hs
index 8736246..397759a 100644
--- a/lib/Data/Time/Clock/Internal/GetTime.hs
+++ b/lib/Data/Time/Clock/Internal/GetTime.hs
@@ -26,7 +26,7 @@ import Foreign.C.Types (CLong(..))
data SystemTime = MkSystemTime
{ systemSeconds :: {-# UNPACK #-} !Int64
, systemNanoseconds :: {-# UNPACK #-} !Word32
- } deriving (Eq,Ord)
+ } deriving (Eq,Ord,Show)
instance NFData SystemTime where
rnf a = a `seq` ()
diff --git a/lib/Data/Time/Clock/POSIX.hs b/lib/Data/Time/Clock/POSIX.hs
index 89a958b..3ca6642 100644
--- a/lib/Data/Time/Clock/POSIX.hs
+++ b/lib/Data/Time/Clock/POSIX.hs
@@ -2,7 +2,8 @@
-- Most people won't need this module.
module Data.Time.Clock.POSIX
(
- posixDayLength,POSIXTime,posixSecondsToUTCTime,utcTimeToPOSIXSeconds,getPOSIXTime,getCurrentTime
+ posixDayLength,POSIXTime,posixSecondsToUTCTime,utcTimeToPOSIXSeconds,getPOSIXTime,getCurrentTime,
+ systemToPOSIXTime,
) where
import Data.Time.Clock.Internal.GetTime
@@ -12,9 +13,6 @@ import Data.Time.Clock.System
import Data.Time.Calendar.Days
import Data.Fixed
-unixEpochDay :: Day
-unixEpochDay = ModifiedJulianDay 40587
-
posixSecondsToUTCTime :: POSIXTime -> UTCTime
posixSecondsToUTCTime i = let
(d,t) = divMod' i posixDayLength
@@ -24,6 +22,9 @@ utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime d t) =
(fromInteger (diffDays d unixEpochDay) * posixDayLength) + min posixDayLength (realToFrac t)
+systemToPOSIXTime :: SystemTime -> POSIXTime
+systemToPOSIXTime (MkSystemTime s ns) = (fromIntegral s) + (fromIntegral ns) * 1E-9
+
-- | Get the current POSIX time from the system clock.
getPOSIXTime :: IO POSIXTime
getPOSIXTime = fmap systemToPOSIXTime getSystemTime
diff --git a/lib/Data/Time/Clock/System.hs b/lib/Data/Time/Clock/System.hs
index f63248e..4dffa17 100644
--- a/lib/Data/Time/Clock/System.hs
+++ b/lib/Data/Time/Clock/System.hs
@@ -1,29 +1,64 @@
module Data.Time.Clock.System
(
+ unixEpochDay,
SystemTime(..),
- systemToUTCTime,getSystemTime,
+ truncateSystemTimeLeapSecond,
+ getSystemTime,
+ systemToUTCTime,
+ utcToSystemTime,
systemToTAITime,
- systemToPOSIXTime,
) where
import Data.Time.Clock.Internal.AbsoluteTime
import Data.Time.Clock.Internal.DiffTime
import Data.Time.Clock.Internal.GetTime
import Data.Time.Clock.Internal.UTCTime
-import Data.Time.Clock.Internal.POSIXTime
import Data.Time.Calendar.Days
import Data.Int (Int64)
+truncateSystemTimeLeapSecond :: SystemTime -> SystemTime
+truncateSystemTimeLeapSecond (MkSystemTime seconds nanoseconds) | nanoseconds >= 1000000000 = MkSystemTime (succ seconds) 0
+truncateSystemTimeLeapSecond t = t
+
systemToUTCTime :: SystemTime -> UTCTime
-systemToUTCTime (MkSystemTime s ns) = let
- (d, s') = s `divMod` 86400
- ps :: Int64
- ps = s' * 1000000000000 + (fromIntegral ns) * 1000
- in UTCTime (addDays (fromIntegral d) unixEpochDay) (picosecondsToDiffTime $ fromIntegral ps)
-
-systemToPOSIXTime :: SystemTime -> POSIXTime
-systemToPOSIXTime (MkSystemTime s ns) = (fromIntegral s) + (fromIntegral ns) * 1E-9
+systemToUTCTime (MkSystemTime seconds nanoseconds) = let
+ days :: Int64
+ timeSeconds :: Int64
+ (days, timeSeconds) = seconds `divMod` 86400
+
+ day :: Day
+ day = addDays (fromIntegral days) unixEpochDay
+
+ timeNanoseconds :: Int64
+ timeNanoseconds = timeSeconds * 1000000000 + (fromIntegral nanoseconds)
+
+ timePicoseconds :: Int64
+ timePicoseconds = timeNanoseconds * 1000
+
+ time :: DiffTime
+ time = picosecondsToDiffTime $ fromIntegral timePicoseconds
+ in UTCTime day time
+
+utcToSystemTime :: UTCTime -> SystemTime
+utcToSystemTime (UTCTime day time) = let
+ days :: Int64
+ days = fromIntegral $ diffDays day unixEpochDay
+
+ timePicoseconds :: Int64
+ timePicoseconds = fromIntegral $ diffTimeToPicoseconds time
+
+ timeNanoseconds :: Int64
+ timeNanoseconds = timePicoseconds `div` 1000
+
+ timeSeconds :: Int64
+ nanoseconds :: Int64
+ (timeSeconds,nanoseconds) = if timeNanoseconds >= 86400000000000 then (86399,timeNanoseconds - 86399000000000) else timeNanoseconds `divMod` 1000000000
+
+ seconds :: Int64
+ seconds = days * 86400 + timeSeconds
+
+ in MkSystemTime seconds $ fromIntegral nanoseconds
unixEpochAbsolute :: AbsoluteTime
unixEpochAbsolute = taiNominalDayStart unixEpochDay
diff --git a/test/Test/ClockConversion.hs b/test/Test/ClockConversion.hs
new file mode 100644
index 0000000..b968620
--- /dev/null
+++ b/test/Test/ClockConversion.hs
@@ -0,0 +1,24 @@
+module Test.ClockConversion(testClockConversion) where
+
+import Data.Time.Clock
+import Data.Time.Clock.System
+import Test.TestUtil
+
+
+testClockConversion :: TestTree;
+testClockConversion = testGroup "clock conversion" $ let
+ testPair :: (SystemTime,UTCTime) -> TestTree
+ testPair (st,ut) = testGroup (show ut) $
+ [
+ testCase "systemToUTCTime" $ assertEqual (show ut) ut $ systemToUTCTime st,
+ testCase "utcToSystemTime" $ assertEqual (show ut) st $ utcToSystemTime ut
+ ]
+ in
+ [
+ testPair (MkSystemTime 0 0,UTCTime unixEpochDay 0),
+ testPair (MkSystemTime 86399 0,UTCTime unixEpochDay 86399),
+ testPair (MkSystemTime 86399 999999999,UTCTime unixEpochDay 86399.999999999),
+ testPair (MkSystemTime 86399 1000000000,UTCTime unixEpochDay 86400),
+ testPair (MkSystemTime 86399 1999999999,UTCTime unixEpochDay 86400.999999999),
+ testPair (MkSystemTime 86400 0,UTCTime (succ unixEpochDay) 0)
+ ]
diff --git a/test/Test/Tests.hs b/test/Test/Tests.hs
index d971887..93a68c8 100644
--- a/test/Test/Tests.hs
+++ b/test/Test/Tests.hs
@@ -4,6 +4,7 @@ import Test.Framework
import Test.AddDays
import Test.ClipDates
+import Test.ClockConversion
import Test.ConvertBack
import Test.LongWeekYears
import Test.Resolution
@@ -20,6 +21,7 @@ import Test.TestValid
tests :: [Test]
tests = [ addDaysTest
, clipDates
+ , testClockConversion
, convertBack
, longWeekYears
, testResolution
diff --git a/time.cabal b/time.cabal
index 295385b..3ee2f0e 100644
--- a/time.cabal
+++ b/time.cabal
@@ -136,6 +136,7 @@ test-suite tests
main-is: Test.hs
other-modules:
Test.Tests
+ Test.ClockConversion
Test.TestTime
Test.TestTimeRef
Test.TestParseTime
More information about the ghc-commits
mailing list