diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +(C)opyright 2009 Peter Gammie, Mark Wotton. + +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 the copyright holders 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/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,79 @@ += TBC: Test by Convention = + +TBC provides two features: + +- It attempts to compile and run all tests, even if some do not + compile or run. +- Aspiring to the write-it-once principle, tests following + conventions require a lot less boilerplate. + +Inspired by test-based development, our aim is not to displace +existing tools such as QuickCheck and HUnit but to make a project's +tests more useful when things are in an inconsistent state. TBC is +also useful for supporting 'what-if' experiments, aiding program +comprehension. + +TBC is presently alpha. It has proven useful to the authors but is +embryonic in many ways. + +The directory 'Sample/' contains a sample project following TBC +conventions. We suggest running 'tbc' in that directory as a quick way +of understanding what it can do. + +== Conventions == + +Tests live in $PROJECT/Tests. Test-specific hierarchical modules can +also exist there. + +Within a test file, lines beginning with _ should _ when evaluated: + +"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. +"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". + +The tests themselves must ensure the test framework (QuickCheck, etc.) +is in scope, i.e. be executable as they are in GHCi. + +The 'tbc' executable will search upwards for a '.cabal' file and +assumes the 'dist/' directory is in the same place. + +== Invocation == + +There are two ways to use TBC: + +- as a Cabal 'test' hook. This is not recommended as packages that do + this cannot be uploaded to hackage. Perhaps changes in Cabal will + make this more useful. + +- invoking the 'tbc' executable. + +The 'tbc' executable will search upwards in the directory hierarchy +for a .cabal file, and then go looking for tests in the current +directory and its children. + +Presently it is best to run 'tbc' in the directory containing the +tests (or a subdirectory of it). + +== Gotchas == + +Say: + +tbc -v + +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. + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TBC.cabal b/TBC.cabal new file mode 100644 --- /dev/null +++ b/TBC.cabal @@ -0,0 +1,39 @@ +Name: TBC +Version: 0.0.1 +Cabal-version: >= 1.7 +Build-type: Simple +Copyright: Peter Gammie, Mark Wotton +Maintainer: peteg42@gmail.com +Author: Peter Gammie, Mark Wotton +License: BSD3 +License-file: LICENSE +Synopsis: Testing By Convention +Category: Testing +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. + +Extra-Source-Files: README + +source-repository head + type: git + location: git://github.com/peteg/TBC.git + +Library + Build-depends: base >= 4 && < 5, Cabal, directory, filepath, process + Extensions: + Ghc-options: -Wall + Exposed-Modules: Test.TBC + Other-modules: + Test.TBC.Convention + Test.TBC.Core + Test.TBC.Drivers + Test.TBC.Renderers + +Executable tbc + Build-depends: base, Cabal, directory, filepath, process, unix + Extensions: + Ghc-options: -Wall + main-is: Test/Main.hs diff --git a/Test/Main.hs b/Test/Main.hs new file mode 100644 --- /dev/null +++ b/Test/Main.hs @@ -0,0 +1,140 @@ +{- Test By Convention: executable top-level. + - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com + - License : BSD3 + -} +module Main ( main ) where + +------------------------------------------------------------------- +-- Dependencies. +------------------------------------------------------------------- + +import Control.Monad ( unless, when ) +import Data.List ( foldl', isSuffixOf ) + +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 System.Directory ( getCurrentDirectory, getDirectoryContents, setCurrentDirectory ) +import System.Exit -- ( ExitFailure, exitWith ) +import System.Environment ( getArgs, getProgName ) +import System.FilePath -- ( takeDirectory ) -- FIXME + +import qualified System.Console.GetOpt as GetOpt + +import Test.TBC + +------------------------------------------------------------------- +-- TBC-as-an-executable. +------------------------------------------------------------------- + +-- | Find a @.cabal@ file that might apply to the current +-- directory. FIXME robustness? Windows? Efficiency? +-- Also want to dodge the ~/.cabal directory. +-- FIXME repair relPath +findCabal :: IO (Maybe (FilePath, FilePath, FilePath)) +findCabal = getCurrentDirectory >>= searchUp ["."] . splitPath + where + searchUp :: [FilePath] -> [FilePath] -> IO (Maybe (FilePath, FilePath, FilePath)) + searchUp relPath path = + do fs <- getDirectoryContents curdir + case filter (".cabal" `isSuffixOf`) fs of + [] -> case nextPath of + [] -> return Nothing + _ -> searchUp (last path : relPath) nextPath + [cabal] -> return (Just (joinPath relPath, curdir, cabal)) + fs' -> error $ "FIXME: several cabal files found: " ++ show fs' + where + curdir = joinPath path + nextPath = init path + +---------------------------------------- + +-- | Program arguments. +data Options = + Options + { optVerbosity :: Verbosity + } deriving Show + +defaultOptions :: Options +defaultOptions = + Options + { optVerbosity = normal + } + +-- | FIXME use intToVerbosity +options :: [GetOpt.OptDescr (Options -> Options)] +options = + [ GetOpt.Option ['v'] ["verbose"] + (GetOpt.NoArg (\ opts -> opts { optVerbosity = verbose })) + "chatty output on stdout" + ] + +progOpts :: [String] -> IO (Options, [String]) +progOpts argv = + case GetOpt.getOpt GetOpt.Permute options argv of + (o, n, [] ) -> return (foldl' (flip id) defaultOptions o, n) + (_, _, errs) -> + do progName <- getProgName + ioError (userError (concat errs ++ GetOpt.usageInfo (header progName) options)) + where header progName = "Usage: " ++ progName ++ " [OPTION...] files..." + +---------------------------------------- + +-- | FIXME infinite room for improvement. +-- FIXME Make use of the options +main :: IO () +main = + do (opts, tests) <- progOpts =<< getArgs + + debug (optVerbosity opts) $ "Options: " ++ show opts + unless (null tests) $ putStrLn $ "Testing: " ++ show tests + + cabalLoc <- findCabal + case cabalLoc of + Nothing -> + do putStrLn ".cabal file not found." + exitWith (ExitFailure 1) + Just (testPath, root, cabalFile) -> + do + info (optVerbosity opts) $ + "Running tests with Cabal file: '" ++ cabalFile ++ "' in directory: " ++ testPath + -- Change to the project root directory + setCurrentDirectory root + when (optVerbosity opts >= deafening) $ + getCurrentDirectory >>= \s -> putStrLn $ "In directory: " ++ s + + -- 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 + let pkg_descr = localPkgDescr localbuildinfo + + let ts = case tests of + [] -> [ testPath ] + _ -> [ testPath t | t <- tests ] + + tbcCabal (optVerbosity opts) ts False pkg_descr localbuildinfo + where hooks = error "FIXME Simple only for now." + +---------------------------------------- + +-- Ripped from Cabal. *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 { + withPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (withPrograms lbi) + } + where hooks = emptyUserHooks diff --git a/Test/TBC.hs b/Test/TBC.hs new file mode 100644 --- /dev/null +++ b/Test/TBC.hs @@ -0,0 +1,125 @@ +{- Test By Convention: Top-level drivers. + - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com + - License : BSD3 + -} +module Test.TBC + ( -- * FIXME Conventions, data structures. + module Conv + , module Core + , module Drivers + + -- * Top-level drivers. + , tbc + , tbcWithHooks + , tbcCabal + , defaultMain + ) where + +------------------------------------------------------------------- +-- Dependencies. +------------------------------------------------------------------- + +import System.Exit ( exitFailure ) +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 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 +import Test.TBC.Renderers as Renderers +import Test.TBC.Core as Core + +------------------------------------------------------------------- +-- TBC-as-a-library. +------------------------------------------------------------------- + +-- | FIXME Bells and whistles driver. +-- FIXME invoke the renderer functions appropriately. +tbcWithHooks :: Conventions s -> RenderFns s -> Driver -> [FilePath] -> IO () +tbcWithHooks convs renderer driver testRoots = + ( rInitialState renderer + >>= traverseDirectories convs driver renderer testRoots + >>= rFinal renderer + >> return () + ) `catch` handler + where + handler e = putStrLn ("TBC: " ++ show e) + +-- | FIXME Conventional driver. +tbc :: Driver -> [FilePath] -> IO () +tbc = tbcWithHooks Conv.std (Renderers.quiet Core.normal) + +---------------------------------------- +-- Cabal support. +---------------------------------------- + +-- | Drop-in replacement for Cabal's 'Distribution.Simple.defaultMain'. +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? +tbcCabal :: Verbosity + -> DS.Args -- ^ Where are the tests (dirs and files)? + -> Bool -> PackageDescription -> LocalBuildInfo -> IO () +tbcCabal verbosity args _wtf pkg_descr localbuildinfo = + withLibLBI pkg_descr localbuildinfo $ \_lib clbi -> + do let + testRoots + | null args = ["Tests"] + | otherwise = args + + -- Find GHC + cmd = fmap programPath (lookupProgram ghcProgram (withPrograms localbuildinfo)) + + -- The tests are part of the package (from GHC's pov). + pkgid = packageId pkg_descr + + -- FIXME We only test the first thing. + buildInfo = head (allBuildInfo pkg_descr) + + -- FIXME hardwire the path? + -- This requires that the user invoked "Setup build". + cObjs = [ buildDir localbuildinfo c `replaceExtension` objExtension + | c <- cSources buildInfo ] + + flags = + ["-v1", "--interactive", "-package-name", display pkgid ] + ++ [ "-l" ++ extraLib | extraLib <- extraLibs buildInfo ] + ++ [ "-L" ++ extraLibDir | extraLibDir <- extraLibDirs buildInfo ] + ++ cObjs + ++ ghcOptions localbuildinfo + buildInfo + clbi + (buildDir localbuildinfo) + + case cmd of + Nothing -> putStrLn "GHC not found." + Just hc_cmd -> + do d <- 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 + + tbc d testRoots + hci_close d + return () diff --git a/Test/TBC/Convention.hs b/Test/TBC/Convention.hs new file mode 100644 --- /dev/null +++ b/Test/TBC/Convention.hs @@ -0,0 +1,173 @@ +{- Test By Convention: the conventions themselves. + - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com + - License : BSD3 + - + - Idea is to apply each of these tests to each line of a 'TestFile' + - and collate the resulting 'TestSuite'. + - + - FIXME Import qualified. + - FIXME tests that appear in block comments {- -} are still picked up. + - FIXME we'd really like an EDSL here. + -} +module Test.TBC.Convention + ( booltest + , exception + , hunit + , quickcheck +-- , convention_mainPlannedTestSuite +-- , convention_mainTestGroup +-- , convention_main + , std + ) where + +------------------------------------------------------------------- +-- Dependencies. +------------------------------------------------------------------- + +import Data.List -- ( isPrefixOf ) +import System.FilePath ( splitPath, takeExtension ) + +import Test.TBC.Drivers ( Driver(..) ) +import Test.TBC.Core + +------------------------------------------------------------------- +-- Directory conventions. +------------------------------------------------------------------- + +-- | Skip the @.darcs@ and @.git@ directories. +-- FIXME could imagine trying to skip subproject directories. +stdDirectoryConv :: DirectoryConvention s +stdDirectoryConv fulldir s + | dir `elem` [".darcs", ".git"] = (Skip, s) + | otherwise = (Cont, s) + where dir = last (splitPath fulldir) + +------------------------------------------------------------------- +-- TestFile conventions. +------------------------------------------------------------------- + +stdTestFileConv :: TestFileConvention s +stdTestFileConv f s + | ext `elem` [".hs", ".lhs"] = (Cont, s) + | otherwise = (Skip, s) + where + ext = takeExtension f + +------------------------------------------------------------------- +-- Test conventions. +------------------------------------------------------------------- + +findException :: [String] -> Bool +findException ls = "*** Exception:" `isPrefixOf` last ls + || "_exception ::" `isPrefixOf` last ls + +findTrue :: [String] -> Bool +findTrue ls = show True == last ls + +---------------------------------------- + +-- | 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'. +booltest :: TestConvention +booltest a@('t':'e':'s':'t':'_':_) = Just run_booltest + where + name = mkTestName a + + run_booltest d = + do r <- hci_send_cmd d $ "seq " ++ name ++ " " ++ name ++ "\n" + return $ if findTrue r + then TestResultSuccess + else TestResultFailure r + +booltest _ = Nothing + +---------------------------------------- + +-- | The test should throw an exception. +exception :: TestConvention +exception a@('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 $ "seq " ++ name ++ " ()\n" + return $ if findException r + then TestResultSuccess + else TestResultFailure r + +exception _ = Nothing + +---------------------------------------- + +-- | A HUnit unit test. +hunit :: TestConvention +hunit a@('h':'u':'n':'i':'t':'_':_) = Just run_hunit_all + where + name = mkTestName a + + run_hunit_all d = do + r <- hci_send_cmd d ("seq " ++ name ++ " $ runTestTT $ test " ++ name ++ "\n") + return $ if findOK r + then TestResultSuccess + else TestResultFailure r + + findOK ls = "errors = 0, failures = 0" `isInfixOf` last ls + +hunit _ = Nothing + +---------------------------------------- + +quickcheck :: TestConvention +quickcheck a@('p':'r':'o':'p':'_':_) = Just run_quickcheck_test + where + name = mkTestName a + + run_quickcheck_test d = + do r <- hci_send_cmd d $ "test " ++ name ++ "\n" + return $ if findOK r + then TestResultSuccess + else TestResultFailure r + + -- FIXME what's going on here? + findOK ls = ", passed" `isInfixOf` last ls + +quickcheck _ = Nothing + +---------------------------------------- + +-- | The test should terminate without throwing an exception. +-- FIXME we really need a DeepSeq here to be sure. +oktest :: TestConvention +oktest a@('o':'k':_) = Just run_oktest + where + name = mkTestName a + + run_oktest d = + do r <- hci_send_cmd d $ "seq " ++ name ++ " True\n" + return $ if findTrue r + then TestResultSuccess + else TestResultFailure r + +oktest _ = Nothing + +---------------------------------------- + +std :: Conventions s +std = Conventions + { cDirectory = stdDirectoryConv + , cTestFile = stdTestFileConv + , cTests = [booltest, exception, hunit, oktest, quickcheck] + } + +{- +FIXME + +This logic requires an overhaul of the types: + + - if you define mainPlannedTestSuite :: (Plan Int, IO TestSuiteResult), we assume you need control and we'll run it and merge the TAP with other tests. (also mainTestSuite) + - elsif you define mainTestGroup :: (Plan Int, IO TestGroupResult), we assume you need control and we'll run it and merge the TAP with other tests. + - elsif you define main :: IO (), we'll treat it as a single test that's passed if it compiles and runs without an exception (?) -- quick and dirty. +-} diff --git a/Test/TBC/Core.hs b/Test/TBC/Core.hs new file mode 100644 --- /dev/null +++ b/Test/TBC/Core.hs @@ -0,0 +1,208 @@ +{- Test By Convention: core types and functions. + - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com + - License : BSD3 + -} +module Test.TBC.Core + ( DirectoryConvention + , TestFileConvention + , TestConvention + , Action(..) + , Test(..) + , Result(..) + , Renderer + , RenderFns(..) + , Conventions(..) + + , Verbosity + , silent, normal, verbose, deafening + , warn, notice, setupMessage, info, debug + + , Location(..) + , mkLocation + , mkTestName + + , traverseDirectories + , applyTestConventions + ) where + +------------------------------------------------------------------- +-- Dependencies. +------------------------------------------------------------------- + +import Control.Monad ( liftM, foldM ) + +import Data.Char ( isAlpha, isDigit ) +import Data.List ( nubBy ) +import Data.Maybe ( catMaybes ) + +import Distribution.Simple.Utils ( warn, notice, setupMessage, info, debug ) +import Distribution.Verbosity ( Verbosity, silent, normal, verbose, deafening ) + +import System.Directory ( Permissions(searchable), getDirectoryContents, getPermissions ) +import System.FilePath ( () ) + +import Test.TBC.Drivers ( Driver(hci_load_file) ) + +------------------------------------------------------------------- +-- Individual tests. +------------------------------------------------------------------- + +-- | Location of a 'Test'. +data Location + = Location + { lFile :: FilePath + , lLine :: Int + , lColumn :: Int + } + +mkLocation :: FilePath -> Int -> Int -> Location +mkLocation = Location + +instance Show Location where + show l = lFile l ++ ":" ++ show (lLine l) ++ ":" ++ show (lColumn l) + +-- | Discern a test name from a string, viz the entirety of the varid +-- 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` ['_', '\'']) ])) + +-- | A single test. +data Test + = Test + { tName :: String -- ^ Each 'Test' in a 'TestFile' must have a different name. + , tLocation :: Location + , tRun :: Driver -> IO Result + } + +-- | 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] } + deriving (Show) + +------------------------------------------------------------------- +-- Test output renderers. +------------------------------------------------------------------- + +-- | A renderer maps a verbosity level into a bunch of functions that +-- tells the user of various events. +type Renderer s = Verbosity -> RenderFns s + +data RenderFns s + = RenderFns + { rInitialState :: IO s + , rCompilationFailure :: FilePath -- ^ TestFile + -> [Test] -- ^ Tests in the file + -> [String] -- ^ Output from the Haskell system + -> 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 + , rTest :: Test + -> s + -> Result + -> IO s + , rFinal :: s -> IO s + } + +------------------------------------------------------------------- +-- Conventions. +-- FIXME some might like some IO's sprinkled in here. +------------------------------------------------------------------- + +-- | FIXME +data Action = Stop | Skip | Cont + +-- | A /directory convention/ maps a directory name into an action. +type DirectoryConvention s = FilePath -> s -> (Action, s) + +-- | A /test file convention/ maps a file name into an action. +type TestFileConvention s = FilePath -> s -> (Action, s) + +-- | A /test convention/ maps a line in a 'TestFile' into a function +-- that runs the test. +type TestConvention = String -> Maybe (Driver -> IO Result) + +-- | A collection of conventions. +data Conventions s + = Conventions + { cDirectory :: DirectoryConvention s + , cTestFile :: TestFileConvention s + , cTests :: [TestConvention] + } + +------------------------------------------------------------------- +-- Directory traversal. +------------------------------------------------------------------- + +-- | Visit all files in a directory tree. +-- FIXME try to eliminate the "." with some refactoring. +traverseDirectories :: Conventions s -> Driver -> RenderFns s -> [FilePath] -> s -> IO s +traverseDirectories convs driver renderer paths s0 = snd `liftM` walk s0 "." paths + where + fold s path = + case cDirectory convs path s of + (Cont, s') -> getUsefulContents path >>= walk s' path + (Skip, s') -> rSkip renderer path s >> return (Cont, s') + as'@(Stop, _s') -> rStop renderer path s >> return as' + + walk s _ [] = return (Cont, s) + walk s path (name:names) = + do let path' = path name + perms <- getPermissions path' + as'@(a, s') <- + if searchable perms + then fold s path' -- It's a directory, Jim. + else testFile convs driver renderer s path' -- It's a file. + case a of + Cont -> walk s' path names + _ -> return as' + + getUsefulContents :: FilePath -> IO [String] + getUsefulContents p = + filter (`notElem` [".", ".."]) `liftM` getDirectoryContents p + +-- | Execute all tests in a given test file, if it passes the +-- 'cTestFile' convention. +testFile :: Conventions s -> Driver -> RenderFns s -> s -> FilePath -> IO (Action, s) +testFile convs driver renderer s0 f = + case cTestFile convs f s0 of + as'@(Stop, _s) -> return as' -- Stop testing. + (Skip, s) -> + do rSkip renderer f s + return (Cont, s) -- ... but continue testing. + (Cont, s) -> + do -- putStrLn $ "Running: " ++ f + ts <- applyTestConventions (cTests convs) f `liftM` readFile f + mCout <- hci_load_file driver f + s' <- case mCout of + [] -> foldM runTest s ts + cout -> rCompilationFailure renderer f ts cout s + return (Cont, s') + where + runTest s t = tRun t driver >>= rTest renderer t s + +{- +This logic requires more work: + + - if you define mainPlannedTestSuite :: (Plan Int, IO TestSuiteResult), we assume you need control and we'll run it and merge the TAP with other tests. (also mainTestSuite) + - elsif you define mainTestGroup :: (Plan Int, IO TestGroupResult), we assume you need control and we'll run it and merge the TAP with other tests. + - elsif you define main :: IO (), we'll treat it as a single test that's passed if it compiles and runs without an exception (?) -- quick and dirty. +-} + +-- | Apply a list of conventions to the guts of a 'TestFile'. +applyTestConventions :: [TestConvention] -> FilePath -> String -> [Test] +applyTestConventions cs f = nubBy (eqOn tName) . catMaybes . applyCs . lines + where + applyCs ls = [ mkTest l lineNum `fmap` c l | (l, lineNum) <- zip ls [1..], c <- cs ] + eqOn p x y = p x == p y + + mkTest l lineNum trun = + Test { tName = mkTestName l + , tLocation = mkLocation f lineNum 0 + , tRun = trun + } diff --git a/Test/TBC/Drivers.hs b/Test/TBC/Drivers.hs new file mode 100644 --- /dev/null +++ b/Test/TBC/Drivers.hs @@ -0,0 +1,118 @@ +{- Test By Convention: Drivers. + - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com + - License : BSD3 + -} +module Test.TBC.Drivers + ( Driver(..) + , ghci + ) where + +------------------------------------------------------------------- +-- Dependencies. +------------------------------------------------------------------- + +import Control.Concurrent -- ( forkIO ) +import Control.Monad ( liftM ) + +import Data.List ( isInfixOf ) + +import Distribution.Simple.Utils ( info, debug ) +import Distribution.Verbosity ( Verbosity ) + +import System.Exit +import System.IO -- ( hClose, hFlush, hGetContents, hPutStr ) +import System.Process ( runInteractiveProcess, waitForProcess, terminateProcess ) + +------------------------------------------------------------------- + +-- | 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 + } + +---------------------------------------- + +-- | GHCi driver, 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 ] + , "----------------------------------------" ] + (hin, hout, herr, hpid) + <- runInteractiveProcess cmd flags Nothing Nothing -- FIXME + + -- Configure GHCi a bit FIXME + hPutStrLn hin ":set prompt \"\"" + hPutStrLn hin "GHC.Handle.hDuplicateTo System.IO.stdout System.IO.stderr" + + -- We don't use GHCi's stderr, get rid of it. + -- FIXME we maybe have to drain it first. + 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 $ 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 + waitForProcess hpid + } + +ghci_sync :: Verbosity + -> Handle -> Handle -> String -> IO [String] +ghci_sync verbosity hin hout inp = + do info verbosity $ + "--Sync----------------------------------\n" + ++ inp + ++ "----------------------------------------\n" + + -- FIXME do we really need the separate thread? + -- Get output + sync + outMVar <- newEmptyMVar + forkIO $ hc_sync hout >>= putMVar outMVar + + -- Tests + sync + hPutStr hin inp + hPutStr hin hc_sync_print + hFlush hin + + -- Synchronize + hc_output <- lint_output `liftM` takeMVar outMVar + + info verbosity $ + unlines ( ">> Output <<" : hc_output ) + + return hc_output + where + lint_output :: [[a]] -> [[a]] + lint_output = reverse . dropWhile null . reverse . dropWhile null + + done :: String + done = ">>>>done<<<<" + + hc_sync_print :: String + hc_sync_print = "System.IO.putStrLn \"" ++ done ++ "\"\n" + + -- FIXME EOF, exceptions, etc. + hc_sync :: Handle -> IO [String] + hc_sync h = sync + where + sync = + do l <- hGetLine h + info verbosity $ "hc>> " ++ l -- FIXME should be "debug" + if done `isInfixOf` l + then return [] + else (l:) `liftM` sync diff --git a/Test/TBC/Renderers.hs b/Test/TBC/Renderers.hs new file mode 100644 --- /dev/null +++ b/Test/TBC/Renderers.hs @@ -0,0 +1,155 @@ +{- Test By Convention: test output renderers. + - Copyright : (C)opyright 2009 {mwotton, peteg42} at gmail dot com + - License : BSD3 + -} +module Test.TBC.Renderers + ( tap + , quiet + ) where + +------------------------------------------------------------------- +-- Dependencies. +------------------------------------------------------------------- + +import Test.TBC.Core ( Renderer, RenderFns(..), Result(..), Test(..) + , info ) + +------------------------------------------------------------------- +-- TAP renderer. +------------------------------------------------------------------- + +-- FIXME what do all these fields mean? Some are rubbery. +data TapState + = TapState + { tsRun :: !Int + , tsPassed :: !Int -- ^ Number of tests passed + , tsToDo :: !Int -- ^ Number of tests run with result 'TestResultToDo' + , tsTestsSkipped :: !Int -- ^ Number of identified tests that got skipped + , tsTestFilesSkipped :: !Int -- ^ Number of potential test files that got skipped + , tsCompilationFailures :: !Int -- ^ Number of test files that failed to compile + } + +tapState0 :: TapState +tapState0 = TapState + { tsRun = 0 + , tsPassed = 0 + , tsToDo = 0 + , tsTestsSkipped = 0 + , tsTestFilesSkipped = 0 + , tsCompilationFailures = 0 + } + +tap :: Renderer TapState +tap verbosity = + RenderFns + { rInitialState = return tapState0 + , rCompilationFailure = tcf + , rSkip = tskip + , rStop = tstop + , rTest = tt + , rFinal = tf + } + where + tid i t = show i ++ " - " ++ show (tLocation t) ++ " " ++ tName t + + tcf f ts cout s = + do mapM_ putStrLn $ (("not ok # compilation failed: " ++ f) + : cout ) + ++ ( "# Tests skipped:" + : [ "# " ++ tName t | t <- ts ] ) + return s{ tsCompilationFailures = tsCompilationFailures s + 1 } + + tskip f s = + do info verbosity $ "Skipping " ++ f + return s{ tsTestFilesSkipped = tsTestFilesSkipped s + 1 } + + tstop f s = + do putStrLn $ "Stopping at " ++ f + return s + + tt t s r = + case r of + TestResultSkip -> + do putStrLn $ "ok " ++ tid i t ++ " # SKIP FIXME is this OK or not?" + return s{ tsTestsSkipped = tsTestsSkipped s + 1 } + TestResultToDo -> + do putStrLn $ "ok " ++ tid i t + return s{ tsToDo = tsToDo s + 1 } + TestResultStop -> + do putStrLn $ "ok " ++ tid i t ++ " # STOP FIXME is this OK or not?" + return s -- FIXME ???? + TestResultFailure strs -> + do mapM_ putStrLn $ ("not ok " ++ tid i t) + : [ '#':' ':l | l <- strs ] + return s{ tsRun = tsRun s + 1 } + TestResultSuccess -> + do putStrLn $ "ok " ++ tid i t + return s{ tsRun = tsRun s + 1 + , tsPassed = tsPassed s + 1 } + where + i = tsRun s + + tf s = + do putStrLn $ "0.." ++ show (tsRun s + tsTestsSkipped s - 1) + return s + +------------------------------------------------------------------- + +-- | UNIX style: only reports failures. +quiet :: Renderer TapState +quiet verbosity = + RenderFns + { rInitialState = return tapState0 + , rCompilationFailure = tcf + , rSkip = tskip + , rStop = tstop + , rTest = tt + , rFinal = tf + } + where + tid t = show (tLocation t) ++ " " ++ tName t + + tcf f _ts _cout s = + do putStrLn $ "** Compilation failed: " ++ f + return s{ tsCompilationFailures = tsCompilationFailures s + 1 } + + tskip f s = + do info verbosity $ "Skipping " ++ f + return s{ tsTestFilesSkipped = tsTestFilesSkipped s + 1 } + + tstop f s = + do putStrLn $ "Stopping at " ++ f + return s + + -- FIXME in a big way + tt t s r = + case r of + TestResultFailure strs -> + do mapM_ putStrLn $ ("** Test failed: " ++ tid t) + : [ '#':' ':l | l <- strs ] + return s{ tsRun = tsRun s + 1 } + TestResultSuccess -> + return s{ tsRun = tsRun s + 1 + , tsPassed = tsPassed s + 1 } + TestResultSkip -> + do putStrLn $ "ok " ++ tid t ++ " # SKIP FIXME is this OK or not?" + return s{ tsTestsSkipped = tsTestsSkipped s + 1 } + TestResultToDo -> + do putStrLn $ "ok " ++ tid t + return s{ tsToDo = tsToDo s + 1 } + TestResultStop -> + do putStrLn $ "ok " ++ tid t ++ " # STOP FIXME is this OK or not?" + return s -- FIXME ???? + + tf s = + do putStrLn $ "Passed " ++ show (tsPassed s) ++ " / " ++ show (tsRun s) + ++ skipped ++ cfail + return s + where + cfail + | tsCompilationFailures s == 0 = "" + | otherwise = " (Failed to compile " ++ show (tsCompilationFailures s) ++ ")" + + skipped + | tsTestsSkipped s == 0 = "" + | otherwise = " (Skipped " ++ show (tsTestsSkipped s) ++ ")"