Commit f2e219b3 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Move Distribution.Client.Compat.Time to Distribution.Compat.Time.


Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent fe4ab56c
......@@ -212,6 +212,10 @@ source-repository head
flag bundled-binary-generic
default: False
flag old-directory
description: Use directory < 1.2 and old-time
default: False
library
build-depends:
array >= 0.1 && < 0.6,
......@@ -219,12 +223,18 @@ library
bytestring >= 0.9 && < 1,
containers >= 0.4 && < 0.6,
deepseq >= 1.3 && < 1.5,
directory >= 1.1 && < 1.3,
filepath >= 1.3 && < 1.5,
pretty >= 1.1 && < 1.2,
process >= 1.1.0.1 && < 1.5,
time >= 1.4 && < 1.7
if flag(old-directory)
build-depends: directory >= 1.1 && < 1.2, old-time >= 1 && < 1.2,
process >= 1.0.1.1 && < 1.1.0.2
else
build-depends: directory >= 1.2 && < 1.3,
process >= 1.1.0.2 && < 1.5
if flag(bundled-binary-generic)
build-depends: binary >= 0.5 && < 0.7
else
......@@ -254,6 +264,7 @@ library
Distribution.Compat.Internal.TempFile
Distribution.Compat.ReadP
Distribution.Compat.Semigroup
Distribution.Compat.Time
Distribution.Compiler
Distribution.InstalledPackageInfo
Distribution.License
......@@ -364,9 +375,11 @@ test-suite unit-tests
build-depends:
base,
directory,
filepath,
tasty,
tasty-hunit,
tasty-quickcheck,
tagged,
pretty,
QuickCheck >= 2.7 && < 2.9,
Cabal
......
{-# LANGUAGE CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving #-}
module Distribution.Client.Compat.Time
{-# LANGUAGE CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
module Distribution.Compat.Time
( ModTime(..) -- Needed for testing
, getModTime, getFileAge, getCurTime
, posixSecondsToModTime )
, posixSecondsToModTime
, calibrateMtimeChangeDelay )
where
import Control.Arrow ( first )
......@@ -11,11 +12,16 @@ import Data.Word ( Word64 )
import System.Directory ( getModificationTime )
import Distribution.Compat.Binary ( Binary )
import Distribution.Simple.Utils ( withTempDirectory )
import Distribution.Verbosity ( silent )
import System.FilePath
import Control.Monad
import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime )
import Data.Time ( diffUTCTime, getCurrentTime )
#if MIN_VERSION_directory(1,2,0)
import Data.Time.Clock.POSIX ( posixDayLength )
import Data.Time ( diffUTCTime, getCurrentTime )
#else
import System.Time ( getClockTime, diffClockTimes
, normalizeTimeDiff, tdDay, tdHour )
......@@ -73,7 +79,7 @@ getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do
if not res
then do
let err = mkIOError doesNotExistErrorType
"Distribution.Client.Compat.Time.getModTime"
"Distribution.Compat.Time.getModTime"
Nothing (Just path)
ioError err
else do
......@@ -165,3 +171,32 @@ getFileAge file = do
-- | Return the current time as 'ModTime'.
getCurTime :: IO ModTime
getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'.
-- | Based on code written by Neil Mitchell for Shake. See
-- 'sleepFileTimeCalibrate' in 'Test.Type'. Returns a pair
-- of the maximum delay seen, and the recommended delay to
-- use before testing for file modification change.
-- The returned delay is never smaller
-- than 10 ms, but never larger than 1 second.
calibrateMtimeChangeDelay :: IO (Int, Int)
calibrateMtimeChangeDelay = do
withTempDirectory silent "." "calibration-" $ \dir -> do
let fileName = dir </> "probe"
mtimes <- forM [1..25] $ \(i::Int) -> time $ do
writeFile fileName $ show i
t0 <- getModTime fileName
let spin j = do
writeFile fileName $ show (i,j)
t1 <- getModTime fileName
unless (t0 < t1) (spin $ j + 1)
spin (0::Int)
let mtimeChange = maximum mtimes
mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2
return (mtimeChange, mtimeChange')
where
time :: IO () -> IO Int
time act = do
t0 <- getCurrentTime
act
t1 <- getCurrentTime
return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds
{-# LANGUAGE DeriveDataTypeable #-}
module Main
( main
) where
import Test.Tasty
import Test.Tasty.Options
import Data.Proxy
import Data.Typeable
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Compat.Time
import qualified UnitTests.Distribution.Compat.CreatePipe
import qualified UnitTests.Distribution.Compat.ReadP
import qualified UnitTests.Distribution.Compat.Time
import qualified UnitTests.Distribution.Simple.Program.Internal
import qualified UnitTests.Distribution.Simple.Utils
import qualified UnitTests.Distribution.System
import qualified UnitTests.Distribution.Utils.NubList
import qualified UnitTests.Distribution.Version (versionTests)
tests :: TestTree
tests = testGroup "Unit Tests" $
tests :: Int -> TestTree
tests mtimeChangeCalibrated =
askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) ->
let mtimeChange = if mtimeChangeProvided /= 0
then mtimeChangeProvided
else mtimeChangeCalibrated
in
testGroup "Unit Tests" $
[ testGroup "Distribution.Compat.CreatePipe"
UnitTests.Distribution.Compat.CreatePipe.tests
, testGroup "Distribution.Compat.ReadP"
UnitTests.Distribution.Compat.ReadP.tests
, testGroup "Distribution.Compat.Time"
(UnitTests.Distribution.Compat.Time.tests mtimeChange)
, testGroup "Distribution.Simple.Program.Internal"
UnitTests.Distribution.Simple.Program.Internal.tests
, testGroup "Distribution.Simple.Utils"
......@@ -30,5 +48,31 @@ tests = testGroup "Unit Tests" $
UnitTests.Distribution.Version.versionTests
]
extraOptions :: [OptionDescription]
extraOptions =
[ Option (Proxy :: Proxy OptionMtimeChangeDelay)
]
newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int
deriving Typeable
instance IsOption OptionMtimeChangeDelay where
defaultValue = OptionMtimeChangeDelay 0
parseValue = fmap OptionMtimeChangeDelay . safeRead
optionName = return "mtime-change-delay"
optionHelp = return $ "How long to wait before attempting to detect"
++ "file modification, in microseconds"
main :: IO ()
main = defaultMain tests
main = do
(mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay
let toMillis :: Int -> Double
toMillis x = fromIntegral x / 1000.0
notice normal $ "File modification time resolution calibration completed, "
++ "maximum delay observed: "
++ (show . toMillis $ mtimeChange ) ++ " ms. "
++ "Will be using delay of " ++ (show . toMillis $ mtimeChange')
++ " for test runs."
defaultMainWithIngredients
(includingOptions extraOptions : defaultIngredients)
(tests mtimeChange')
module UnitTests.Distribution.Client.Compat.Time (tests) where
module UnitTests.Distribution.Compat.Time (tests) where
import Control.Concurrent (threadDelay)
import System.FilePath
......@@ -6,7 +6,7 @@ import System.FilePath
import Distribution.Simple.Utils (withTempDirectory)
import Distribution.Verbosity
import Distribution.Client.Compat.Time
import Distribution.Compat.Time
import Test.Tasty
import Test.Tasty.HUnit
......
......@@ -58,7 +58,7 @@ import Control.Monad.Except (ExceptT, runExceptT, withExceptT,
throwError)
import Control.Exception
import Distribution.Client.Compat.Time
import Distribution.Compat.Time
import Distribution.Client.Glob
import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic)
import Distribution.Client.Utils (mergeBy, MergeResult(..))
......
......@@ -85,7 +85,7 @@ import Distribution.Client.GZipUtils (maybeDecompress)
import Distribution.Client.Utils ( byteStringToFilePath
, tryFindAddSourcePackageDesc )
import Distribution.Compat.Exception (catchIO)
import Distribution.Client.Compat.Time (getFileAge, getModTime)
import Distribution.Compat.Time (getFileAge, getModTime)
import System.Directory (doesFileExist, doesDirectoryExist)
import System.FilePath
( (</>), takeExtension, replaceExtension, splitDirectories, normalise )
......
......@@ -55,7 +55,7 @@ import Distribution.Client.Utils
(inDir, removeExistingFile, tryCanonicalizePath, tryFindAddSourcePackageDesc)
import Distribution.Compat.Exception (catchIO)
import Distribution.Client.Compat.Time (ModTime, getCurTime,
import Distribution.Compat.Time (ModTime, getCurTime,
getModTime,
posixSecondsToModTime)
......
......@@ -19,7 +19,7 @@ module Distribution.Client.Utils ( MergeResult(..)
where
import Distribution.Compat.Exception ( catchIO )
import Distribution.Client.Compat.Time ( getModTime )
import Distribution.Compat.Time ( getModTime )
import Distribution.Simple.Setup ( Flag(..) )
import Distribution.Simple.Utils ( die, findPackageDesc )
import qualified Data.ByteString.Lazy as BS
......
......@@ -211,7 +211,6 @@ executable cabal
Distribution.Client.Compat.FilePerms
Distribution.Client.Compat.Process
Distribution.Client.Compat.Semaphore
Distribution.Client.Compat.Time
Paths_cabal_install
-- NOTE: when updating build-depends, don't forget to update version regexps
......@@ -276,7 +275,6 @@ Test-Suite unit-tests
other-modules:
UnitTests.Distribution.Client.ArbitraryInstances
UnitTests.Distribution.Client.Targets
UnitTests.Distribution.Client.Compat.Time
UnitTests.Distribution.Client.Dependency.Modular.PSQ
UnitTests.Distribution.Client.Dependency.Modular.Solver
UnitTests.Distribution.Client.Dependency.Modular.DSL
......
......@@ -5,16 +5,11 @@ module Main
import Test.Tasty
import Control.Monad
import Data.Time.Clock
import System.FilePath
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Client.Compat.Time
import Distribution.Compat.Time
import qualified UnitTests.Distribution.Client.Compat.Time
import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ
import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver
import qualified UnitTests.Distribution.Client.FileMonitor
......@@ -38,9 +33,7 @@ tests mtimeChangeCalibrated =
else mtimeChangeCalibrated
in
testGroup "Unit Tests"
[ testGroup "UnitTests.Distribution.Client.Compat.Time" $
UnitTests.Distribution.Client.Compat.Time.tests mtimeChange
, testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"
[ testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"
UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests
, testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"
UnitTests.Distribution.Client.Dependency.Modular.Solver.tests
......@@ -66,41 +59,15 @@ tests mtimeChangeCalibrated =
main :: IO ()
main = do
mtimeChangeDelay <- calibrateMtimeChangeDelay
(mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay
let toMillis :: Int -> Double
toMillis x = fromIntegral x / 1000.0
notice normal $ "File modification time resolution calibration completed, "
++ "maximum delay observed: "
++ (show . toMillis $ mtimeChange ) ++ " ms. "
++ "Will be using delay of " ++ (show . toMillis $ mtimeChange')
++ " for test runs."
defaultMainWithIngredients
(includingOptions extraOptions : defaultIngredients)
(tests mtimeChangeDelay)
-- Based on code written by Neill Mitchell for Shake. See
-- 'sleepFileTimeCalibrate' in 'Test.Type'. The returned delay is never smaller
-- than 10 ms, but never larger than 1 second.
calibrateMtimeChangeDelay :: IO Int
calibrateMtimeChangeDelay = do
withTempDirectory silent "." "calibration-" $ \dir -> do
let fileName = dir </> "probe"
mtimes <- forM [1..25] $ \(i::Int) -> time $ do
writeFile fileName $ show i
t0 <- getModTime fileName
let spin j = do
writeFile fileName $ show (i,j)
t1 <- getModTime fileName
unless (t0 < t1) (spin $ j + 1)
spin (0::Int)
let mtimeChange = maximum mtimes
mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2
notice normal $ "File modification time resolution calibration completed, "
++ "maximum delay observed: "
++ (show . toMillis $ mtimeChange ) ++ " ms. "
++ "Will be using delay of " ++ (show . toMillis $ mtimeChange')
++ " for test runs."
return mtimeChange'
where
toMillis :: Int -> Double
toMillis x = fromIntegral x / 1000.0
(tests mtimeChange')
time :: IO () -> IO Int
time act = do
t0 <- getCurrentTime
act
t1 <- getCurrentTime
return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds
......@@ -15,7 +15,7 @@ import Distribution.Simple.Utils (withTempDirectory)
import Distribution.Verbosity (silent)
import Distribution.Client.FileMonitor
import Distribution.Client.Compat.Time
import Distribution.Compat.Time
import Test.Tasty
import Test.Tasty.HUnit
......
......@@ -5,7 +5,7 @@ import System.FilePath
import Distribution.Simple.Utils (withTempDirectory)
import Distribution.Verbosity
import Distribution.Client.Compat.Time
import Distribution.Compat.Time
import Distribution.Client.Sandbox.Timestamp
import Test.Tasty
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment