module Test.HUnit.Text
(
PutText(..),
putTextToHandle, putTextToShowS,
runTestText,
showPath, showCounts,
runTestTT,
runTestTTAndExit
)
where
import Test.HUnit.Base
import Data.CallStack
import Control.Monad (when)
import System.IO (Handle, stderr, hPutStr, hPutStrLn)
import System.Exit (exitSuccess, exitFailure)
data PutText st = PutText (String -> Bool -> st -> IO st) st
putTextToHandle
:: Handle
-> Bool
-> PutText Int
putTextToHandle :: Handle -> Bool -> PutText Int
putTextToHandle Handle
handle Bool
showProgress = (String -> Bool -> Int -> IO Int) -> Int -> PutText Int
forall st. (String -> Bool -> st -> IO st) -> st -> PutText st
PutText String -> Bool -> Int -> IO Int
put Int
initCnt
where
initCnt :: Int
initCnt = if Bool
showProgress then Int
0 else -Int
1
put :: String -> Bool -> Int -> IO Int
put String
line Bool
pers (-1) = do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pers (Handle -> String -> IO ()
hPutStrLn Handle
handle String
line); Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (-Int
1)
put String
line Bool
True Int
cnt = do Handle -> String -> IO ()
hPutStrLn Handle
handle (Int -> String
erase Int
cnt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
line); Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
put String
line Bool
False Int
_ = do Handle -> String -> IO ()
hPutStr Handle
handle (Char
'\r' Char -> String -> String
forall a. a -> [a] -> [a]
: String
line); Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
line)
erase :: Int -> String
erase Int
cnt = if Int
cnt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String
"" else String
"\r" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
cnt Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r"
putTextToShowS :: PutText ShowS
putTextToShowS :: PutText (String -> String)
putTextToShowS = (String -> Bool -> (String -> String) -> IO (String -> String))
-> (String -> String) -> PutText (String -> String)
forall st. (String -> Bool -> st -> IO st) -> st -> PutText st
PutText String -> Bool -> (String -> String) -> IO (String -> String)
forall (m :: * -> *) t.
Monad m =>
String -> Bool -> (String -> t) -> m (String -> t)
put String -> String
forall a. a -> a
id
where put :: String -> Bool -> (String -> t) -> m (String -> t)
put String
line Bool
pers String -> t
f = (String -> t) -> m (String -> t)
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
pers then (String -> t) -> String -> String -> t
forall t. (String -> t) -> String -> String -> t
acc String -> t
f String
line else String -> t
f)
acc :: (String -> t) -> String -> String -> t
acc String -> t
f String
line String
rest = String -> t
f (String
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest)
runTestText :: PutText st -> Test -> IO (Counts, st)
runTestText :: PutText st -> Test -> IO (Counts, st)
runTestText (PutText String -> Bool -> st -> IO st
put st
us0) Test
t = do
(Counts
counts', st
us1) <- ReportStart st
-> ReportProblem st
-> ReportProblem st
-> st
-> Test
-> IO (Counts, st)
forall us.
ReportStart us
-> ReportProblem us
-> ReportProblem us
-> us
-> Test
-> IO (Counts, us)
performTest ReportStart st
reportStart ReportProblem st
reportError ReportProblem st
reportFailure st
us0 Test
t
st
us2 <- String -> Bool -> st -> IO st
put (Counts -> String
showCounts Counts
counts') Bool
True st
us1
(Counts, st) -> IO (Counts, st)
forall (m :: * -> *) a. Monad m => a -> m a
return (Counts
counts', st
us2)
where
reportStart :: ReportStart st
reportStart State
ss st
us = String -> Bool -> st -> IO st
put (Counts -> String
showCounts (State -> Counts
counts State
ss)) Bool
False st
us
reportError :: ReportProblem st
reportError = String -> String -> ReportProblem st
reportProblem String
"Error:" String
"Error in: "
reportFailure :: ReportProblem st
reportFailure = String -> String -> ReportProblem st
reportProblem String
"Failure:" String
"Failure in: "
reportProblem :: String -> String -> ReportProblem st
reportProblem String
p0 String
p1 Maybe SrcLoc
loc String
msg State
ss st
us = String -> Bool -> st -> IO st
put String
line Bool
True st
us
where line :: String
line = String
"### " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
kind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe SrcLoc -> String
formatLocation Maybe SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
kind :: String
kind = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path' then String
p0 else String
p1
path' :: String
path' = Path -> String
showPath (State -> Path
path State
ss)
formatLocation :: Maybe SrcLoc -> String
formatLocation :: Maybe SrcLoc -> String
formatLocation Maybe SrcLoc
Nothing = String
""
formatLocation (Just SrcLoc
loc) = SrcLoc -> String
srcLocFile SrcLoc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (SrcLoc -> Int
srcLocStartLine SrcLoc
loc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
showCounts :: Counts -> String
showCounts :: Counts -> String
showCounts Counts{ cases :: Counts -> Int
cases = Int
cases', tried :: Counts -> Int
tried = Int
tried',
errors :: Counts -> Int
errors = Int
errors', failures :: Counts -> Int
failures = Int
failures' } =
String
"Cases: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
cases' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Tried: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tried' String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" Errors: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
errors' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Failures: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
failures'
showPath :: Path -> String
showPath :: Path -> String
showPath [] = String
""
showPath Path
nodes = (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 String -> String -> String
f ((Node -> String) -> Path -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Node -> String
showNode Path
nodes)
where f :: String -> String -> String
f String
b String
a = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b
showNode :: Node -> String
showNode (ListItem Int
n) = Int -> String
forall a. Show a => a -> String
show Int
n
showNode (Label String
label) = String -> String -> String
safe String
label (String -> String
forall a. Show a => a -> String
show String
label)
safe :: String -> String -> String
safe String
s String
ss = if Char
':' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s Bool -> Bool -> Bool
|| String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
ss then String
ss else String
s
runTestTT :: Test -> IO Counts
runTestTT :: Test -> IO Counts
runTestTT Test
t = do (Counts
counts', Int
0) <- PutText Int -> Test -> IO (Counts, Int)
forall st. PutText st -> Test -> IO (Counts, st)
runTestText (Handle -> Bool -> PutText Int
putTextToHandle Handle
stderr Bool
True) Test
t
Counts -> IO Counts
forall (m :: * -> *) a. Monad m => a -> m a
return Counts
counts'
runTestTTAndExit :: Test -> IO ()
runTestTTAndExit :: Test -> IO ()
runTestTTAndExit Test
tests = do
Counts
c <- Test -> IO Counts
runTestTT Test
tests
if (Counts -> Int
errors Counts
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) Bool -> Bool -> Bool
&& (Counts -> Int
failures Counts
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
then IO ()
forall a. IO a
exitSuccess
else IO ()
forall a. IO a
exitFailure