packages feed

TBC (empty) → 0.0.1

raw patch · 10 files changed

+1070/−0 lines, 10 filesdep +Cabaldep +basedep +directorysetup-changed

Dependencies added: Cabal, base, directory, filepath, process, unix

Files

+ LICENSE view
@@ -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.
+ README view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ TBC.cabal view
@@ -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
+ Test/Main.hs view
@@ -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
+ Test/TBC.hs view
@@ -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 ()
+ Test/TBC/Convention.hs view
@@ -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.+-}
+ Test/TBC/Core.hs view
@@ -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+             }
+ Test/TBC/Drivers.hs view
@@ -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
+ Test/TBC/Renderers.hs view
@@ -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) ++ ")"