----------------------------------------------------------------------------- -- | -- 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 ()