module Test.HUnitPlus.Text(
PutText(..),
putTextToHandle,
putTextToShowS,
showCounts,
textReporter,
runTestText,
runSuiteText,
runSuitesText,
terminalReporter,
runTestTT,
runSuiteTT,
runSuitesTT
) where
import Distribution.TestSuite
import Test.HUnitPlus.Base
import Test.HUnitPlus.Execution
import Test.HUnitPlus.Filter
import Test.HUnitPlus.Reporting
import Control.Monad (when)
import System.IO (Handle, stderr)
import Text.Printf(printf)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as Strict
import qualified Data.Text.IO as Strict
data PutText st = PutText (Strict.Text -> st -> IO st) st
putTextToHandle :: Handle -> PutText ()
putTextToHandle handle = PutText (\line () -> Strict.hPutStr handle line) ()
putTextToShowS :: PutText (Strict.Text -> Strict.Text)
putTextToShowS =
PutText (\line func -> return (\rest -> func (Strict.concat [line, rest]))) id
textReporter :: PutText us
-> Bool
-> Reporter us
textReporter (PutText put initUs) verbose =
let
reportProblem prefix msg ss us =
let
path = showQualName ss
line = Strict.concat ["### ", prefix, path, ": ", msg, "\n"]
in
put line us
reportOutput prefix msg ss us =
let
path = showQualName ss
line = Strict.concat ["### ", prefix, path, ": ", msg, "\n"]
in
if verbose then put line us else return us
reportStartSuite ss us =
let
line = Strict.concat ["Test suite ", stName ss, " starting\n"]
in
if verbose then put line us else return us
reportEndSuite time ss us =
let
timestr = printf "%.6f" time
line = Strict.concat ["Test suite", stName ss, " completed in ",
Strict.pack timestr, " sec\n"]
in
if verbose then put line us else return us
reportStartCase ss us =
let
path = showQualName ss
line = if Strict.null path then "Test case starting\n"
else Strict.concat ["Test case ", path, " starting\n"]
in
if verbose then put line us else return us
reportEndCase time ss us =
let
path = showQualName ss
timestr = printf "%.6f" time
line = if Strict.null path
then Strict.concat ["Test completed in ",
Strict.pack timestr, " sec\n"]
else Strict.concat ["Test ", path, " completed in ",
Strict.pack timestr, " sec\n"]
in
if verbose then put line us else return us
reportEnd time counts us =
let
countstr = Strict.concat [showCounts counts, "\n"]
timestr = printf "%.6f" time
timeline = Strict.concat ["Tests completed in ",
Strict.pack timestr, " sec\n"]
in do
if verbose
then do
us' <- put timeline us
put countstr us'
else put countstr us
in
defaultReporter {
reporterStart = return initUs,
reporterEnd = reportEnd,
reporterStartSuite = reportStartSuite,
reporterEndSuite = reportEndSuite,
reporterStartCase = reportStartCase,
reporterEndCase = reportEndCase,
reporterSystemOut = reportOutput "STDOUT from ",
reporterSystemErr = reportOutput "STDERR from ",
reporterError = reportProblem "Error in ",
reporterFailure = reportProblem "Failure in "
}
runTestText :: PutText us
-> Bool
-> Test
-> IO (Counts, us)
runTestText puttext @ (PutText put us0) verbose t =
let
initState = State { stCounts = zeroCounts, stName = "",
stPath = [], stOptions = HashMap.empty,
stOptionDescs = [] }
reporter = textReporter puttext verbose
in do
(ss1, us1) <- ((performTest $! reporter) allSelector $! initState) us0 t
us2 <- put (Strict.concat [showCounts (stCounts ss1), "\n"]) us1
return (stCounts ss1, us2)
runSuiteText :: PutText us
-> Bool
-> TestSuite
-> IO (Counts, us)
runSuiteText puttext @ (PutText put us0) verbose
suite @ TestSuite { suiteName = sname } =
let
selectorMap = HashMap.singleton sname (HashMap.singleton HashMap.empty
allSelector)
reporter = textReporter puttext verbose
in do
(counts, us1) <- ((performTestSuite $! reporter) $!selectorMap) us0 suite
us2 <- put (Strict.concat [showCounts counts, "\n"]) us1
return (counts, us2)
runSuitesText :: PutText us
-> Bool
-> [TestSuite]
-> IO (Counts, us)
runSuitesText puttext @ (PutText put _) verbose suites =
let
suiteNames = map suiteName suites
selectorMap =
foldl (\suitemap sname ->
HashMap.insert sname (HashMap.singleton HashMap.empty
allSelector) suitemap)
HashMap.empty suiteNames
reporter = textReporter puttext verbose
in do
(counts, us1) <- ((performTestSuites $! reporter) $! selectorMap) suites
us2 <- put (Strict.concat [showCounts counts, "\n"]) us1
return (counts, us2)
showCounts :: Counts -> Strict.Text
showCounts Counts { cCases = cases, cTried = tried,
cErrors = errors, cFailures = failures,
cAsserts = asserts, cSkipped = skipped } =
Strict.concat ["Cases: ", Strict.pack (show cases), " Tried: ",
Strict.pack (show tried), " Errors: ",
Strict.pack (show errors), " Failures: ",
Strict.pack (show failures), " Assertions: ",
Strict.pack (show asserts), " Skipped: ",
Strict.pack (show skipped)]
termPut :: Strict.Text -> Bool -> Int -> IO Int
termPut line pers (1) =
do
when pers (Strict.hPutStrLn stderr line)
return (1)
termPut line True cnt =
do
Strict.hPutStrLn stderr (Strict.concat [erase cnt, line])
return 0
termPut line False _ =
do
Strict.hPutStr stderr (Strict.concat ["\r", line])
return (Strict.length line)
erase :: Int -> Strict.Text
erase cnt =
if cnt == 0 then "" else Strict.concat ["\r", Strict.replicate cnt " ", "\r"]
terminalReporter :: Reporter Int
terminalReporter =
let
reportProblem prefix msg ss us =
let
line = Strict.concat ["### ", prefix, path, "\n", msg]
path = showQualName ss
in
termPut line True us
in
defaultReporter {
reporterStart = return 0,
reporterEnd = \_ _ _ -> do Strict.hPutStr stderr "\n"; return 0,
reporterEndCase = \_ ss us -> termPut (showCounts (stCounts ss)) False us,
reporterError = reportProblem "Error in: ",
reporterFailure = reportProblem "Failure in: "
}
runTestTT :: Test -> IO Counts
runTestTT t =
let
initState = State { stCounts = zeroCounts, stName = "",
stPath = [], stOptions = HashMap.empty,
stOptionDescs = [] }
in do
(ss1, us1) <- (performTest terminalReporter allSelector $! initState) 0 t
0 <- termPut (showCounts (stCounts ss1)) True us1
return (stCounts ss1)
runSuiteTT :: TestSuite -> IO Counts
runSuiteTT suite @ TestSuite { suiteName = sname } =
let
selectorMap = HashMap.singleton sname (HashMap.singleton HashMap.empty
allSelector)
in do
(counts, us) <- (performTestSuite terminalReporter $! selectorMap) 0 suite
0 <- termPut (Strict.concat [showCounts counts, "\n"]) True us
return counts
runSuitesTT :: [TestSuite] -> IO Counts
runSuitesTT suites =
let
suiteNames = map suiteName suites
selectorMap =
foldl (\suitemap sname ->
HashMap.insert sname (HashMap.singleton HashMap.empty
allSelector) suitemap)
HashMap.empty suiteNames
in do
(counts, us) <- (performTestSuites terminalReporter $! selectorMap) suites
0 <- termPut (Strict.concat [showCounts counts, "\n"]) True us
return counts