module Test.Hspec.Internal where
import System.IO
import System.Exit
import Data.List (mapAccumL, groupBy, intersperse)
import System.CPUTime (getCPUTime)
import Text.Printf
import Control.Exception
import Control.Monad (liftM)
data Result = Success | Fail String | Pending String
deriving Eq
data Spec = Spec {
name::String,
requirement::String,
result::Result }
describe :: String
-> [IO (String, Result)]
-> IO [Spec]
describe n ss = do
ss' <- sequence ss
return $ map (\ (req, res) -> Spec n req res) ss'
descriptions :: [IO [Spec]] -> IO [Spec]
descriptions = liftM concat . sequence
safely :: Result -> IO Result
safely f = Control.Exception.catch ok failed
where ok = f `seq` return f
failed e = return $ Fail (show (e :: SomeException))
class SpecVerifier a where
it :: String
-> a
-> IO (String, Result)
instance SpecVerifier Bool where
it description example = do
r <- safely (if example then Success else Fail "")
return (description, r)
instance SpecVerifier Result where
it description example = return (description, example)
pending :: String
-> Result
pending = Pending
documentSpecs :: [Spec] -> [String]
documentSpecs specs = lines $ unlines $ concat report ++ [""] ++ intersperse "" errors
where organize = groupBy (\ a b -> name a == name b)
(errors, report) = mapAccumL documentGroup [] $ organize specs
documentGroup :: [String] -> [Spec] -> ([String], [String])
documentGroup errors specGroup = (errors', "" : name (head specGroup) : report)
where (errors', report) = mapAccumL documentSpec errors specGroup
documentSpec :: [String] -> Spec -> ([String], String)
documentSpec errors spec = case result spec of
Success -> (errors, " - " ++ requirement spec)
Fail s -> (errors ++ [errorDetails s], " x " ++ requirement spec ++ errorTag)
Pending s -> (errors, " - " ++ requirement spec ++ "\n # " ++ s)
where errorTag = " [" ++ (show $ length errors + 1) ++ "]"
errorDetails s = concat [ show (length errors + 1), ") ", name spec,
" ", requirement spec, " FAILED",
if null s then "" else "\n" ++ s ]
timingSummary :: Double -> String
timingSummary t = printf "Finished in %1.4f seconds" (t / (10.0^(12::Integer)) :: Double)
failedCount :: [Spec] -> Int
failedCount ss = length $ filter (isFailure.result) ss
where
isFailure (Fail _) = True
isFailure _ = False
successSummary :: [Spec] -> String
successSummary ss = quantify (length ss) "example" ++ ", " ++ quantify (failedCount ss) "failure"
pureHspec :: [Spec]
-> [String]
pureHspec = fst . pureHspecB
pureHspecB :: [Spec]
-> ([String], Bool)
pureHspecB ss = (report, failedCount ss == 0)
where report = documentSpecs ss ++ [ "", timingSummary 0, "", successSummary ss]
hspec :: IO [Spec] -> IO ()
hspec ss = hspecB ss >> return ()
hspecB :: IO [Spec] -> IO Bool
hspecB = hHspec stdout
hspecX :: IO [Spec] -> IO a
hspecX ss = hspecB ss >>= exitWith . toExitCode
toExitCode :: Bool -> ExitCode
toExitCode True = ExitSuccess
toExitCode False = ExitFailure 1
hHspec :: Handle
-> IO [Spec]
-> IO Bool
hHspec h ss = do
t0 <- getCPUTime
ss' <- ss
mapM_ (hPutStrLn h) $ documentSpecs ss'
t1 <- getCPUTime
mapM_ (hPutStrLn h) [ "", timingSummary (fromIntegral $ t1 t0), "", successSummary ss']
return $ failedCount ss' == 0
quantify :: Num a => a -> String -> String
quantify 1 s = "1 " ++ s
quantify n s = show n ++ " " ++ s ++ "s"