[commit: packages/time] format-widths, ghc, master: Fix SystemTime on Windows (ad27c60)

[git at git.haskell.org]

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

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

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

commit ad27c60e85531d607aa8a945406e2fe8c0184685
Author: Ashley Yakeley <ashley at semantic.org>
Date:   Sat Feb 4 18:10:39 2017 -0800

    Fix SystemTime on Windows


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

ad27c60e85531d607aa8a945406e2fe8c0184685
 lib/Data/Time/Clock/Internal/SystemTime.hs |  4 +--
 test/main/Main.hs                          |  2 +-
 test/main/Test/Clock/Resolution.hs         | 40 +++++++++++++++++++-----------
 3 files changed, 29 insertions(+), 17 deletions(-)

diff --git a/lib/Data/Time/Clock/Internal/SystemTime.hs b/lib/Data/Time/Clock/Internal/SystemTime.hs
index bc9aad5..480d374 100644
--- a/lib/Data/Time/Clock/Internal/SystemTime.hs
+++ b/lib/Data/Time/Clock/Internal/SystemTime.hs
@@ -59,11 +59,11 @@ getTAISystemTime :: Maybe (DiffTime,IO SystemTime)
 getSystemTime = do
     Win32.FILETIME ft <- Win32.getSystemTimeAsFileTime
     let (s, us) = (ft - win32_epoch_adjust) `divMod` 10000000
-    return (MkSystemTime (fromIntegral s) (fromIntegral us * 1000))
+    return (MkSystemTime (fromIntegral s) (fromIntegral us * 100))
   where
     win32_epoch_adjust :: Word64
     win32_epoch_adjust = 116444736000000000
-getTime_resolution = 1E-6 -- microsecond
+getTime_resolution = 100E-9 -- 100ns
 getTAISystemTime = Nothing
 
 #elif HAVE_CLOCK_GETTIME
diff --git a/test/main/Main.hs b/test/main/Main.hs
index 8f205e3..5c40256 100644
--- a/test/main/Main.hs
+++ b/test/main/Main.hs
@@ -32,7 +32,7 @@ tests = testGroup "Time" [
         ],
     testGroup "Clock" [
         testClockConversion,
-        testResolution,
+        testResolutions,
         testTAI
         ],
     testGroup "Format" [
diff --git a/test/main/Test/Clock/Resolution.hs b/test/main/Test/Clock/Resolution.hs
index a8bcd91..d61e8d9 100644
--- a/test/main/Test/Clock/Resolution.hs
+++ b/test/main/Test/Clock/Resolution.hs
@@ -1,5 +1,6 @@
-module Test.Clock.Resolution(testResolution) where
+module Test.Clock.Resolution(testResolutions) where
 
+import Control.Concurrent
 import Data.Fixed
 import Data.Time.Clock
 import Data.Time.Clock.TAI
@@ -20,21 +21,32 @@ gcd' a b = gcd' b (mod' a b)
 gcdAll :: Real a => [a] -> a
 gcdAll = foldr gcd' 0
 
-testClockResolution :: TestTree
-testClockResolution = testCase "getCurrentTime" $ do
-    times <- repeatN 100 getCurrentTime
-    assertEqual "resolution" getTime_resolution $ gcdAll (fmap utctDayTime times)
+testResolution :: (Show dt,Real dt) => String -> (at -> at -> dt) -> (dt,IO at) -> TestTree
+testResolution name timeDiff (res,getTime) = testCase name $ do
+    t0 <- getTime
+    times0 <- repeatN 100 $ do
+        threadDelay 0
+        getTime
+    times1 <- repeatN 100 $ do -- 100us
+        threadDelay 1 -- 1us
+        getTime
+    times2 <- repeatN 100 $ do -- 1ms
+        threadDelay 10 -- 10us
+        getTime
+    times3 <- repeatN 100 $ do -- 10ms
+        threadDelay 100 -- 100us
+        getTime
+    times4 <- repeatN 100 $ do -- 100ms
+        threadDelay 1000 -- 1ms
+        getTime
+    let times = fmap (\t -> timeDiff t t0) $ times0 ++ times1 ++ times2 ++ times3 ++ times4
+    assertEqual "resolution" res $ gcdAll times
 
-testTAIResolution :: (DiffTime,IO AbsoluteTime) -> TestTree
-testTAIResolution (res,getTime) = testCase "taiClock" $ do
-    times <- repeatN 100 getTime
-    assertEqual "resolution" res $ gcdAll (fmap (\t -> diffAbsoluteTime t taiEpoch) times)
-
-testResolution :: TestTree
-testResolution = testGroup "resolution" $
+testResolutions :: TestTree
+testResolutions = testGroup "resolution" $
     [
-    testClockResolution
+    testResolution "getCurrentTime" diffUTCTime (realToFrac getTime_resolution,getCurrentTime)
     ]
     ++ case taiClock of
-        Just clock -> [testTAIResolution clock]
+        Just clock -> [testResolution "taiClock" diffAbsoluteTime clock]
         Nothing -> []