-----------------------------------------------------------------------------
-- |
-- Module : Main
-- Copyright : (c) David Himmelstrup 2006
-- License : BSD-like
--
-- Maintainer : lemmih@gmail.com
-- Stability : provisional
-- Portability : GHC specific
--
-- Test a cabal project (library+executables) using parallel quickcheck.
-----------------------------------------------------------------------------
module Main
( main ) where
import Data.Maybe ( fromJust )
import Data.List ( nub, intersperse, isPrefixOf, tails )
import System.Environment ( getArgs )
import System.IO ( hGetLine )
import System.Exit
import System.Directory ( doesFileExist )
import System.Process ( runInteractiveProcess, waitForProcess )
import System.FilePath ( (</>), replaceExtension )
import Control.Monad ( when, filterM, forM_ )
import Control.Exception
import Text.Printf ( printf )
import Distribution.PackageDescription
import Distribution.Simple.LocalBuildInfo
import Distribution.Package
import Distribution.Compiler
import Distribution.PreProcess
import Distribution.Simple.Utils
import Distribution.Simple.Configure
import GHC -- lots
import DriverPipeline ( compileFile )
import DriverPhases ( Phase(..) )
import DynFlags ( defaultDynFlags )
import BasicTypes ( failed )
import Outputable ( showSDocForUser, ppr )
import Name ( getOccString )
import Util ( consIORef )
import StaticFlags ( v_Ld_inputs )
import Setup ( parseArguments )
import Config ( Config(..) )
import Tests()
--------------------------------------------------------------
-- Main
--------------------------------------------------------------
main :: IO ()
main = do (paths, cfg) <- parseArguments =<< getArgs
libdir <- getLibDir cfg
let cfg' = cfg{confLibDir = libdir}
case paths of
[] -> testCabalProject cfg' "."
_ -> mapM_ (testCabalProject cfg') paths
--------------------------------------------------------------
-- Output
--------------------------------------------------------------
out :: Config -> String -> IO ()
out cfg | confVerbose cfg > 0 = putStrLn
out _ = const (return ())
info :: Config -> String -> IO ()
info cfg | confVerbose cfg > 1 = putStrLn
info _ = const (return ())
debug :: Config -> String -> IO ()
debug cfg | confVerbose cfg > 3 = putStrLn
debug _ = const (return ())
--------------------------------------------------------------
-- Utils
--------------------------------------------------------------
getLibDir :: Config -> IO FilePath
getLibDir cfg
= do debug cfg $ "Using ghc command: " ++ (confGHCPath cfg)
(_,outh,_,pid) <- runInteractiveProcess (confGHCPath cfg) ["--print-libdir"] Nothing Nothing
libDir <- hGetLine outh
waitForProcess pid
return libDir
constructGHCCmdLine
:: LocalBuildInfo
-> BuildInfo
-> [String]
constructGHCCmdLine lbi bi =
-- Unsupported extensions have already been checked by configure
snd (extensionsToGHCFlag (extensions bi))
++ hcOptions GHC (options bi)
++ ["-hide-all-packages"]
++ ["-i"]
++ ["-i" ++ autogenModulesDir lbi]
++ ["-l" ++lib | lib <- extraLibs bi]
++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]
++ ["-I" ++ dir | dir <- includeDirs bi]
++ ["-optc" ++ opt | opt <- ccOptions bi]
++ [ "-odir", "/tmp"]
++ [ "-#include \"" ++ inc ++ "\"" | inc <- includes bi ]
++ ["-D__CABAL_TEST__"]
++ ["-package","QuickCheck","-package","pqc"]
++ ["-v0","-w"]
++ (concat [ ["-package", showPackageId pkg] | pkg <- packageDeps lbi ])
getCabalDesc :: FilePath -> IO PackageDescription
getCabalDesc rootDir
= do cabalFile <- findPackageDesc rootDir
readPackageDescription (rootDir </> cabalFile)
getLocalBuildInfo :: FilePath -> IO LocalBuildInfo
getLocalBuildInfo rootDir
= do str <- readFile lbiFile
case reads str of
[(lbi,_)] -> return lbi
_ -> error $ "Invalid local build file: " ++ lbiFile
where lbiFile = rootDir </> localBuildInfoFile
--------------------------------------------------------------
-- The tester
--------------------------------------------------------------
buildCSources :: Config -> Session -> BuildInfo -> IO ()
buildCSources _ _ buildinfo | null (cSources buildinfo)
= return ()
buildCSources cfg session buildinfo
= do debug cfg $ " Building C Sources..."
dflags <- GHC.getSessionDynFlags session
forM_ cFiles $ \cFile ->
do let cArgs = ["-I" ++ dir | dir <- includeDirs buildinfo]
++ ["-optc" ++ opt | opt <- ccOptions buildinfo]
++ ["-odir", "/tmp", "-c"]
(dflags', _) <- GHC.parseDynamicFlags dflags cArgs
debug cfg $ " Building: " ++ show cFile
compileFile dflags' StopLn (cFile,Nothing)
return ()
where cFiles = cSources buildinfo
buildTarget :: Config -> Session -> BuildInfo ->[String] -> IO [Name]
buildTarget cfg session buildinfo targetsPreliminary
= do buildCSources cfg session buildinfo
let targets' = targetsPreliminary -- ++ otherModules buildinfo
cObjs = map (\cFile -> "/tmp" </> cFile `replaceExtension` "o") (cSources buildinfo)
mapM_ (consIORef v_Ld_inputs) (reverse cObjs)
targets <- mapM (flip GHC.guessTarget Nothing) targets'
setTargets session targets
mbDepGraph <- depanal session [] True
let sortedTargets = nub $ reverse $ map ms_mod (fromJust mbDepGraph)
setTargets session [ Target (TargetModule (moduleName m)) Nothing
| m <- sortedTargets ]
info cfg $ " Compiling"
status <- GHC.load session LoadAllTargets
when (failed status) $ fail "Failed to compile"
info cfg $ " Compilation done"
result <- getModuleGraph session
GHC.setContext session (map ms_mod result) []
scope <- getNamesInScope session
let f n = moduleIsInterpreted session (nameModule n)
filterM f scope
configSession :: Config -> Session -> LocalBuildInfo -> BuildInfo -> IO ()
configSession cfg session lbi buildinfo
= do dflags0 <- GHC.getSessionDynFlags session
let dflags1 = dflags0 {ghcMode = Interactive, hscTarget=HscInterpreted}
cabalFlags = constructGHCCmdLine lbi buildinfo
debug cfg $ "Cabal flags: " ++ show cabalFlags
(dflags2, _) <- GHC.parseDynamicFlags dflags1 $ cabalFlags
GHC.setSessionDynFlags session dflags2
return ()
runProps :: Config -> Session -> [Name] -> IO ()
runProps cfg session props
= do let unqual = (\m _ -> Just (moduleName m), \m -> Just (modulePackageId m))
propsStr = flip map props $ \name ->
let pretty = showSDocForUser (\_ _ -> Nothing, \_ -> Nothing) (ppr name)
fn = showSDocForUser unqual (ppr name)
in printf "(\"%s\", Test.QuickCheck.Parallel.pDet %s)" pretty fn
propsList = "[" ++ concat (intersperse "," propsStr) ++ "]"
pRun = "Test.QuickCheck.Parallel.pRun"
expr = printf "%s %d %d $ %s" pRun (confThreads cfg) (confTests cfg) propsList
debug cfg $ "Running: " ++ expr
result <- runStmt session expr
case result of
RunFailed -> putStrLn "Compilation failed." >> exitFailure
RunException exp -> throwIO exp
_ -> return ()
testTarget :: Config -> Session -> LocalBuildInfo -> BuildInfo -> [String] -> IO ()
testTarget cfg session lbi buildinfo targets
= defaultErrorHandler defaultDynFlags $
do configSession cfg session lbi buildinfo
scope <- buildTarget cfg session buildinfo targets
let contains key lst = any (key `isPrefixOf`) (tails lst)
props = filter (contains (confPropTag cfg).getOccString) scope
runProps cfg session props
GHC.setTargets session []
GHC.load session LoadAllTargets
return ()
testCabalProject :: Config -> FilePath -> IO ()
testCabalProject cfg path
= do pkg <- getCabalDesc path
lbi <- getLocalBuildInfo path
session <- GHC.newSession Interactive (Just (confLibDir cfg))
out cfg $ "Testing " ++ showPackageId (package pkg)
preprocessSources pkg lbi 0 knownSuffixHandlers
case library pkg of
Nothing -> do out cfg $ " No library"
Just lib -> do out cfg $ " Testing library"
testTarget cfg session lbi (libBuildInfo lib) (exposedModules lib)
forM_ (executables pkg) $ \exe ->
do out cfg $ " Testing executable: " ++ exeName exe
let targets = map (</> modulePath exe) (hsSourceDirs (buildInfo exe))
targets' <- filterM doesFileExist targets
testTarget cfg session lbi (buildInfo exe) targets'
return ()