From af190658454ec84994650d1965e6862e3c7c56b0 Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 25 2020 13:52:21 +0000 Subject: ghc-hspec-core-2.4.4 base --- diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..8e79e73 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright (c) 2011-2017 Simon Hengel +Copyright (c) 2011-2012 Trystan Spangler +Copyright (c) 2011-2011 Greg Weber + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 index 0000000..5bde0de --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/hspec-core.cabal b/hspec-core.cabal new file mode 100644 index 0000000..ccb9b0d --- /dev/null +++ b/hspec-core.cabal @@ -0,0 +1,145 @@ +-- This file has been generated from package.yaml by hpack version 0.18.0. +-- +-- see: https://github.com/sol/hpack + +name: hspec-core +version: 2.4.4 +license: MIT +license-file: LICENSE +copyright: (c) 2011-2017 Simon Hengel, + (c) 2011-2012 Trystan Spangler, + (c) 2011 Greg Weber +maintainer: Simon Hengel +build-type: Simple +cabal-version: >= 1.10 +category: Testing +stability: experimental +bug-reports: https://github.com/hspec/hspec/issues +homepage: http://hspec.github.io/ +synopsis: A Testing Framework for Haskell +description: This package exposes internal types and functions that can be used to extend Hspec's functionality. + +source-repository head + type: git + location: https://github.com/hspec/hspec + subdir: hspec-core + +library + hs-source-dirs: + src + vendor + ghc-options: -Wall + build-depends: + base >= 4.5.0.0 && < 5 + , random + , tf-random + , setenv + , ansi-terminal >= 0.5 + , time + , transformers >= 0.2.2.0 + , deepseq + , HUnit >= 1.2.5 + , QuickCheck >= 2.5.1 + , quickcheck-io >= 0.2.0 + , hspec-expectations == 0.8.2.* + , async >= 2 + , call-stack + , directory + , filepath + , array + exposed-modules: + Test.Hspec.Core.Spec + Test.Hspec.Core.Hooks + Test.Hspec.Core.Runner + Test.Hspec.Core.Formatters + Test.Hspec.Core.QuickCheck + Test.Hspec.Core.Util + other-modules: + Test.Hspec.Core.Compat + Test.Hspec.Core.Config + Test.Hspec.Core.Example + Test.Hspec.Core.FailureReport + Test.Hspec.Core.Formatters.Diff + Test.Hspec.Core.Formatters.Free + Test.Hspec.Core.Formatters.Internal + Test.Hspec.Core.Formatters.Monad + Test.Hspec.Core.Options + Test.Hspec.Core.QuickCheckUtil + Test.Hspec.Core.Runner.Eval + Test.Hspec.Core.Spec.Monad + Test.Hspec.Core.Timer + Test.Hspec.Core.Tree + Data.Algorithm.Diff + Paths_hspec_core + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + src + vendor + test + ghc-options: -Wall + cpp-options: -DTEST + build-depends: + base >= 4.5.0.0 && < 5 + , random + , tf-random + , setenv + , ansi-terminal >= 0.5 + , time + , transformers >= 0.2.2.0 + , deepseq + , HUnit >= 1.2.5 + , QuickCheck >= 2.5.1 + , quickcheck-io >= 0.2.0 + , hspec-expectations == 0.8.2.* + , async >= 2 + , call-stack + , directory + , filepath + , array + , hspec-meta >= 2.3.2 + , silently >= 1.2.4 + , process + , temporary + other-modules: + Test.Hspec.Core.Compat + Test.Hspec.Core.Config + Test.Hspec.Core.Example + Test.Hspec.Core.FailureReport + Test.Hspec.Core.Formatters + Test.Hspec.Core.Formatters.Diff + Test.Hspec.Core.Formatters.Free + Test.Hspec.Core.Formatters.Internal + Test.Hspec.Core.Formatters.Monad + Test.Hspec.Core.Hooks + Test.Hspec.Core.Options + Test.Hspec.Core.QuickCheck + Test.Hspec.Core.QuickCheckUtil + Test.Hspec.Core.Runner + Test.Hspec.Core.Runner.Eval + Test.Hspec.Core.Spec + Test.Hspec.Core.Spec.Monad + Test.Hspec.Core.Timer + Test.Hspec.Core.Tree + Test.Hspec.Core.Util + Data.Algorithm.Diff + All + Helper + Mock + Test.Hspec.Core.CompatSpec + Test.Hspec.Core.ConfigSpec + Test.Hspec.Core.ExampleSpec + Test.Hspec.Core.FailureReportSpec + Test.Hspec.Core.Formatters.DiffSpec + Test.Hspec.Core.FormattersSpec + Test.Hspec.Core.HooksSpec + Test.Hspec.Core.OptionsSpec + Test.Hspec.Core.QuickCheckUtilSpec + Test.Hspec.Core.RunnerSpec + Test.Hspec.Core.SpecSpec + Test.Hspec.Core.TimerSpec + Test.Hspec.Core.UtilSpec + default-language: Haskell2010 diff --git a/src/Test/Hspec/Core/Compat.hs b/src/Test/Hspec/Core/Compat.hs new file mode 100644 index 0000000..1ec4e13 --- /dev/null +++ b/src/Test/Hspec/Core/Compat.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Compat ( + getDefaultConcurrentJobs +, showType +, showFullType +, readMaybe +, lookupEnv +, module Data.IORef + +, module Prelude +, module Control.Applicative +, module Data.Foldable +, module Data.Traversable +, module Data.Monoid + +#if !MIN_VERSION_base(4,6,0) +, modifyIORef' +#endif +) where + +import Control.Applicative +import Data.Foldable +import Data.Traversable +import Data.Monoid + +import Prelude hiding ( + all + , and + , any + , concat + , concatMap + , elem + , foldl + , foldl1 + , foldr + , foldr1 + , mapM + , mapM_ + , maximum + , minimum + , notElem + , or + , product + , sequence + , sequence_ + , sum + ) + +import Data.Typeable (Typeable, typeOf, typeRepTyCon) +import Text.Read +import Data.IORef +import System.Environment + +import Data.Typeable (tyConModule, tyConName) +import Control.Concurrent + +#if !MIN_VERSION_base(4,6,0) +import qualified Text.ParserCombinators.ReadP as P + +-- |Strict version of 'modifyIORef' +modifyIORef' :: IORef a -> (a -> a) -> IO () +modifyIORef' ref f = do + x <- readIORef ref + let x' = f x + x' `seq` writeIORef ref x' + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +-- A 'Left' value indicates a parse error. +readEither :: Read a => String -> Either String a +readEither s = + case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of + [x] -> Right x + [] -> Left "Prelude.read: no parse" + _ -> Left "Prelude.read: ambiguous parse" + where + read' = + do x <- readPrec + lift P.skipSpaces + return x + +-- | Parse a string using the 'Read' instance. +-- Succeeds if there is exactly one valid result. +readMaybe :: Read a => String -> Maybe a +readMaybe s = case readEither s of + Left _ -> Nothing + Right a -> Just a + +-- | Return the value of the environment variable @var@, or @Nothing@ if +-- there is no such value. +-- +-- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'. +lookupEnv :: String -> IO (Maybe String) +lookupEnv k = lookup k `fmap` getEnvironment +#endif + +showType :: Typeable a => a -> String +showType a = let t = typeRepTyCon (typeOf a) in + show t + +showFullType :: Typeable a => a -> String +showFullType a = let t = typeRepTyCon (typeOf a) in + tyConModule t ++ "." ++ tyConName t + +getDefaultConcurrentJobs :: IO Int +getDefaultConcurrentJobs = getNumCapabilities diff --git a/src/Test/Hspec/Core/Config.hs b/src/Test/Hspec/Core/Config.hs new file mode 100644 index 0000000..3e6f5e0 --- /dev/null +++ b/src/Test/Hspec/Core/Config.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Config ( + Config (..) +, ColorMode(..) +, defaultConfig +, getConfig +, configAddFilter +, configQuickCheckArgs +#ifdef TEST +, readConfigFiles +#endif +) where + +import Prelude () + +import Control.Exception +import Control.Monad +import Data.Maybe +import System.IO +import System.IO.Error +import System.Exit +import System.FilePath +import System.Directory +import qualified Test.QuickCheck as QC + +import Test.Hspec.Core.Util +import Test.Hspec.Core.Compat +import Test.Hspec.Core.Options +import Test.Hspec.Core.FailureReport +import Test.Hspec.Core.QuickCheckUtil (mkGen) +import Test.Hspec.Core.Example (Params(..), defaultParams) + +-- | Add a filter predicate to config. If there is already a filter predicate, +-- then combine them with `||`. +configAddFilter :: (Path -> Bool) -> Config -> Config +configAddFilter p1 c = c { + configFilterPredicate = Just p1 `filterOr` configFilterPredicate c + } + +mkConfig :: Maybe FailureReport -> Config -> Config +mkConfig mFailureReport opts = opts { + configFilterPredicate = matchFilter `filterOr` rerunFilter + , configQuickCheckSeed = mSeed + , configQuickCheckMaxSuccess = mMaxSuccess + , configQuickCheckMaxDiscardRatio = mMaxDiscardRatio + , configQuickCheckMaxSize = mMaxSize + } + where + + mSeed = configQuickCheckSeed opts <|> (failureReportSeed <$> mFailureReport) + mMaxSuccess = configQuickCheckMaxSuccess opts <|> (failureReportMaxSuccess <$> mFailureReport) + mMaxSize = configQuickCheckMaxSize opts <|> (failureReportMaxSize <$> mFailureReport) + mMaxDiscardRatio = configQuickCheckMaxDiscardRatio opts <|> (failureReportMaxDiscardRatio <$> mFailureReport) + + matchFilter = configFilterPredicate opts + + rerunFilter = case failureReportPaths <$> mFailureReport of + Just [] -> Nothing + Just xs -> Just (`elem` xs) + Nothing -> Nothing + +configQuickCheckArgs :: Config -> QC.Args +configQuickCheckArgs c = qcArgs + where + qcArgs = ( + maybe id setSeed (configQuickCheckSeed c) + . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c) + . maybe id setMaxSize (configQuickCheckMaxSize c) + . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) (paramsQuickCheckArgs defaultParams) + + setMaxSuccess :: Int -> QC.Args -> QC.Args + setMaxSuccess n args = args {QC.maxSuccess = n} + + setMaxSize :: Int -> QC.Args -> QC.Args + setMaxSize n args = args {QC.maxSize = n} + + setMaxDiscardRatio :: Int -> QC.Args -> QC.Args + setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n} + + setSeed :: Integer -> QC.Args -> QC.Args + setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)} + +getConfig :: Config -> String -> [String] -> IO (Maybe FailureReport, Config) +getConfig opts_ prog args = do + configFiles <- do + ignore <- ignoreConfigFile opts_ args + case ignore of + True -> return [] + False -> readConfigFiles + envVar <- fmap words <$> lookupEnv envVarName + case parseOptions opts_ prog configFiles envVar args of + Left (err, msg) -> exitWithMessage err msg + Right opts -> do + r <- if configRerun opts then readFailureReport opts else return Nothing + return (r, mkConfig r opts) + +readConfigFiles :: IO [ConfigFile] +readConfigFiles = do + global <- readGlobalConfigFile + local <- readLocalConfigFile + return $ catMaybes [global, local] + +readGlobalConfigFile :: IO (Maybe ConfigFile) +readGlobalConfigFile = do + mHome <- tryJust (guard . isDoesNotExistError) getHomeDirectory + case mHome of + Left _ -> return Nothing + Right home -> readConfigFile (home ".hspec") + +readLocalConfigFile :: IO (Maybe ConfigFile) +readLocalConfigFile = do + mName <- tryJust (guard . isDoesNotExistError) (canonicalizePath ".hspec") + case mName of + Left _ -> return Nothing + Right name -> readConfigFile name + +readConfigFile :: FilePath -> IO (Maybe ConfigFile) +readConfigFile name = do + exists <- doesFileExist name + if exists then Just . (,) name . words <$> readFile name else return Nothing + +exitWithMessage :: ExitCode -> String -> IO a +exitWithMessage err msg = do + hPutStr h msg + exitWith err + where + h = case err of + ExitSuccess -> stdout + _ -> stderr diff --git a/src/Test/Hspec/Core/Example.hs b/src/Test/Hspec/Core/Example.hs new file mode 100644 index 0000000..160dc45 --- /dev/null +++ b/src/Test/Hspec/Core/Example.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE CPP, TypeFamilies, FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable #-} +module Test.Hspec.Core.Example ( + Example (..) +, Params (..) +, defaultParams +, ActionWith +, Progress +, ProgressCallback +, Result (..) +, Location (..) +, LocationAccuracy (..) +, FailureReason (..) +, safeEvaluateExample +) where + +import Data.Maybe (fromMaybe) +import Data.List (isPrefixOf) +import qualified Test.HUnit.Lang as HUnit + +#if MIN_VERSION_HUnit(1,4,0) +import Data.CallStack +#endif + +import qualified Control.Exception as E +import Control.DeepSeq +import Data.Typeable (Typeable) +import qualified Test.QuickCheck as QC +import Test.Hspec.Expectations (Expectation) + +import qualified Test.QuickCheck.State as QC +import qualified Test.QuickCheck.Property as QCP + +import Test.Hspec.Core.QuickCheckUtil +import Test.Hspec.Core.Util +import Test.Hspec.Core.Compat + +-- | A type class for examples +class Example e where + type Arg e + type Arg e = () + evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result + +data Params = Params { + paramsQuickCheckArgs :: QC.Args +, paramsSmallCheckDepth :: Int +} deriving (Show) + +defaultParams :: Params +defaultParams = Params { + paramsQuickCheckArgs = QC.stdArgs +, paramsSmallCheckDepth = 5 +} + +type Progress = (Int, Int) +type ProgressCallback = Progress -> IO () + +-- | An `IO` action that expects an argument of type @a@ +type ActionWith a = a -> IO () + +-- | The result of running an example +data Result = Success | Pending (Maybe String) | Failure (Maybe Location) FailureReason + deriving (Eq, Show, Read, Typeable) + +data FailureReason = NoReason | Reason String | ExpectedButGot (Maybe String) String String + deriving (Eq, Show, Read, Typeable) + +instance NFData FailureReason where + rnf reason = case reason of + NoReason -> () + Reason r -> r `deepseq` () + ExpectedButGot p e a -> p `deepseq` e `deepseq` a `deepseq` () + +instance E.Exception Result + +-- | @Location@ is used to represent source locations. +data Location = Location { + locationFile :: FilePath +, locationLine :: Int +, locationColumn :: Int +, locationAccuracy :: LocationAccuracy +} deriving (Eq, Show, Read) + +-- | A marker for source locations +data LocationAccuracy = + -- | The source location is accurate + ExactLocation | + -- | The source location was determined on a best-effort basis and my be + -- wrong or inaccurate + BestEffort + deriving (Eq, Show, Read) + +safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO (Either E.SomeException Result) +safeEvaluateExample example params around progress = do + r <- safeTry $ forceResult <$> evaluateExample example params around progress + return $ case r of + Left e | Just result <- E.fromException e -> Right result + Left e | Just hunit <- E.fromException e -> Right (hunitFailureToResult hunit) + _ -> r + where + forceResult :: Result -> Result + forceResult r = case r of + Success -> r + Pending m -> m `deepseq` r + Failure _ m -> m `deepseq` r + +instance Example Result where + type Arg Result = () + evaluateExample e = evaluateExample (\() -> e) + +instance Example (a -> Result) where + type Arg (a -> Result) = a + evaluateExample example _params action _callback = do + ref <- newIORef Success + action (writeIORef ref . example) + readIORef ref + +instance Example Bool where + type Arg Bool = () + evaluateExample e = evaluateExample (\() -> e) + +instance Example (a -> Bool) where + type Arg (a -> Bool) = a + evaluateExample p _params action _callback = do + ref <- newIORef Success + action $ \a -> example a >>= writeIORef ref + readIORef ref + where + example a + | p a = return Success + | otherwise = return (Failure Nothing NoReason) + +instance Example Expectation where + type Arg Expectation = () + evaluateExample e = evaluateExample (\() -> e) + +hunitFailureToResult :: HUnit.HUnitFailure -> Result +hunitFailureToResult e = case e of +#if MIN_VERSION_HUnit(1,3,0) + HUnit.HUnitFailure mLoc err -> +#if MIN_VERSION_HUnit(1,5,0) + case err of + HUnit.Reason reason -> Failure location (Reason reason) + HUnit.ExpectedButGot preface expected actual -> Failure location (ExpectedButGot preface expected actual) +#else + Failure location (Reason err) +#endif + where + location = case mLoc of + Nothing -> Nothing +#if MIN_VERSION_HUnit(1,4,0) + Just loc -> Just $ Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) ExactLocation +#else + Just loc -> Just $ Location (HUnit.locationFile loc) (HUnit.locationLine loc) (HUnit.locationColumn loc) ExactLocation +#endif +#else + HUnit.HUnitFailure err -> Failure Nothing (Reason err) +#endif + +instance Example (a -> Expectation) where + type Arg (a -> Expectation) = a + evaluateExample e _ action _ = action e >> return Success + +instance Example QC.Property where + type Arg QC.Property = () + evaluateExample e = evaluateExample (\() -> e) + +instance Example (a -> QC.Property) where + type Arg (a -> QC.Property) = a + evaluateExample p c action progressCallback = do + r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty action p) + return $ + case r of + QC.Success {} -> Success + QC.Failure {QC.output = m} -> fromMaybe (Failure Nothing . Reason $ sanitizeFailureMessage r) (parsePending m) + QC.GaveUp {QC.numTests = n} -> Failure Nothing (Reason $ "Gave up after " ++ pluralize n "test" ) + QC.NoExpectedFailure {} -> Failure Nothing (Reason $ "No expected failure") +#if MIN_VERSION_QuickCheck(2,8,0) + QC.InsufficientCoverage {} -> Failure Nothing (Reason $ "Insufficient coverage") +#endif + where + qcProgressCallback = QCP.PostTest QCP.NotCounterexample $ + \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st) + + sanitizeFailureMessage :: QC.Result -> String + sanitizeFailureMessage r = let m = QC.output r in strip $ +#if MIN_VERSION_QuickCheck(2,7,0) + case QC.theException r of + Just e -> case E.fromException e :: Maybe (HUnit.HUnitFailure) of + Just _ -> (addFalsifiable . stripFailed) m + Nothing -> let numbers = formatNumbers r in + "uncaught exception: " ++ formatException e ++ " " ++ numbers ++ "\n" ++ case lines m of + x:xs | x == (exceptionPrefix ++ show e ++ "' " ++ numbers ++ ": ") -> unlines xs + _ -> m + Nothing -> +#endif + (addFalsifiable . stripFailed) m + + addFalsifiable :: String -> String + addFalsifiable m + | "(after " `isPrefixOf` m = "Falsifiable " ++ m + | otherwise = m + + stripFailed :: String -> String + stripFailed m + | prefix `isPrefixOf` m = drop n m + | otherwise = m + where + prefix = "*** Failed! " + n = length prefix + + parsePending :: String -> Maybe Result + parsePending m + | exceptionPrefix `isPrefixOf` m = (readMaybe . takeWhile (/= '\'') . drop n) m + | otherwise = Nothing + where + n = length exceptionPrefix + + exceptionPrefix = "*** Failed! Exception: '" diff --git a/src/Test/Hspec/Core/FailureReport.hs b/src/Test/Hspec/Core/FailureReport.hs new file mode 100644 index 0000000..734e1da --- /dev/null +++ b/src/Test/Hspec/Core/FailureReport.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.FailureReport ( + FailureReport (..) +, writeFailureReport +, readFailureReport +) where + +#ifndef __GHCJS__ +import System.SetEnv +import Test.Hspec.Core.Util (safeTry) +#endif +import Control.Monad +import System.IO +import System.Directory +import Test.Hspec.Core.Compat +import Test.Hspec.Core.Util (Path) +import Test.Hspec.Core.Options (Config(..)) + +data FailureReport = FailureReport { + failureReportSeed :: Integer +, failureReportMaxSuccess :: Int +, failureReportMaxSize :: Int +, failureReportMaxDiscardRatio :: Int +, failureReportPaths :: [Path] +} deriving (Eq, Show, Read) + +writeFailureReport :: Config -> FailureReport -> IO () +writeFailureReport config report = case configFailureReport config of + Just file -> writeFile file (show report) + Nothing -> do +#ifdef __GHCJS__ + -- ghcjs currently does not support setting environment variables + -- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report + -- into the environment is a non-essential feature we just disable this to be + -- able to run hspec test-suites with ghcjs at all. Should be reverted once + -- the issue is fixed. + return () +#else + -- on Windows this can throw an exception when the input is too large, hence + -- we use `safeTry` here + safeTry (setEnv "HSPEC_FAILURES" $ show report) >>= either onError return + where + onError err = do + hPutStrLn stderr ("WARNING: Could not write environment variable HSPEC_FAILURES (" ++ show err ++ ")") +#endif + +readFailureReport :: Config -> IO (Maybe FailureReport) +readFailureReport config = case configFailureReport config of + Just file -> do + exists <- doesFileExist file + if exists + then do + r <- readFile file + let report = readMaybe r + when (report == Nothing) $ do + hPutStrLn stderr ("WARNING: Could not read failure report from file " ++ show file ++ "!") + return report + else return Nothing + Nothing -> do + mx <- lookupEnv "HSPEC_FAILURES" + case mx >>= readMaybe of + Nothing -> do + hPutStrLn stderr "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!" + return Nothing + report -> return report diff --git a/src/Test/Hspec/Core/Formatters.hs b/src/Test/Hspec/Core/Formatters.hs new file mode 100644 index 0000000..c9b8d93 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters.hs @@ -0,0 +1,255 @@ +-- | +-- Stability: experimental +-- +-- This module contains formatters that can be used with +-- `Test.Hspec.Runner.hspecWith`. +module Test.Hspec.Core.Formatters ( + +-- * Formatters + silent +, specdoc +, progress +, failed_examples + +-- * Implementing a custom Formatter +-- | +-- A formatter is a set of actions. Each action is evaluated when a certain +-- situation is encountered during a test run. +-- +-- Actions live in the `FormatM` monad. It provides access to the runner state +-- and primitives for appending to the generated report. +, Formatter (..) +, FailureReason (..) +, FormatM + +-- ** Accessing the runner state +, getSuccessCount +, getPendingCount +, getFailCount +, getTotalCount + +, FailureRecord (..) +, getFailMessages +, usedSeed + +, getCPUTime +, getRealTime + +-- ** Appending to the gerenated report +, write +, writeLine + +-- ** Dealing with colors +, withInfoColor +, withSuccessColor +, withPendingColor +, withFailColor + +, extraChunk +, missingChunk + +-- ** Helpers +, formatException +) where + +import Prelude () +import Test.Hspec.Core.Compat hiding (First) + +import Data.Maybe +import Test.Hspec.Core.Util +import Test.Hspec.Core.Spec (Location(..), LocationAccuracy(..)) +import Text.Printf +import Control.Monad (when, unless) +import System.IO (hPutStr, hFlush) + +-- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make +-- sure, that we only use the public API to implement formatters. +-- +-- Everything imported here has to be re-exported, so that users can implement +-- their own formatters. +import Test.Hspec.Core.Formatters.Monad ( + Formatter (..) + , FailureReason (..) + , FormatM + + , getSuccessCount + , getPendingCount + , getFailCount + , getTotalCount + + , FailureRecord (..) + , getFailMessages + , usedSeed + + , getCPUTime + , getRealTime + + , write + , writeLine + + , withInfoColor + , withSuccessColor + , withPendingColor + , withFailColor + + , extraChunk + , missingChunk + ) + +import Test.Hspec.Core.Formatters.Diff + +silent :: Formatter +silent = Formatter { + headerFormatter = return () +, exampleGroupStarted = \_ _ -> return () +, exampleGroupDone = return () +, exampleProgress = \_ _ _ -> return () +, exampleSucceeded = \_ -> return () +, exampleFailed = \_ _ -> return () +, examplePending = \_ _ -> return () +, failedFormatter = return () +, footerFormatter = return () +} + +specdoc :: Formatter +specdoc = silent { + + headerFormatter = do + writeLine "" + +, exampleGroupStarted = \nesting name -> do + writeLine (indentationFor nesting ++ name) + +, exampleProgress = \h _ p -> do + hPutStr h (formatProgress p) + hFlush h + +, exampleSucceeded = \(nesting, requirement) -> withSuccessColor $ do + writeLine $ indentationFor nesting ++ requirement + +, exampleFailed = \(nesting, requirement) _ -> withFailColor $ do + n <- getFailCount + writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]" + +, examplePending = \(nesting, requirement) reason -> withPendingColor $ do + writeLine $ indentationFor nesting ++ requirement ++ "\n # PENDING: " ++ fromMaybe "No reason given" reason + +, failedFormatter = defaultFailedFormatter + +, footerFormatter = defaultFooter +} where + indentationFor nesting = replicate (length nesting * 2) ' ' + formatProgress (current, total) + | total == 0 = show current ++ "\r" + | otherwise = show current ++ "/" ++ show total ++ "\r" + + +progress :: Formatter +progress = silent { + exampleSucceeded = \_ -> withSuccessColor $ write "." +, exampleFailed = \_ _ -> withFailColor $ write "F" +, examplePending = \_ _ -> withPendingColor $ write "." +, failedFormatter = defaultFailedFormatter +, footerFormatter = defaultFooter +} + + +failed_examples :: Formatter +failed_examples = silent { + failedFormatter = defaultFailedFormatter +, footerFormatter = defaultFooter +} + +defaultFailedFormatter :: FormatM () +defaultFailedFormatter = do + writeLine "" + + failures <- getFailMessages + + unless (null failures) $ do + writeLine "Failures:" + writeLine "" + + forM_ (zip [1..] failures) $ \x -> do + formatFailure x + writeLine "" + + when (hasBestEffortLocations failures) $ do + withInfoColor $ writeLine "Source locations marked with \"best-effort\" are calculated heuristically and may be incorrect." + writeLine "" + + write "Randomized with seed " >> usedSeed >>= writeLine . show + writeLine "" + where + hasBestEffortLocations :: [FailureRecord] -> Bool + hasBestEffortLocations = any p + where + p :: FailureRecord -> Bool + p failure = (locationAccuracy <$> failureRecordLocation failure) == Just BestEffort + + formatFailure :: (Int, FailureRecord) -> FormatM () + formatFailure (n, FailureRecord mLoc path reason) = do + forM_ mLoc $ \loc -> do + withInfoColor $ writeLine (formatLoc loc) + write (" " ++ show n ++ ") ") + writeLine (formatRequirement path) + case reason of + Left e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e + Right NoReason -> return () + Right (Reason err) -> withFailColor $ indent err + Right (ExpectedButGot preface expected actual) -> do + mapM_ indent preface + + let chunks = diff expected actual + + withFailColor $ write (indentation ++ "expected: ") + forM_ chunks $ \chunk -> case chunk of + Both a _ -> indented write a + First a -> indented extraChunk a + Second _ -> return () + writeLine "" + + withFailColor $ write (indentation ++ " but got: ") + forM_ chunks $ \chunk -> case chunk of + Both a _ -> indented write a + First _ -> return () + Second a -> indented missingChunk a + writeLine "" + where + indented output text = case break (== '\n') text of + (xs, "") -> output xs + (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ " ") >> indented output ys + where + indentation = " " + indent message = do + forM_ (lines message) $ \line -> do + writeLine (indentation ++ line) + formatLoc (Location file line _column accuracy) = " " ++ file ++ ":" ++ show line ++ ":" ++ message + where + message = case accuracy of + ExactLocation -> " " -- NOTE: Vim's default 'errorformat' + -- requires a non-empty message. This is + -- why we use a single space as message + -- here. + BestEffort -> " (best-effort)" + +defaultFooter :: FormatM () +defaultFooter = do + + writeLine =<< (++) + <$> (printf "Finished in %1.4f seconds" <$> getRealTime) + <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime) + + fails <- getFailCount + pending <- getPendingCount + total <- getTotalCount + + let + output = + pluralize total "example" + ++ ", " ++ pluralize fails "failure" + ++ if pending == 0 then "" else ", " ++ show pending ++ " pending" + c | fails /= 0 = withFailColor + | pending /= 0 = withPendingColor + | otherwise = withSuccessColor + c $ writeLine output diff --git a/src/Test/Hspec/Core/Formatters/Diff.hs b/src/Test/Hspec/Core/Formatters/Diff.hs new file mode 100644 index 0000000..a238f79 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/Diff.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Formatters.Diff ( + Diff (..) +, diff +#ifdef TEST +, partition +, breakList +#endif +) where + +import Data.Char +import Data.Algorithm.Diff + +diff :: String -> String -> [Diff String] +diff expected actual = map (fmap concat) $ getGroupedDiff (partition expected) (partition actual) + +partition :: String -> [String] +partition = mergeBackslashes . breakList isAlphaNum + where + mergeBackslashes xs = case xs of + ['\\'] : (y : ys) : zs -> ['\\', y] : ys : mergeBackslashes zs + z : zs -> z : mergeBackslashes zs + [] -> [] + +breakList :: (a -> Bool) -> [a] -> [[a]] +breakList _ [] = [] +breakList p xs = case break p xs of + (y, ys) -> map return y ++ case span p ys of + (z, zs) -> z `cons` breakList p zs + where + cons x + | null x = id + | otherwise = (x :) diff --git a/src/Test/Hspec/Core/Formatters/Free.hs b/src/Test/Hspec/Core/Formatters/Free.hs new file mode 100644 index 0000000..e5c227d --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/Free.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveFunctor #-} +module Test.Hspec.Core.Formatters.Free where + +import Prelude () +import Test.Hspec.Core.Compat + +data Free f a = Free (f (Free f a)) | Pure a + deriving Functor + +instance Functor f => Applicative (Free f) where + pure = Pure + Pure f <*> Pure a = Pure (f a) + Pure f <*> Free m = Free (fmap f <$> m) + Free m <*> b = Free (fmap (<*> b) m) + +instance Functor f => Monad (Free f) where + return = pure + Pure a >>= f = f a + Free m >>= f = Free (fmap (>>= f) m) + +liftF :: Functor f => f a -> Free f a +liftF command = Free (fmap Pure command) diff --git a/src/Test/Hspec/Core/Formatters/Internal.hs b/src/Test/Hspec/Core/Formatters/Internal.hs new file mode 100644 index 0000000..57355c1 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/Internal.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Test.Hspec.Core.Formatters.Internal ( + FormatM +, runFormatM +, interpret +, increaseSuccessCount +, increasePendingCount +, increaseFailCount +, addFailMessage +, finally_ +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import qualified System.IO as IO +import System.IO (Handle) +import Control.Monad +import Control.Exception (SomeException, AsyncException(..), bracket_, try, throwIO) +import System.Console.ANSI +import Control.Monad.Trans.State hiding (gets, modify) +import Control.Monad.IO.Class +import qualified System.CPUTime as CPUTime +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) + +import Test.Hspec.Core.Util (Path) +import Test.Hspec.Core.Spec (Location) +import Test.Hspec.Core.Example (FailureReason(..)) + +import qualified Test.Hspec.Core.Formatters.Monad as M +import Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..)) + +interpret :: M.FormatM a -> FormatM a +interpret = interpretWith Environment { + environmentGetSuccessCount = getSuccessCount +, environmentGetPendingCount = getPendingCount +, environmentGetFailCount = getFailCount +, environmentGetFailMessages = getFailMessages +, environmentUsedSeed = usedSeed +, environmentGetCPUTime = getCPUTime +, environmentGetRealTime = getRealTime +, environmentWrite = write +, environmentWithFailColor = withFailColor +, environmentWithSuccessColor = withSuccessColor +, environmentWithPendingColor = withPendingColor +, environmentWithInfoColor = withInfoColor +, environmentExtraChunk = extraChunk +, environmentMissingChunk = missingChunk +, environmentLiftIO = liftIO +} + +-- | A lifted version of `Control.Monad.Trans.State.gets` +gets :: (FormatterState -> a) -> FormatM a +gets f = FormatM $ do + f <$> (get >>= liftIO . readIORef) + +-- | A lifted version of `Control.Monad.Trans.State.modify` +modify :: (FormatterState -> FormatterState) -> FormatM () +modify f = FormatM $ do + get >>= liftIO . (`modifyIORef'` f) + +data FormatterState = FormatterState { + stateHandle :: Handle +, stateUseColor :: Bool +, stateUseDiff :: Bool +, produceHTML :: Bool +, successCount :: Int +, pendingCount :: Int +, failCount :: Int +, failMessages :: [FailureRecord] +, stateUsedSeed :: Integer +, cpuStartTime :: Maybe Integer +, startTime :: POSIXTime +} + +-- | The random seed that is used for QuickCheck. +usedSeed :: FormatM Integer +usedSeed = gets stateUsedSeed + +-- NOTE: We use an IORef here, so that the state persists when UserInterrupt is +-- thrown. +newtype FormatM a = FormatM (StateT (IORef FormatterState) IO a) + deriving (Functor, Applicative, Monad, MonadIO) + +runFormatM :: Bool -> Bool -> Bool -> Bool -> Integer -> Handle -> FormatM a -> IO a +runFormatM useColor useDiff produceHTML_ printCpuTime seed handle (FormatM action) = do + time <- getPOSIXTime + cpuTime <- if printCpuTime then Just <$> CPUTime.getCPUTime else pure Nothing + st <- newIORef (FormatterState handle useColor useDiff produceHTML_ 0 0 0 [] seed cpuTime time) + evalStateT action st + +-- | Increase the counter for successful examples +increaseSuccessCount :: FormatM () +increaseSuccessCount = modify $ \s -> s {successCount = succ $ successCount s} + +-- | Increase the counter for pending examples +increasePendingCount :: FormatM () +increasePendingCount = modify $ \s -> s {pendingCount = succ $ pendingCount s} + +-- | Increase the counter for failed examples +increaseFailCount :: FormatM () +increaseFailCount = modify $ \s -> s {failCount = succ $ failCount s} + +-- | Get the number of successful examples encountered so far. +getSuccessCount :: FormatM Int +getSuccessCount = gets successCount + +-- | Get the number of pending examples encountered so far. +getPendingCount :: FormatM Int +getPendingCount = gets pendingCount + +-- | Get the number of failed examples encountered so far. +getFailCount :: FormatM Int +getFailCount = gets failCount + +-- | Append to the list of accumulated failure messages. +addFailMessage :: Maybe Location -> Path -> Either SomeException FailureReason -> FormatM () +addFailMessage loc p m = modify $ \s -> s {failMessages = FailureRecord loc p m : failMessages s} + +-- | Get the list of accumulated failure messages. +getFailMessages :: FormatM [FailureRecord] +getFailMessages = reverse `fmap` gets failMessages + +-- | Append some output to the report. +write :: String -> FormatM () +write s = do + h <- gets stateHandle + liftIO $ IO.hPutStr h s + +-- | Set output color to red, run given action, and finally restore the default +-- color. +withFailColor :: FormatM a -> FormatM a +withFailColor = withColor (SetColor Foreground Dull Red) "hspec-failure" + +-- | Set output color to green, run given action, and finally restore the +-- default color. +withSuccessColor :: FormatM a -> FormatM a +withSuccessColor = withColor (SetColor Foreground Dull Green) "hspec-success" + +-- | Set output color to yellow, run given action, and finally restore the +-- default color. +withPendingColor :: FormatM a -> FormatM a +withPendingColor = withColor (SetColor Foreground Dull Yellow) "hspec-pending" + +-- | Set output color to cyan, run given action, and finally restore the +-- default color. +withInfoColor :: FormatM a -> FormatM a +withInfoColor = withColor (SetColor Foreground Dull Cyan) "hspec-info" + +-- | Set a color, run an action, and finally reset colors. +withColor :: SGR -> String -> FormatM a -> FormatM a +withColor color cls action = do + r <- gets produceHTML + (if r then htmlSpan cls else withColor_ color) action + +htmlSpan :: String -> FormatM a -> FormatM a +htmlSpan cls action = write ("") *> action <* write "" + +withColor_ :: SGR -> FormatM a -> FormatM a +withColor_ color (FormatM action) = do + useColor <- gets stateUseColor + h <- gets stateHandle + + FormatM . StateT $ \st -> do + bracket_ + + -- set color + (when useColor $ hSetSGR h [color]) + + -- reset colors + (when useColor $ hSetSGR h [Reset]) + + -- run action + (runStateT action st) + +-- | Output given chunk in red. +extraChunk :: String -> FormatM () +extraChunk s = do + useDiff <- gets stateUseDiff + case useDiff of + True -> withFailColor $ write s + False -> write s + +-- | Output given chunk in green. +missingChunk :: String -> FormatM () +missingChunk s = do + useDiff <- gets stateUseDiff + case useDiff of + True -> withSuccessColor $ write s + False -> write s + +-- | +-- @finally_ actionA actionB@ runs @actionA@ and then @actionB@. @actionB@ is +-- run even when a `UserInterrupt` occurs during @actionA@. +finally_ :: FormatM () -> FormatM () -> FormatM () +finally_ (FormatM actionA) (FormatM actionB) = FormatM . StateT $ \st -> do + r <- try (execStateT actionA st) + case r of + Left e -> do + when (e == UserInterrupt) $ + runStateT actionB st >> return () + throwIO e + Right st_ -> do + runStateT actionB st_ + +-- | Get the used CPU time since the test run has been started. +getCPUTime :: FormatM (Maybe Double) +getCPUTime = do + t1 <- liftIO CPUTime.getCPUTime + mt0 <- gets cpuStartTime + return $ toSeconds <$> ((-) <$> pure t1 <*> mt0) + where + toSeconds x = fromIntegral x / (10.0 ^ (12 :: Integer)) + +-- | Get the passed real time since the test run has been started. +getRealTime :: FormatM Double +getRealTime = do + t1 <- liftIO getPOSIXTime + t0 <- gets startTime + return (realToFrac $ t1 - t0) diff --git a/src/Test/Hspec/Core/Formatters/Monad.hs b/src/Test/Hspec/Core/Formatters/Monad.hs new file mode 100644 index 0000000..55f98c9 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/Monad.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ExistentialQuantification #-} +module Test.Hspec.Core.Formatters.Monad ( + Formatter (..) +, FailureReason (..) +, FormatM + +, getSuccessCount +, getPendingCount +, getFailCount +, getTotalCount + +, FailureRecord (..) +, getFailMessages +, usedSeed + +, getCPUTime +, getRealTime + +, write +, writeLine + +, withInfoColor +, withSuccessColor +, withPendingColor +, withFailColor + +, extraChunk +, missingChunk + +, Environment(..) +, interpretWith +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import System.IO (Handle) +import Control.Exception +import Control.Monad.IO.Class + +import Test.Hspec.Core.Formatters.Free + +import Test.Hspec.Core.Example (FailureReason(..)) +import Test.Hspec.Core.Util (Path) +import Test.Hspec.Core.Spec (Progress, Location) + +data Formatter = Formatter { + + headerFormatter :: FormatM () + +-- | evaluated before each test group +-- +-- The given number indicates the position within the parent group. +, exampleGroupStarted :: [String] -> String -> FormatM () + +, exampleGroupDone :: FormatM () + +-- | used to notify the progress of the currently evaluated example +-- +-- /Note/: This is only called when interactive/color mode. +, exampleProgress :: Handle -> Path -> Progress -> IO () + +-- | evaluated after each successful example +, exampleSucceeded :: Path -> FormatM () + +-- | evaluated after each failed example +, exampleFailed :: Path -> Either SomeException FailureReason -> FormatM () + +-- | evaluated after each pending example +, examplePending :: Path -> Maybe String -> FormatM () + +-- | evaluated after a test run +, failedFormatter :: FormatM () + +-- | evaluated after `failuresFormatter` +, footerFormatter :: FormatM () +} + +data FailureRecord = FailureRecord { + failureRecordLocation :: Maybe Location +, failureRecordPath :: Path +, failureRecordMessage :: Either SomeException FailureReason +} + +data FormatF next = + GetSuccessCount (Int -> next) + | GetPendingCount (Int -> next) + | GetFailCount (Int -> next) + | GetFailMessages ([FailureRecord] -> next) + | UsedSeed (Integer -> next) + | GetCPUTime (Maybe Double -> next) + | GetRealTime (Double -> next) + | Write String next + | forall a. WithFailColor (FormatM a) (a -> next) + | forall a. WithSuccessColor (FormatM a) (a -> next) + | forall a. WithPendingColor (FormatM a) (a -> next) + | forall a. WithInfoColor (FormatM a) (a -> next) + | ExtraChunk String next + | MissingChunk String next + | forall a. LiftIO (IO a) (a -> next) + +instance Functor FormatF where -- deriving this instance would require GHC >= 7.10.1 + fmap f x = case x of + GetSuccessCount next -> GetSuccessCount (fmap f next) + GetPendingCount next -> GetPendingCount (fmap f next) + GetFailCount next -> GetFailCount (fmap f next) + GetFailMessages next -> GetFailMessages (fmap f next) + UsedSeed next -> UsedSeed (fmap f next) + GetCPUTime next -> GetCPUTime (fmap f next) + GetRealTime next -> GetRealTime (fmap f next) + Write s next -> Write s (f next) + WithFailColor action next -> WithFailColor action (fmap f next) + WithSuccessColor action next -> WithSuccessColor action (fmap f next) + WithPendingColor action next -> WithPendingColor action (fmap f next) + WithInfoColor action next -> WithInfoColor action (fmap f next) + ExtraChunk s next -> ExtraChunk s (f next) + MissingChunk s next -> MissingChunk s (f next) + LiftIO action next -> LiftIO action (fmap f next) + +type FormatM = Free FormatF + +instance MonadIO FormatM where + liftIO s = liftF (LiftIO s id) + +data Environment m = Environment { + environmentGetSuccessCount :: m Int +, environmentGetPendingCount :: m Int +, environmentGetFailCount :: m Int +, environmentGetFailMessages :: m [FailureRecord] +, environmentUsedSeed :: m Integer +, environmentGetCPUTime :: m (Maybe Double) +, environmentGetRealTime :: m Double +, environmentWrite :: String -> m () +, environmentWithFailColor :: forall a. m a -> m a +, environmentWithSuccessColor :: forall a. m a -> m a +, environmentWithPendingColor :: forall a. m a -> m a +, environmentWithInfoColor :: forall a. m a -> m a +, environmentExtraChunk :: String -> m () +, environmentMissingChunk :: String -> m () +, environmentLiftIO :: forall a. IO a -> m a +} + +interpretWith :: forall m a. Monad m => Environment m -> FormatM a -> m a +interpretWith Environment{..} = go + where + go :: forall b. FormatM b -> m b + go m = case m of + Pure value -> return value + Free action -> case action of + GetSuccessCount next -> environmentGetSuccessCount >>= go . next + GetPendingCount next -> environmentGetPendingCount >>= go . next + GetFailCount next -> environmentGetFailCount >>= go . next + GetFailMessages next -> environmentGetFailMessages >>= go . next + UsedSeed next -> environmentUsedSeed >>= go . next + GetCPUTime next -> environmentGetCPUTime >>= go . next + GetRealTime next -> environmentGetRealTime >>= go . next + Write s next -> environmentWrite s >> go next + WithFailColor inner next -> environmentWithFailColor (go inner) >>= go . next + WithSuccessColor inner next -> environmentWithSuccessColor (go inner) >>= go . next + WithPendingColor inner next -> environmentWithPendingColor (go inner) >>= go . next + WithInfoColor inner next -> environmentWithInfoColor (go inner) >>= go . next + ExtraChunk s next -> environmentExtraChunk s >> go next + MissingChunk s next -> environmentMissingChunk s >> go next + LiftIO inner next -> environmentLiftIO inner >>= go . next + +-- | Get the number of successful examples encountered so far. +getSuccessCount :: FormatM Int +getSuccessCount = liftF (GetSuccessCount id) + +-- | Get the number of pending examples encountered so far. +getPendingCount :: FormatM Int +getPendingCount = liftF (GetPendingCount id) + +-- | Get the number of failed examples encountered so far. +getFailCount :: FormatM Int +getFailCount = liftF (GetFailCount id) + +-- | Get the total number of examples encountered so far. +getTotalCount :: FormatM Int +getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount] + +-- | Get the list of accumulated failure messages. +getFailMessages :: FormatM [FailureRecord] +getFailMessages = liftF (GetFailMessages id) + +-- | The random seed that is used for QuickCheck. +usedSeed :: FormatM Integer +usedSeed = liftF (UsedSeed id) + +-- | Get the used CPU time since the test run has been started. +getCPUTime :: FormatM (Maybe Double) +getCPUTime = liftF (GetCPUTime id) + +-- | Get the passed real time since the test run has been started. +getRealTime :: FormatM Double +getRealTime = liftF (GetRealTime id) + +-- | Append some output to the report. +write :: String -> FormatM () +write s = liftF (Write s ()) + +-- | The same as `write`, but adds a newline character. +writeLine :: String -> FormatM () +writeLine s = write s >> write "\n" + +-- | Set output color to red, run given action, and finally restore the default +-- color. +withFailColor :: FormatM a -> FormatM a +withFailColor s = liftF (WithFailColor s id) + +-- | Set output color to green, run given action, and finally restore the +-- default color. +withSuccessColor :: FormatM a -> FormatM a +withSuccessColor s = liftF (WithSuccessColor s id) + +-- | Set output color to yellow, run given action, and finally restore the +-- default color. +withPendingColor :: FormatM a -> FormatM a +withPendingColor s = liftF (WithPendingColor s id) + +-- | Set output color to cyan, run given action, and finally restore the +-- default color. +withInfoColor :: FormatM a -> FormatM a +withInfoColor s = liftF (WithInfoColor s id) + +-- | Output given chunk in red. +extraChunk :: String -> FormatM () +extraChunk s = liftF (ExtraChunk s ()) + +-- | Output given chunk in green. +missingChunk :: String -> FormatM () +missingChunk s = liftF (MissingChunk s ()) diff --git a/src/Test/Hspec/Core/Hooks.hs b/src/Test/Hspec/Core/Hooks.hs new file mode 100644 index 0000000..ba9d311 --- /dev/null +++ b/src/Test/Hspec/Core/Hooks.hs @@ -0,0 +1,93 @@ +-- | Stability: provisional +module Test.Hspec.Core.Hooks ( + before +, before_ +, beforeWith +, beforeAll +, beforeAll_ +, after +, after_ +, afterAll +, afterAll_ +, around +, around_ +, aroundWith +) where + +import Control.Exception (SomeException, finally, throwIO, try) +import Control.Concurrent.MVar + +import Test.Hspec.Core.Example +import Test.Hspec.Core.Tree +import Test.Hspec.Core.Spec.Monad + +-- | Run a custom action before every spec item. +before :: IO a -> SpecWith a -> Spec +before action = around (action >>=) + +-- | Run a custom action before every spec item. +before_ :: IO () -> SpecWith a -> SpecWith a +before_ action = around_ (action >>) + +-- | Run a custom action before every spec item. +beforeWith :: (b -> IO a) -> SpecWith a -> SpecWith b +beforeWith action = aroundWith $ \e x -> action x >>= e + +-- | Run a custom action before the first spec item. +beforeAll :: IO a -> SpecWith a -> Spec +beforeAll action spec = do + mvar <- runIO (newMVar Empty) + before (memoize mvar action) spec + +-- | Run a custom action before the first spec item. +beforeAll_ :: IO () -> SpecWith a -> SpecWith a +beforeAll_ action spec = do + mvar <- runIO (newMVar Empty) + before_ (memoize mvar action) spec + +data Memoized a = + Empty + | Memoized a + | Failed SomeException + +memoize :: MVar (Memoized a) -> IO a -> IO a +memoize mvar action = do + result <- modifyMVar mvar $ \ma -> case ma of + Empty -> do + a <- try action + return (either Failed Memoized a, a) + Memoized a -> return (ma, Right a) + Failed _ -> throwIO (Pending (Just "exception in beforeAll-hook (see previous failure)")) + either throwIO return result + +-- | Run a custom action after every spec item. +after :: ActionWith a -> SpecWith a -> SpecWith a +after action = aroundWith $ \e x -> e x `finally` action x + +-- | Run a custom action after every spec item. +after_ :: IO () -> SpecWith a -> SpecWith a +after_ action = after $ \_ -> action + +-- | Run a custom action before and/or after every spec item. +around :: (ActionWith a -> IO ()) -> SpecWith a -> Spec +around action = aroundWith $ \e () -> action e + +-- | Run a custom action after the last spec item. +afterAll :: ActionWith a -> SpecWith a -> SpecWith a +afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . return . NodeWithCleanup action + +-- | Run a custom action after the last spec item. +afterAll_ :: IO () -> SpecWith a -> SpecWith a +afterAll_ action = afterAll (\_ -> action) + +-- | Run a custom action before and/or after every spec item. +around_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a +around_ action = aroundWith $ \e a -> action (e a) + +-- | Run a custom action before and/or after every spec item. +aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b +aroundWith action = mapSpecItem action (modifyAroundAction action) + +modifyAroundAction :: (ActionWith a -> ActionWith b) -> Item a -> Item b +modifyAroundAction action item@Item{itemExample = e} = + item{ itemExample = \params aroundAction -> e params (aroundAction . action) } diff --git a/src/Test/Hspec/Core/Options.hs b/src/Test/Hspec/Core/Options.hs new file mode 100644 index 0000000..57b7162 --- /dev/null +++ b/src/Test/Hspec/Core/Options.hs @@ -0,0 +1,283 @@ +module Test.Hspec.Core.Options ( + Config(..) +, ColorMode (..) +, defaultConfig +, filterOr +, parseOptions +, ConfigFile +, ignoreConfigFile +, envVarName +) where + +import Prelude () +import Control.Monad +import Test.Hspec.Core.Compat + +import System.IO +import System.Exit +import System.Console.GetOpt + +import Test.Hspec.Core.Formatters +import Test.Hspec.Core.Util +import Test.Hspec.Core.Example (Params(..), defaultParams) +import Data.Functor.Identity +import Data.Maybe + +type ConfigFile = (FilePath, [String]) + +type EnvVar = [String] + +envVarName :: String +envVarName = "HSPEC_OPTIONS" + +data Config = Config { + configIgnoreConfigFile :: Bool +, configDryRun :: Bool +, configPrintCpuTime :: Bool +, configFastFail :: Bool +, configFailureReport :: Maybe FilePath +, configRerun :: Bool +, configRerunAllOnSuccess :: Bool + +-- | +-- A predicate that is used to filter the spec before it is run. Only examples +-- that satisfy the predicate are run. +, configFilterPredicate :: Maybe (Path -> Bool) +, configSkipPredicate :: Maybe (Path -> Bool) +, configQuickCheckSeed :: Maybe Integer +, configQuickCheckMaxSuccess :: Maybe Int +, configQuickCheckMaxDiscardRatio :: Maybe Int +, configQuickCheckMaxSize :: Maybe Int +, configSmallCheckDepth :: Int +, configColorMode :: ColorMode +, configDiff :: Bool +, configFormatter :: Maybe Formatter +, configHtmlOutput :: Bool +, configOutputFile :: Either Handle FilePath +, configConcurrentJobs :: Maybe Int +} + +defaultConfig :: Config +defaultConfig = Config { + configIgnoreConfigFile = False +, configDryRun = False +, configPrintCpuTime = False +, configFastFail = False +, configFailureReport = Nothing +, configRerun = False +, configRerunAllOnSuccess = False +, configFilterPredicate = Nothing +, configSkipPredicate = Nothing +, configQuickCheckSeed = Nothing +, configQuickCheckMaxSuccess = Nothing +, configQuickCheckMaxDiscardRatio = Nothing +, configQuickCheckMaxSize = Nothing +, configSmallCheckDepth = paramsSmallCheckDepth defaultParams +, configColorMode = ColorAuto +, configDiff = True +, configFormatter = Nothing +, configHtmlOutput = False +, configOutputFile = Left stdout +, configConcurrentJobs = Nothing +} + +filterOr :: Maybe (Path -> Bool) -> Maybe (Path -> Bool) -> Maybe (Path -> Bool) +filterOr p1_ p2_ = case (p1_, p2_) of + (Just p1, Just p2) -> Just $ \path -> p1 path || p2 path + _ -> p1_ <|> p2_ + +addMatch :: String -> Config -> Config +addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c} + +addSkip :: String -> Config -> Config +addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c} + +setDepth :: Int -> Config -> Config +setDepth n c = c {configSmallCheckDepth = n} + +setMaxSuccess :: Int -> Config -> Config +setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n} + +setMaxSize :: Int -> Config -> Config +setMaxSize n c = c {configQuickCheckMaxSize = Just n} + +setMaxDiscardRatio :: Int -> Config -> Config +setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n} + +setSeed :: Integer -> Config -> Config +setSeed n c = c {configQuickCheckSeed = Just n} + +data ColorMode = ColorAuto | ColorNever | ColorAlways + deriving (Eq, Show) + +formatters :: [(String, Formatter)] +formatters = [ + ("specdoc", specdoc) + , ("progress", progress) + , ("failed-examples", failed_examples) + , ("silent", silent) + ] + +formatHelp :: String +formatHelp = unlines (addLineBreaks "use a custom formatter; this can be one of:" ++ map ((" " ++) . fst) formatters) + +type Result m = Either InvalidArgument (m Config) + +data InvalidArgument = InvalidArgument String String + +data Arg a = Arg { + _argumentName :: String +, _argumentParser :: String -> Maybe a +, _argumentSetter :: a -> Config -> Config +} + +mkOption :: Monad m => [Char] -> String -> Arg a -> String -> OptDescr (Result m -> Result m) +mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help + where + arg input x = x >>= \c -> case parser input of + Just n -> Right (setter n `liftM` c) + Nothing -> Left (InvalidArgument name input) + +addLineBreaks :: String -> [String] +addLineBreaks = lineBreaksAt 40 + +h :: String -> String +h = unlines . addLineBreaks + +commandLineOptions :: [OptDescr (Result Maybe -> Result Maybe)] +commandLineOptions = [ + Option [] ["help"] (NoArg (const $ Right Nothing)) (h "display this help and exit") + , Option [] ["ignore-dot-hspec"] (NoArg setIgnoreConfigFile) (h "do not read options from ~/.hspec and .hspec") + , mkOption "m" "match" (Arg "PATTERN" return addMatch) (h "only run examples that match given PATTERN") + , mkOption [] "skip" (Arg "PATTERN" return addSkip) (h "skip examples that match given PATTERN") + ] + where + setIgnoreConfigFile = set $ \config -> config {configIgnoreConfigFile = True} + +configFileOptions :: Monad m => [OptDescr (Result m -> Result m)] +configFileOptions = [ + Option [] ["color"] (NoArg setColor) (h "colorize the output") + , Option [] ["no-color"] (NoArg setNoColor) (h "do not colorize the output") + , Option [] ["diff"] (NoArg setDiff) (h "show colorized diffs") + , Option [] ["no-diff"] (NoArg setNoDiff) (h "do not show colorized diffs") + , mkOption "f" "format" (Arg "FORMATTER" readFormatter setFormatter) formatHelp + , mkOption "o" "out" (Arg "FILE" return setOutputFile) (h "write output to a file instead of STDOUT") + , mkOption [] "depth" (Arg "N" readMaybe setDepth) (h "maximum depth of generated test values for SmallCheck properties") + , mkOption "a" "qc-max-success" (Arg "N" readMaybe setMaxSuccess) (h "maximum number of successful tests before a QuickCheck property succeeds") + , mkOption "" "qc-max-size" (Arg "N" readMaybe setMaxSize) (h "size to use for the biggest test cases") + , mkOption "" "qc-max-discard" (Arg "N" readMaybe setMaxDiscardRatio) (h "maximum number of discarded tests per successful test before giving up") + , mkOption [] "seed" (Arg "N" readMaybe setSeed) (h "used seed for QuickCheck properties") + , Option [] ["print-cpu-time"] (NoArg setPrintCpuTime) (h "include used CPU time in summary") + , Option [] ["dry-run"] (NoArg setDryRun) (h "pretend that everything passed; don't verify anything") + , Option [] ["fail-fast"] (NoArg setFastFail) (h "abort on first failure") + , Option "r" ["rerun"] (NoArg setRerun) (h "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)") + , mkOption [] "failure-report" (Arg "FILE" return setFailureReport)(h "read/write a failure report for use with --rerun") + , Option [] ["rerun-all-on-success"] (NoArg setRerunAllOnSuccess) (h "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)") + , mkOption "j" "jobs" (Arg "N" readMaxJobs setMaxJobs) (h "run at most N parallelizable tests simultaneously (default: number of available processors)") + ] + where + readFormatter :: String -> Maybe Formatter + readFormatter = (`lookup` formatters) + + readMaxJobs :: String -> Maybe Int + readMaxJobs s = do + n <- readMaybe s + guard $ n > 0 + return n + + setFormatter :: Formatter -> Config -> Config + setFormatter f c = c {configFormatter = Just f} + + setOutputFile :: String -> Config -> Config + setOutputFile file c = c {configOutputFile = Right file} + + setFailureReport :: String -> Config -> Config + setFailureReport file c = c {configFailureReport = Just file} + + setMaxJobs :: Int -> Config -> Config + setMaxJobs n c = c {configConcurrentJobs = Just n} + + setPrintCpuTime = set $ \config -> config {configPrintCpuTime = True} + setDryRun = set $ \config -> config {configDryRun = True} + setFastFail = set $ \config -> config {configFastFail = True} + setRerun = set $ \config -> config {configRerun = True} + setRerunAllOnSuccess = set $ \config -> config {configRerunAllOnSuccess = True} + setColor = set $ \config -> config {configColorMode = ColorAlways} + setNoColor = set $ \config -> config {configColorMode = ColorNever} + setDiff = set $ \config -> config {configDiff = True} + setNoDiff = set $ \config -> config {configDiff = False} + +set :: Monad m => (Config -> Config) -> Either a (m Config) -> Either a (m Config) +set = liftM . liftM + +documentedOptions :: [OptDescr (Result Maybe -> Result Maybe)] +documentedOptions = commandLineOptions ++ configFileOptions + +undocumentedOptions :: [OptDescr (Result Maybe -> Result Maybe)] +undocumentedOptions = [ + -- for compatibility with test-framework + mkOption [] "maximum-generated-tests" (Arg "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default" + + -- undocumented for now, as we probably want to change this to produce a + -- standalone HTML report in the future + , Option [] ["html"] (NoArg setHtml) "produce HTML output" + + -- now a noop + , Option "v" ["verbose"] (NoArg id) "do not suppress output to stdout when evaluating examples" + ] + where + setHtml :: Result Maybe -> Result Maybe + setHtml = set $ \config -> config {configHtmlOutput = True} + +recognizedOptions :: [OptDescr (Result Maybe -> Result Maybe)] +recognizedOptions = documentedOptions ++ undocumentedOptions + +parseOptions :: Config -> String -> [ConfigFile] -> Maybe EnvVar -> [String] -> Either (ExitCode, String) Config +parseOptions config prog configFiles envVar args = do + foldM (parseFileOptions prog) config configFiles + >>= parseEnvVarOptions prog envVar + >>= parseCommandLineOptions prog args + +parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config +parseCommandLineOptions prog args config = case parse recognizedOptions config args of + Right Nothing -> Left (ExitSuccess, usageInfo ("Usage: " ++ prog ++ " [OPTION]...\n\nOPTIONS") documentedOptions) + Right (Just c) -> Right c + Left err -> failure err + where + failure err = Left (ExitFailure 1, prog ++ ": " ++ err ++ "\nTry `" ++ prog ++ " --help' for more information.\n") + +parseFileOptions :: String -> Config -> ConfigFile -> Either (ExitCode, String) Config +parseFileOptions prog config (name, args) = + parseOtherOptions prog ("in config file " ++ name) args config + +parseEnvVarOptions :: String -> (Maybe EnvVar) -> Config -> Either (ExitCode, String) Config +parseEnvVarOptions prog args = + parseOtherOptions prog ("from environment variable " ++ envVarName) (fromMaybe [] args) + +parseOtherOptions :: String -> String -> [String] -> Config -> Either (ExitCode, String) Config +parseOtherOptions prog source args config = case parse configFileOptions config args of + Right (Identity c) -> Right c + Left err -> failure err + where + failure err = Left (ExitFailure 1, prog ++ ": " ++ message) + where + message = unlines $ case lines err of + [x] -> [x ++ " " ++ source] + xs -> xs ++ [source] + +parse :: Monad m => [OptDescr (Result m -> Result m)] -> Config -> [String] -> Either String (m Config) +parse options config args = case getOpt Permute options args of + (opts, [], []) -> case foldl' (flip id) (Right $ return config) opts of + Left (InvalidArgument name value) -> Left ("invalid argument `" ++ value ++ "' for `--" ++ name ++ "'") + Right x -> Right x + (_, _, err:_) -> Left (init err) + (_, arg:_, _) -> Left ("unexpected argument `" ++ arg ++ "'") + +ignoreConfigFile :: Config -> [String] -> IO Bool +ignoreConfigFile config args = do + ignore <- lookupEnv "IGNORE_DOT_HSPEC" + case ignore of + Just _ -> return True + Nothing -> case parse recognizedOptions config args of + Right (Just c) -> return (configIgnoreConfigFile c) + _ -> return False diff --git a/src/Test/Hspec/Core/QuickCheck.hs b/src/Test/Hspec/Core/QuickCheck.hs new file mode 100644 index 0000000..9a0ec64 --- /dev/null +++ b/src/Test/Hspec/Core/QuickCheck.hs @@ -0,0 +1,37 @@ +-- | Stability: provisional +module Test.Hspec.Core.QuickCheck ( + modifyMaxSuccess +, modifyMaxDiscardRatio +, modifyMaxSize + +) where + +import Test.QuickCheck +import Test.Hspec.Core.Spec + +-- | Use a modified `maxSuccess` for given spec. +modifyMaxSuccess :: (Int -> Int) -> SpecWith a -> SpecWith a +modifyMaxSuccess = modifyArgs . modify + where + modify :: (Int -> Int) -> Args -> Args + modify f args = args {maxSuccess = f (maxSuccess args)} + +-- | Use a modified `maxDiscardRatio` for given spec. +modifyMaxDiscardRatio :: (Int -> Int) -> SpecWith a -> SpecWith a +modifyMaxDiscardRatio = modifyArgs . modify + where + modify :: (Int -> Int) -> Args -> Args + modify f args = args {maxDiscardRatio = f (maxDiscardRatio args)} + +-- | Use a modified `maxSize` for given spec. +modifyMaxSize :: (Int -> Int) -> SpecWith a -> SpecWith a +modifyMaxSize = modifyArgs . modify + where + modify :: (Int -> Int) -> Args -> Args + modify f args = args {maxSize = f (maxSize args)} + +modifyArgs :: (Args -> Args) -> SpecWith a -> SpecWith a +modifyArgs = modifyParams . modify + where + modify :: (Args -> Args) -> Params -> Params + modify f p = p {paramsQuickCheckArgs = f (paramsQuickCheckArgs p)} diff --git a/src/Test/Hspec/Core/QuickCheckUtil.hs b/src/Test/Hspec/Core/QuickCheckUtil.hs new file mode 100644 index 0000000..33245c3 --- /dev/null +++ b/src/Test/Hspec/Core/QuickCheckUtil.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.QuickCheckUtil where + +import Prelude () +import Test.Hspec.Core.Compat + +import Data.Int +import Test.QuickCheck hiding (Result(..)) +import Test.QuickCheck as QC +import Test.QuickCheck.Property hiding (Result(..)) +import Test.QuickCheck.Gen +import qualified Test.QuickCheck.Property as QCP +import Test.QuickCheck.IO () + + +#if MIN_VERSION_QuickCheck(2,7,0) +import Test.QuickCheck.Random +#endif + +import System.Random + +import Test.Hspec.Core.Util + +aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property +#if MIN_VERSION_QuickCheck(2,7,0) +aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a -> (unGen . unProperty $ p a) r n +#else +aroundProperty action p = MkGen $ \r n -> aroundProp action $ \a -> (unGen $ p a) r n +#endif + +aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop +aroundProp action p = MkProp $ aroundRose action (\a -> unProp $ p a) + +aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result +aroundRose action r = ioRose $ do + ref <- newIORef (return QCP.succeeded) + action $ \a -> reduceRose (r a) >>= writeIORef ref + readIORef ref + +formatNumbers :: Result -> String +formatNumbers r = "(after " ++ pluralize (numTests r) "test" ++ shrinks ++ ")" + where + shrinks + | 0 < numShrinks r = " and " ++ pluralize (numShrinks r) "shrink" + | otherwise = "" + +newSeed :: IO Int +newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$> +#if MIN_VERSION_QuickCheck(2,7,0) + newQCGen +#else + newStdGen +#endif + +#if MIN_VERSION_QuickCheck(2,7,0) +mkGen :: Int -> QCGen +mkGen = mkQCGen +#else +mkGen :: Int -> StdGen +mkGen = mkStdGen +#endif diff --git a/src/Test/Hspec/Core/Runner.hs b/src/Test/Hspec/Core/Runner.hs new file mode 100644 index 0000000..dfc2c6e --- /dev/null +++ b/src/Test/Hspec/Core/Runner.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE CPP #-} + +#if MIN_VERSION_base(4,6,0) +-- Control.Concurrent.QSem is deprecated in base-4.6.0.* +{-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif + +-- | +-- Stability: provisional +module Test.Hspec.Core.Runner ( +-- * Running a spec + hspec +, hspecWith +, hspecResult +, hspecWithResult + +-- * Types +, Summary (..) +, Config (..) +, ColorMode (..) +, Path +, defaultConfig +, configAddFilter + +#ifdef TEST +, rerunAll +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Control.Monad +import Data.Maybe +import System.IO +import System.Environment (getProgName, getArgs, withArgs) +import System.Exit +import qualified Control.Exception as E +import Control.Concurrent + +import System.Console.ANSI (hHideCursor, hShowCursor) +import qualified Test.QuickCheck as QC +import Control.Monad.IO.Class (liftIO) + +import Test.Hspec.Core.Util (Path) +import Test.Hspec.Core.Spec +import Test.Hspec.Core.Config +import Test.Hspec.Core.Formatters +import Test.Hspec.Core.Formatters.Internal +import qualified Test.Hspec.Core.Formatters.Internal as Formatter +import Test.Hspec.Core.FailureReport +import Test.Hspec.Core.QuickCheckUtil + +import Test.Hspec.Core.Runner.Eval + +-- | Filter specs by given predicate. +-- +-- The predicate takes a list of "describe" labels and a "requirement". +filterSpecs :: Config -> [SpecTree a] -> [SpecTree a] +filterSpecs c = go [] + where + p :: Path -> Bool + p path = (fromMaybe (const True) (configFilterPredicate c) path) && + not (fromMaybe (const False) (configSkipPredicate c) path) + + go :: [String] -> [SpecTree a] -> [SpecTree a] + go groups = mapMaybe (goSpec groups) + + goSpecs :: [String] -> [SpecTree a] -> ([SpecTree a] -> b) -> Maybe b + goSpecs groups specs ctor = case go groups specs of + [] -> Nothing + xs -> Just (ctor xs) + + goSpec :: [String] -> SpecTree a -> Maybe (SpecTree a) + 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 -> [SpecTree ()] -> [SpecTree ()] +applyDryRun c + | configDryRun c = map (removeCleanup . fmap markSuccess) + | otherwise = id + where + markSuccess :: Item () -> Item () + markSuccess item = item {itemExample = safeEvaluateExample Success} + + removeCleanup :: SpecTree () -> SpecTree () + removeCleanup spec = case spec of + Node x xs -> Node x (map removeCleanup xs) + NodeWithCleanup _ xs -> NodeWithCleanup (\() -> return ()) (map removeCleanup xs) + leaf@(Leaf _) -> leaf + +-- | Run given spec and write a report to `stdout`. +-- Exit with `exitFailure` if at least one spec item fails. +hspec :: Spec -> IO () +hspec = hspecWith defaultConfig + +-- Add a seed to given config if there is none. That way the same seed is used +-- for all properties. This helps with --seed and --rerun. +ensureSeed :: Config -> IO Config +ensureSeed c = case configQuickCheckSeed c of + Nothing -> do + seed <- newSeed + return c {configQuickCheckSeed = Just (fromIntegral seed)} + _ -> return c + +-- | Run given spec with custom options. +-- This is similar to `hspec`, but more flexible. +hspecWith :: Config -> Spec -> IO () +hspecWith conf spec = do + r <- hspecWithResult conf spec + unless (isSuccess r) exitFailure + +isSuccess :: Summary -> Bool +isSuccess summary = summaryFailures summary == 0 + +-- | Run given spec and returns a summary of the test run. +-- +-- /Note/: `hspecResult` does not exit with `exitFailure` on failing spec +-- items. If you need this, you have to check the `Summary` yourself and act +-- accordingly. +hspecResult :: Spec -> IO Summary +hspecResult = hspecWithResult defaultConfig + +-- | Run given spec with custom options and returns a summary of the test run. +-- +-- /Note/: `hspecWithResult` does not exit with `exitFailure` on failing spec +-- items. If you need this, you have to check the `Summary` yourself and act +-- accordingly. +hspecWithResult :: Config -> Spec -> IO Summary +hspecWithResult config spec = do + prog <- getProgName + args <- getArgs + (oldFailureReport, c_) <- getConfig config prog args + c <- ensureSeed c_ + if configRerunAllOnSuccess c + -- With --rerun-all we may run the spec twice. For that reason GHC can not + -- optimize away the spec tree. That means that the whole spec tree has to + -- be constructed in memory and we loose constant space behavior. + -- + -- By separating between rerunAllMode and normalMode here, we retain + -- constant space behavior in normalMode. + -- + -- see: https://github.com/hspec/hspec/issues/169 + then rerunAllMode c oldFailureReport + else normalMode c + where + normalMode c = runSpec c spec + rerunAllMode c oldFailureReport = do + summary <- runSpec c spec + if rerunAll c oldFailureReport summary + then hspecWithResult config spec + else return summary + +runSpec :: Config -> Spec -> IO Summary +runSpec config spec = do + doNotLeakCommandLineArgumentsToExamples $ withHandle config $ \h -> do + let formatter = fromMaybe specdoc (configFormatter config) + seed = (fromJust . configQuickCheckSeed) config + qcArgs = configQuickCheckArgs config + + jobsSem <- newQSem =<< case configConcurrentJobs config of + Nothing -> getDefaultConcurrentJobs + Just maxJobs -> return maxJobs + + useColor <- doesUseColor h config + + filteredSpec <- filterSpecs config . applyDryRun config <$> runSpecM spec + + withHiddenCursor useColor h $ + runFormatM useColor (configDiff config) (configHtmlOutput config) (configPrintCpuTime config) seed h $ do + runFormatter jobsSem useColor h config formatter filteredSpec `finally_` do + Formatter.interpret $ failedFormatter formatter + + Formatter.interpret $ footerFormatter formatter + + xs <- map failureRecordPath <$> Formatter.interpret getFailMessages + liftIO $ dumpFailureReport config seed qcArgs xs + + Summary <$> Formatter.interpret getTotalCount <*> Formatter.interpret getFailCount + +dumpFailureReport :: Config -> Integer -> QC.Args -> [Path] -> IO () +dumpFailureReport config seed qcArgs xs = do + writeFailureReport config FailureReport { + failureReportSeed = seed + , failureReportMaxSuccess = QC.maxSuccess qcArgs + , failureReportMaxSize = QC.maxSize qcArgs + , failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs + , failureReportPaths = xs + } + +doNotLeakCommandLineArgumentsToExamples :: IO a -> IO a +doNotLeakCommandLineArgumentsToExamples = withArgs [] + +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 + +rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool +rerunAll _ Nothing _ = False +rerunAll config (Just oldFailureReport) summary = + configRerunAllOnSuccess config + && configRerun config + && isSuccess summary + && (not . null) (failureReportPaths oldFailureReport) + +isDumb :: IO Bool +isDumb = maybe False (== "dumb") <$> lookupEnv "TERM" + +-- | Summary of a test run. +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) diff --git a/src/Test/Hspec/Core/Runner/Eval.hs b/src/Test/Hspec/Core/Runner/Eval.hs new file mode 100644 index 0000000..162a9ef --- /dev/null +++ b/src/Test/Hspec/Core/Runner/Eval.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE CPP #-} + +#if MIN_VERSION_base(4,6,0) +-- Control.Concurrent.QSem is deprecated in base-4.6.0.* +{-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif + +module Test.Hspec.Core.Runner.Eval (runFormatter) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Control.Monad (unless, when) +import qualified Control.Exception as E +import Control.Concurrent +import System.IO (Handle) + +import Control.Monad.IO.Class (liftIO) +import Data.Time.Clock.POSIX + +import Test.Hspec.Core.Util +import Test.Hspec.Core.Spec +import Test.Hspec.Core.Config +import Test.Hspec.Core.Formatters hiding (FormatM) +import Test.Hspec.Core.Formatters.Internal +import qualified Test.Hspec.Core.Formatters.Internal as Formatter +import Test.Hspec.Core.Timer + +type EvalTree = Tree (ActionWith ()) (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) + +-- | Evaluate all examples of a given spec and produce a report. +runFormatter :: QSem -> Bool -> Handle -> Config -> Formatter -> [SpecTree ()] -> FormatM () +runFormatter jobsSem useColor h c formatter specs = do + Formatter.interpret $ headerFormatter formatter + chan <- liftIO newChan + reportProgress <- liftIO mkReportProgress + run chan reportProgress c formatter (toEvalTree specs) + where + mkReportProgress :: IO (Path -> Progress -> IO ()) + mkReportProgress + | useColor = every 0.05 $ exampleProgress formatter h + | otherwise = return $ \_ _ -> return () + + toEvalTree :: [SpecTree ()] -> [EvalTree] + toEvalTree = map (fmap f) + where + f :: Item () -> (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) + f (Item requirement loc isParallelizable e) = (requirement, loc, parallelize jobsSem isParallelizable $ e params ($ ())) + + params :: Params + params = Params (configQuickCheckArgs c) (configSmallCheckDepth c) + +-- | Execute given action at most every specified number of seconds. +every :: POSIXTime -> (a -> b -> IO ()) -> IO (a -> b -> IO ()) +every seconds action = do + timer <- newTimer seconds + return $ \a b -> do + r <- timer + when r (action a b) + +type FormatResult = Either E.SomeException Result -> FormatM () + +parallelize :: QSem -> Bool -> (ProgressCallback -> IO (Either E.SomeException Result)) -> ProgressCallback -> FormatResult -> IO (FormatM ()) +parallelize jobsSem isParallelizable e + | isParallelizable = runParallel jobsSem e + | otherwise = runSequentially e + +runSequentially :: (ProgressCallback -> IO (Either E.SomeException Result)) -> ProgressCallback -> FormatResult -> IO (FormatM ()) +runSequentially e reportProgress formatResult = return $ do + result <- liftIO $ e reportProgress + formatResult result + +data Report = ReportProgress Progress | ReportResult (Either E.SomeException Result) + +runParallel :: QSem -> (ProgressCallback -> IO (Either E.SomeException Result)) -> ProgressCallback -> FormatResult -> IO (FormatM ()) +runParallel jobsSem e reportProgress formatResult = do + mvar <- newEmptyMVar + _ <- forkIO $ E.bracket_ (waitQSem jobsSem) (signalQSem jobsSem) $ do + let progressCallback = replaceMVar mvar . ReportProgress + result <- e progressCallback + replaceMVar mvar (ReportResult result) + return $ evalReport mvar + where + evalReport :: MVar Report -> FormatM () + evalReport mvar = do + r <- liftIO (takeMVar mvar) + case r of + ReportProgress p -> do + liftIO $ reportProgress p + evalReport mvar + ReportResult result -> formatResult result + + replaceMVar :: MVar a -> a -> IO () + replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p + +data Message = Done | Run (FormatM ()) + +run :: Chan Message -> (Path -> ProgressCallback) -> Config -> Formatter -> [EvalTree] -> FormatM () +run chan reportProgress_ c formatter specs = do + liftIO $ do + forM_ specs (queueSpec []) + writeChan chan Done + processMessages (readChan chan) (configFastFail c) + where + defer :: FormatM () -> IO () + defer = writeChan chan . Run + + runCleanup :: IO () -> Path -> FormatM () + runCleanup action path = do + r <- liftIO $ safeTry action + either (failed Nothing path . Left) return r + + queueSpec :: [String] -> EvalTree -> IO () + queueSpec rGroups (Node group xs) = do + defer (Formatter.interpret $ exampleGroupStarted formatter (reverse rGroups) group) + forM_ xs (queueSpec (group : rGroups)) + defer (Formatter.interpret $ exampleGroupDone formatter) + queueSpec rGroups (NodeWithCleanup action xs) = do + forM_ xs (queueSpec rGroups) + defer (runCleanup (action ()) (reverse rGroups, "afterAll-hook")) + queueSpec rGroups (Leaf e) = + queueExample (reverse rGroups) e + + queueExample :: [String] -> (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) -> IO () + queueExample groups (requirement, loc, e) = e reportProgress formatResult >>= defer + where + path :: Path + path = (groups, requirement) + + reportProgress = reportProgress_ path + + formatResult :: FormatResult + formatResult result = do + case result of + Right Success -> do + increaseSuccessCount + Formatter.interpret $ exampleSucceeded formatter path + Right (Pending reason) -> do + increasePendingCount + Formatter.interpret $ examplePending formatter path reason + Right (Failure loc_ err) -> failed (loc_ <|> loc) path (Right err) + Left err -> failed loc path (Left err) + + failed loc path err = do + increaseFailCount + addFailMessage loc path err + Formatter.interpret $ exampleFailed formatter path err + +processMessages :: IO Message -> Bool -> FormatM () +processMessages getMessage fastFail = go + where + go = liftIO getMessage >>= \m -> case m of + Run action -> do + action + fails <- Formatter.interpret getFailCount + unless (fastFail && fails /= 0) go + Done -> return () diff --git a/src/Test/Hspec/Core/Spec.hs b/src/Test/Hspec/Core/Spec.hs new file mode 100644 index 0000000..899742e --- /dev/null +++ b/src/Test/Hspec/Core/Spec.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +-- | +-- Stability: unstable +-- +-- This module provides access to Hspec's internals. It is less stable than +-- other parts of the API. For most users @Test.Hspec@ is more suitable! +module Test.Hspec.Core.Spec ( + +-- * Defining a spec + it +, specify +, describe +, context +, pending +, pendingWith +, xit +, xspecify +, xdescribe +, xcontext +, parallel + +-- * The @SpecM@ monad +, module Test.Hspec.Core.Spec.Monad + +-- * A type class for examples +, module Test.Hspec.Core.Example + +-- * Internal representation of a spec tree +, module Test.Hspec.Core.Tree +) where + +import qualified Control.Exception as E +import Data.CallStack + +import Test.Hspec.Expectations (Expectation) + +import Test.Hspec.Core.Example +import Test.Hspec.Core.Hooks +import Test.Hspec.Core.Tree +import Test.Hspec.Core.Spec.Monad + +-- | The @describe@ function combines a list of specs into a larger spec. +describe :: String -> SpecWith a -> SpecWith a +describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . specGroup label + +-- | @context@ is an alias for `describe`. +context :: String -> SpecWith a -> SpecWith a +context = describe + +-- | +-- Changing `describe` to `xdescribe` marks all spec items of the corresponding subtree as pending. +-- +-- This can be used to temporarily disable spec items. +xdescribe :: String -> SpecWith a -> SpecWith a +xdescribe label spec = before_ pending $ describe label spec + +-- | @xcontext@ is an alias for `xdescribe`. +xcontext :: String -> SpecWith a -> SpecWith a +xcontext = xdescribe + +-- | The @it@ function creates a spec item. +-- +-- A spec item consists of: +-- +-- * a textual description of a desired behavior +-- +-- * an example for that behavior +-- +-- > describe "absolute" $ do +-- > it "returns a positive number when given a negative number" $ +-- > absolute (-1) == 1 +it :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) +it label action = fromSpecList [specItem label action] + +-- | @specify@ is an alias for `it`. +specify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) +specify = it + +-- | +-- Changing `it` to `xit` marks the corresponding spec item as pending. +-- +-- This can be used to temporarily disable a spec item. +xit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) +xit label action = before_ pending $ it label action + +-- | @xspecify@ is an alias for `xit`. +xspecify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) +xspecify = xit + +-- | `parallel` marks all spec items of the given spec to be safe for parallel +-- evaluation. +parallel :: SpecWith a -> SpecWith a +parallel = mapSpecItem_ $ \item -> item {itemIsParallelizable = True} + +-- | `pending` can be used to mark a spec item as pending. +-- +-- If you want to textually specify a behavior but do not have an example yet, +-- use this: +-- +-- > describe "fancyFormatter" $ do +-- > it "can format text in a way that everyone likes" $ +-- > pending +pending :: Expectation +pending = E.throwIO (Pending Nothing) + +-- | +-- `pendingWith` is similar to `pending`, but it takes an additional string +-- argument that can be used to specify the reason for why the spec item is pending. +pendingWith :: String -> Expectation +pendingWith = E.throwIO . Pending . Just diff --git a/src/Test/Hspec/Core/Spec/Monad.hs b/src/Test/Hspec/Core/Spec/Monad.hs new file mode 100644 index 0000000..2c2ae2f --- /dev/null +++ b/src/Test/Hspec/Core/Spec/Monad.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Test.Hspec.Core.Spec.Monad ( + Spec +, SpecWith +, SpecM (..) +, runSpecM +, fromSpecList +, runIO + +, mapSpecTree +, mapSpecItem +, mapSpecItem_ +, modifyParams +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Control.Monad.Trans.Writer +import Control.Monad.IO.Class (liftIO) + +import Test.Hspec.Core.Example +import Test.Hspec.Core.Tree + +type Spec = SpecWith () + +type SpecWith a = SpecM a () + +-- | A writer monad for `SpecTree` forests +newtype SpecM a r = SpecM (WriterT [SpecTree a] IO r) + deriving (Functor, Applicative, Monad) + +-- | Convert a `Spec` to a forest of `SpecTree`s. +runSpecM :: SpecWith a -> IO [SpecTree a] +runSpecM (SpecM specs) = execWriterT specs + +-- | Create a `Spec` from a forest of `SpecTree`s. +fromSpecList :: [SpecTree a] -> SpecWith a +fromSpecList = SpecM . tell + +-- | Run an IO action while constructing the spec tree. +-- +-- `SpecM` is a monad to construct a spec tree, without executing any spec +-- items. @runIO@ allows you to run IO actions during this construction phase. +-- The IO action is always run when the spec tree is constructed (e.g. even +-- when @--dry-run@ is specified). +-- If you do not need the result of the IO action to construct the spec tree, +-- `Test.Hspec.Core.Hooks.beforeAll` may be more suitable for your use case. +runIO :: IO r -> SpecM a r +runIO = SpecM . liftIO + +mapSpecTree :: (SpecTree a -> SpecTree b) -> SpecWith a -> SpecWith b +mapSpecTree f spec = runIO (runSpecM spec) >>= fromSpecList . map f + +mapSpecItem :: (ActionWith a -> ActionWith b) -> (Item a -> Item b) -> SpecWith a -> SpecWith b +mapSpecItem g f = mapSpecTree go + where + go spec = case spec of + Node d xs -> Node d (map go xs) + NodeWithCleanup cleanup xs -> NodeWithCleanup (g cleanup) (map go xs) + Leaf item -> Leaf (f item) + +mapSpecItem_ :: (Item a -> Item a) -> SpecWith a -> SpecWith a +mapSpecItem_ = mapSpecItem id + +modifyParams :: (Params -> Params) -> SpecWith a -> SpecWith a +modifyParams f = mapSpecItem_ $ \item -> item {itemExample = \p -> (itemExample item) (f p)} diff --git a/src/Test/Hspec/Core/Timer.hs b/src/Test/Hspec/Core/Timer.hs new file mode 100644 index 0000000..9e75b34 --- /dev/null +++ b/src/Test/Hspec/Core/Timer.hs @@ -0,0 +1,14 @@ +module Test.Hspec.Core.Timer where + +import Data.IORef +import Data.Time.Clock.POSIX + +newTimer :: POSIXTime -> IO (IO Bool) +newTimer delay = do + ref <- getPOSIXTime >>= newIORef + return $ do + t0 <- readIORef ref + t1 <- getPOSIXTime + if delay < t1 - t0 + then writeIORef ref t1 >> return True + else return False diff --git a/src/Test/Hspec/Core/Tree.hs b/src/Test/Hspec/Core/Tree.hs new file mode 100644 index 0000000..ef164b7 --- /dev/null +++ b/src/Test/Hspec/Core/Tree.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- Stability: unstable +module Test.Hspec.Core.Tree ( + SpecTree +, Tree (..) +, Item (..) +, specGroup +, specItem +) where + +import Data.CallStack +import Control.Exception + +import Prelude () +import Test.Hspec.Core.Compat + +import Test.Hspec.Core.Example + +-- | Internal tree data structure +data Tree c a = + Node String [Tree c a] + | NodeWithCleanup c [Tree c a] + | Leaf a + deriving (Functor, Foldable, Traversable) + +-- | A tree is used to represent a spec internally. The tree is parametrize +-- over the type of cleanup actions and the type of the actual spec items. +type SpecTree a = Tree (ActionWith a) (Item a) + +-- | +-- @Item@ is used to represent spec items internally. A spec item consists of: +-- +-- * a textual description of a desired behavior +-- * an example for that behavior +-- * additional meta information +-- +-- Everything that is an instance of the `Example` type class can be used as an +-- example, including QuickCheck properties, Hspec expectations and HUnit +-- assertions. +data Item a = Item { + -- | Textual description of behavior + itemRequirement :: String + -- | Source location of the spec item +, itemLocation :: Maybe Location + -- | A flag that indicates whether it is safe to evaluate this spec item in + -- parallel with other spec items +, itemIsParallelizable :: Bool + -- | Example for behavior +, itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO (Either SomeException Result) +} + +-- | The @specGroup@ function combines a list of specs into a larger spec. +specGroup :: String -> [SpecTree a] -> SpecTree a +specGroup s = Node msg + where + msg + | null s = "(no description given)" + | otherwise = s + +-- | The @specItem@ function creates a spec item. +specItem :: (HasCallStack, Example a) => String -> a -> SpecTree (Arg a) +specItem s e = Leaf $ Item requirement location False (safeEvaluateExample e) + where + requirement + | null s = "(unspecified behavior)" + | otherwise = s + + location :: Maybe Location + location = case reverse callStack of + (_, loc) : _ -> Just (Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) ExactLocation) + _ -> Nothing diff --git a/src/Test/Hspec/Core/Util.hs b/src/Test/Hspec/Core/Util.hs new file mode 100644 index 0000000..24372d3 --- /dev/null +++ b/src/Test/Hspec/Core/Util.hs @@ -0,0 +1,141 @@ +-- | Stability: unstable +module Test.Hspec.Core.Util ( +-- * String functions + pluralize +, strip +, lineBreaksAt + +-- * Working with paths +, Path +, formatRequirement +, filterPredicate + +-- * Working with exception +, safeTry +, formatException +) where + +import Data.List +import Data.Char (isSpace) +import GHC.IO.Exception +import Control.Exception +import Control.Concurrent.Async + +import Test.Hspec.Core.Compat (showType) + +-- | +-- @pluralize count singular@ pluralizes the given @singular@ word unless given +-- @count@ is 1. +-- +-- Examples: +-- +-- >>> pluralize 0 "example" +-- "0 examples" +-- +-- >>> pluralize 1 "example" +-- "1 example" +-- +-- >>> pluralize 2 "example" +-- "2 examples" +pluralize :: Int -> String -> String +pluralize 1 s = "1 " ++ s +pluralize n s = show n ++ " " ++ s ++ "s" + +-- | Strip leading and trailing whitespace +strip :: String -> String +strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse + +-- | +-- ensure that lines are not longer than given `n`, insert line breaks at word +-- boundaries +lineBreaksAt :: Int -> String -> [String] +lineBreaksAt n input = case words input of + [] -> [] + x:xs -> go (x, xs) + where + go :: (String, [String]) -> [String] + go c = case c of + (s, []) -> [s] + (s, y:ys) -> let r = s ++ " " ++ y in + if length r <= n + then go (r, ys) + else s : go (y, ys) + +-- | +-- A `Path` represents the location of an example within the spec tree. +-- +-- It consists of a list of group descriptions and a requirement description. +type Path = ([String], String) + +-- | +-- Try to create a proper English sentence from a path by applying some +-- heuristics. +formatRequirement :: Path -> String +formatRequirement (groups, requirement) = groups_ ++ requirement + where + groups_ = case break (any isSpace) groups of + ([], ys) -> join ys + (xs, ys) -> join (intercalate "." xs : ys) + + join xs = case xs of + [x] -> x ++ " " + ys -> concatMap (++ ", ") ys + +-- | A predicate that can be used to filter a spec tree. +filterPredicate :: String -> Path -> Bool +filterPredicate pattern path@(groups, requirement) = + pattern `isInfixOf` plain + || pattern `isInfixOf` formatted + where + plain = intercalate "/" (groups ++ [requirement]) + formatted = formatRequirement path + +-- | The function `formatException` converts an exception to a string. +-- +-- This is different from `show`. The type of the exception is included, e.g.: +-- +-- >>> formatException (toException DivideByZero) +-- "ArithException (divide by zero)" +-- +-- For `IOException`s the `IOErrorType` is included, as well. +formatException :: SomeException -> String +formatException err@(SomeException e) = case fromException err of + Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ " (" ++ show ioe ++ ")" + Nothing -> showType e ++ " (" ++ show e ++ ")" + where + showIOErrorType :: IOException -> String + showIOErrorType ioe = case ioe_type ioe of + AlreadyExists -> "AlreadyExists" + NoSuchThing -> "NoSuchThing" + ResourceBusy -> "ResourceBusy" + ResourceExhausted -> "ResourceExhausted" + EOF -> "EOF" + IllegalOperation -> "IllegalOperation" + PermissionDenied -> "PermissionDenied" + UserError -> "UserError" + UnsatisfiedConstraints -> "UnsatisfiedConstraints" + SystemError -> "SystemError" + ProtocolError -> "ProtocolError" + OtherError -> "OtherError" + InvalidArgument -> "InvalidArgument" + InappropriateType -> "InappropriateType" + HardwareFault -> "HardwareFault" + UnsupportedOperation -> "UnsupportedOperation" + TimeExpired -> "TimeExpired" + ResourceVanished -> "ResourceVanished" + Interrupted -> "Interrupted" + +-- | @safeTry@ evaluates given action and returns its result. If an exception +-- occurs, the exception is returned instead. Unlike `try` it is agnostic to +-- asynchronous exceptions. +safeTry :: IO a -> IO (Either SomeException a) +safeTry action = bracket runAction cancelAction waitForAction + where + runAction = async ((action >>= evaluate)) + waitForAction = waitCatch + cancelAction a = do + cancel a + -- It is important to wait here to make sure all finalizers in action have + -- been run. Otherwise the main thread can exit before they have finished + -- and the finalizers are only partially run. + waitCatch a -- We use waitCatch to hide the ThreadKilled exception diff --git a/test/All.hs b/test/All.hs new file mode 100644 index 0000000..f7445b8 --- /dev/null +++ b/test/All.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-meta-discover -optF --module-name=All #-} diff --git a/test/Helper.hs b/test/Helper.hs new file mode 100644 index 0000000..e787afc --- /dev/null +++ b/test/Helper.hs @@ -0,0 +1,117 @@ +module Helper ( + module Test.Hspec.Meta +, module Test.Hspec.Core.Compat +, module Test.QuickCheck +, module System.IO.Silently +, sleep +, timeout +, defaultParams +, noOpProgressCallback +, captureLines +, normalizeSummary + +, ignoreExitCode +, ignoreUserInterrupt +, throwException + +, withEnvironment +, inTempDirectory + +, shouldUseArgs + +, removeLocations +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Data.List +import Data.Char +import Control.Monad (guard) +import System.Environment (withArgs, getEnvironment) +import System.Exit +import Control.Concurrent +import qualified Control.Exception as E +import Control.Exception (bracket) +import qualified System.Timeout as System +import Data.Time.Clock.POSIX +import System.IO.Silently +import System.SetEnv +import System.Directory +import System.IO.Temp + +import Test.Hspec.Meta +import Test.QuickCheck hiding (Result(..)) + +import qualified Test.Hspec.Core.Spec as H +import qualified Test.Hspec.Core.Runner as H +import Test.Hspec.Core.QuickCheckUtil (mkGen) + +throwException :: IO () +throwException = E.throwIO (E.ErrorCall "foobar") + +ignoreExitCode :: IO () -> IO () +ignoreExitCode action = action `E.catch` \e -> let _ = e :: ExitCode in return () + +ignoreUserInterrupt :: IO () -> IO () +ignoreUserInterrupt action = E.catchJust (guard . (== E.UserInterrupt)) action return + +captureLines :: IO a -> IO [String] +captureLines = fmap lines . capture_ + +-- replace times in summary with zeroes +normalizeSummary :: [String] -> [String] +normalizeSummary = map f + where + f x | "Finished in " `isPrefixOf` x = map g x + | otherwise = x + g x | isNumber x = '0' + | otherwise = x + +defaultParams :: H.Params +defaultParams = H.defaultParams {H.paramsQuickCheckArgs = stdArgs {replay = Just (mkGen 23, 0), maxSuccess = 1000}} + +noOpProgressCallback :: H.ProgressCallback +noOpProgressCallback _ = return () + +sleep :: POSIXTime -> IO () +sleep = threadDelay . floor . (* 1000000) + +timeout :: POSIXTime -> IO a -> IO (Maybe a) +timeout = System.timeout . floor . (* 1000000) + +shouldUseArgs :: [String] -> (Args -> Bool) -> Expectation +shouldUseArgs args p = do + spy <- newIORef (H.paramsQuickCheckArgs defaultParams) + let interceptArgs item = item {H.itemExample = \params action progressCallback -> writeIORef spy (H.paramsQuickCheckArgs params) >> H.itemExample item params action progressCallback} + spec = H.mapSpecItem_ interceptArgs $ + H.it "foo" False + (silence . ignoreExitCode . withArgs args . H.hspec) spec + readIORef spy >>= (`shouldSatisfy` p) + +removeLocations :: H.SpecWith a -> H.SpecWith a +removeLocations = H.mapSpecItem_ (\item -> item{H.itemLocation = Nothing}) + +withEnvironment :: [(String, String)] -> IO a -> IO a +withEnvironment environment action = bracket saveEnv restoreEnv $ const action + where + saveEnv :: IO [(String, String)] + saveEnv = do + env <- clearEnv + forM_ environment $ uncurry setEnv + return env + restoreEnv :: [(String, String)] -> IO () + restoreEnv env = do + _ <- clearEnv + forM_ env $ uncurry setEnv + clearEnv :: IO [(String, String)] + clearEnv = do + env <- getEnvironment + forM_ env (unsetEnv . fst) + return env + +inTempDirectory :: IO a -> IO a +inTempDirectory action = withSystemTempDirectory "mockery" $ \path -> do + bracket getCurrentDirectory setCurrentDirectory $ \_ -> do + setCurrentDirectory path + action diff --git a/test/Mock.hs b/test/Mock.hs new file mode 100644 index 0000000..dd16042 --- /dev/null +++ b/test/Mock.hs @@ -0,0 +1,15 @@ +module Mock where + +import Prelude () +import Test.Hspec.Core.Compat + +newtype Mock = Mock (IORef Int) + +newMock :: IO Mock +newMock = Mock <$> newIORef 0 + +mockAction :: Mock -> IO () +mockAction (Mock ref) = modifyIORef ref succ + +mockCounter :: Mock -> IO Int +mockCounter (Mock ref) = readIORef ref diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..2ef4f1c --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,11 @@ +module Main where + +import Test.Hspec.Meta +import System.SetEnv +import qualified All + +spec :: Spec +spec = beforeAll_ (setEnv "IGNORE_DOT_HSPEC" "yes") $ afterAll_ (unsetEnv "IGNORE_DOT_HSPEC") All.spec + +main :: IO () +main = hspec spec diff --git a/test/Test/Hspec/Core/CompatSpec.hs b/test/Test/Hspec/Core/CompatSpec.hs new file mode 100644 index 0000000..e2c33f8 --- /dev/null +++ b/test/Test/Hspec/Core/CompatSpec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Test.Hspec.Core.CompatSpec (main, spec) where + +import Helper +import System.SetEnv +import Data.Typeable + +data SomeType = SomeType + deriving Typeable + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "showType" $ do + it "shows unqualified name of type" $ do + showType SomeType `shouldBe` "SomeType" + + describe "showFullType (currently unused)" $ do + it "shows fully qualified name of type" $ do + showFullType SomeType `shouldBe` "Test.Hspec.Core.CompatSpec.SomeType" + + describe "lookupEnv" $ do + it "returns value of specified environment variable" $ do + setEnv "FOO" "bar" + lookupEnv "FOO" `shouldReturn` Just "bar" + + it "returns Nothing if specified environment variable is not set" $ do + unsetEnv "FOO" + lookupEnv "FOO" `shouldReturn` Nothing diff --git a/test/Test/Hspec/Core/ConfigSpec.hs b/test/Test/Hspec/Core/ConfigSpec.hs new file mode 100644 index 0000000..f2f5b71 --- /dev/null +++ b/test/Test/Hspec/Core/ConfigSpec.hs @@ -0,0 +1,33 @@ +module Test.Hspec.Core.ConfigSpec (spec) where + +import Helper +import System.Directory +import System.FilePath + +import Test.Hspec.Core.Config + +spec :: Spec +spec = do + describe "readConfigFiles" $ around_ (withEnvironment []) $ around_ inTempDirectory $ do + it "reads .hspec" $ do + dir <- getCurrentDirectory + let name = dir ".hspec" + writeFile name "--diff" + readConfigFiles `shouldReturn` [(name, ["--diff"])] + + it "reads ~/.hspec" $ do + let name = "my-home/.hspec" + createDirectory "my-home" + writeFile name "--diff" + withEnvironment [("HOME", "my-home")] $ do + readConfigFiles `shouldReturn` [(name, ["--diff"])] + + context "without $HOME" $ do + it "returns empty list" $ do + readConfigFiles `shouldReturn` [] + + context "without current directory" $ do + it "returns empty list" $ do + dir <- getCurrentDirectory + removeDirectory dir + readConfigFiles `shouldReturn` [] diff --git a/test/Test/Hspec/Core/ExampleSpec.hs b/test/Test/Hspec/Core/ExampleSpec.hs new file mode 100644 index 0000000..2522a92 --- /dev/null +++ b/test/Test/Hspec/Core/ExampleSpec.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-} +module Test.Hspec.Core.ExampleSpec (main, spec) where + +import Helper +import Mock +import Data.List +import qualified Control.Exception as E + +import qualified Test.Hspec.Core.Example as H +import qualified Test.Hspec.Core.Spec as H +import qualified Test.Hspec.Core.Runner as H + +main :: IO () +main = hspec spec + +safeEvaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO (Either E.SomeException H.Result) +safeEvaluateExample e = H.safeEvaluateExample e defaultParams ($ ()) noOpProgressCallback + +evaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO H.Result +evaluateExample e = H.evaluateExample e defaultParams ($ ()) noOpProgressCallback + +evaluateExampleWith :: (H.Example e, H.Arg e ~ ()) => (IO () -> IO ()) -> e -> IO H.Result +evaluateExampleWith action e = H.evaluateExample e defaultParams (action . ($ ())) noOpProgressCallback + +evaluateExampleWithArgument :: H.Example e => (ActionWith (H.Arg e) -> IO ()) -> e -> IO H.Result +evaluateExampleWithArgument action e = H.evaluateExample e defaultParams action noOpProgressCallback + +spec :: Spec +spec = do + describe "safeEvaluateExample" $ do + context "for Expectation" $ do + it "returns Failure if an expectation does not hold" $ do + Right (H.Failure _ msg) <- safeEvaluateExample (23 `shouldBe` (42 :: Int)) +#if MIN_VERSION_HUnit(1,5,0) + msg `shouldBe` H.ExpectedButGot Nothing "42" "23" +#else + msg `shouldBe` H.Reason "expected: 42\n but got: 23" +#endif + + context "when used with `pending`" $ do + it "returns Pending" $ do + Right result <- safeEvaluateExample (H.pending) + result `shouldBe` H.Pending Nothing + + context "when used with `pendingWith`" $ do + it "includes the optional reason" $ do + Right result <- safeEvaluateExample (H.pendingWith "foo") + result `shouldBe` H.Pending (Just "foo") + + describe "evaluateExample" $ do + context "for Result" $ do + it "runs around-action" $ do + ref <- newIORef (0 :: Int) + let action :: IO () -> IO () + action e = do + e + modifyIORef ref succ + evaluateExampleWith action (H.Failure Nothing H.NoReason) `shouldReturn` H.Failure Nothing H.NoReason + readIORef ref `shouldReturn` 1 + + it "accepts arguments" $ do + ref <- newIORef (0 :: Int) + let action :: (Integer -> IO ()) -> IO () + action e = do + e 42 + modifyIORef ref succ + evaluateExampleWithArgument action (H.Failure Nothing . H.Reason . show) `shouldReturn` H.Failure Nothing (H.Reason "42") + readIORef ref `shouldReturn` 1 + + context "for Bool" $ do + it "returns Success on True" $ do + evaluateExample True `shouldReturn` H.Success + + it "returns Failure on False" $ do + evaluateExample False `shouldReturn` H.Failure Nothing H.NoReason + + it "propagates exceptions" $ do + evaluateExample (error "foobar" :: Bool) `shouldThrow` errorCall "foobar" + + it "runs around-action" $ do + ref <- newIORef (0 :: Int) + let action :: IO () -> IO () + action e = do + e + modifyIORef ref succ + evaluateExampleWith action False `shouldReturn` H.Failure Nothing H.NoReason + readIORef ref `shouldReturn` 1 + + it "accepts arguments" $ do + ref <- newIORef (0 :: Int) + let action :: (Integer -> IO ()) -> IO () + action e = do + e 42 + modifyIORef ref succ + evaluateExampleWithArgument action (== (23 :: Integer)) `shouldReturn` H.Failure Nothing H.NoReason + readIORef ref `shouldReturn` 1 + + context "for Expectation" $ do + it "returns Success if all expectations hold" $ do + evaluateExample (23 `shouldBe` (23 :: Int)) `shouldReturn` H.Success + + it "propagates exceptions" $ do + evaluateExample (error "foobar" :: Expectation) `shouldThrow` errorCall "foobar" + + it "runs around-action" $ do + ref <- newIORef (0 :: Int) + let action :: IO () -> IO () + action e = do + n <- readIORef ref + e + readIORef ref `shouldReturn` succ n + modifyIORef ref succ + evaluateExampleWith action (modifyIORef ref succ) `shouldReturn` H.Success + readIORef ref `shouldReturn` 2 + + context "for Property" $ do + it "returns Success if property holds" $ do + evaluateExample (property $ \n -> n == (n :: Int)) `shouldReturn` H.Success + + it "returns Failure if property does not hold" $ do + H.Failure _ _ <- evaluateExample $ property $ \n -> n /= (n :: Int) + return () + + it "shows what falsified it" $ do + H.Failure _ r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False + r `shouldBe` (H.Reason . intercalate "\n") [ + "Falsifiable (after 1 test): " + , "0" + , "1" + ] + + it "runs around-action for each single check of the property" $ do + ref <- newIORef (0 :: Int) + let action :: IO () -> IO () + action e = do + n <- readIORef ref + e + readIORef ref `shouldReturn` succ n + modifyIORef ref succ + H.Success <- evaluateExampleWith action (property $ \(_ :: Int) -> modifyIORef ref succ) + readIORef ref `shouldReturn` 2000 + + it "pretty-prints exceptions" $ do + H.Failure _ r <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (E.throw (E.ErrorCall "foobar") :: Bool)) + r `shouldBe` (H.Reason . intercalate "\n") [ +#if MIN_VERSION_QuickCheck(2,7,0) + "uncaught exception: ErrorCall (foobar) (after 1 test)" +#else + "Exception: 'foobar' (after 1 test): " +#endif + , "0" + ] + + context "when used with shouldBe" $ do + it "shows what falsified it" $ do + H.Failure _ (H.Reason r) <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> 23 `shouldBe` (42 :: Int) + r `shouldStartWith` "Falsifiable (after 1 test): \n" + r `shouldEndWith` intercalate "\n" [ + "expected: 42" + , " but got: 23" + , "0" + , "1" + ] + + context "when used with `pending`" $ do + it "returns Pending" $ do + evaluateExample (property H.pending) `shouldReturn` H.Pending Nothing + + context "when used with `pendingWith`" $ do + it "includes the optional reason" $ do + evaluateExample (property $ H.pendingWith "foo") `shouldReturn` H.Pending (Just "foo") + + describe "Expectation" $ do + context "as a QuickCheck property" $ do + it "can be quantified" $ do + e <- newMock + silence . H.hspec $ do + H.it "some behavior" $ property $ \xs -> do + mockAction e + (reverse . reverse) xs `shouldBe` (xs :: [Int]) + mockCounter e `shouldReturn` 100 + + it "can be used with expectations/HUnit assertions" $ do + silence . H.hspecResult $ do + H.describe "readIO" $ do + H.it "is inverse to show" $ property $ \x -> do + (readIO . show) x `shouldReturn` (x :: Int) + `shouldReturn` H.Summary 1 0 diff --git a/test/Test/Hspec/Core/FailureReportSpec.hs b/test/Test/Hspec/Core/FailureReportSpec.hs new file mode 100644 index 0000000..73f734a --- /dev/null +++ b/test/Test/Hspec/Core/FailureReportSpec.hs @@ -0,0 +1,51 @@ +module Test.Hspec.Core.FailureReportSpec (main, spec) where + +import Helper + +import System.IO +import qualified Control.Exception as E +import Test.Hspec.Core.FailureReport +import Test.Hspec.Core.Config + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "writeFailureReport" $ do + it "prints a warning on unexpected exceptions" $ do + r <- hCapture_ [stderr] $ writeFailureReport defaultConfig (E.throw (E.ErrorCall "some error")) + r `shouldBe` "WARNING: Could not write environment variable HSPEC_FAILURES (some error)\n" + + describe "readFailureReport" $ do + context "when configFailureReport is specified" $ do + let + file = "report" + config = defaultConfig {configFailureReport = Just file} + report = FailureReport { + failureReportSeed = 23 + , failureReportMaxSuccess = 42 + , failureReportMaxSize = 65 + , failureReportMaxDiscardRatio = 123 + , failureReportPaths = [(["foo", "bar"], "baz")] + } + it "reads a failure report from a file" $ do + inTempDirectory $ do + writeFailureReport config report + readFailureReport config `shouldReturn` Just report + + context "when file does not exist" $ do + it "returns Nothing" $ do + inTempDirectory $ do + readFailureReport config `shouldReturn` Nothing + + context "when file is malformed" $ do + it "returns Nothing" $ do + hSilence [stderr] $ inTempDirectory $ do + writeFile file "foo" + readFailureReport config `shouldReturn` Nothing + + it "prints a warning" $ do + inTempDirectory $ do + writeFile file "foo" + hCapture_ [stderr] (readFailureReport config) `shouldReturn` "WARNING: Could not read failure report from file \"report\"!\n" diff --git a/test/Test/Hspec/Core/Formatters/DiffSpec.hs b/test/Test/Hspec/Core/Formatters/DiffSpec.hs new file mode 100644 index 0000000..919c75b --- /dev/null +++ b/test/Test/Hspec/Core/Formatters/DiffSpec.hs @@ -0,0 +1,21 @@ +module Test.Hspec.Core.Formatters.DiffSpec (spec) where + +import Helper +import Data.Char + +import Test.Hspec.Core.Formatters.Diff + +spec :: Spec +spec = do + describe "partition" $ do + it "puts backslash-escaped characters into a separate chunks" $ do + partition (show "foo\nbar") `shouldBe` ["\"", "foo", "\\n", "bar", "\""] + + describe "breakList" $ do + context "with a list where the predicate matches at the beginning and the end" $ do + it "breaks the list into pieces" $ do + breakList isAlphaNum "foo bar baz" `shouldBe` ["foo", " ", "bar", " ", " ", "baz"] + + context "with a list where the predicate does not match at the beginning and the end" $ do + it "breaks the list into pieces" $ do + breakList isAlphaNum " foo bar baz " `shouldBe` [" ", " ", "foo", " ", "bar", " ", " ", "baz", " ", " "] diff --git a/test/Test/Hspec/Core/FormattersSpec.hs b/test/Test/Hspec/Core/FormattersSpec.hs new file mode 100644 index 0000000..82c0f86 --- /dev/null +++ b/test/Test/Hspec/Core/FormattersSpec.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE OverloadedStrings #-} +module Test.Hspec.Core.FormattersSpec (spec) where + +import Prelude () +import Helper +import Data.String +import Control.Monad.Trans.Writer +import qualified Control.Exception as E + +import qualified Test.Hspec.Core.Spec as H +import qualified Test.Hspec.Core.Runner as H +import qualified Test.Hspec.Core.Formatters as H +import qualified Test.Hspec.Core.Formatters.Monad as H +import Test.Hspec.Core.Formatters.Monad hiding (interpretWith) + +data ColorizedText = + Plain String + | Info String + | Succeeded String + | Failed String + | Pending String + | Extra String + | Missing String + deriving (Eq, Show) + +instance IsString ColorizedText where + fromString = Plain + +removeColors :: [ColorizedText] -> String +removeColors input = case input of + Plain x : xs -> x ++ removeColors xs + Info x : xs -> x ++ removeColors xs + Succeeded x : xs -> x ++ removeColors xs + Failed x : xs -> x ++ removeColors xs + Pending x : xs -> x ++ removeColors xs + Extra x : xs -> x ++ removeColors xs + Missing x : xs -> x ++ removeColors xs + [] -> "" + +simplify :: [ColorizedText] -> [ColorizedText] +simplify input = case input of + Plain xs : Plain ys : zs -> simplify (Plain (xs ++ ys) : zs) + Extra xs : Extra ys : zs -> simplify (Extra (xs ++ ys) : zs) + Missing xs : Missing ys : zs -> simplify (Missing (xs ++ ys) : zs) + x : xs -> x : simplify xs + [] -> [] + +colorize :: (String -> ColorizedText) -> [ColorizedText] -> [ColorizedText] +colorize color input = case simplify input of + Plain x : xs -> color x : xs + xs -> xs + +interpret :: FormatM a -> [ColorizedText] +interpret = interpretWith environment + +interpretWith :: Environment (Writer [ColorizedText]) -> FormatM a -> [ColorizedText] +interpretWith env = simplify . execWriter . H.interpretWith env + +environment :: Environment (Writer [ColorizedText]) +environment = Environment { + environmentGetSuccessCount = return 0 +, environmentGetPendingCount = return 0 +, environmentGetFailCount = return 0 +, environmentGetFailMessages = return [] +, environmentUsedSeed = return 0 +, environmentGetCPUTime = return Nothing +, environmentGetRealTime = return 0 +, environmentWrite = tell . return . Plain +, environmentWithFailColor = \action -> let (a, r) = runWriter action in tell (colorize Failed r) >> return a +, environmentWithSuccessColor = \action -> let (a, r) = runWriter action in tell (colorize Succeeded r) >> return a +, environmentWithPendingColor = \action -> let (a, r) = runWriter action in tell (colorize Pending r) >> return a +, environmentWithInfoColor = \action -> let (a, r) = runWriter action in tell (colorize Info r) >> return a +, environmentExtraChunk = tell . return . Extra +, environmentMissingChunk = tell . return . Missing +, environmentLiftIO = undefined +} + +testSpec :: H.Spec +testSpec = do + H.describe "Example" $ do + H.it "success" (H.Success) + H.it "fail 1" (H.Failure Nothing $ H.Reason "fail message") + H.it "pending" (H.pendingWith "pending message") + H.it "fail 2" (H.Failure Nothing H.NoReason) + H.it "exceptions" (undefined :: H.Result) + H.it "fail 3" (H.Failure Nothing H.NoReason) + +spec :: Spec +spec = do + describe "progress" $ do + let formatter = H.progress + + describe "exampleSucceeded" $ do + it "marks succeeding examples with ." $ do + interpret (H.exampleSucceeded formatter undefined) `shouldBe` [ + Succeeded "." + ] + + describe "exampleFailed" $ do + it "marks failing examples with F" $ do + interpret (H.exampleFailed formatter undefined undefined) `shouldBe` [ + Failed "F" + ] + + describe "examplePending" $ do + it "marks pending examples with ." $ do + interpret (H.examplePending formatter undefined undefined) `shouldBe` [ + Pending "." + ] + + describe "specdoc" $ do + let + formatter = H.specdoc + runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter} + + it "displays a header for each thing being described" $ do + _:x:_ <- runSpec testSpec + x `shouldBe` "Example" + + it "displays one row for each behavior" $ do + r <- runSpec $ do + H.describe "List as a Monoid" $ do + H.describe "mappend" $ do + H.it "is associative" True + H.describe "mempty" $ do + H.it "is a left identity" True + H.it "is a right identity" True + H.describe "Maybe as a Monoid" $ do + H.describe "mappend" $ do + H.it "is associative" True + H.describe "mempty" $ do + H.it "is a left identity" True + H.it "is a right identity" True + normalizeSummary r `shouldBe` [ + "" + , "List as a Monoid" + , " mappend" + , " is associative" + , " mempty" + , " is a left identity" + , " is a right identity" + , "Maybe as a Monoid" + , " mappend" + , " is associative" + , " mempty" + , " is a left identity" + , " is a right identity" + , "" + , "Finished in 0.0000 seconds" + , "6 examples, 0 failures" + ] + + it "outputs an empty line at the beginning (even for non-nested specs)" $ do + r <- runSpec $ do + H.it "example 1" True + H.it "example 2" True + normalizeSummary r `shouldBe` [ + "" + , "example 1" + , "example 2" + , "" + , "Finished in 0.0000 seconds" + , "2 examples, 0 failures" + ] + + it "displays a row for each successfull, failed, or pending example" $ do + r <- runSpec testSpec + r `shouldSatisfy` any (== " fail 1 FAILED [1]") + r `shouldSatisfy` any (== " success") + + it "displays a '#' with an additional message for pending examples" $ do + r <- runSpec testSpec + r `shouldSatisfy` any (== " # PENDING: pending message") + + context "with an empty group" $ do + it "omits that group from the report" $ do + r <- runSpec $ do + H.describe "foo" $ do + H.it "example 1" True + H.describe "bar" $ do + return () + H.describe "baz" $ do + H.it "example 2" True + + normalizeSummary r `shouldBe` [ + "" + , "foo" + , " example 1" + , "baz" + , " example 2" + , "" + , "Finished in 0.0000 seconds" + , "2 examples, 0 failures" + ] + + describe "failedFormatter" $ do + let action = H.failedFormatter formatter + + context "when actual/expected contain newlines" $ do + let + env = environment { + environmentGetFailMessages = return [FailureRecord Nothing ([], "") (Right $ ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")] + } + it "adds indentation" $ do + removeColors (interpretWith env action) `shouldBe` unlines [ + "" + , "Failures:" + , "" + , " 1) " + , " expected: first" + , " second" + , " third" + , " but got: first" + , " two" + , " third" + , "" + , "Randomized with seed 0" + , "" + ] + + describe "footerFormatter" $ do + let action = H.footerFormatter formatter + + context "without failures" $ do + let env = environment {environmentGetSuccessCount = return 1} + it "shows summary in green if there are no failures" $ do + interpretWith env action `shouldBe` [ + "Finished in 0.0000 seconds\n" + , Succeeded "1 example, 0 failures\n" + ] + + context "with pending examples" $ do + let env = environment {environmentGetPendingCount = return 1} + it "shows summary in yellow if there are pending examples" $ do + interpretWith env action `shouldBe` [ + "Finished in 0.0000 seconds\n" + , Pending "1 example, 0 failures, 1 pending\n" + ] + + context "with failures" $ do + let env = environment {environmentGetFailCount = return 1} + it "shows summary in red" $ do + interpretWith env action `shouldBe` [ + "Finished in 0.0000 seconds\n" + , Failed "1 example, 1 failure\n" + ] + + context "with both failures and pending examples" $ do + let env = environment {environmentGetFailCount = return 1, environmentGetPendingCount = return 1} + it "shows summary in red" $ do + interpretWith env action `shouldBe` [ + "Finished in 0.0000 seconds\n" + , Failed "2 examples, 1 failure, 1 pending\n" + ] + + context "same as failed_examples" $ do + failed_examplesSpec formatter + +failed_examplesSpec :: H.Formatter -> Spec +failed_examplesSpec formatter = do + let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter} + + context "displays a detailed list of failures" $ do + it "prints all requirements that are not met" $ do + r <- runSpec testSpec + r `shouldSatisfy` any (== " 1) Example fail 1") + + it "prints the exception type for requirements that fail due to an uncaught exception" $ do + r <- runSpec $ do + H.it "foobar" (E.throw (E.ErrorCall "baz") :: Bool) + r `shouldContain` [ + " 1) foobar" + , " uncaught exception: ErrorCall (baz)" + ] + + it "prints all descriptions when a nested requirement fails" $ do + r <- runSpec $ + H.describe "foo" $ do + H.describe "bar" $ do + H.it "baz" False + r `shouldSatisfy` any (== " 1) foo.bar baz") + + + context "when a failed example has a source location" $ do + let bestEffortExplanation = "Source locations marked with \"best-effort\" are calculated heuristically and may be incorrect." + + it "includes the source locations above the error messages" $ do + let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation + addLoc e = e {H.itemLocation = Just loc} + r <- runSpec $ H.mapSpecItem_ addLoc $ do + H.it "foo" False + r `shouldContain` [" test/FooSpec.hs:23: ", " 1) foo"] + + context "when source location is exact" $ do + it "includes that source locations" $ do + let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation + addLoc e = e {H.itemLocation = Just loc} + r <- runSpec $ H.mapSpecItem_ addLoc $ do + H.it "foo" False + r `shouldSatisfy` any (== " test/FooSpec.hs:23: ") + + it "does not include 'best-effort' explanation" $ do + let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation + addLoc e = e {H.itemLocation = Just loc} + r <- runSpec $ H.mapSpecItem_ addLoc $ do + H.it "foo" False + r `shouldSatisfy` all (/= bestEffortExplanation) + + context "when source location is best-effort" $ do + it "marks that source location as 'best-effort'" $ do + let loc = H.Location "test/FooSpec.hs" 23 0 H.BestEffort + addLoc e = e {H.itemLocation = Just loc} + r <- runSpec $ H.mapSpecItem_ addLoc $ do + H.it "foo" False + r `shouldSatisfy` any (== " test/FooSpec.hs:23: (best-effort)") + + it "includes 'best-effort' explanation" $ do + let loc = H.Location "test/FooSpec.hs" 23 0 H.BestEffort + addLoc e = e {H.itemLocation = Just loc} + r <- runSpec $ H.mapSpecItem_ addLoc $ do + H.it "foo" False + r `shouldSatisfy` any (== bestEffortExplanation) diff --git a/test/Test/Hspec/Core/HooksSpec.hs b/test/Test/Hspec/Core/HooksSpec.hs new file mode 100644 index 0000000..6419827 --- /dev/null +++ b/test/Test/Hspec/Core/HooksSpec.hs @@ -0,0 +1,374 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Hspec.Core.HooksSpec (main, spec) where + +import Control.Exception +import Helper +import Prelude () + +import qualified Test.Hspec.Core.Runner as H +import qualified Test.Hspec.Core.Spec as H + +import qualified Test.Hspec.Core.Hooks as H + +main :: IO () +main = hspec spec + +runSilent :: H.Spec -> IO () +runSilent = silence . H.hspec + +mkAppend :: IO (String -> IO (), IO [String]) +mkAppend = do + ref <- newIORef ([] :: [String]) + let rec n = modifyIORef ref (++ [n]) + return (rec, readIORef ref) + +spec :: Spec +spec = do + describe "before" $ do + it "runs an action before every spec item" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.before (rec "before" >> return "value") $ do + H.it "foo" $ \value -> do + rec (value ++ " foo") + H.it "bar" $ \value -> do + rec (value ++ " bar") + retrieve `shouldReturn` ["before", "value foo", "before", "value bar"] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + pending + + context "when used with a QuickCheck property" $ do + it "runs action before every check of the property" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.before (rec "before" >> return "value") $ do + H.it "foo" $ \value -> property $ \(_ :: Int) -> rec value + retrieve `shouldReturn` (take 200 . cycle) ["before", "value"] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + pending + + describe "before_" $ do + it "runs an action before every spec item" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.before_ (rec "before") $ do + H.it "foo" $ do + rec "foo" + H.it "bar" $ do + rec "bar" + retrieve `shouldReturn` ["before", "foo", "before", "bar"] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do + H.it "foo" $ do + rec "foo" + retrieve `shouldReturn` ["outer", "inner", "foo"] + + context "when used with a QuickCheck property" $ do + it "runs action before every check of the property" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.before_ (rec "before") $ do + H.it "foo" $ property $ \(_ :: Int) -> rec "foo" + retrieve `shouldReturn` (take 200 . cycle) ["before", "foo"] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do + H.it "foo" $ property $ \(_ :: Int) -> rec "foo" + retrieve `shouldReturn` (take 300 . cycle) ["outer", "inner", "foo"] + + describe "beforeWith" $ do + it "transforms spec argument" $ do + (rec, retrieve) <- mkAppend + let action :: Int -> IO String + action = return . show + runSilent $ H.before (return 23) $ H.beforeWith action $ do + H.it "foo" $ \value -> rec value + retrieve `shouldReturn` ["23"] + + it "can be used multiple times" $ do + let action1 :: Int -> IO Int + action1 = return . succ + + action2 :: Int -> IO String + action2 = return . show + + action3 :: String -> IO String + action3 = return . ("foo " ++) + + (rec, retrieve) <- mkAppend + + runSilent $ H.before (return 23) $ H.beforeWith action1 $ H.beforeWith action2 $ H.beforeWith action3 $ do + H.it "foo" $ \value -> rec value + + retrieve `shouldReturn` ["foo 24"] + + describe "beforeAll" $ do + it "runs an action before the first spec item" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.beforeAll (rec "beforeAll" >> return "value") $ do + H.it "foo" $ \value -> do + rec $ "foo " ++ value + H.it "bar" $ \value -> do + rec $ "bar " ++ value + retrieve `shouldReturn` [ + "beforeAll" + , "foo value" + , "bar value" + ] + + context "when specified action throws an exception" $ do + it "sets subsequent spec items to pending" $ do + result <- silence . H.hspecResult $ H.beforeAll (throwIO (ErrorCall "foo")) $ do + H.it "foo" $ \n -> do + n `shouldBe` (23 :: Int) + H.it "bar" $ \n -> do + n `shouldBe` 23 + result `shouldBe` H.Summary {H.summaryExamples = 2, H.summaryFailures = 1} + + context "when used with an empty list of examples" $ do + it "does not run specified action" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.beforeAll (rec "beforeAll" >> return "value") $ do + return () + retrieve `shouldReturn` [] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + pending + + describe "beforeAll_" $ do + it "runs an action before the first spec item" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.beforeAll_ (rec "beforeAll_") $ do + H.it "foo" $ do + rec "foo" + H.it "bar" $ do + rec "bar" + retrieve `shouldReturn` [ + "beforeAll_" + , "foo" + , "bar" + ] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.beforeAll_ (rec "outer") $ H.beforeAll_ (rec "inner") $ do + H.it "foo" $ do + rec "foo" + H.it "bar" $ do + rec "bar" + retrieve `shouldReturn` [ + "outer" + , "inner" + , "foo" + , "bar" + ] + + describe "after" $ do + it "runs an action after every spec item" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.before (rec "before" >> return "from before") $ H.after rec $ do + H.it "foo" $ \_ -> do + rec "foo" + H.it "bar" $ \_ -> do + rec "bar" + retrieve `shouldReturn` [ + "before" + , "foo" + , "from before" + , "before" + , "bar" + , "from before" + ] + + it "guarantees that action is run" $ do + (rec, retrieve) <- mkAppend + silence . ignoreExitCode . H.hspec $ H.before (rec "before" >> return "from before") $ H.after rec $ do + H.it "foo" $ \_ -> do + ioError $ userError "foo" :: IO () + rec "foo" + retrieve `shouldReturn` ["before", "from before"] + + context "when used multiple times" $ do + it "is evaluated inside out" $ do + pending + + describe "after_" $ do + it "runs an action after every spec item" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.after_ (rec "after") $ do + H.it "foo" $ do + rec "foo" + H.it "bar" $ do + rec "bar" + retrieve `shouldReturn` [ + "foo" + , "after" + , "bar" + , "after" + ] + + it "guarantees that action is run" $ do + (rec, retrieve) <- mkAppend + silence . ignoreExitCode $ H.hspec $ H.after_ (rec "after") $ do + H.it "foo" $ do + ioError $ userError "foo" :: IO () + rec "foo" + retrieve `shouldReturn` ["after"] + + context "when used multiple times" $ do + it "is evaluated inside out" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.after_ (rec "after outer") $ H.after_ (rec "after inner") $ do + H.it "foo" $ do + rec "foo" + retrieve `shouldReturn` [ + "foo" + , "after inner" + , "after outer" + ] + + describe "afterAll" $ do + it "runs an action after the last spec item" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do + H.it "foo" $ \_ -> do + rec "foo" + H.it "bar" $ \_ -> do + rec "bar" + retrieve `shouldReturn` [ + "before" + , "foo" + , "before" + , "bar" + , "before" + , "from before" + ] + + context "when used with an empty list of examples" $ do + it "does not run specified action" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do + return () + retrieve `shouldReturn` [] + + context "when action throws an exception" $ do + it "reports a failure" $ do + r <- runSpec $ H.before (return "from before") $ H.afterAll (\_ -> throwException) $ do + H.it "foo" $ \a -> a `shouldBe` "from before" + r `shouldSatisfy` any (== "afterAll-hook FAILED [1]") + + describe "afterAll_" $ do + it "runs an action after the last spec item" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.before_ (rec "before") $ H.afterAll_ (rec "afterAll_") $ do + H.it "foo" $ do + rec "foo" + H.it "bar" $ do + rec "bar" + retrieve `shouldReturn` [ + "before" + , "foo" + , "before" + , "bar" + , "before" + , "afterAll_" + ] + + context "when used multiple times" $ do + it "is evaluated inside out" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.afterAll_ (rec "after outer") $ H.afterAll_ (rec "after inner") $ do + H.it "foo" $ do + rec "foo" + retrieve `shouldReturn` [ + "foo" + , "after inner" + , "after outer" + ] + + context "when used with an empty list of examples" $ do + it "does not run specified action" $ do + (rec, retrieve) <- mkAppend + runSilent $ H.afterAll_ (rec "afterAll_") $ do + return () + retrieve `shouldReturn` [] + + context "when action throws an exception" $ do + it "reports a failure" $ do + r <- runSpec $ do + H.afterAll_ throwException $ do + H.it "foo" True + r `shouldSatisfy` any (== "afterAll-hook FAILED [1]") + + describe "around" $ do + it "wraps every spec item with an action" $ do + (rec, retrieve) <- mkAppend + let action e = rec "before" >> e "from around" >> rec "after" + runSilent $ H.around action $ do + H.it "foo" $ rec . ("foo " ++) + H.it "bar" $ rec . ("bar " ++) + retrieve `shouldReturn` [ + "before" + , "foo from around" + , "after" + , "before" + , "bar from around" + , "after" + ] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + pending + + describe "around_" $ do + it "wraps every spec item with an action" $ do + (rec, retrieve) <- mkAppend + let action e = rec "before" >> e >> rec "after" + runSilent $ H.around_ action $ do + H.it "foo" $ do + rec "foo" + H.it "bar" $ do + rec "bar" + retrieve `shouldReturn` [ + "before" + , "foo" + , "after" + , "before" + , "bar" + , "after" + ] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + (rec, retrieve) <- mkAppend + let actionOuter e = rec "before outer" >> e >> rec "after outer" + actionInner e = rec "before inner" >> e >> rec "after inner" + runSilent $ H.around_ actionOuter $ H.around_ actionInner $ do + H.it "foo" $ do + rec "foo" + retrieve `shouldReturn` [ + "before outer" + , "before inner" + , "foo" + , "after inner" + , "after outer" + ] + + describe "aroundWith" $ do + it "wraps every spec item with an action" $ do + (rec, retrieve) <- mkAppend + let action :: H.ActionWith String -> H.ActionWith Int + action e = e . show + runSilent $ H.before (return 23) $ H.aroundWith action $ do + H.it "foo" rec + retrieve `shouldReturn` ["23"] + where + runSpec :: H.Spec -> IO [String] + runSpec = captureLines . H.hspecResult diff --git a/test/Test/Hspec/Core/OptionsSpec.hs b/test/Test/Hspec/Core/OptionsSpec.hs new file mode 100644 index 0000000..b8ee190 --- /dev/null +++ b/test/Test/Hspec/Core/OptionsSpec.hs @@ -0,0 +1,108 @@ +module Test.Hspec.Core.OptionsSpec (spec) where + +import Control.Monad +import Helper +import System.Exit + +import qualified Test.Hspec.Core.Options as Options +import Test.Hspec.Core.Options hiding (parseOptions) + +fromLeft :: Either a b -> a +fromLeft (Left a) = a +fromLeft _ = error "fromLeft: No left value!" + +spec :: Spec +spec = do + describe "parseOptions" $ do + + let parseOptions = Options.parseOptions defaultConfig "my-spec" + + it "rejects unexpected arguments" $ do + fromLeft (parseOptions [] Nothing ["foo"]) `shouldBe` (ExitFailure 1, "my-spec: unexpected argument `foo'\nTry `my-spec --help' for more information.\n") + + it "rejects unrecognized options" $ do + fromLeft (parseOptions [] Nothing ["--foo"]) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--foo'\nTry `my-spec --help' for more information.\n") + + it "sets configColorMode to ColorAuto" $ do + configColorMode <$> parseOptions [] Nothing [] `shouldBe` Right ColorAuto + + context "with --no-color" $ do + it "sets configColorMode to ColorNever" $ do + configColorMode <$> parseOptions [] Nothing ["--no-color"] `shouldBe` Right ColorNever + + context "with --color" $ do + it "sets configColorMode to ColorAlways" $ do + configColorMode <$> parseOptions [] Nothing ["--color"] `shouldBe` Right ColorAlways + + context "with --out" $ do + it "sets configOutputFile" $ do + either (const Nothing) Just . configOutputFile <$> parseOptions [] Nothing ["--out", "foo"] `shouldBe` Right (Just "foo") + + context "with --qc-max-success" $ do + context "when given an invalid argument" $ do + it "returns an error message" $ do + fromLeft (parseOptions [] Nothing ["--qc-max-success", "foo"]) `shouldBe` (ExitFailure 1, "my-spec: invalid argument `foo' for `--qc-max-success'\nTry `my-spec --help' for more information.\n") + + context "with --depth" $ do + it "sets depth parameter for SmallCheck" $ do + configSmallCheckDepth <$> parseOptions [] Nothing ["--depth", "23"] `shouldBe` Right 23 + + context "with --jobs" $ do + it "sets number of concurrent jobs" $ do + configConcurrentJobs <$> parseOptions [] Nothing ["--jobs=23"] `shouldBe` Right (Just 23) + + it "rejects values < 1" $ do + let msg = "my-spec: invalid argument `0' for `--jobs'\nTry `my-spec --help' for more information.\n" + void (parseOptions [] Nothing ["--jobs=0"]) `shouldBe` Left (ExitFailure 1, msg) + + context "when given a config file" $ do + it "uses options from config file" $ do + configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing [] `shouldBe` Right ColorNever + + it "gives command-line options precedence" $ do + configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing ["--color"] `shouldBe` Right ColorAlways + + it "rejects --help" $ do + fromLeft (parseOptions [("~/.hspec", ["--help"])] Nothing []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--help' in config file ~/.hspec\n") + + it "rejects unrecognized options" $ do + fromLeft (parseOptions [("~/.hspec", ["--invalid"])] Nothing []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' in config file ~/.hspec\n") + + it "rejects ambiguous options" $ do + fromLeft (parseOptions [("~/.hspec", ["--qc-max-s"])] Nothing []) `shouldBe` (ExitFailure 1, + unlines [ + "my-spec: option `--qc-max-s' is ambiguous; could be one of:" + , " -a N --qc-max-success=N maximum number of successful tests" + , " before a QuickCheck property succeeds" + , " --qc-max-size=N size to use for the biggest test cases" + , "in config file ~/.hspec" + ] + ) + + context "when given multiple config files" $ do + it "gives later config files precedence" $ do + configColorMode <$> parseOptions [("~/.hspec", ["--no-color"]), (".hspec", ["--color"])] Nothing [] `shouldBe` Right ColorAlways + + context "when given an environment variable" $ do + it "uses options from environment variable" $ do + configColorMode <$> parseOptions [] (Just ["--no-color"]) [] `shouldBe` Right ColorNever + + it "gives command-line options precedence" $ do + configColorMode <$> parseOptions [] (Just ["--no-color"]) ["--color"] `shouldBe` Right ColorAlways + + it "rejects unrecognized options" $ do + fromLeft (parseOptions [] (Just ["--invalid"]) []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' from environment variable HSPEC_OPTIONS\n") + + describe "ignoreConfigFile" $ around_ (withEnvironment []) $ do + context "by default" $ do + it "returns False" $ do + ignoreConfigFile defaultConfig [] `shouldReturn` False + + context "with --ignore-dot-hspec" $ do + it "returns True" $ do + ignoreConfigFile defaultConfig ["--ignore-dot-hspec"] `shouldReturn` True + + context "with IGNORE_DOT_HSPEC" $ do + it "returns True" $ do + withEnvironment [("IGNORE_DOT_HSPEC", "yes")] $ do + ignoreConfigFile defaultConfig [] `shouldReturn` True diff --git a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs b/test/Test/Hspec/Core/QuickCheckUtilSpec.hs new file mode 100644 index 0000000..df15f28 --- /dev/null +++ b/test/Test/Hspec/Core/QuickCheckUtilSpec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +module Test.Hspec.Core.QuickCheckUtilSpec (main, spec) where + +import Helper + +import Test.QuickCheck +import Test.Hspec.Core.QuickCheckUtil + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "formatNumbers" $ do + it "includes number of tests" $ do + formatNumbers (failure 1 0) `shouldBe` "(after 1 test)" + + it "pluralizes number of tests" $ do + formatNumbers (failure 3 0) `shouldBe` "(after 3 tests)" + + it "includes number of shrinks" $ do + formatNumbers (failure 3 1) `shouldBe` "(after 3 tests and 1 shrink)" + + it "pluralizes number of shrinks" $ do + formatNumbers (failure 3 3) `shouldBe` "(after 3 tests and 3 shrinks)" + where + failure tests shrinks = Failure { + numTests = tests + , numShrinks = shrinks + } diff --git a/test/Test/Hspec/Core/RunnerSpec.hs b/test/Test/Hspec/Core/RunnerSpec.hs new file mode 100644 index 0000000..a123c9d --- /dev/null +++ b/test/Test/Hspec/Core/RunnerSpec.hs @@ -0,0 +1,520 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Hspec.Core.RunnerSpec (main, spec) where + +import Prelude () +import Helper + +import System.IO (stderr) +import Control.Monad (replicateM_) +import System.Environment (withArgs, withProgName, getArgs) +import System.Exit +import Control.Concurrent +import qualified Control.Exception as E +import Mock +import System.SetEnv +#if MIN_VERSION_HUnit(1,5,0) +import System.Console.ANSI +#endif + +import Test.Hspec.Core.FailureReport (FailureReport(..)) +import qualified Test.Hspec.Core.Spec as H +import qualified Test.Hspec.Core.Runner as H +import qualified Test.Hspec.Core.Formatters as H (silent) +import qualified Test.Hspec.Core.QuickCheck as H + +import qualified Test.QuickCheck as QC +import qualified Test.Hspec.Core.Hooks as H + +main :: IO () +main = hspec spec + +quickCheckOptions :: [([Char], Args -> Int)] +quickCheckOptions = [("--qc-max-success", QC.maxSuccess), ("--qc-max-size", QC.maxSize), ("--qc-max-discard", QC.maxDiscardRatio)] + +runPropFoo :: [String] -> IO String +runPropFoo args = unlines . normalizeSummary . lines <$> do + capture_ . ignoreExitCode . withArgs args . H.hspec . H.modifyMaxSuccess (const 1000000) $ do + H.it "foo" $ do + property (/= (23 :: Int)) + +spec :: Spec +spec = do + describe "hspec" $ do + it "runs a spec" $ do + silence . H.hspec $ do + H.it "foobar" True + `shouldReturn` () + + it "exits with exitFailure if not all examples pass" $ do + silence . H.hspec $ do + H.it "foobar" False + `shouldThrow` (== ExitFailure 1) + + it "allows output to stdout" $ do + r <- captureLines . H.hspec $ do + H.it "foobar" $ do + putStrLn "baz" + r `shouldSatisfy` elem "baz" + + it "prints an error message on unrecognized command-line options" $ do + withProgName "myspec" . withArgs ["--foo"] $ do + hSilence [stderr] (H.hspec $ pure ()) `shouldThrow` (== ExitFailure 1) + fst `fmap` hCapture [stderr] (ignoreExitCode (H.hspec $ pure ())) `shouldReturn` unlines [ + "myspec: unrecognized option `--foo'" + , "Try `myspec --help' for more information." + ] + + it "stores a failure report in the environment" $ do + silence . ignoreExitCode . withArgs ["--seed", "23"] . H.hspec $ do + H.describe "foo" $ do + H.describe "bar" $ do + H.it "example 1" True + H.it "example 2" False + H.describe "baz" $ do + H.it "example 3" False + lookupEnv "HSPEC_FAILURES" `shouldReturn` (Just . show) FailureReport { + failureReportSeed = 23 + , failureReportMaxSuccess = 100 + , failureReportMaxSize = 100 + , failureReportMaxDiscardRatio = 10 + , failureReportPaths = [ + (["foo", "bar"], "example 2") + , (["baz"], "example 3") + ] + } + + describe "with --rerun" $ do + let runSpec = (captureLines . ignoreExitCode . H.hspec) $ do + H.it "example 1" True + H.it "example 2" False + H.it "example 3" False + H.it "example 4" True + H.it "example 5" False + + it "reruns examples that previously failed" $ do + r0 <- runSpec + r0 `shouldSatisfy` elem "5 examples, 3 failures" + + r1 <- withArgs ["--rerun"] runSpec + r1 `shouldSatisfy` elem "3 examples, 3 failures" + + it "reuses the same seed" $ do + r <- runPropFoo ["--seed", "42"] + runPropFoo ["--rerun"] `shouldReturn` r + + forM_ quickCheckOptions $ \(name, accessor) -> do + it ("reuses same " ++ name) $ do + [name, "23"] `shouldUseArgs` ((== 23) . accessor) + ["--rerun"] `shouldUseArgs` ((== 23) . accessor) + + context "when no examples failed previously" $ do + it "runs all examples" $ do + let run = capture_ . H.hspec $ do + H.it "example 1" True + H.it "example 2" True + H.it "example 3" True + + r0 <- run + r0 `shouldContain` "3 examples, 0 failures" + + r1 <- withArgs ["--rerun"] run + r1 `shouldContain` "3 examples, 0 failures" + + context "when there is no failure report in the environment" $ do + it "runs everything" $ do + unsetEnv "HSPEC_FAILURES" + r <- hSilence [stderr] $ withArgs ["--rerun"] runSpec + r `shouldSatisfy` elem "5 examples, 3 failures" + + it "prints a warning to stderr" $ do + unsetEnv "HSPEC_FAILURES" + r <- hCapture_ [stderr] $ withArgs ["--rerun"] runSpec + r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n" + + context "when parsing of failure report fails" $ do + it "runs everything" $ do + setEnv "HSPEC_FAILURES" "some invalid report" + r <- hSilence [stderr] $ withArgs ["--rerun"] runSpec + r `shouldSatisfy` elem "5 examples, 3 failures" + + it "prints a warning to stderr" $ do + setEnv "HSPEC_FAILURES" "some invalid report" + r <- hCapture_ [stderr] $ withArgs ["--rerun"] runSpec + r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n" + + + it "does not leak command-line options to examples" $ do + silence . withArgs ["--verbose"] $ do + H.hspec $ do + H.it "foobar" $ do + getArgs `shouldReturn` [] + `shouldReturn` () + + context "when interrupted with ctrl-c" $ do + it "prints summary immediately" $ do + mvar <- newEmptyMVar + sync <- newEmptyMVar + threadId <- forkIO $ do + r <- captureLines . ignoreUserInterrupt . withArgs ["--seed", "23"] . H.hspec . removeLocations $ do + H.it "foo" False + H.it "bar" $ do + putMVar sync () + threadDelay 1000000 + H.it "baz" True + putMVar mvar r + takeMVar sync + throwTo threadId E.UserInterrupt + r <- takeMVar mvar + normalizeSummary r `shouldBe` [ + "" + , "foo FAILED [1]" + , "" + , "Failures:" + , "" + , " 1) foo" + , "" + , "Randomized with seed 23" + , "" + ] + + it "throws UserInterrupt" $ do + mvar <- newEmptyMVar + sync <- newEmptyMVar + threadId <- forkIO $ do + silence . H.hspec $ do + H.it "foo" $ do + putMVar sync () + threadDelay 1000000 + `E.catch` putMVar mvar + takeMVar sync + throwTo threadId E.UserInterrupt + takeMVar mvar `shouldReturn` E.UserInterrupt + + context "with --help" $ do + let printHelp = withProgName "spec" . withArgs ["--help"] . H.hspec $ pure () + it "prints help" $ do + r <- (captureLines . ignoreExitCode) printHelp + r `shouldStartWith` ["Usage: spec [OPTION]..."] + silence printHelp `shouldThrow` (== ExitSuccess) + + it "constrains lines to 80 characters" $ do + r <- (captureLines . ignoreExitCode) printHelp + r `shouldSatisfy` all ((<= 80) . length) + r `shouldSatisfy` any ((78 <=) . length) + + context "with --dry-run" $ do + let withDryRun = captureLines . withArgs ["--dry-run"] . H.hspec + it "produces a report" $ do + r <- withDryRun $ do + H.it "foo" True + H.it "bar" True + normalizeSummary r `shouldBe` [ + "" + , "foo" + , "bar" + , "" + , "Finished in 0.0000 seconds" + , "2 examples, 0 failures" + ] + + it "does not verify anything" $ do + e <- newMock + _ <- withDryRun $ do + H.it "foo" (mockAction e) + H.it "bar" False + mockCounter e `shouldReturn` 0 + + it "ignores afterAll-hooks" $ do + ref <- newIORef False + _ <- withDryRun $ do + H.afterAll_ (writeIORef ref True) $ do + H.it "bar" True + readIORef ref `shouldReturn` False + + context "with --fail-fast" $ do + it "stops after first failure" $ do + r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do + H.it "foo" True + H.it "bar" False + H.it "baz" False + normalizeSummary r `shouldBe` [ + "" + , "foo" + , "bar FAILED [1]" + , "" + , "Failures:" + , "" + , " 1) bar" + , "" + , "Randomized with seed 23" + , "" + , "Finished in 0.0000 seconds" + , "2 examples, 1 failure" + ] + + it "works for nested specs" $ do + r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do + H.describe "foo" $ do + H.it "bar" False + H.it "baz" True + normalizeSummary r `shouldBe` [ + "" + , "foo" + , " bar FAILED [1]" + , "" + , "Failures:" + , "" + , " 1) foo bar" + , "" + , "Randomized with seed 23" + , "" + , "Finished in 0.0000 seconds" + , "1 example, 1 failure" + ] + + context "with --match" $ do + it "only runs examples that match a given pattern" $ do + e1 <- newMock + e2 <- newMock + e3 <- newMock + silence . withArgs ["-m", "/bar/example"] . H.hspec $ do + H.describe "foo" $ do + H.describe "bar" $ do + H.it "example 1" $ mockAction e1 + H.it "example 2" $ mockAction e2 + H.describe "baz" $ do + H.it "example 3" $ mockAction e3 + (,,) <$> mockCounter e1 <*> mockCounter e2 <*> mockCounter e3 `shouldReturn` (1, 1, 0) + + it "only runs examples that match a given pattern (-m and --skip combined)" $ do + e1 <- newMock + e2 <- newMock + e3 <- newMock + e4 <- newMock + silence . withArgs ["-m", "/bar/example", "--skip", "example 3"] . H.hspec $ do + H.describe "foo" $ do + H.describe "bar" $ do + H.it "example 1" $ mockAction e1 + H.it "example 2" $ mockAction e2 + H.it "example 3" $ mockAction e3 + H.describe "baz" $ do + H.it "example 4" $ mockAction e4 + (,,,) <$> mockCounter e1 <*> mockCounter e2 <*> mockCounter e3 <*> mockCounter e4 + `shouldReturn` (1, 1, 0, 0) + + it "can be given multiple times" $ do + e1 <- newMock + e2 <- newMock + e3 <- newMock + silence . withArgs ["-m", "foo", "-m", "baz"] . H.hspec $ do + H.describe "foo" $ do + H.it "example 1" $ mockAction e1 + H.describe "bar" $ do + H.it "example 2" $ mockAction e2 + H.describe "baz" $ do + H.it "example 3" $ mockAction e3 + (,,) <$> mockCounter e1 <*> mockCounter e2 <*> mockCounter e3 `shouldReturn` (1, 0, 1) + + context "with --diff" $ do + it "shows colorized diffs" $ do +#if MIN_VERSION_HUnit(1,5,0) + r <- capture_ . ignoreExitCode . withArgs ["--diff", "--color"] . H.hspec $ do + H.it "foo" $ do + 23 `shouldBe` (42 :: Int) + r `shouldContain` unlines [ + red ++ " expected: " ++ reset ++ red ++ "42" ++ reset + , red ++ " but got: " ++ reset ++ green ++ "23" ++ reset + ] +#else + pending +#endif + + context "with --no-diff" $ do + it "it does not show colorized diffs" $ do +#if MIN_VERSION_HUnit(1,5,0) + r <- capture_ . ignoreExitCode . withArgs ["--no-diff", "--color"] . H.hspec $ do + H.it "foo" $ do + 23 `shouldBe` (42 :: Int) + r `shouldContain` unlines [ + red ++ " expected: " ++ reset ++ "42" + , red ++ " but got: " ++ reset ++ "23" + ] +#else + pending +#endif + + context "with --format" $ do + it "uses specified formatter" $ do + r <- capture_ . ignoreExitCode . withArgs ["--format", "progress"] . H.hspec $ do + H.it "foo" True + H.it "bar" True + H.it "baz" False + H.it "qux" True + r `shouldContain` "..F." + + context "when given an invalid argument" $ do + it "prints an error message to stderr" $ do + r <- hCapture_ [stderr] . ignoreExitCode . withArgs ["--format", "foo"] . H.hspec $ do + H.it "foo" True + r `shouldContain` "invalid argument `foo' for `--format'" + + context "with --qc-max-success" $ do + it "tries QuickCheck properties specified number of times" $ do + m <- newMock + silence . withArgs ["--qc-max-success", "23"] . H.hspec $ do + H.it "foo" $ property $ \(_ :: Int) -> do + mockAction m + mockCounter m `shouldReturn` 23 + + context "when run with --rerun" $ do + it "takes precedence" $ do + ["--qc-max-success", "23"] `shouldUseArgs` ((== 23) . QC.maxSuccess) + ["--rerun", "--qc-max-success", "42"] `shouldUseArgs` ((== 42) . QC.maxSuccess) + + context "with --qc-max-size" $ do + it "passes specified size to QuickCheck properties" $ do + ["--qc-max-size", "23"] `shouldUseArgs` ((== 23) . QC.maxSize) + + context "with --qc-max-discard" $ do + it "uses specified discard ratio to QuickCheck properties" $ do + ["--qc-max-discard", "23"] `shouldUseArgs` ((== 23) . QC.maxDiscardRatio) + + context "with --seed" $ do + it "uses specified seed" $ do + r <- runPropFoo ["--seed", "42"] + runPropFoo ["--seed", "42"] `shouldReturn` r + + context "when run with --rerun" $ do + it "takes precedence" $ do + r <- runPropFoo ["--seed", "23"] + _ <- runPropFoo ["--seed", "42"] + runPropFoo ["--rerun", "--seed", "23"] `shouldReturn` r + + context "when given an invalid argument" $ do + let run = withArgs ["--seed", "foo"] . H.hspec $ do + H.it "foo" True + it "prints an error message to stderr" $ do + r <- hCapture_ [stderr] (ignoreExitCode run) + r `shouldContain` "invalid argument `foo' for `--seed'" + + it "exits with exitFailure" $ do + hSilence [stderr] run `shouldThrow` (== ExitFailure 1) + + context "with --print-cpu-time" $ do + it "includes used CPU time in summary" $ do + r <- capture_ $ withArgs ["--print-cpu-time"] (H.hspec $ pure ()) + (normalizeSummary . lines) r `shouldContain` ["Finished in 0.0000 seconds, used 0.0000 seconds of CPU time"] + + context "with --html" $ do + it "produces HTML output" $ do + r <- capture_ . withArgs ["--html"] . H.hspec $ do + H.it "foo" True + r `shouldContain` "" + + it "marks successful examples with CSS class hspec-success" $ do + r <- capture_ . withArgs ["--html"] . H.hspec $ do + H.it "foo" True + r `shouldContain` "foo\n" + + it "marks pending examples with CSS class hspec-pending" $ do + r <- capture_ . withArgs ["--html"] . H.hspec $ do + H.it "foo" H.pending + r `shouldContain` "foo" + + it "marks failed examples with CSS class hspec-failure" $ do + r <- capture_ . ignoreExitCode . withArgs ["--html"] . H.hspec $ do + H.it "foo" False + r `shouldContain` "foo" + + describe "hspecResult" $ do + it "returns a summary of the test run" $ do + silence . H.hspecResult $ do + H.it "foo" True + H.it "foo" False + H.it "foo" False + H.it "foo" True + H.it "foo" True + `shouldReturn` H.Summary 5 2 + + it "treats uncaught exceptions as failure" $ do + silence . H.hspecResult $ do + H.it "foobar" throwException + `shouldReturn` H.Summary 1 1 + + it "uses the specdoc formatter by default" $ do + _:r:_ <- captureLines . H.hspecResult $ do + H.describe "Foo.Bar" $ do + H.it "some example" True + r `shouldBe` "Foo.Bar" + + it "can use a custom formatter" $ do + r <- capture_ . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.silent} $ do + H.describe "Foo.Bar" $ do + H.it "some example" True + r `shouldBe` "" + + it "does not let escape error thunks from failure messages" $ do + r <- silence . H.hspecResult $ do + H.it "some example" (H.Failure Nothing . H.Reason $ "foobar" ++ undefined) + r `shouldBe` H.Summary 1 1 + + it "runs specs in parallel" $ do + let n = 10 + t = 0.01 + dt = t * (fromIntegral n / 2) + r <- timeout dt . silence . withArgs ["-j", show n] . H.hspecResult . H.parallel $ do + replicateM_ n (H.it "foo" $ sleep t) + r `shouldBe` Just (H.Summary n 0) + + context "with -j" $ do + it "limits parallelism" $ do + currentRef <- newIORef (0 :: Int) + highRef <- newIORef 0 + let n = 10 + t = 0.01 + j = 2 + start = do + current <- atomicModifyIORef currentRef $ \x -> let y = succ x in (y, y) + atomicModifyIORef highRef $ \x -> (max x current, ()) + stop = atomicModifyIORef currentRef $ \x -> (pred x, ()) + r <- withArgs ["-j", show j] . H.hspecResult . H.parallel $ do + replicateM_ n $ H.it "foo" $ E.bracket_ start stop $ sleep t + r `shouldBe` H.Summary n 0 + high <- readIORef highRef + high `shouldBe` j + + describe "rerunAll" $ do + let + report = FailureReport 0 0 0 0 [([], "foo")] + config = H.defaultConfig {H.configRerun = True, H.configRerunAllOnSuccess = True} + summary = H.Summary 1 0 + context "with --rerun, --rerun-all-on-success, previous failures, on success" $ do + it "returns True" $ do + H.rerunAll config (Just report) summary `shouldBe` True + + context "without --rerun" $ do + it "returns False" $ do + H.rerunAll config {H.configRerun = False} (Just report) summary `shouldBe` False + + context "without --rerun-all-on-success" $ do + it "returns False" $ do + H.rerunAll config {H.configRerunAllOnSuccess = False} (Just report) summary `shouldBe` False + + context "without previous failures" $ do + it "returns False" $ do + H.rerunAll config (Just report {failureReportPaths = []}) summary `shouldBe` False + + context "without failure report" $ do + it "returns False" $ do + H.rerunAll config Nothing summary `shouldBe` False + + context "on failure" $ do + it "returns False" $ do + H.rerunAll config (Just report) summary {H.summaryFailures = 1} `shouldBe` False + where +#if MIN_VERSION_HUnit(1,5,0) + green = setSGRCode [SetColor Foreground Dull Green] + red = setSGRCode [SetColor Foreground Dull Red] + reset = setSGRCode [Reset] +#endif diff --git a/test/Test/Hspec/Core/SpecSpec.hs b/test/Test/Hspec/Core/SpecSpec.hs new file mode 100644 index 0000000..88ca35c --- /dev/null +++ b/test/Test/Hspec/Core/SpecSpec.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.SpecSpec (main, spec) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Spec (Item(..), Result(..)) +import qualified Test.Hspec.Core.Runner as H +import Test.Hspec.Core.Spec (Tree(..), runSpecM) + +import qualified Test.Hspec.Core.Spec as H + +main :: IO () +main = hspec spec + +runSpec :: H.Spec -> IO [String] +runSpec = captureLines . H.hspecResult + +spec :: Spec +spec = do + describe "describe" $ do + it "can be nested" $ do + [Node foo [Node bar [Leaf _]]] <- runSpecM $ do + H.describe "foo" $ do + H.describe "bar" $ do + H.it "baz" True + (foo, bar) `shouldBe` ("foo", "bar") + + context "when no description is given" $ do + it "uses a default description" $ do + [Node d _] <- runSpecM (H.describe "" (pure ())) + d `shouldBe` "(no description given)" + + describe "xdescribe" $ do + it "creates a tree of pending spec items" $ do + [Node _ [Leaf item]] <- runSpecM (H.xdescribe "" $ H.it "whatever" True) + Right r <- itemExample item defaultParams ($ ()) noOpProgressCallback + r `shouldBe` Pending Nothing + + describe "it" $ do + it "takes a description of a desired behavior" $ do + [Leaf item] <- runSpecM (H.it "whatever" True) + itemRequirement item `shouldBe` "whatever" + + it "takes an example of that behavior" $ do + [Leaf item] <- runSpecM (H.it "whatever" True) + Right r <- itemExample item defaultParams ($ ()) noOpProgressCallback + r `shouldBe` Success + + it "adds source locations" $ do + [Leaf item] <- runSpecM (H.it "foo" True) + let location = +#if MIN_VERSION_base(4,8,1) + Just $ H.Location __FILE__ (__LINE__ - 3) 32 H.ExactLocation +#else + Nothing +#endif + itemLocation item `shouldBe` location + + context "when no description is given" $ do + it "uses a default description" $ do + [Leaf item] <- runSpecM (H.it "" True) + itemRequirement item `shouldBe` "(unspecified behavior)" + + describe "xit" $ do + it "creates a pending spec item" $ do + [Leaf item] <- runSpecM (H.xit "whatever" True) + Right r <- itemExample item defaultParams ($ ()) noOpProgressCallback + r `shouldBe` Pending Nothing + + describe "pending" $ do + it "specifies a pending example" $ do + r <- runSpec $ do + H.it "foo" H.pending + r `shouldSatisfy` any (== " # PENDING: No reason given") + + describe "pendingWith" $ do + it "specifies a pending example with a reason for why it's pending" $ do + r <- runSpec $ do + H.it "foo" $ do + H.pendingWith "for some reason" + r `shouldSatisfy` any (== " # PENDING: for some reason") + + describe "parallel" $ do + it "marks examples for parallel execution" $ do + [Leaf item] <- runSpecM . H.parallel $ H.it "whatever" True + itemIsParallelizable item `shouldBe` True + + it "is applied recursively" $ do + [Node _ [Node _ [Leaf item]]] <- runSpecM . H.parallel $ do + H.describe "foo" $ do + H.describe "bar" $ do + H.it "baz" True + itemIsParallelizable item `shouldBe` True diff --git a/test/Test/Hspec/Core/TimerSpec.hs b/test/Test/Hspec/Core/TimerSpec.hs new file mode 100644 index 0000000..213b5db --- /dev/null +++ b/test/Test/Hspec/Core/TimerSpec.hs @@ -0,0 +1,29 @@ +module Test.Hspec.Core.TimerSpec (main, spec) where + +import Helper + +import Test.Hspec.Core.Timer + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "timer action returned by newTimer" $ do + + let dt = 0.01 + + it "returns False" $ do + timer <- newTimer dt + timer `shouldReturn` False + + context "after specified time" $ do + it "returns True" $ do + timer <- newTimer dt + sleep dt + timer `shouldReturn` True + timer `shouldReturn` False + sleep dt + sleep dt + timer `shouldReturn` True + timer `shouldReturn` False diff --git a/test/Test/Hspec/Core/UtilSpec.hs b/test/Test/Hspec/Core/UtilSpec.hs new file mode 100644 index 0000000..b91fbc2 --- /dev/null +++ b/test/Test/Hspec/Core/UtilSpec.hs @@ -0,0 +1,103 @@ +module Test.Hspec.Core.UtilSpec (main, spec) where + +import Helper +import Control.Concurrent +import qualified Control.Exception as E + +import Test.Hspec.Core.Util + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "pluralize" $ do + it "returns singular when used with 1" $ do + pluralize 1 "thing" `shouldBe` "1 thing" + + it "returns plural when used with number greater 1" $ do + pluralize 2 "thing" `shouldBe` "2 things" + + it "returns plural when used with 0" $ do + pluralize 0 "thing" `shouldBe` "0 things" + + describe "formatException" $ do + it "converts exception to string" $ do + formatException (E.toException E.DivideByZero) `shouldBe` "ArithException (divide by zero)" + + context "when used with an IOException" $ do + it "includes the IOErrorType" $ do + Left e <- E.try (readFile "foo") + formatException e `shouldBe` "IOException of type NoSuchThing (foo: openFile: does not exist (No such file or directory))" + + describe "lineBreaksAt" $ do + it "inserts line breaks at word boundaries" $ do + lineBreaksAt 20 "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod" + `shouldBe` [ + "Lorem ipsum dolor" + , "sit amet," + , "consectetur" + , "adipisicing elit," + , "sed do eiusmod" + ] + + describe "safeTry" $ do + it "returns Right on success" $ do + Right e <- safeTry (return 23 :: IO Int) + e `shouldBe` 23 + + it "returns Left on exception" $ do + Left e <- safeTry throwException + show e `shouldBe` "foobar" + + it "evaluates result to weak head normal form" $ do + Left e <- safeTry (return $ E.throw $ E.ErrorCall "foo") + show e `shouldBe` "foo" + + it "does not catch asynchronous exceptions" $ do + mvar <- newEmptyMVar + sync <- newEmptyMVar + threadId <- forkIO $ do + safeTry (putMVar sync () >> threadDelay 1000000) >> return () + `E.catch` putMVar mvar + takeMVar sync + throwTo threadId E.UserInterrupt + readMVar mvar `shouldReturn` E.UserInterrupt + + describe "filterPredicate" $ do + it "tries to match a pattern against a path" $ do + let p = filterPredicate "foo/bar/example 1" + p (["foo", "bar"], "example 1") `shouldBe` True + p (["foo", "bar"], "example 2") `shouldBe` False + + it "is ambiguous" $ do + let p = filterPredicate "foo/bar/baz" + p (["foo", "bar"], "baz") `shouldBe` True + p (["foo"], "bar/baz") `shouldBe` True + + it "succeeds on a partial match" $ do + let p = filterPredicate "bar/baz" + p (["foo", "bar", "baz"], "example 1") `shouldBe` True + + it "succeeds with a pattern that matches the message give in the failure list" $ do + let p = filterPredicate "ModuleA.ModuleB.foo does something" + p (["ModuleA", "ModuleB", "foo"], "does something") `shouldBe` True + + describe "formatRequirement" $ do + it "creates a sentence from a subject and a requirement" $ do + formatRequirement (["reverse"], "reverses a list") `shouldBe` "reverse reverses a list" + + it "creates a sentence from a subject and a requirement when the subject consits of multiple words" $ do + formatRequirement (["The reverse function"], "reverses a list") `shouldBe` "The reverse function reverses a list" + + it "returns the requirement if no subject is given" $ do + formatRequirement ([], "reverses a list") `shouldBe` "reverses a list" + + it "inserts context separated by commas" $ do + formatRequirement (["reverse", "when applied twice"], "reverses a list") `shouldBe` "reverse, when applied twice, reverses a list" + + it "joins components of a subject with a dot" $ do + formatRequirement (["Data", "List", "reverse"], "reverses a list") `shouldBe` "Data.List.reverse reverses a list" + + it "properly handles context after a subject that consists of several components" $ do + formatRequirement (["Data", "List", "reverse", "when applied twice"], "reverses a list") `shouldBe` "Data.List.reverse, when applied twice, reverses a list" diff --git a/vendor/Data/Algorithm/Diff.hs b/vendor/Data/Algorithm/Diff.hs new file mode 100644 index 0000000..dd721c8 --- /dev/null +++ b/vendor/Data/Algorithm/Diff.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DeriveFunctor #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Algorithm.Diff +-- Copyright : (c) Sterling Clover 2008-2011, Kevin Charter 2011 +-- License : BSD 3 Clause +-- Maintainer : s.clover@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This is an implementation of the O(ND) diff algorithm as described in +-- \"An O(ND) Difference Algorithm and Its Variations (1986)\" +-- . It is O(mn) in space. +-- The algorithm is the same one used by standared Unix diff. +----------------------------------------------------------------------------- + +module Data.Algorithm.Diff + ( Diff(..) + -- * Comparing lists for differences + , getDiff + , getDiffBy + + -- * Finding chunks of differences + , getGroupedDiff + , getGroupedDiffBy + ) where + +import Prelude hiding (pi) + +import Data.Array + +data DI = F | S | B deriving (Show, Eq) + +-- | A value is either from the 'First' list, the 'Second' or from 'Both'. +-- 'Both' contains both the left and right values, in case you are using a form +-- of equality that doesn't check all data (for example, if you are using a +-- newtype to only perform equality on side of a tuple). +data Diff a = First a | Second a | Both a a deriving (Show, Eq, Functor) + +data DL = DL {poi :: !Int, poj :: !Int, path::[DI]} deriving (Show, Eq) + +instance Ord DL + where x <= y = if poi x == poi y + then poj x > poj y + else poi x <= poi y + +canDiag :: (a -> a -> Bool) -> [a] -> [a] -> Int -> Int -> Int -> Int -> Bool +canDiag eq as bs lena lenb = \ i j -> + if i < lena && j < lenb then (arAs ! i) `eq` (arBs ! j) else False + where arAs = listArray (0,lena - 1) as + arBs = listArray (0,lenb - 1) bs + +dstep :: (Int -> Int -> Bool) -> [DL] -> [DL] +dstep cd dls = hd:pairMaxes rst + where (hd:rst) = nextDLs dls + nextDLs [] = [] + nextDLs (dl:rest) = dl':dl'':nextDLs rest + where dl' = addsnake cd $ dl {poi=poi dl + 1, path=(F : pdl)} + dl'' = addsnake cd $ dl {poj=poj dl + 1, path=(S : pdl)} + pdl = path dl + pairMaxes [] = [] + pairMaxes [x] = [x] + pairMaxes (x:y:rest) = max x y:pairMaxes rest + +addsnake :: (Int -> Int -> Bool) -> DL -> DL +addsnake cd dl + | cd pi pj = addsnake cd $ + dl {poi = pi + 1, poj = pj + 1, path=(B : path dl)} + | otherwise = dl + where pi = poi dl; pj = poj dl + +lcs :: (a -> a -> Bool) -> [a] -> [a] -> [DI] +lcs eq as bs = path . head . dropWhile (\dl -> poi dl /= lena || poj dl /= lenb) . + concat . iterate (dstep cd) . (:[]) . addsnake cd $ + DL {poi=0,poj=0,path=[]} + where cd = canDiag eq as bs lena lenb + lena = length as; lenb = length bs + +-- | Takes two lists and returns a list of differences between them. This is +-- 'getDiffBy' with '==' used as predicate. +getDiff :: (Eq t) => [t] -> [t] -> [Diff t] +getDiff = getDiffBy (==) + +-- | Takes two lists and returns a list of differences between them, grouped +-- into chunks. This is 'getGroupedDiffBy' with '==' used as predicate. +getGroupedDiff :: (Eq t) => [t] -> [t] -> [Diff [t]] +getGroupedDiff = getGroupedDiffBy (==) + +-- | A form of 'getDiff' with no 'Eq' constraint. Instead, an equality predicate +-- is taken as the first argument. +getDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff t] +getDiffBy eq a b = markup a b . reverse $ lcs eq a b + where markup (x:xs) ys (F:ds) = First x : markup xs ys ds + markup xs (y:ys) (S:ds) = Second y : markup xs ys ds + markup (x:xs) (y:ys) (B:ds) = Both x y : markup xs ys ds + markup _ _ _ = [] + +getGroupedDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff [t]] +getGroupedDiffBy eq a b = go $ getDiffBy eq a b + where go (First x : xs) = let (fs, rest) = goFirsts xs in First (x:fs) : go rest + go (Second x : xs) = let (fs, rest) = goSeconds xs in Second (x:fs) : go rest + go (Both x y : xs) = let (fs, rest) = goBoth xs + (fxs, fys) = unzip fs + in Both (x:fxs) (y:fys) : go rest + go [] = [] + + goFirsts (First x : xs) = let (fs, rest) = goFirsts xs in (x:fs, rest) + goFirsts xs = ([],xs) + + goSeconds (Second x : xs) = let (fs, rest) = goSeconds xs in (x:fs, rest) + goSeconds xs = ([],xs) + + goBoth (Both x y : xs) = let (fs, rest) = goBoth xs in ((x,y):fs, rest) + goBoth xs = ([],xs)