diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ -(C)opyright 2009 Peter Gammie, Mark Wotton. +(C)opyright 2009-2011 Peter Gammie, Mark Wotton. +{mwotton, peteg42} at gmail dot com All rights reserved. diff --git a/README b/README --- a/README +++ b/README @@ -30,7 +30,7 @@ "exception_" / throw an exception. "hunit_" / be HUnit tests: TBC applies "runTestTT . test" to them. "ok_" / not throw an exception. -"prop_" / be QuickCheck tests: TBC applies "test" to them. +"prop_" / be QuickCheck tests: TBC applies "Test.QuickCheck.quickCheck" to them. "test_" / be boolean tests (of type Bool or IO Bool or IO () with a print statement or ...): TBC runs them and expects the final line of output to be "True". @@ -67,13 +67,27 @@ for a verbose session. It seems that the parts of Cabal that TBC depends on change -frequently. TBC has only been tested with the latest Cabal (>= 1.7) -from the darcs repository. It is probably not difficult to make it -work with earlier Cabals. +frequently. TBC has only been tested with Cabal-1.10.1.0 in the +Haskell Platform 2011.2.0.1. +It is probably not difficult to make it work with other Cabals. Mostly +this involves copying out the guts of some of the Cabal modules. + Conventions must retain the full name of the test, otherwise we run into some nasty lexical issues, e.g. to avoid: hunit_prop_blah =tName equals= prop_blah -We only support GHCi on *NIX presently. +We only support GHCi on *NIX (including OS X) presently. + +== Changes == + +0.0.1 + Initial release +0.0.2 + The tbc binary exits with status 1 if anything goes wrong, 0 otherwise + Fixed GHCi scoping issue (say ":l *filename" instead of ":l filename" - perhaps new with GHC 7. + Andy Morris: support for Bird tracks + Works with the Haskell Platform 2011.2.0.1 + - GHC 7.0.3 + - QuickCheck 2 diff --git a/TBC.cabal b/TBC.cabal --- a/TBC.cabal +++ b/TBC.cabal @@ -1,5 +1,5 @@ Name: TBC -Version: 0.0.1 +Version: 0.0.2 Cabal-version: >= 1.7 Build-type: Simple Copyright: Peter Gammie, Mark Wotton @@ -13,7 +13,9 @@ TBC is a harness for running tests, relying on other libraries such as QuickCheck and HUnit to do the actual testing. If the tests follow - conventions, TBC lets you skip a lot of boilerplate. + conventions, TBC lets you skip a lot of boilerplate. It also supports + test-driven development (TDD) by running as many tests as it can + compile, whatever the state of the project as a whole. Extra-Source-Files: README @@ -22,7 +24,7 @@ location: git://github.com/peteg/TBC.git Library - Build-depends: base >= 4 && < 5, Cabal, directory, filepath, process + Build-depends: base >= 4 && < 5, Cabal >= 1.10 && < 2, directory, filepath, process Extensions: Ghc-options: -Wall Exposed-Modules: Test.TBC diff --git a/Test/Main.hs b/Test/Main.hs --- a/Test/Main.hs +++ b/Test/Main.hs @@ -1,5 +1,5 @@ {- Test By Convention: executable top-level. - - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com + - Copyright : (C)opyright 2009-2011 {mwotton, peteg42} at gmail dot com - License : BSD3 -} module Main ( main ) where @@ -11,12 +11,16 @@ import Control.Monad ( unless, when ) import Data.List ( foldl', isSuffixOf ) +import Distribution.PackageDescription ( GenericPackageDescription ) +import Distribution.PackageDescription.Parse ( readPackageDescription ) + import Distribution.Simple import Distribution.Simple.Configure -import Distribution.Simple.UserHooks ( UserHooks, emptyUserHooks ) import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program ( builtinPrograms, restoreProgramConfiguration ) -import Distribution.Simple.Setup ( defaultDistPref ) +import Distribution.Simple.Setup + ( ConfigFlags(..), Flag(..), configPrograms, configVerbosity, defaultDistPref, fromFlag ) +import Distribution.Simple.Utils ( defaultPackageDesc ) import System.Directory ( getCurrentDirectory, getDirectoryContents, setCurrentDirectory ) import System.Exit -- ( ExitFailure, exitWith ) @@ -69,7 +73,7 @@ options :: [GetOpt.OptDescr (Options -> Options)] options = [ GetOpt.Option ['v'] ["verbose"] - (GetOpt.NoArg (\ opts -> opts { optVerbosity = verbose })) + (GetOpt.NoArg (\ opts -> opts { optVerbosity = deafening })) -- verbose "chatty output on stdout" ] @@ -110,7 +114,8 @@ -- FIXME assume the dist/ dir is with the .cabal file. -- No good evidence for this except it's the Simple thing to do. let distPref = defaultDistPref - localbuildinfo <- getBuildConfig hooks distPref + verbosity = optVerbosity opts -- fromFlag $ buildVerbosity flags + localbuildinfo <- getBuildConfig hooks verbosity distPref let pkg_descr = localPkgDescr localbuildinfo let ts = case tests of @@ -118,23 +123,87 @@ _ -> [ testPath t | t <- tests ] tbcCabal (optVerbosity opts) ts False pkg_descr localbuildinfo - where hooks = error "FIXME Simple only for now." + where hooks = simpleUserHooks -- error "FIXME Simple only for now." ---------------------------------------- --- Ripped from Cabal. *sigh* Why not export more stuff? +-- Ripped from Cabal (Distribution.Simple). *sigh* Why not export more stuff? -- | FIXME we assume the user isn't doing anything clever with -- UserHooks. This info lies in Setup.hs, a bit beyond our reach. -getBuildConfig :: UserHooks -> FilePath -> IO LocalBuildInfo -getBuildConfig _hooks distPref = do - lbi <- getPersistBuildConfig distPref - case pkgDescrFile lbi of - Nothing -> return () - Just pkg_descr_file -> checkPersistBuildConfig distPref pkg_descr_file - return lbi { +getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo +getBuildConfig hooks verbosity distPref = do + lbi_wo_programs <- getPersistBuildConfig distPref + -- Restore info about unconfigured programs, since it is not serialized + let lbi = lbi_wo_programs { withPrograms = restoreProgramConfiguration (builtinPrograms ++ hookedPrograms hooks) - (withPrograms lbi) + (withPrograms lbi_wo_programs) } - where hooks = emptyUserHooks + + case pkgDescrFile lbi of + Nothing -> return lbi + Just pkg_descr_file -> do + outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file + if outdated + then reconfigure pkg_descr_file lbi + else return lbi + + where + reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo + reconfigure pkg_descr_file lbi = do + notice verbosity $ pkg_descr_file ++ " has been changed. " + ++ "Re-configuring with most recently used options. " + ++ "If this fails, please run configure manually.\n" + let cFlags = configFlags lbi + let cFlags' = cFlags { + -- Since the list of unconfigured programs is not serialized, + -- restore it to the same value as normally used at the beginning + -- of a conigure run: + configPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (configPrograms cFlags), + + -- Use the current, not saved verbosity level: + configVerbosity = Flag verbosity + } + configureAction hooks cFlags' (extraConfigArgs lbi) + +configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo +configureAction hooks flags args = do + let distPref = fromFlag $ configDistPref flags + pbi <- preConf hooks args flags + + (mb_pd_file, pkg_descr0) <- confPkgDescr + + -- get_pkg_descr (configVerbosity flags') + --let pkg_descr = updatePackageDescription pbi pkg_descr0 + let epkg_descr = (pkg_descr0, pbi) + + --(warns, ers) <- sanityCheckPackage pkg_descr + --errorOut (configVerbosity flags') warns ers + + localbuildinfo0 <- confHook hooks epkg_descr flags + + -- remember the .cabal filename if we know it + -- and all the extra command line args + let localbuildinfo = localbuildinfo0 { + pkgDescrFile = mb_pd_file, + extraConfigArgs = args + } + writePersistBuildConfig distPref localbuildinfo + + let pkg_descr = localPkgDescr localbuildinfo + postConf hooks args flags pkg_descr localbuildinfo + return localbuildinfo + where + verbosity = fromFlag (configVerbosity flags) + confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription) + confPkgDescr = do + mdescr <- readDesc hooks + case mdescr of + Just descr -> return (Nothing, descr) + Nothing -> do + pdfile <- defaultPackageDesc verbosity + descr <- readPackageDescription verbosity pdfile + return (Just pdfile, descr) diff --git a/Test/TBC.hs b/Test/TBC.hs --- a/Test/TBC.hs +++ b/Test/TBC.hs @@ -1,5 +1,5 @@ {- Test By Convention: Top-level drivers. - - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com + - Copyright : (C)opyright 2009-2011 {mwotton, peteg42} at gmail dot com - License : BSD3 -} module Test.TBC @@ -19,22 +19,20 @@ -- Dependencies. ------------------------------------------------------------------- -import System.Exit ( exitFailure ) +import System.Exit ( ExitCode(ExitFailure), exitFailure, exitWith ) import System.FilePath ( (), replaceExtension ) -import System.IO.Error -- FIXME import System.Posix.Signals ( installHandler, sigINT, Handler(..) ) import Distribution.Package ( packageId ) import Distribution.PackageDescription ( PackageDescription, allBuildInfo , BuildInfo(cSources, extraLibs, extraLibDirs) ) -import qualified Distribution.Simple as DS +import qualified Distribution.Simple as DS -- FIXME update import Distribution.Simple.BuildPaths ( objExtension ) import Distribution.Simple.GHC ( ghcOptions ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo, buildDir, withLibLBI, withPrograms ) import Distribution.Simple.Program ( ghcProgram, lookupProgram, programPath ) import Distribution.Text ( display ) -import Distribution.Verbosity ( Verbosity, normal ) import Test.TBC.Convention as Conv import Test.TBC.Drivers as Drivers @@ -47,19 +45,20 @@ -- | FIXME Bells and whistles driver. -- FIXME invoke the renderer functions appropriately. -tbcWithHooks :: Conventions s -> RenderFns s -> Driver -> [FilePath] -> IO () +tbcWithHooks :: Conventions s -> RenderFns s -> Driver -> [FilePath] -> IO ExitCode tbcWithHooks convs renderer driver testRoots = ( rInitialState renderer >>= traverseDirectories convs driver renderer testRoots >>= rFinal renderer - >> return () ) `catch` handler where - handler e = putStrLn ("TBC: " ++ show e) + handler e = putStrLn ("TBC: " ++ show e) >> return (ExitFailure 1) -- | FIXME Conventional driver. tbc :: Driver -> [FilePath] -> IO () -tbc = tbcWithHooks Conv.std (Renderers.quiet Core.normal) +tbc driver testRoots = + tbcWithHooks Conv.std (Renderers.quiet Core.normal) driver testRoots + >> return () ---------------------------------------- -- Cabal support. @@ -77,6 +76,14 @@ -> DS.Args -- ^ Where are the tests (dirs and files)? -> Bool -> PackageDescription -> LocalBuildInfo -> IO () tbcCabal verbosity args _wtf pkg_descr localbuildinfo = + cabalDriver verbosity args pkg_descr localbuildinfo >> return () + +-- | Core Cabal-based driver. +-- FIXME generalise to Hugs, etc. +-- FIXME withLibLBI should use IO a, not IO (). Hack around it for +-- now: this function exits. +cabalDriver :: Verbosity -> DS.Args -> PackageDescription -> LocalBuildInfo -> IO () +cabalDriver verbosity args pkg_descr localbuildinfo = withLibLBI pkg_descr localbuildinfo $ \_lib clbi -> do let testRoots @@ -110,16 +117,16 @@ case cmd of Nothing -> putStrLn "GHC not found." Just hc_cmd -> - do d <- ghci verbosity hc_cmd flags + do driver <- ghci verbosity hc_cmd flags -- TODO arguably other signals too -- TODO timeouts: although perhaps bad idea to arbitrarily limit time for a test run -- TODO windows: now we need to import unix package for System.Posix.Signals - installHandler sigINT (Catch $ do - hci_kill d - exitFailure - ) Nothing + _ <- installHandler sigINT (Catch $ do + hci_kill driver + exitFailure + ) Nothing - tbc d testRoots - hci_close d - return () + exitCode <- tbcWithHooks Conv.std (Renderers.quiet Core.normal) driver testRoots + _ <- hci_close driver + exitWith exitCode -- FIXME hack around Cabal's restrictive types. diff --git a/Test/TBC/Convention.hs b/Test/TBC/Convention.hs --- a/Test/TBC/Convention.hs +++ b/Test/TBC/Convention.hs @@ -25,6 +25,7 @@ ------------------------------------------------------------------- import Data.List -- ( isPrefixOf ) +import Data.Char (isSpace) import System.FilePath ( splitPath, takeExtension ) import Test.TBC.Drivers ( Driver(..) ) @@ -35,10 +36,11 @@ ------------------------------------------------------------------- -- | Skip the @.darcs@ and @.git@ directories. +-- FIXME also skip Cabal's @dist@ directory. -- FIXME could imagine trying to skip subproject directories. stdDirectoryConv :: DirectoryConvention s stdDirectoryConv fulldir s - | dir `elem` [".darcs", ".git"] = (Skip, s) + | dir `elem` [".darcs", ".git", "dist"] = (Skip, s) | otherwise = (Cont, s) where dir = last (splitPath fulldir) @@ -58,10 +60,12 @@ ------------------------------------------------------------------- findException :: [String] -> Bool +findException [] = False findException ls = "*** Exception:" `isPrefixOf` last ls || "_exception ::" `isPrefixOf` last ls findTrue :: [String] -> Bool +findTrue [] = False findTrue ls = show True == last ls ---------------------------------------- @@ -114,6 +118,7 @@ then TestResultSuccess else TestResultFailure r + findOK [] = False findOK ls = "errors = 0, failures = 0" `isInfixOf` last ls hunit _ = Nothing @@ -126,12 +131,13 @@ name = mkTestName a run_quickcheck_test d = - do r <- hci_send_cmd d $ "test " ++ name ++ "\n" + do r <- hci_send_cmd d $ "Test.QuickCheck.quickCheck " ++ name ++ "\n" return $ if findOK r then TestResultSuccess else TestResultFailure r -- FIXME what's going on here? + findOK [] = False findOK ls = ", passed" `isInfixOf` last ls quickcheck _ = Nothing @@ -159,8 +165,15 @@ std = Conventions { cDirectory = stdDirectoryConv , cTestFile = stdTestFileConv - , cTests = [booltest, exception, hunit, oktest, quickcheck] + , cTests = map unlittest tests } + where + -- We might need to remove bird tracks from an lhs file. + unlittest :: TestConvention -> TestConvention + unlittest c ('>':ln) = c $ dropWhile isSpace ln + unlittest c ln = c ln + + tests = [booltest, exception, hunit, oktest, quickcheck] {- FIXME diff --git a/Test/TBC/Core.hs b/Test/TBC/Core.hs --- a/Test/TBC/Core.hs +++ b/Test/TBC/Core.hs @@ -1,5 +1,5 @@ {- Test By Convention: core types and functions. - - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com + - Copyright : (C)opyright 2009-2011 {mwotton, peteg42} at gmail dot com - License : BSD3 -} module Test.TBC.Core @@ -31,7 +31,7 @@ import Control.Monad ( liftM, foldM ) -import Data.Char ( isAlpha, isDigit ) +import Data.Char ( isAlpha, isDigit, isSpace ) import Data.List ( nubBy ) import Data.Maybe ( catMaybes ) @@ -39,6 +39,7 @@ import Distribution.Verbosity ( Verbosity, silent, normal, verbose, deafening ) import System.Directory ( Permissions(searchable), getDirectoryContents, getPermissions ) +import System.Exit ( ExitCode ) import System.FilePath ( () ) import Test.TBC.Drivers ( Driver(hci_load_file) ) @@ -65,7 +66,10 @@ -- starting at the start of the string. FIXME this should follow the -- Haskell lexical conventions and perhaps be more robust. mkTestName :: String -> String -mkTestName = takeWhile (\c -> or (map ($c) [ isAlpha, isDigit, (`elem` ['_', '\'']) ])) +mkTestName = takeWhile (\c -> or (map ($c) [ isAlpha, isDigit, (`elem` ['_', '\'']) ])) . unlit + where + unlit ('>':cs) = dropWhile isSpace cs + unlit str = str -- | A single test. data Test @@ -106,7 +110,7 @@ -> s -> Result -> IO s - , rFinal :: s -> IO s + , rFinal :: s -> IO ExitCode } ------------------------------------------------------------------- @@ -173,7 +177,7 @@ case cTestFile convs f s0 of as'@(Stop, _s) -> return as' -- Stop testing. (Skip, s) -> - do rSkip renderer f s + do _ <-rSkip renderer f s return (Cont, s) -- ... but continue testing. (Cont, s) -> do -- putStrLn $ "Running: " ++ f diff --git a/Test/TBC/Drivers.hs b/Test/TBC/Drivers.hs --- a/Test/TBC/Drivers.hs +++ b/Test/TBC/Drivers.hs @@ -1,5 +1,5 @@ {- Test By Convention: Drivers. - - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com + - Copyright : (C)opyright 2009-2011 {mwotton, peteg42} at gmail dot com - License : BSD3 -} module Test.TBC.Drivers @@ -49,6 +49,10 @@ <- runInteractiveProcess cmd flags Nothing Nothing -- FIXME -- Configure GHCi a bit FIXME + -- FIXME this doesn't help if GHCi craps out before we get a prompt + -- e.g. if the package flags are wrong. This can happen if the package + -- hash changes but not the version number. + -- Perhaps we need a dup2 wrapper... hPutStrLn hin ":set prompt \"\"" hPutStrLn hin "GHC.Handle.hDuplicateTo System.IO.stdout System.IO.stderr" @@ -57,7 +61,7 @@ hClose herr let load_file f = - do cout <- ghci_sync verbosity hin hout (":l " ++ f ++ "\n") + do cout <- ghci_sync verbosity hin hout (":l *" ++ f ++ "\n") if not (null cout) && "Ok, modules loaded" `isInfixOf` last cout then return [] else return cout @@ -82,12 +86,13 @@ -- FIXME do we really need the separate thread? -- Get output + sync outMVar <- newEmptyMVar - forkIO $ hc_sync hout >>= putMVar outMVar + _ <- forkIO $ hc_sync hout >>= putMVar outMVar -- Tests + sync hPutStr hin inp hPutStr hin hc_sync_print - hFlush hin + -- This can fail if GHCi has died. + hFlush hin `catch` ghciDiedEH outMVar -- Synchronize hc_output <- lint_output `liftM` takeMVar outMVar @@ -111,8 +116,16 @@ hc_sync h = sync where sync = - do l <- hGetLine h - info verbosity $ "hc>> " ++ l -- FIXME should be "debug" - if done `isInfixOf` l + do eof <- hIsEOF h + if eof then return [] - else (l:) `liftM` sync + else do l <- hGetLine h + info verbosity $ "hc>> " ++ l -- FIXME should be "debug" + if done `isInfixOf` l + then return [] + else (l:) `liftM` sync + + ghciDiedEH outMVar e = + do hc_output <- takeMVar outMVar + putStr $ unlines ( ">> GHCi died. Output <<" : hc_output ) + ioError e diff --git a/Test/TBC/Renderers.hs b/Test/TBC/Renderers.hs --- a/Test/TBC/Renderers.hs +++ b/Test/TBC/Renderers.hs @@ -1,5 +1,5 @@ {- Test By Convention: test output renderers. - - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com + - Copyright : (C)opyright 2009-2011 {mwotton, peteg42} at gmail dot com - License : BSD3 -} module Test.TBC.Renderers @@ -11,6 +11,7 @@ -- Dependencies. ------------------------------------------------------------------- +import System.Exit ( ExitCode(ExitSuccess, ExitFailure) ) import Test.TBC.Core ( Renderer, RenderFns(..), Result(..), Test(..) , info ) @@ -39,6 +40,10 @@ , tsCompilationFailures = 0 } +success :: TapState -> Bool +success s = tsPassed s == tsRun s && tsCompilationFailures s == 0 + + tap :: Renderer TapState tap verbosity = RenderFns @@ -91,7 +96,7 @@ tf s = do putStrLn $ "0.." ++ show (tsRun s + tsTestsSkipped s - 1) - return s + return (if success s then ExitSuccess else ExitFailure 1) ------------------------------------------------------------------- @@ -144,7 +149,7 @@ tf s = do putStrLn $ "Passed " ++ show (tsPassed s) ++ " / " ++ show (tsRun s) ++ skipped ++ cfail - return s + return (if success s then ExitSuccess else ExitFailure 1) where cfail | tsCompilationFailures s == 0 = "" @@ -153,3 +158,4 @@ skipped | tsTestsSkipped s == 0 = "" | otherwise = " (Skipped " ++ show (tsTestsSkipped s) ++ ")" +