TBC 0.0.2 → 0.0.3
raw patch · 8 files changed
+162/−67 lines, 8 filesdep +deepseq
Dependencies added: deepseq
Files
- README +20/−0
- TBC.cabal +9/−6
- Test/Main.hs +3/−2
- Test/TBC.hs +26/−11
- Test/TBC/Convention.hs +52/−14
- Test/TBC/Core.hs +26/−19
- Test/TBC/Drivers.hs +23/−14
- Test/TBC/Renderers.hs +3/−1
README view
@@ -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 ==
TBC.cabal view
@@ -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
Test/Main.hs view
@@ -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.
Test/TBC.hs view
@@ -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 ()
Test/TBC/Convention.hs view
@@ -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
Test/TBC/Core.hs view
@@ -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. } -------------------------------------------------------------------
Test/TBC/Drivers.hs view
@@ -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 =
Test/TBC/Renderers.hs view
@@ -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 =