diff --git a/README b/README --- a/README +++ b/README @@ -58,6 +58,14 @@ Presently it is best to run 'tbc' in the directory containing the tests (or a subdirectory of it). +The Sample/ directory contains a sample project. After installing TBC: + +$ cd Sample +$ runghc Setup configure +$ tbc +$ cd Tests +$ tbc + == Gotchas == Say: @@ -79,6 +87,18 @@ hunit_prop_blah =tName equals= prop_blah We only support GHCi on *NIX (including OS X) presently. + +This: + +$ tbc +>> GHCi died. Output << +GHCi, version 7.0.3: http://www.haskell.org/ghc/ :? for help +TBC: fd:4: hFlush: resource vanished (Broken pipe) + +probably means that you need to reconfigure your project as one of +libraries it depends on has a different hash but not a new version +number. (For example, Cabal calls QuickCheck-2.4.0.1 the +overly-specific QuickCheck-2.4.0.1-5898cfb0116fc1d6ecef04b3f053c323.) == Changes == diff --git a/TBC.cabal b/TBC.cabal --- a/TBC.cabal +++ b/TBC.cabal @@ -1,5 +1,5 @@ Name: TBC -Version: 0.0.2 +Version: 0.0.3 Cabal-version: >= 1.7 Build-type: Simple Copyright: Peter Gammie, Mark Wotton @@ -12,11 +12,14 @@ Description: 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. 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. + as QuickCheck and HUnit to do the actual testing. TBC lets you skip a + lot of boilerplate by adopting naming conventions for tests. 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. + For further information see the examples that accompany the + distribution. + Extra-Source-Files: README source-repository head @@ -24,7 +27,7 @@ location: git://github.com/peteg/TBC.git Library - Build-depends: base >= 4 && < 5, Cabal >= 1.10 && < 2, directory, filepath, process + Build-depends: base >= 4 && < 5, Cabal >= 1.10 && < 2, deepseq, 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-2011 {mwotton, peteg42} at gmail dot com + - Copyright : (C)opyright 2009-2012 {mwotton, peteg42} at gmail dot com - License : BSD3 -} module Main ( main ) where @@ -29,7 +29,8 @@ import qualified System.Console.GetOpt as GetOpt -import Test.TBC +import Test.TBC ( Verbosity, deafening, debug, info, normal, notice + , tbcCabal ) ------------------------------------------------------------------- -- TBC-as-an-executable. diff --git a/Test/TBC.hs b/Test/TBC.hs --- a/Test/TBC.hs +++ b/Test/TBC.hs @@ -1,12 +1,12 @@ {- Test By Convention: Top-level drivers. - - Copyright : (C)opyright 2009-2011 {mwotton, peteg42} at gmail dot com + - Copyright : (C)opyright 2009-2012 {mwotton, peteg42} at gmail dot com - License : BSD3 -} module Test.TBC - ( -- * FIXME Conventions, data structures. - module Conv - , module Core - , module Drivers + ( -- * Conventions and data structures. + module Test.TBC.Convention + , module Test.TBC.Core + , module Test.TBC.Drivers -- * Top-level drivers. , tbc @@ -19,6 +19,9 @@ -- Dependencies. ------------------------------------------------------------------- +import Prelude hiding ( catch ) +import Control.Exception ( catch, SomeException ) + import System.Exit ( ExitCode(ExitFailure), exitFailure, exitWith ) import System.FilePath ( (), replaceExtension ) import System.Posix.Signals ( installHandler, sigINT, Handler(..) ) @@ -34,17 +37,21 @@ import Distribution.Simple.Program ( ghcProgram, lookupProgram, programPath ) import Distribution.Text ( display ) +-- FIXME This is what we want to say: import Test.TBC.Convention as Conv import Test.TBC.Drivers as Drivers import Test.TBC.Renderers as Renderers import Test.TBC.Core as Core +-- ... but Haddock doesn't understand (Haskell Platform 2012.2.0.0), so... +import Test.TBC.Convention +import Test.TBC.Drivers +import Test.TBC.Core ------------------------------------------------------------------- -- TBC-as-a-library. ------------------------------------------------------------------- --- | FIXME Bells and whistles driver. --- FIXME invoke the renderer functions appropriately. +-- | A parametrised bells-and-whistles driver. tbcWithHooks :: Conventions s -> RenderFns s -> Driver -> [FilePath] -> IO ExitCode tbcWithHooks convs renderer driver testRoots = ( rInitialState renderer @@ -52,9 +59,10 @@ >>= rFinal renderer ) `catch` handler where + handler :: SomeException -> IO ExitCode handler e = putStrLn ("TBC: " ++ show e) >> return (ExitFailure 1) --- | FIXME Conventional driver. +-- | A hardwired (conventional) driver. tbc :: Driver -> [FilePath] -> IO () tbc driver testRoots = tbcWithHooks Conv.std (Renderers.quiet Core.normal) driver testRoots @@ -64,14 +72,21 @@ -- Cabal support. ---------------------------------------- --- | Drop-in replacement for Cabal's 'Distribution.Simple.defaultMain'. +-- | This is a drop-in replacement for Cabal's +-- 'Distribution.Simple.defaultMain'. +-- +-- However the test infrastructure in Cabal has changed since this was +-- written, and its use is discouraged. Use the TBC binary instead. defaultMain :: IO () defaultMain = DS.defaultMainWithHooks hooks where hooks = DS.simpleUserHooks { DS.runTests = tbcCabal normal } -- | A driver compatible with Cabal's 'runTests' hook. --- FIXME generalise to Hugs, etc. --- FIXME how do we get flags? Verbosity? +-- +-- However the test infrastructure in Cabal has changed since this was +-- written, and its use is discouraged. Use the TBC binary instead. +-- +-- This is used by the TBC binary. tbcCabal :: Verbosity -> DS.Args -- ^ Where are the tests (dirs and files)? -> Bool -> PackageDescription -> LocalBuildInfo -> IO () diff --git a/Test/TBC/Convention.hs b/Test/TBC/Convention.hs --- a/Test/TBC/Convention.hs +++ b/Test/TBC/Convention.hs @@ -1,5 +1,5 @@ -{- Test By Convention: the conventions themselves. - - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com +{- | Test By Convention: the conventions themselves. + - Copyright : (C)opyright 2009-2012 {mwotton, peteg42} at gmail dot com - License : BSD3 - - Idea is to apply each of these tests to each line of a 'TestFile' @@ -17,7 +17,7 @@ -- , convention_mainPlannedTestSuite -- , convention_mainTestGroup -- , convention_main - , std + , stdDirectoryConv, stdTestFileConv, std ) where ------------------------------------------------------------------- @@ -26,7 +26,7 @@ import Data.List -- ( isPrefixOf ) import Data.Char (isSpace) -import System.FilePath ( splitPath, takeExtension ) +import System.FilePath ( splitPath, takeExtension, takeFileName ) import Test.TBC.Drivers ( Driver(..) ) import Test.TBC.Core @@ -35,9 +35,10 @@ -- Directory conventions. ------------------------------------------------------------------- --- | Skip the @.darcs@ and @.git@ directories. --- FIXME also skip Cabal's @dist@ directory. --- FIXME could imagine trying to skip subproject directories. +-- | Skip @.darcs@ and @.git@ directories, and Cabal's @dist@ +-- directory. +-- +-- Could also imagine skipping subproject directories. stdDirectoryConv :: DirectoryConvention s stdDirectoryConv fulldir s | dir `elem` [".darcs", ".git", "dist"] = (Skip, s) @@ -48,8 +49,10 @@ -- TestFile conventions. ------------------------------------------------------------------- +-- | Skip Cabal's @Setup.hs@. stdTestFileConv :: TestFileConvention s stdTestFileConv f s + | takeFileName f == "Setup.hs" = (Skip, s) | ext `elem` [".hs", ".lhs"] = (Cont, s) | otherwise = (Skip, s) where @@ -72,9 +75,10 @@ -- | The test should yield the string 'True'. This should work for -- tests of type @Bool@, @IO Bool@, @IO ()@ with a @putStrLn@, ... --- Note the 'seq' is not entirely useless: the test may use --- 'unsafePerformIO' or 'trace' to incidentally output things after --- 'True'. +-- +-- Note the 'seq' in its implementation is not entirely useless: the +-- test may use 'unsafePerformIO' or 'trace' to incidentally output +-- things after 'True'. booltest :: TestConvention booltest a@('t':'e':'s':'t':'_':_) = Just run_booltest where @@ -90,7 +94,7 @@ ---------------------------------------- --- | The test should throw an exception. +-- | The 'seq'ed test should throw an exception. exception :: TestConvention exception a@('e':'x':'c':'e':'p':'t':'i':'o':'n':_) = Just run_exception where @@ -106,6 +110,22 @@ ---------------------------------------- +-- | The @deepseq@'d test should throw an exception. +deep_exception :: TestConvention +deep_exception a@('d':'e':'e':'p':'_':'e':'x':'c':'e':'p':'t':'i':'o':'n':_) = Just run_exception + where + name = mkTestName a + + run_exception d = + do r <- hci_send_cmd d $ "Control.DeepSeq.deepseq " ++ name ++ " ()\n" + return $ if findException r + then TestResultSuccess + else TestResultFailure r + +deep_exception _ = Nothing + +---------------------------------------- + -- | A HUnit unit test. hunit :: TestConvention hunit a@('h':'u':'n':'i':'t':'_':_) = Just run_hunit_all @@ -125,6 +145,8 @@ ---------------------------------------- +-- | A QuickCheck test. We use the 'Test.QuickCheck.quickCheck' +-- driver, i.e., the default settings. quickcheck :: TestConvention quickcheck a@('p':'r':'o':'p':'_':_) = Just run_quickcheck_test where @@ -144,8 +166,7 @@ ---------------------------------------- --- | The test should terminate without throwing an exception. --- FIXME we really need a DeepSeq here to be sure. +-- | The @seq@'d test should terminate without throwing an exception. oktest :: TestConvention oktest a@('o':'k':_) = Just run_oktest where @@ -161,6 +182,23 @@ ---------------------------------------- +-- | The @deepseq@'d test should terminate without throwing an exception. +deep_oktest :: TestConvention +deep_oktest a@('d':'e':'e':'p':'_':'o':'k':_) = Just run_oktest + where + name = mkTestName a + + run_oktest d = + do r <- hci_send_cmd d $ "Control.DeepSeq.deepseq " ++ name ++ " True\n" + return $ if findTrue r + then TestResultSuccess + else TestResultFailure r + +deep_oktest _ = Nothing + +---------------------------------------- + +-- | The standard set of conventions. std :: Conventions s std = Conventions { cDirectory = stdDirectoryConv @@ -173,7 +211,7 @@ unlittest c ('>':ln) = c $ dropWhile isSpace ln unlittest c ln = c ln - tests = [booltest, exception, hunit, oktest, quickcheck] + tests = [booltest, deep_exception, exception, hunit, deep_oktest, 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 @@ -56,6 +56,7 @@ , lColumn :: Int } +-- | Construct a location. mkLocation :: FilePath -> Int -> Int -> Location mkLocation = Location @@ -81,11 +82,11 @@ -- | The result of a single 'Test'. data Result - = TestResultSkip -- ^ FIXME Skip this test - | TestResultToDo -- ^ This test is not yet done - | TestResultStop -- ^ FIXME Stop testing - | TestResultSuccess - | TestResultFailure { msg :: [String] } + = TestResultSkip -- ^ Skip this test. + | TestResultToDo -- ^ This test has not yet been written. + | TestResultStop -- ^ Cease testing. + | TestResultSuccess -- ^ The test succeeded. + | TestResultFailure { msg :: [String] } -- ^ The test failed with this explanation. deriving (Show) ------------------------------------------------------------------- @@ -96,21 +97,23 @@ -- tells the user of various events. type Renderer s = Verbosity -> RenderFns s +-- | The collection of rendering functions. data RenderFns s = RenderFns - { rInitialState :: IO s - , rCompilationFailure :: FilePath -- ^ TestFile - -> [Test] -- ^ Tests in the file - -> [String] -- ^ Output from the Haskell system + { rInitialState :: IO s -- ^ Allocate a new test state. + , rCompilationFailure :: FilePath + -> [Test] + -> [String] -- The arguments are the TestFile, the Tests in the file and the accumulator state. -> s - -> IO s - , rSkip :: FilePath -> s -> IO s -- FIXME refine: skipped a file, skipped some tests, some tests told us to skip, ... - , rStop :: FilePath -> s -> IO s + -> IO s -- ^ Render a compilation failure. + -- FIXME refine: skipped a file, skipped some tests, some tests told us to skip, ... + , rSkip :: FilePath -> s -> IO s -- ^ Render a skipped directory or file. + , rStop :: FilePath -> s -> IO s -- ^ Handle being told to stop. , rTest :: Test -> s -> Result - -> IO s - , rFinal :: s -> IO ExitCode + -> IO s -- ^ Execute a test and render its result. + , rFinal :: s -> IO ExitCode -- ^ Yield an 'ExitCode' depending on how the tests went. } ------------------------------------------------------------------- @@ -118,8 +121,12 @@ -- FIXME some might like some IO's sprinkled in here. ------------------------------------------------------------------- --- | FIXME -data Action = Stop | Skip | Cont +-- | An /action/ tells TBC what to do when it (recursively) encounters +-- a directory or file. +data Action + = Stop -- ^ Cease testing. + | Skip -- ^ Skip this file or directory. + | Cont -- ^ Process this file or directory. -- | A /directory convention/ maps a directory name into an action. type DirectoryConvention s = FilePath -> s -> (Action, s) @@ -134,9 +141,9 @@ -- | A collection of conventions. data Conventions s = Conventions - { cDirectory :: DirectoryConvention s - , cTestFile :: TestFileConvention s - , cTests :: [TestConvention] + { cDirectory :: DirectoryConvention s -- ^ The directory convention. + , cTestFile :: TestFileConvention s -- ^ The filename convention. + , cTests :: [TestConvention] -- ^ The test conventions. } ------------------------------------------------------------------- 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-2011 {mwotton, peteg42} at gmail dot com +{- | Test By Convention: Drivers. + - Copyright : (C)opyright 2009-2012 {mwotton, peteg42} at gmail dot com - License : BSD3 -} module Test.TBC.Drivers @@ -11,6 +11,9 @@ -- Dependencies. ------------------------------------------------------------------- +import Prelude hiding ( catch ) +import Control.Exception ( catch, SomeException ) + import Control.Concurrent -- ( forkIO ) import Control.Monad ( liftM ) @@ -28,22 +31,23 @@ -- | Interaction with a Haskell system. data Driver = MkDriver - { hci_send_cmd :: String -> IO [String] -- ^ FIXME exec and return lines of response - , hci_load_file :: String -> IO [String] -- ^ FIXME load a file - , hci_kill :: IO () -- ^ Terminate with prejudice - , hci_close :: IO ExitCode -- ^ Clean exit + { hci_send_cmd :: String -> IO [String] -- ^ Execute the given Haskell code and return the response as a list of lines. + , hci_load_file :: String -> IO [String] -- ^ Load a file into the Haskell system. + , hci_kill :: IO () -- ^ Terminate with prejudice. + , hci_close :: IO ExitCode -- ^ Clean exit. } ---------------------------------------- --- | GHCi driver, slave process. +-- | A driver for @GHCi@ using a slave process. ghci :: Verbosity -> String -- ^ ghci command name -> [String] -- ^ flags -> IO Driver ghci verbosity cmd flags = - do debug verbosity $ - unlines [ "system $ " ++ cmd ++ " " ++ concat [ ' ' : a | a <- flags ] + do let extra_flags = [] -- ["-package", "deepseq"] + debug verbosity $ + unlines [ "system $ " ++ cmd ++ " " ++ concat [ ' ' : a | a <- flags ++ extra_flags ] , "----------------------------------------" ] (hin, hout, herr, hpid) <- runInteractiveProcess cmd flags Nothing Nothing -- FIXME @@ -55,26 +59,31 @@ -- Perhaps we need a dup2 wrapper... hPutStrLn hin ":set prompt \"\"" hPutStrLn hin "GHC.Handle.hDuplicateTo System.IO.stdout System.IO.stderr" + -- adding "-package deepseq" to the commandline doesn't seem to work (GHC 7.0.3, OS X) + -- but this does. + hPutStrLn hin ":s -package deepseq" -- We don't use GHCi's stderr, get rid of it. -- FIXME we maybe have to drain it first. - hClose herr + -- GHC 7.4.1 dies if we do this. + -- hClose herr let load_file f = 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 + return $ if not (null cout) && "Ok, modules loaded" `isInfixOf` last cout + then [] + else cout return $ MkDriver { hci_send_cmd = ghci_sync verbosity hin hout , hci_load_file = load_file , hci_kill = terminateProcess hpid , hci_close = do hPutStr hin ":quit\n" - hFlush hin + hFlush hin `catch` (const (return ()) :: (SomeException -> IO ())) -- FIXME if GHCi is dead already that's fine by us. waitForProcess hpid } +-- | Crudely synchronise with the slave process. ghci_sync :: Verbosity -> Handle -> Handle -> String -> IO [String] ghci_sync verbosity hin hout inp = diff --git a/Test/TBC/Renderers.hs b/Test/TBC/Renderers.hs --- a/Test/TBC/Renderers.hs +++ b/Test/TBC/Renderers.hs @@ -44,6 +44,7 @@ success s = tsPassed s == tsRun s && tsCompilationFailures s == 0 +-- | A TAP generator (noisy). tap :: Renderer TapState tap verbosity = RenderFns @@ -114,8 +115,9 @@ where tid t = show (tLocation t) ++ " " ++ tName t - tcf f _ts _cout s = + tcf f _ts cout s = do putStrLn $ "** Compilation failed: " ++ f + mapM_ putStrLn cout return s{ tsCompilationFailures = tsCompilationFailures s + 1 } tskip f s =