Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs

   1 {-# LANGUAGE GADTs #-}
   2 module UnitTests.Distribution.Simple.Utils
   3     ( tests
   4     ) where
   5
   6 import Distribution.Simple.BuildPaths ( exeExtension )
   7 import Distribution.Simple.Utils
   8 import Distribution.System ( buildPlatform )
   9 import Distribution.Verbosity
  10
  11 import Data.IORef
  12 import System.Directory ( doesDirectoryExist, doesFileExist
  13                         , getTemporaryDirectory
  14                         , removeDirectoryRecursive, removeFile )
  15 import System.FilePath ( (<.>) )
  16 import System.IO (hClose, localeEncoding, hPutStrLn)
  17 import System.IO.Error
  18 import qualified Control.Exception as Exception
  19
  20 import Test.Tasty
  21 import Test.Tasty.HUnit
  22
  23 withTempFileTest :: Assertion
  24 withTempFileTest = do
  25   fileName <- newIORef ""
  26   tempDir  <- getTemporaryDirectory
  27   withTempFile tempDir ".foo" $ \fileName' _handle -> do
  28     writeIORef fileName fileName'
  29   fileExists <- readIORef fileName >>= doesFileExist
  30   assertBool "Temporary file not deleted by 'withTempFile'!" (not fileExists)
  31
  32 withTempFileRemovedTest :: Assertion
  33 withTempFileRemovedTest = do
  34   tempDir <- getTemporaryDirectory
  35   withTempFile tempDir ".foo" $ \fileName handle -> do
  36     hClose handle
  37     removeFile fileName
  38
  39 withTempDirTest :: Assertion
  40 withTempDirTest = do
  41   dirName <- newIORef ""
  42   tempDir <- getTemporaryDirectory
  43   withTempDirectory normal tempDir "foo" $ \dirName' -> do
  44     writeIORef dirName dirName'
  45   dirExists <- readIORef dirName >>= doesDirectoryExist
  46   assertBool "Temporary directory not deleted by 'withTempDirectory'!"
  47     (not dirExists)
  48
  49 withTempDirRemovedTest :: Assertion
  50 withTempDirRemovedTest = do
  51   tempDir <- getTemporaryDirectory
  52   withTempDirectory normal tempDir "foo" $ \dirPath -> do
  53     removeDirectoryRecursive dirPath
  54
  55 rawSystemStdInOutTextDecodingTest :: FilePath -> Assertion
  56 rawSystemStdInOutTextDecodingTest ghcPath
  57     -- We can only get this exception when the locale encoding is UTF-8
  58     -- so skip the test if it's not.
  59     | show localeEncoding /= "UTF-8" = return ()
  60     | otherwise = do
  61   tempDir  <- getTemporaryDirectory
  62   res <- withTempFile tempDir ".hs" $ \filenameHs handleHs -> do
  63     withTempFile tempDir ".exe" $ \filenameExe handleExe -> do
  64       -- Small program printing not utf8
  65       hPutStrLn handleHs "import Data.ByteString"
  66       hPutStrLn handleHs "main = Data.ByteString.putStr (Data.ByteString.pack [32, 32, 255])"
  67       hClose handleHs
  68
  69       -- We need to close exe handle as well, otherwise compilation (writing) may fail
  70       hClose handleExe
  71
  72       -- Compile
  73       (resOutput, resErrors, resExitCode) <- rawSystemStdInOut normal
  74          ghcPath ["-o", filenameExe, filenameHs]
  75          Nothing Nothing Nothing
  76          IODataModeText
  77       print (resOutput, resErrors, resExitCode)
  78
  79       -- Execute
  80       Exception.try $ do
  81         rawSystemStdInOut normal
  82            filenameExe []
  83            Nothing Nothing Nothing
  84            IODataModeText -- not binary mode output, ie utf8 text mode so try to decode
  85   case res of
  86     Right (x1, x2, x3) -> assertFailure $ "expected IO decoding exception: " ++ show (x1,x2,x3)
  87     Left err | isDoesNotExistError err -> Exception.throwIO err -- no ghc!
  88              | otherwise               -> return ()
  89
  90 dropExeExtensionTest :: Assertion
  91 dropExeExtensionTest =
  92   assertBool "dropExeExtension didn't drop exeExtension!" $
  93     dropExeExtension ("foo" <.> exeExtension buildPlatform) == "foo"
  94
  95
  96 tests :: FilePath -> [TestTree]
  97 tests ghcPath =
  98     [ testCase "withTempFile works as expected" $
  99       withTempFileTest
 100     , testCase "withTempFile can handle removed files" $
 101       withTempFileRemovedTest
 102     , testCase "withTempDirectory works as expected" $
 103       withTempDirTest
 104     , testCase "withTempDirectory can handle removed directories" $
 105       withTempDirRemovedTest
 106     , testCase "rawSystemStdInOut reports text decoding errors" $
 107       rawSystemStdInOutTextDecodingTest ghcPath
 108     , testCase "dropExeExtension drops exe extension" $
 109       dropExeExtensionTest
 110     ]