cabal-helper-0.8.2.0: tests/CacheTest.hs
-- | This test ensures caches are updated when on-disk project state changes.
--
-- For example when a cabal file changes we have to call the project's build
-- tool to regenerate @setup-config@s. When a @setup-config@ file changes we
-- have to re-run the helper to get the 'UnitInfo'.
module Main where
import GHC
import GHC.Paths (libdir)
import DynFlags
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.IO.Class
import Data.List
import Data.Version
import qualified Data.Map as Map
import System.Environment (getArgs)
import System.Exit
import System.FilePath ((</>), takeFileName, takeDirectory)
import System.Directory
import System.IO
import System.IO.Temp
import System.Process (readProcess)
import Distribution.Helper
import CabalHelper.Shared.Common
import CabalHelper.Compiletime.Process
main :: IO ()
main = do
args <- getArgs
topdir <- getCurrentDirectory
res <- mapM (setup topdir test) $ case args of
[] -> [ ("tests/exelib/exelib.cabal", parseVer "1.10", parseVer "0")
, ("tests/exeintlib/exeintlib.cabal", parseVer "2.0", parseVer "0")
, ("tests/fliblib/fliblib.cabal", parseVer "2.0", parseVer "0")
, ("tests/bkpregex/bkpregex.cabal", parseVer "2.0", parseVer "8.1")
-- min Cabal lib ver -^ min GHC ver -^
]
xs -> map (, parseVer "0", parseVer "0") xs
if any (==False) $ concat res
then exitFailure
else exitSuccess
cabalInstallVersion :: IO Version
cabalInstallVersion =
parseVer . trim <$> readProcess "cabal" ["--numeric-version"] ""
ghcVersion :: IO Version
ghcVersion =
parseVer . trim <$> readProcess "ghc" ["--numeric-version"] ""
cabalInstallBuiltinCabalVersion :: IO Version
cabalInstallBuiltinCabalVersion =
parseVer . trim <$> readProcess "cabal"
["act-as-setup", "--", "--numeric-version"] ""
data ProjSetup pt =
ProjSetup
{ psDistDir :: FilePath -> DistDir pt
, psProjDir :: FilePath -> ProjLoc pt
, psConfigure :: FilePath -> IO ()
, psBuild :: FilePath -> IO ()
, psSdist :: FilePath -> FilePath -> IO ()
}
oldBuild :: ProjSetup 'V1
oldBuild = ProjSetup
{ psDistDir = \dir -> DistDirV1 (dir </> "dist")
, psProjDir = \cabal_file -> ProjLocCabalFile cabal_file
, psConfigure = \dir ->
runWithCwd dir "cabal" [ "configure" ]
, psBuild = \dir ->
runWithCwd dir "cabal" [ "build" ]
, psSdist = \srcdir destdir ->
runWithCwd srcdir "cabal" [ "sdist", "-v0", "--output-dir", destdir ]
}
newBuild :: ProjSetup 'V2
newBuild = ProjSetup
{ psDistDir = \dir -> DistDirV2 (dir </> "dist-newstyle")
, psProjDir = \cabal_file -> ProjLocV2Dir (takeDirectory cabal_file)
, psConfigure = \dir ->
runWithCwd dir "cabal" [ "new-configure" ]
, psBuild = \dir ->
runWithCwd dir "cabal" [ "new-build" ]
, psSdist = \srcdir destdir ->
runWithCwd srcdir "cabal" [ "sdist", "-v0", "--output-dir", destdir ]
}
setup :: FilePath -> (forall pt . ProjSetup pt -> FilePath -> IO [Bool]) -> (FilePath, Version, Version) -> IO [Bool]
setup topdir act (cabal_file, min_cabal_ver, min_ghc_ver) = do
let projdir = takeDirectory cabal_file
ci_ver <- cabalInstallVersion
c_ver <- cabalInstallBuiltinCabalVersion
g_ver <- ghcVersion
let mreason
| (ci_ver < parseVer "1.24") =
Just $ "cabal-install-" ++ showVersion ci_ver ++ " is too old"
| c_ver < min_cabal_ver =
Just $ "Cabal-" ++ showVersion c_ver
++ " < " ++ showVersion min_cabal_ver
| g_ver < min_ghc_ver =
Just $ "ghc-" ++ showVersion g_ver
++ " < " ++ showVersion min_ghc_ver
| otherwise =
Nothing
case mreason of
Just reason -> do
putStrLn $ "Skipping test '" ++ projdir ++ "' because " ++ reason ++ "."
return []
Nothing -> do
putStrLn $ "Running test '" ++ projdir ++ "' with " ++ showVersion ci_ver ++ "."
putStrLn "Old build -------------------------------------"
rold <- runTest oldBuild topdir projdir cabal_file act
putStrLn "New build -------------------------------------"
rnew <- runTest newBuild topdir projdir cabal_file act
return (rold ++ rnew)
runTest :: ProjSetup pt -> FilePath -> String -> FilePath
-> (ProjSetup pt -> FilePath -> IO [Bool]) -> IO [Bool]
runTest ps@ProjSetup{..} topdir projdir cabal_file act = do
putStrLn $ "Running test '" ++ projdir ++ "'-------------------------"
withSystemTempDirectory' "cabal-helper.ghc-session.test" $ \tmpdir -> do
psSdist (topdir </> projdir) tmpdir
psConfigure tmpdir
act ps $ tmpdir </> takeFileName cabal_file
runWithCwd :: FilePath -> String -> [String] -> IO ()
runWithCwd cwd x xs = do
let ?verbose = True
callProcessStderr (Just cwd) x xs
run :: String -> [String] -> IO ()
run x xs = do
let ?verbose = True
callProcessStderr Nothing x xs
test :: ProjSetup pt -> FilePath -> IO [Bool]
test ProjSetup{..} cabal_file = do
let projdir = takeDirectory cabal_file
qe <- mkQueryEnv
(psProjDir cabal_file)
(psDistDir projdir)
cs <- concat <$> runQuery (allUnits (Map.elems . uiComponents)) qe
forM cs $ \ChComponentInfo{..} -> do
putStrLn $ "\n" ++ show ciComponentName ++ ":::: " ++ show ciNeedsBuildOutput
when (ciNeedsBuildOutput == ProduceBuildOutput) $ do
psBuild projdir
let opts' = "-Werror" : ciGhcOptions
let sopts = intercalate " " $ map formatArg $ "\nghc" : opts'
putStrLn $ "\n" ++ show ciComponentName ++ ": " ++ sopts
hFlush stdout
compileModule projdir ciNeedsBuildOutput ciEntrypoints opts'
where
formatArg x
| "-" `isPrefixOf` x = "\n "++x
| otherwise = x
addCabalProject :: FilePath -> IO ()
addCabalProject dir = do
writeFile (dir </> "cabal.project") "packages: .\n"
compileModule
:: FilePath -> NeedsBuildOutput -> ChEntrypoint -> [String] -> IO Bool
compileModule projdir nb ep opts = do
setCurrentDirectory projdir
putStrLn $ "compiling:" ++ show ep ++ " (" ++ show nb ++ ")"
E.handle (\(ec :: ExitCode) -> print ec >> return False) $ do
defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
runGhc (Just libdir) $ do
handleSourceError (\e -> GHC.printException e >> return False) $ do
let target = case nb of
ProduceBuildOutput -> HscNothing -- AZ: what should this be?
NoBuildOutput -> HscInterpreted
dflags0 <- getSessionDynFlags
let dflags1 = dflags0 {
ghcMode = CompManager
, ghcLink = LinkInMemory
, hscTarget = target
, optLevel = 0
}
(dflags2, _, _) <- parseDynamicFlags dflags1 (map noLoc opts)
_ <- setSessionDynFlags dflags2
ts <- mapM (\t -> guessTarget t Nothing) $
case ep of
ChLibEntrypoint ms ms' ss -> map unChModuleName $ ms ++ ms' ++ ss
ChExeEntrypoint m' ms ->
let
-- The options first clear out includes, then put in the build
-- dir. We want the first one after that, so "regex-example" in
-- the following case
--
-- ,"-i"
-- ,"-idist/build/regex-example"
-- ,"-iregex-example"
firstInclude = drop 2 $ head $ drop 2 $ filter (isPrefixOf "-i") opts
m = firstInclude </> m'
in [m] ++ map unChModuleName ms
ChSetupEntrypoint -> ["Setup.hs"]
let ts' = case nb of
NoBuildOutput -> map (\t -> t { targetAllowObjCode = False }) ts
ProduceBuildOutput -> ts
setTargets ts'
_ <- load LoadAllTargets
when (nb == NoBuildOutput) $ do
setContext $ case ep of
ChLibEntrypoint ms ms' ss ->
map (IIModule . mkModuleName . unChModuleName) $ ms ++ ms' ++ ss
ChExeEntrypoint _ ms ->
map (IIModule . mkModuleName . unChModuleName) $ ChModuleName "Main" : ms
ChSetupEntrypoint ->
map (IIModule . mkModuleName) ["Main"]
liftIO $ print ExitSuccess
return True
unChModuleName :: ChModuleName -> String
unChModuleName (ChModuleName mn) = mn