module Test.Hspec.Runner (
hspec
, hspecWith
, hspecResult
, hspecWithResult
, Summary (..)
, Config (..)
, ColorMode (..)
, Path
, defaultConfig
, configAddFilter
) where
import Control.Monad
import Control.Applicative
import Data.Monoid
import Data.Maybe
import System.IO
import System.Environment (getProgName, getArgs, withArgs)
import System.Exit
import qualified Control.Exception as E
import System.Console.ANSI (hHideCursor, hShowCursor)
import qualified Test.QuickCheck as QC
import Control.Monad.IO.Class (liftIO)
import Test.Hspec.Compat (lookupEnv)
import Test.Hspec.Util (Path)
import Test.Hspec.Core.Type
import Test.Hspec.Config
import Test.Hspec.Formatters
import Test.Hspec.Formatters.Internal
import Test.Hspec.FailureReport
import Test.Hspec.Core.QuickCheckUtil
import Test.Hspec.Runner.Tree
import Test.Hspec.Runner.Eval
filterSpecs :: Config -> [Tree Item] -> [Tree Item]
filterSpecs c = go []
where
p :: Path -> Bool
p = fromMaybe (const True) (configFilterPredicate c)
go :: [String] -> [Tree Item] -> [Tree Item]
go groups = mapMaybe (goSpec groups)
goSpecs :: [String] -> [Tree Item] -> ([Tree Item] -> a) -> Maybe a
goSpecs groups specs ctor = case go groups specs of
[] -> Nothing
xs -> Just (ctor xs)
goSpec :: [String] -> Tree Item -> Maybe (Tree Item)
goSpec groups spec = case spec of
Leaf item -> guard (p (groups, itemRequirement item)) >> return spec
Node group specs -> goSpecs (groups ++ [group]) specs (Node group)
NodeWithCleanup action specs -> goSpecs groups specs (NodeWithCleanup action)
applyDryRun :: Config -> [Tree Item] -> [Tree Item]
applyDryRun c
| configDryRun c = map (removeCleanup . fmap markSuccess)
| otherwise = id
where
markSuccess :: Item -> Item
markSuccess item = item {itemExample = evaluateExample Success}
removeCleanup :: Tree Item -> Tree Item
removeCleanup spec = case spec of
Node x xs -> Node x (map removeCleanup xs)
NodeWithCleanup _ xs -> NodeWithCleanup (return ()) (map removeCleanup xs)
leaf@(Leaf _) -> leaf
hspec :: Spec -> IO ()
hspec = hspecWith defaultConfig
ensureSeed :: Config -> IO Config
ensureSeed c = case configQuickCheckSeed c of
Nothing -> do
seed <- newSeed
return c {configQuickCheckSeed = Just (fromIntegral seed)}
_ -> return c
hspecWith :: Config -> Spec -> IO ()
hspecWith conf spec = do
r <- hspecWithResult conf spec
unless (summaryFailures r == 0) exitFailure
hspecResult :: Spec -> IO Summary
hspecResult = hspecWithResult defaultConfig
hspecWithResult :: Config -> Spec -> IO Summary
hspecWithResult conf spec = do
prog <- getProgName
args <- getArgs
c <- getConfig conf prog args >>= ensureSeed
withArgs [] $ withHandle c $ \h -> do
let formatter = fromMaybe specdoc (configFormatter c)
seed = (fromJust . configQuickCheckSeed) c
qcArgs = configQuickCheckArgs c
useColor <- doesUseColor h c
filteredSpec <- filterSpecs c . applyDryRun c <$> toTree spec
withHiddenCursor useColor h $
runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) seed h $ do
runFormatter useColor h c formatter filteredSpec `finally_` do
failedFormatter formatter
footerFormatter formatter
xs <- map failureRecordPath <$> getFailMessages
liftIO $ writeFailureReport FailureReport {
failureReportSeed = seed
, failureReportMaxSuccess = QC.maxSuccess qcArgs
, failureReportMaxSize = QC.maxSize qcArgs
, failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs
, failureReportPaths = xs
}
Summary <$> getTotalCount <*> getFailCount
where
withHiddenCursor :: Bool -> Handle -> IO a -> IO a
withHiddenCursor useColor h
| useColor = E.bracket_ (hHideCursor h) (hShowCursor h)
| otherwise = id
doesUseColor :: Handle -> Config -> IO Bool
doesUseColor h c = case configColorMode c of
ColorAuto -> (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb)
ColorNever -> return False
ColorAlways -> return True
withHandle :: Config -> (Handle -> IO a) -> IO a
withHandle c action = case configOutputFile c of
Left h -> action h
Right path -> withFile path WriteMode action
isDumb :: IO Bool
isDumb = maybe False (== "dumb") <$> lookupEnv "TERM"
data Summary = Summary {
summaryExamples :: Int
, summaryFailures :: Int
} deriving (Eq, Show)
instance Monoid Summary where
mempty = Summary 0 0
(Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)