1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
module Test.Clock.Resolution (
testResolutions,
) where
import Control.Concurrent
import Data.Fixed
import Data.Time.Clock.Compat
import Data.Time.Clock.TAI.Compat
import Test.Tasty
import Test.Tasty.HUnit
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
testResolution :: (Show dt, Real dt) => String -> (at -> at -> dt) -> (dt, IO at) -> TestTree
testResolution name timeDiff (reportedRes, getTime) =
testCase name $ do
t0 <- getTime
times0 <-
repeatN 100 $ do
threadDelay 0
getTime
times1 <-
repeatN 100 $ -- 100us
do
threadDelay 1 -- 1us
getTime
times2 <-
repeatN 100 $ -- 1ms
do
threadDelay 10 -- 10us
getTime
times3 <-
repeatN 100 $ -- 10ms
do
threadDelay 100 -- 100us
getTime
times4 <-
repeatN 100 $ -- 100ms
do
threadDelay 1000 -- 1ms
getTime
let
times = fmap (\t -> timeDiff t t0) $ times0 ++ times1 ++ times2 ++ times3 ++ times4
foundGrid = gcdAll times
assertBool ("reported resolution: " <> show reportedRes <> ", found: " <> show foundGrid) $ foundGrid <= reportedRes
testResolutions :: TestTree
testResolutions =
testGroup "resolution" $
[testResolution "getCurrentTime" diffUTCTime (realToFrac getTime_resolution, getCurrentTime)]
++ case taiClock of
Just clock -> [testResolution "taiClock" diffAbsoluteTime clock]
Nothing -> []
|
