cabal-install-1.24.0.0: tests/UnitTests.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Main
       where

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 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
import qualified UnitTests.Distribution.Client.Glob
import qualified UnitTests.Distribution.Client.GZipUtils
import qualified UnitTests.Distribution.Client.Sandbox
import qualified UnitTests.Distribution.Client.Sandbox.Timestamp
import qualified UnitTests.Distribution.Client.Tar
import qualified UnitTests.Distribution.Client.Targets
import qualified UnitTests.Distribution.Client.UserConfig
import qualified UnitTests.Distribution.Client.ProjectConfig

import UnitTests.Options


tests :: Int -> TestTree
tests mtimeChangeCalibrated =
  askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) ->
  let mtimeChange = if mtimeChangeProvided /= 0
                    then mtimeChangeProvided
                    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"
        UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests
  , testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"
        UnitTests.Distribution.Client.Dependency.Modular.Solver.tests
  , testGroup "UnitTests.Distribution.Client.FileMonitor" $
        UnitTests.Distribution.Client.FileMonitor.tests mtimeChange
  , testGroup "UnitTests.Distribution.Client.Glob"
        UnitTests.Distribution.Client.Glob.tests
  , testGroup "Distribution.Client.GZipUtils"
       UnitTests.Distribution.Client.GZipUtils.tests
  , testGroup "Distribution.Client.Sandbox"
       UnitTests.Distribution.Client.Sandbox.tests
  , testGroup "Distribution.Client.Sandbox.Timestamp"
       UnitTests.Distribution.Client.Sandbox.Timestamp.tests
  , testGroup "Distribution.Client.Tar"
       UnitTests.Distribution.Client.Tar.tests
  , testGroup "Distribution.Client.Targets"
       UnitTests.Distribution.Client.Targets.tests
  , testGroup "UnitTests.Distribution.Client.UserConfig"
       UnitTests.Distribution.Client.UserConfig.tests
  , testGroup "UnitTests.Distribution.Client.ProjectConfig"
       UnitTests.Distribution.Client.ProjectConfig.tests
  ]

main :: IO ()
main = do
  mtimeChangeDelay <- calibrateMtimeChangeDelay
  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

    time :: IO () -> IO Int
    time act = do
      t0 <- getCurrentTime
      act
      t1 <- getCurrentTime
      return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds