TBC 0.0.1 → 0.0.2
raw patch · 9 files changed
+190/−61 lines, 9 filesdep ~Cabal
Dependency ranges changed: Cabal
Files
- LICENSE +2/−1
- README +19/−5
- TBC.cabal +5/−3
- Test/Main.hs +85/−16
- Test/TBC.hs +24/−17
- Test/TBC/Convention.hs +16/−3
- Test/TBC/Core.hs +9/−5
- Test/TBC/Drivers.hs +21/−8
- Test/TBC/Renderers.hs +9/−3
LICENSE view
@@ -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.
README view
@@ -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
TBC.cabal view
@@ -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
Test/Main.hs view
@@ -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)
Test/TBC.hs view
@@ -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.
Test/TBC/Convention.hs view
@@ -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
Test/TBC/Core.hs view
@@ -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
Test/TBC/Drivers.hs view
@@ -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
Test/TBC/Renderers.hs view
@@ -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) ++ ")"+