diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,35 @@ +Copyright (c) 2004-2006, David Himmelstrup +All rights reserved. + +Redistribution and use in source and binary forms, +with or without modification, are permitted provided +that the following conditions are met: + + * Redistributions of source code must retain + the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce + the above copyright notice, this list of + conditions and the following disclaimer in the + documentation and/or other materials provided + with the distribution. + * Neither the name of David Himmelstrup nor the + names of other contributors may be used to + endorse or promote products derived from this + software without specific prior written permission. + + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND +CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY +OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple + +> main = defaultMain + diff --git a/cabal-test.cabal b/cabal-test.cabal new file mode 100644 --- /dev/null +++ b/cabal-test.cabal @@ -0,0 +1,21 @@ +Name: cabal-test +Version: 0.1 +Maintainer: Lemmih (lemmih@gmail.com) +Author: Lemmih (lemmih@gmail.com) +Copyright: 2006-2007, Lemmih +Category: Testing +License-File: LICENSE +License: BSD3 +Build-Depends: base, Cabal, filepath, QuickCheck, pqc, ghc +Synopsis: Automated test tool for cabal projects. +Description: + Cabal-test is a tool for testing cabal projects. It uses the GHC-api to load the code so any + code currently buildable by GHCi should be testable by cabal-test. + You can choose how many tests to run and how many to run concurrently. + +Executable: cabal-test +Main-is: Main.hs +Extensions: +GHC-Options: -fwarn-duplicate-exports + -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches +Hs-Source-Dirs: src diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,231 @@ +----------------------------------------------------------------------------- +-- | +-- 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 ()