module Test.TBC.Convention
( booltest
, exception
, hunit
, quickcheck
, stdDirectoryConv, stdTestFileConv, std
) where
import Data.List
import Data.Char (isSpace)
import System.FilePath ( splitPath, takeExtension, takeFileName )
import Test.TBC.Drivers ( Driver(..) )
import Test.TBC.Core
stdDirectoryConv :: DirectoryConvention s
stdDirectoryConv fulldir s
| dir `elem` [".darcs", ".git", "dist"] = (Skip, s)
| otherwise = (Cont, s)
where dir = last (splitPath fulldir)
stdTestFileConv :: TestFileConvention s
stdTestFileConv f s
| takeFileName f == "Setup.hs" = (Skip, s)
| ext `elem` [".hs", ".lhs"] = (Cont, s)
| otherwise = (Skip, s)
where
ext = takeExtension f
findException :: [String] -> Bool
findException [] = False
findException ls = "*** Exception:" `isPrefixOf` last ls
|| "_exception ::" `isPrefixOf` last ls
findTrue :: [String] -> Bool
findTrue [] = False
findTrue ls = show True == last ls
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
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
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
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 [] = False
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.QuickCheck.quickCheck " ++ name ++ "\n"
return $ if findOK r
then TestResultSuccess
else TestResultFailure r
findOK [] = False
findOK ls = ", passed" `isInfixOf` last ls
quickcheck _ = Nothing
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
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
std :: Conventions s
std = Conventions
{ cDirectory = stdDirectoryConv
, cTestFile = stdTestFileConv
, cTests = map unlittest tests
}
where
unlittest :: TestConvention -> TestConvention
unlittest c ('>':ln) = c $ dropWhile isSpace ln
unlittest c ln = c ln
tests = [booltest, deep_exception, exception, hunit, deep_oktest, oktest, quickcheck]