[commit: packages/time] format-widths, master, tasty: add clockResolution (d7969bd)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/time

On branches: format-widths,master,tasty
Link       : http://git.haskell.org/packages/time.git/commitdiff/d7969bd44e2947f7d1ef8e6db0c0ae35436580f4

>---------------------------------------------------------------

commit d7969bd44e2947f7d1ef8e6db0c0ae35436580f4
Author: Ashley Yakeley <ashley at yakeley.org>
Date:   Wed Dec 14 00:10:03 2016 -0800

    add clockResolution


>---------------------------------------------------------------

d7969bd44e2947f7d1ef8e6db0c0ae35436580f4
 lib/Data/Time/Clock.hs         |  4 +++-
 lib/Data/Time/Clock/GetTime.hs | 13 ++++++++++++-
 test/Test/Resolution.hs        | 29 +++++++++++++++++++++++++++++
 test/Test/TestUtil.hs          |  7 +++++--
 test/Test/Tests.hs             |  2 ++
 time.cabal                     |  1 +
 6 files changed, 52 insertions(+), 4 deletions(-)

diff --git a/lib/Data/Time/Clock.hs b/lib/Data/Time/Clock.hs
index b03e272..7b38c5a 100644
--- a/lib/Data/Time/Clock.hs
+++ b/lib/Data/Time/Clock.hs
@@ -4,10 +4,12 @@ module Data.Time.Clock
     module Data.Time.Clock.Scale,
     module Data.Time.Clock.UTC,
     module Data.Time.Clock.UTCDiff,
-    getCurrentTime
+    getCurrentTime,
+    clockResolution
 ) where
 
 import Data.Time.Clock.Scale
+import Data.Time.Clock.GetTime
 import Data.Time.Clock.UTCDiff
 import Data.Time.Clock.UTC
 import Data.Time.Clock.POSIX
diff --git a/lib/Data/Time/Clock/GetTime.hs b/lib/Data/Time/Clock/GetTime.hs
index 0d453eb..6cb50af 100644
--- a/lib/Data/Time/Clock/GetTime.hs
+++ b/lib/Data/Time/Clock/GetTime.hs
@@ -1,8 +1,10 @@
+{-# LANGUAGE Trustworthy #-}
 module Data.Time.Clock.GetTime where
 
 import Data.Int (Int64)
 import Data.Word
 import Control.DeepSeq
+import Data.Time.Clock.Scale
 
 #include "HsTimeConfig.h"
 
@@ -44,7 +46,9 @@ instance Real POSIXTime where
     toRational (POSIXTime xs xn) = toRational xs + (toRational xn) / 1000000000
 
 instance Fractional POSIXTime where
-    fromRational r = makePOSIXTime 0 $ floor $ r * 1000000000
+    fromRational r = let
+        (s,ns) = divMod (floor $ r * 1000000000)  1000000000
+        in POSIXTime (fromInteger s) (fromInteger ns)
     recip = error "undefined POSIXTime function"
     (/) = error "undefined POSIXTime function"
 #endif
@@ -52,7 +56,10 @@ instance Fractional POSIXTime where
 instance NFData POSIXTime where
     rnf a = a `seq` ()
 
+
 getPOSIXTime :: IO POSIXTime
+clockResolution :: DiffTime
+
 #ifdef mingw32_HOST_OS
 -- On Windows, the equlvalent of POSIX time is "file time", defined as
 -- the number of 100-nanosecond intervals that have elapsed since
@@ -66,6 +73,7 @@ getPOSIXTime = do
   where
     win32_epoch_adjust :: Word64
     win32_epoch_adjust = 116444736000000000
+clockResolution = 1E-6 -- microsecond
 
 #elif HAVE_CLOCK_GETTIME
 -- Use hi-res clock_gettime
@@ -73,11 +81,14 @@ getPOSIXTime = do
 getPOSIXTime = do
     MkCTimespec (CTime s) (CLong ns) <- clockGetTime clock_REALTIME
     return (POSIXTime (fromIntegral s) (fromIntegral ns))
+clockResolution = case realtimeRes of
+    MkCTimespec (CTime s) ns -> (fromIntegral s) + (fromIntegral ns) * 1E-9
 
 #else
 -- Use gettimeofday
 getPOSIXTime = do
     MkCTimeval (CLong s) (CLong us) <- getCTimeval
     return (POSIXTime (fromIntegral s) (fromIntegral us * 1000))
+clockResolution = 1E-6 -- microsecond
 
 #endif
diff --git a/test/Test/Resolution.hs b/test/Test/Resolution.hs
new file mode 100644
index 0000000..579e14f
--- /dev/null
+++ b/test/Test/Resolution.hs
@@ -0,0 +1,29 @@
+module Test.Resolution(testResolution) where
+
+import Data.Fixed
+import Data.Time.Clock
+import Test.TestUtil
+
+repeatN :: Monad m => Int -> m a -> m [a]
+repeatN 0 _ = return []
+repeatN n ma = do
+    a <- ma
+    aa <- repeatN (n - 1) ma
+    return $ a:aa
+
+gcd' :: Real a => a -> a -> a
+gcd' a 0 = a
+gcd' a b = gcd' b (mod' a b)
+
+gcdAll :: Real a => [a] -> a
+gcdAll = foldr gcd' 0
+
+testClockResolution = ioTest "getCurrentTime" $ do
+    times <- repeatN 100 getCurrentTime
+    return $ assertionResult $ assertEqual "resolution" clockResolution $ gcdAll (fmap utctDayTime times)
+
+testResolution :: Test
+testResolution = testGroup "resolution"
+    [
+    testClockResolution
+    ]
diff --git a/test/Test/TestUtil.hs b/test/Test/TestUtil.hs
index cef8763..6b31273 100644
--- a/test/Test/TestUtil.hs
+++ b/test/Test/TestUtil.hs
@@ -43,9 +43,12 @@ diff expected found = Fail ("expected " ++ (show expected) ++ " but found " ++ (
 type TestTree = Test
 type Assertion = Either String ()
 
+assertionResult :: Assertion -> Result
+assertionResult (Right ()) = Pass
+assertionResult (Left s) = Fail s
+
 testCase :: String -> Assertion -> Test
-testCase name (Right ()) = pureTest name Pass
-testCase name (Left s) = pureTest name (Fail s)
+testCase name ass = pureTest name $ assertionResult ass
 
 assertFailure :: String -> Either String a
 assertFailure = Left
diff --git a/test/Test/Tests.hs b/test/Test/Tests.hs
index d241204..d971887 100644
--- a/test/Test/Tests.hs
+++ b/test/Test/Tests.hs
@@ -6,6 +6,7 @@ import Test.AddDays
 import Test.ClipDates
 import Test.ConvertBack
 import Test.LongWeekYears
+import Test.Resolution
 import Test.TestCalendars
 import Test.TestEaster
 import Test.TestFormat
@@ -21,6 +22,7 @@ tests = [ addDaysTest
         , clipDates
         , convertBack
         , longWeekYears
+        , testResolution
         , testCalendars
         , testEaster
         , testFormat
diff --git a/time.cabal b/time.cabal
index e2dfa2c..84f60ed 100644
--- a/time.cabal
+++ b/time.cabal
@@ -144,6 +144,7 @@ test-suite tests
         Test.TestTAI
         Test.TestTimeZone
         Test.TestValid
+        Test.Resolution
         Test.LongWeekYears
         Test.LongWeekYearsRef
         Test.ConvertBack