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
import Control.Monad ( liftM, foldM )
import Data.Char ( isAlpha, isDigit, isSpace )
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.Exit ( ExitCode )
import System.FilePath ( (</>) )
import Test.TBC.Drivers ( Driver(hci_load_file) )
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)
mkTestName :: String -> String
mkTestName = takeWhile (\c -> or (map ($c) [ isAlpha, isDigit, (`elem` ['_', '\'']) ])) . unlit
where
unlit ('>':cs) = dropWhile isSpace cs
unlit str = str
data Test
= Test
{ tName :: String
, tLocation :: Location
, tRun :: Driver -> IO Result
}
data Result
= TestResultSkip
| TestResultToDo
| TestResultStop
| TestResultSuccess
| TestResultFailure { msg :: [String] }
deriving (Show)
type Renderer s = Verbosity -> RenderFns s
data RenderFns s
= RenderFns
{ rInitialState :: IO s
, rCompilationFailure :: FilePath
-> [Test]
-> [String]
-> s
-> IO s
, rSkip :: FilePath -> s -> IO s
, rStop :: FilePath -> s -> IO s
, rTest :: Test
-> s
-> Result
-> IO s
, rFinal :: s -> IO ExitCode
}
data Action
= Stop
| Skip
| Cont
type DirectoryConvention s = FilePath -> s -> (Action, s)
type TestFileConvention s = FilePath -> s -> (Action, s)
type TestConvention = String -> Maybe (Driver -> IO Result)
data Conventions s
= Conventions
{ cDirectory :: DirectoryConvention s
, cTestFile :: TestFileConvention s
, cTests :: [TestConvention]
}
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'
else testFile convs driver renderer s path'
case a of
Cont -> walk s' path names
_ -> return as'
getUsefulContents :: FilePath -> IO [String]
getUsefulContents p =
filter (`notElem` [".", ".."]) `liftM` getDirectoryContents p
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'
(Skip, s) ->
do _ <-rSkip renderer f s
return (Cont, s)
(Cont, s) ->
do
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
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
}