diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +Copyright (c) 2011-2014 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 --- /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 --- /dev/null +++ b/hspec-core.cabal @@ -0,0 +1,106 @@ +name: hspec-core +version: 2.0.0 +license: MIT +license-file: LICENSE +copyright: (c) 2011-2014 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 + ghc-options: + -Wall + hs-source-dirs: + src + build-depends: + base >= 4.3 && < 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 + , hspec-expectations + , async >= 2 + 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.Compat + Test.Hspec.Core.Example + Test.Hspec.Core.Tree + Test.Hspec.Core.Spec.Monad + Test.Hspec.Core.QuickCheckUtil + Test.Hspec.Config + Test.Hspec.Options + Test.Hspec.FailureReport + Test.Hspec.Core.Runner.Eval + Test.Hspec.Core.Formatters.Internal + Test.Hspec.Timer + default-language: Haskell2010 + +test-suite spec + type: + exitcode-stdio-1.0 + hs-source-dirs: + src, test + main-is: + Spec.hs + other-modules: + Helper + Mock + Test.Hspec.CompatSpec + Test.Hspec.Core.ExampleSpec + Test.Hspec.Core.FormattersSpec + Test.Hspec.Core.HooksSpec + Test.Hspec.Core.QuickCheckUtilSpec + Test.Hspec.Core.RunnerSpec + Test.Hspec.Core.SpecSpec + Test.Hspec.Core.UtilSpec + Test.Hspec.FailureReportSpec + Test.Hspec.OptionsSpec + Test.Hspec.TimerSpec + ghc-options: + -Wall + build-depends: + base == 4.* + , random + , tf-random + , setenv + , ansi-terminal + , time + , transformers + , deepseq + , HUnit + , QuickCheck + , quickcheck-io + , hspec-expectations + , async + + , hspec-meta >= 1.12 + , silently >= 1.2.4 + , process + , ghc-paths + default-language: Haskell2010 diff --git a/src/Test/Hspec/Compat.hs b/src/Test/Hspec/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Compat.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Compat ( + showType +, showFullType +, readMaybe +, lookupEnv +, module Data.IORef +#if !MIN_VERSION_base(4,6,0) +, modifyIORef' +#endif +) where + +#if !MIN_VERSION_base(4,3,0) +import Control.Monad.Trans.Error () -- for Monad (Either e) +#endif + +import Data.Typeable (Typeable, typeOf, typeRepTyCon) +import Text.Read +import Data.IORef +import System.Environment + +#if MIN_VERSION_base(4,4,0) +import Data.Typeable.Internal (tyConModule, tyConName) +#endif + +#if !MIN_VERSION_base(4,6,0) +import qualified Text.ParserCombinators.ReadP as P +#endif + +#if !MIN_VERSION_base(4,6,0) +-- |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 +#if MIN_VERSION_base(4,4,0) + show t +#else + (reverse . takeWhile (/= '.') . reverse . show) t +#endif + + +showFullType :: Typeable a => a -> String +showFullType a = let t = typeRepTyCon (typeOf a) in +#if MIN_VERSION_base(4,4,0) + tyConModule t ++ "." ++ tyConName t +#else + show t +#endif diff --git a/src/Test/Hspec/Config.hs b/src/Test/Hspec/Config.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Config.hs @@ -0,0 +1,82 @@ +module Test.Hspec.Config ( + Config (..) +, ColorMode(..) +, defaultConfig +, getConfig +, configAddFilter +, configQuickCheckArgs +) where + +import Control.Applicative +import System.IO +import System.Exit +import qualified Test.QuickCheck as QC + +import Test.Hspec.Core.Util +import Test.Hspec.Options +import Test.Hspec.FailureReport +import Test.Hspec.Core.QuickCheckUtil (mkGen) + +-- | 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 = flip elem . failureReportPaths <$> mFailureReport + +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)) QC.stdArgs + + 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 Config +getConfig opts_ prog args = do + case parseOptions opts_ prog args of + Left (err, msg) -> exitWithMessage err msg + Right opts -> do + r <- if configRerun opts then readFailureReport else return Nothing + return (mkConfig r opts) + +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 --- /dev/null +++ b/src/Test/Hspec/Core/Example.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE CPP, TypeFamilies, FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable #-} +module Test.Hspec.Core.Example ( + Example (..) +, Params (..) +, ActionWith +, Progress +, ProgressCallback +, Result (..) +) where + +import Data.Maybe (fromMaybe) +import Data.List (isPrefixOf) +import Test.HUnit.Lang (HUnitFailure(..)) +import qualified Control.Exception as E +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 qualified Test.QuickCheck.IO () + +import Test.Hspec.Core.QuickCheckUtil +import Test.Hspec.Core.Util +import Test.Hspec.Compat + +-- | A type class for examples +class Example e where + type Arg e +#if __GLASGOW_HASKELL__ >= 704 + type Arg e = () +#endif + evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result + +data Params = Params { + paramsQuickCheckArgs :: QC.Args +, paramsSmallCheckDepth :: Int +} deriving (Show) + +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) | Fail String + deriving (Eq, Show, Read, Typeable) + +instance E.Exception Result + +instance Example Bool where + type Arg Bool = () + evaluateExample b _ _ _ = if b then return Success else return (Fail "") + +instance Example Expectation where + type Arg Expectation = () + evaluateExample e = evaluateExample (\() -> e) + +instance Example (a -> Expectation) where + type Arg (a -> Expectation) = a + evaluateExample e _ action _ = (action e >> return Success) `E.catches` [ + E.Handler (\(HUnitFailure err) -> return (Fail err)) + , E.Handler (return :: Result -> IO Result) + ] + +instance Example Result where + type Arg Result = () + evaluateExample r _ _ _ = return r + +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 (Fail $ sanitizeFailureMessage r) (parsePending m) + QC.GaveUp {QC.numTests = n} -> Fail ("Gave up after " ++ pluralize n "test" ) + QC.NoExpectedFailure {} -> Fail ("No expected failure") + 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 -> 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/Formatters.hs b/src/Test/Hspec/Core/Formatters.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters.hs @@ -0,0 +1,216 @@ +-- | +-- 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 (..) +, FormatM + +-- ** Accessing the runner state +, getSuccessCount +, getPendingCount +, getFailCount +, getTotalCount + +, FailureRecord (..) +, getFailMessages +, usedSeed + +, getCPUTime +, getRealTime + +-- ** Appending to the gerenated report +, write +, writeLine +, newParagraph + +-- ** Dealing with colors +, withInfoColor +, withSuccessColor +, withPendingColor +, withFailColor + +-- ** Helpers +, formatException +) where + +import Data.Maybe +import Test.Hspec.Core.Util +import Test.Hspec.Core.Spec (Location(..), LocationAccuracy(..)) +import Text.Printf +import Control.Monad (when, unless) +import Data.Foldable (forM_) +import Control.Applicative +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.Internal ( + Formatter (..) + , FormatM + + , getSuccessCount + , getPendingCount + , getFailCount + , getTotalCount + + , FailureRecord (..) + , getFailMessages + , usedSeed + + , getCPUTime + , getRealTime + + , write + , writeLine + , newParagraph + + , withInfoColor + , withSuccessColor + , withPendingColor + , withFailColor + ) + +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 + + 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 "" + + unless (null failures) $ do + 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 + write (show n ++ ") ") + writeLine (formatRequirement path) + withFailColor $ do + unless (null err) $ do + writeLine err + forM_ mLoc $ \loc -> do + writeLine "" + withInfoColor $ writeLine (formatLoc loc) + where + err = either (("uncaught exception: " ++) . formatException) id reason + formatLoc (Location file line _column accuracy) = "# " ++ file ++ ":" ++ show line ++ bestEffortMarking + where + bestEffortMarking = case accuracy of + ExactLocation -> "" + 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 c | fails /= 0 = withFailColor + | pending /= 0 = withPendingColor + | otherwise = withSuccessColor + c $ do + write $ pluralize total "example" + write (", " ++ pluralize fails "failure") + unless (pending == 0) $ + write (", " ++ show pending ++ " pending") + writeLine "" diff --git a/src/Test/Hspec/Core/Formatters/Internal.hs b/src/Test/Hspec/Core/Formatters/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/Internal.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Test.Hspec.Core.Formatters.Internal ( + +-- * Public API + Formatter (..) +, FormatM + +, getSuccessCount +, getPendingCount +, getFailCount +, getTotalCount + +, FailureRecord (..) +, getFailMessages +, usedSeed + +, getCPUTime +, getRealTime + +, write +, writeLine +, newParagraph + +, withInfoColor +, withSuccessColor +, withPendingColor +, withFailColor + +-- * Functions for internal use +, runFormatM +, increaseSuccessCount +, increasePendingCount +, increaseFailCount +, addFailMessage +, finally_ +) where + +import qualified System.IO as IO +import System.IO (Handle) +import Control.Monad +import Control.Applicative +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.Compat +import Test.Hspec.Core.Spec (Progress, Location) + +-- | 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 +, 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 + +-- | The total number of examples encountered so far. +totalCount :: FormatterState -> Int +totalCount s = successCount s + pendingCount s + failCount s + +-- 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 -> Integer -> Handle -> FormatM a -> IO a +runFormatM useColor produceHTML_ printCpuTime seed handle (FormatM action) = do + time <- getPOSIXTime + cpuTime <- if printCpuTime then Just <$> CPUTime.getCPUTime else pure Nothing + st <- newIORef (FormatterState handle useColor 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 + +-- | Get the total number of examples encountered so far. +getTotalCount :: FormatM Int +getTotalCount = gets totalCount + +-- | Append to the list of accumulated failure messages. +addFailMessage :: Maybe Location -> Path -> Either SomeException String -> 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 + +data FailureRecord = FailureRecord { + failureRecordLocation :: Maybe Location +, failureRecordPath :: Path +, failureRecordMessage :: Either SomeException String +} + +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 String -> FormatM () + +-- | evaluated after each pending example +, examplePending :: Path -> Maybe String -> FormatM () + +-- | evaluated after a test run +, failedFormatter :: FormatM () + +-- | evaluated after `failuresFormatter` +, footerFormatter :: FormatM () +} + + +-- | Append an empty line to the report. +-- +-- Calling this multiple times has the same effect as calling it once. +newParagraph :: FormatM () +newParagraph = writeLine "" +{-# DEPRECATED newParagraph "use @writeLine \"\"@ instead" #-} + +-- | Append some output to the report. +write :: String -> FormatM () +write s = do + h <- gets stateHandle + liftIO $ IO.hPutStr h 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 = 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) + +-- | +-- @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/Hooks.hs b/src/Test/Hspec/Core/Hooks.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Hooks.hs @@ -0,0 +1,74 @@ +-- | Stability: provisional +module Test.Hspec.Core.Hooks ( + before +, beforeWith +, beforeAll +, after +, after_ +, afterAll +, afterAll_ +, around +, around_ +, aroundWith +) where + +import Control.Exception (finally) +import Control.Concurrent.MVar + +import Test.Hspec.Core.Spec + +-- | 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. +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 Nothing) + let action_ = memoize mvar action + before action_ spec + +memoize :: MVar (Maybe a) -> IO a -> IO a +memoize mvar action = modifyMVar mvar $ \ma -> case ma of + Just a -> return (ma, a) + Nothing -> do + a <- action + return (Just a, a) + +-- | 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 () -> Spec -> Spec +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 () -> Spec -> Spec +afterAll_ action = afterAll (\() -> action) + +-- | Run a custom action before and/or after every spec item. +around_ :: (IO () -> IO ()) -> Spec -> Spec +around_ action = around $ action . ($ ()) + +-- | Run a custom action before and/or after every spec item. +aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b +aroundWith action = mapAround (. action) + +mapAround :: ((ActionWith b -> IO ()) -> ActionWith a -> IO ()) -> SpecWith a -> SpecWith b +mapAround f = mapSpecItem (untangle f) $ \i@Item{itemExample = e} -> i{itemExample = (. f) . e} + +untangle :: ((ActionWith b -> IO ()) -> ActionWith a -> IO ()) -> ActionWith a -> ActionWith b +untangle f g = \b -> f ($ b) g diff --git a/src/Test/Hspec/Core/QuickCheck.hs b/src/Test/Hspec/Core/QuickCheck.hs new file mode 100644 --- /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 --- /dev/null +++ b/src/Test/Hspec/Core/QuickCheckUtil.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.QuickCheckUtil where + +import Control.Applicative +import Data.Int +import Data.IORef +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 --- /dev/null +++ b/src/Test/Hspec/Core/Runner.hs @@ -0,0 +1,174 @@ +-- | +-- Stability: provisional +module Test.Hspec.Core.Runner ( +-- * Running a spec + hspec +, hspecWith +, hspecResult +, hspecWithResult + +-- * Types +, Summary (..) +, Config (..) +, ColorMode (..) +, Path +, defaultConfig +, configAddFilter +) where + +import Control.Monad +import Control.Applicative +import Data.Monoid +import Data.Maybe +import System.IO +import System.Environment (getProgName, getArgs, withArgs) +import System.Exit +import qualified Control.Exception as E + +import System.Console.ANSI (hHideCursor, hShowCursor) +import qualified Test.QuickCheck as QC +import Control.Monad.IO.Class (liftIO) + +import Test.Hspec.Compat (lookupEnv) +import Test.Hspec.Core.Util (Path) +import Test.Hspec.Core.Spec +import Test.Hspec.Config +import Test.Hspec.Core.Formatters +import Test.Hspec.Core.Formatters.Internal +import Test.Hspec.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 = fromMaybe (const True) (configFilterPredicate c) + + 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 = evaluateExample 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 (summaryFailures r == 0) exitFailure + +-- | 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 conf spec = do + prog <- getProgName + args <- getArgs + c <- getConfig conf prog args >>= ensureSeed + withArgs [] {- do not leak command-line arguments to examples -} $ withHandle c $ \h -> do + let formatter = fromMaybe specdoc (configFormatter c) + seed = (fromJust . configQuickCheckSeed) c + qcArgs = configQuickCheckArgs c + + useColor <- doesUseColor h c + + filteredSpec <- filterSpecs c . applyDryRun c <$> runSpecM spec + + withHiddenCursor useColor h $ + runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) seed h $ do + runFormatter useColor h c formatter filteredSpec `finally_` do + failedFormatter formatter + + footerFormatter formatter + + -- dump failure report + xs <- map failureRecordPath <$> getFailMessages + liftIO $ writeFailureReport FailureReport { + failureReportSeed = seed + , failureReportMaxSuccess = QC.maxSuccess qcArgs + , failureReportMaxSize = QC.maxSize qcArgs + , failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs + , failureReportPaths = xs + } + + Summary <$> getTotalCount <*> getFailCount + where + withHiddenCursor :: Bool -> Handle -> IO a -> IO a + withHiddenCursor useColor h + | useColor = E.bracket_ (hHideCursor h) (hShowCursor h) + | otherwise = id + + doesUseColor :: Handle -> Config -> IO Bool + doesUseColor h c = case configColorMode c of + ColorAuto -> (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb) + ColorNever -> return False + ColorAlways -> return True + + withHandle :: Config -> (Handle -> IO a) -> IO a + withHandle c action = case configOutputFile c of + Left h -> action h + Right path -> withFile path WriteMode action + +isDumb :: IO Bool +isDumb = maybe False (== "dumb") <$> lookupEnv "TERM" + +-- | 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 --- /dev/null +++ b/src/Test/Hspec/Core/Runner/Eval.hs @@ -0,0 +1,157 @@ +module Test.Hspec.Core.Runner.Eval (runFormatter) where + +import Control.Applicative +import Control.Monad +import qualified Control.Exception as E +import Control.Concurrent +import System.IO (Handle) + +import Control.Monad.IO.Class (liftIO) +import Control.DeepSeq (deepseq) +import Data.Time.Clock.POSIX + +import Test.Hspec.Core.Util +import Test.Hspec.Core.Spec +import Test.Hspec.Config +import Test.Hspec.Core.Formatters +import Test.Hspec.Core.Formatters.Internal +import Test.Hspec.Timer + +type EvalTree = Tree (ActionWith ()) (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) + +-- | Evaluate all examples of a given spec and produce a report. +runFormatter :: Bool -> Handle -> Config -> Formatter -> [SpecTree ()] -> FormatM () +runFormatter useColor h c formatter specs = do + 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 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 :: Bool -> (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ()) +parallelize isParallelizable e + | isParallelizable = runParallel e + | otherwise = runSequentially e + +runSequentially :: (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ()) +runSequentially e reportProgress formatResult = return $ do + result <- liftIO $ evalExample (e reportProgress) + formatResult result + +data Report = ReportProgress Progress | ReportResult (Either E.SomeException Result) + +runParallel :: (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ()) +runParallel e reportProgress formatResult = do + mvar <- newEmptyMVar + _ <- forkIO $ do + let progressCallback = replaceMVar mvar . ReportProgress + result <- evalExample (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 + +evalExample :: IO Result -> IO (Either E.SomeException Result) +evalExample e = safeTry $ forceResult <$> e + where + forceResult :: Result -> Result + forceResult r = case r of + Success -> r + Pending m -> m `deepseq` r + Fail m -> m `deepseq` r + +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 (exampleGroupStarted formatter (reverse rGroups) group) + forM_ xs (queueSpec (group : rGroups)) + defer (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 :: Either E.SomeException Result -> FormatM () + formatResult result = do + case result of + Right Success -> do + increaseSuccessCount + exampleSucceeded formatter path + Right (Pending reason) -> do + increasePendingCount + examplePending formatter path reason + Right (Fail err) -> failed loc path (Right err) + Left err -> failed loc path (Left err) + + failed loc path err = do + increaseFailCount + addFailMessage loc path err + 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 <- 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 --- /dev/null +++ b/src/Test/Hspec/Core/Spec.hs @@ -0,0 +1,70 @@ +-- | +-- 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 + describe +, it +, pending +, pendingWith +, 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 Test.Hspec.Expectations (Expectation) + +import Test.Hspec.Core.Example +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 + +-- | 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 :: Example a => String -> a -> SpecWith (Arg a) +it label action = fromSpecList [specItem label action] + +-- | `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 indicate that an example is /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 it's 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 --- /dev/null +++ b/src/Test/Hspec/Core/Spec/Monad.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Test.Hspec.Core.Spec.Monad ( + Spec +, SpecWith +, SpecM (..) +, runSpecM +, fromSpecList +, runIO + +, mapSpecTree +, mapSpecItem +, mapSpecItem_ +, modifyParams +) where + +import Control.Applicative +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/Tree.hs b/src/Test/Hspec/Core/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Tree.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DeriveFunctor #-} +-- | +-- Stability: unstable +module Test.Hspec.Core.Tree ( + SpecTree +, Tree (..) +, Item (..) +, Location (..) +, LocationAccuracy (..) +, specGroup +, specItem +) where + +import Control.Applicative +import Data.Foldable +import Data.Traversable +import Data.Monoid + +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 + +instance Foldable (Tree c) where -- Note: GHC 7.0.1 fails to derive this instance + foldMap = go + where + go :: Monoid m => (a -> m) -> Tree c a -> m + go f t = case t of + Node _ xs -> foldMap (foldMap f) xs + NodeWithCleanup _ xs -> foldMap (foldMap f) xs + Leaf x -> f x + +instance Traversable (Tree c) where -- Note: GHC 7.0.1 fails to derive this instance + sequenceA = go + where + go :: Applicative f => Tree c (f a) -> f (Tree c a) + go t = case t of + Node label xs -> Node label <$> sequenceA (map go xs) + NodeWithCleanup action xs -> NodeWithCleanup action <$> sequenceA (map go xs) + Leaf a -> Leaf <$> a + +-- | 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 Result +} + +-- | @Location@ is used to represent source locations. +data Location = Location { + locationFile :: String +, locationLine :: Int +, locationColumn :: Int +, locationAccuracy :: LocationAccuracy +} deriving (Eq, Show) + +-- | 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) + +-- | 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 :: Example a => String -> a -> SpecTree (Arg a) +specItem s e = Leaf $ Item requirement Nothing False (evaluateExample e) + where + requirement + | null s = "(unspecified behavior)" + | otherwise = s diff --git a/src/Test/Hspec/Core/Util.hs b/src/Test/Hspec/Core/Util.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Util.hs @@ -0,0 +1,132 @@ +-- | 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.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 then 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 = withAsync (action >>= evaluate) waitCatch diff --git a/src/Test/Hspec/FailureReport.hs b/src/Test/Hspec/FailureReport.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/FailureReport.hs @@ -0,0 +1,36 @@ +module Test.Hspec.FailureReport ( + FailureReport (..) +, writeFailureReport +, readFailureReport +) where + +import System.IO +import System.SetEnv +import Test.Hspec.Compat +import Test.Hspec.Core.Util (Path, safeTry) + +data FailureReport = FailureReport { + failureReportSeed :: Integer +, failureReportMaxSuccess :: Int +, failureReportMaxSize :: Int +, failureReportMaxDiscardRatio :: Int +, failureReportPaths :: [Path] +} deriving (Eq, Show, Read) + +writeFailureReport :: FailureReport -> IO () +writeFailureReport x = do + -- on Windows this can throw an exception when the input is too large, hence + -- we use `safeTry` here + safeTry (setEnv "HSPEC_FAILURES" $ show x) >>= either onError return + where + onError err = do + hPutStrLn stderr ("WARNING: Could not write environment variable HSPEC_FAILURES (" ++ show err ++ ")") + +readFailureReport :: IO (Maybe FailureReport) +readFailureReport = 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 + x -> return x diff --git a/src/Test/Hspec/Options.hs b/src/Test/Hspec/Options.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Options.hs @@ -0,0 +1,178 @@ +module Test.Hspec.Options ( + Config(..) +, ColorMode (..) +, defaultConfig +, filterOr +, parseOptions +) where + +import Control.Applicative +import Data.List +import System.IO +import System.Exit +import System.Console.GetOpt + +import Test.Hspec.Core.Formatters +import Test.Hspec.Compat +import Test.Hspec.Core.Util + +data Config = Config { + configDryRun :: Bool +, configPrintCpuTime :: Bool +, configFastFail :: Bool + +-- | +-- A predicate that is used to filter the spec before it is run. Only examples +-- that satisfy the predicate are run. +, configRerun :: Bool +, configFilterPredicate :: Maybe (Path -> Bool) +, configQuickCheckSeed :: Maybe Integer +, configQuickCheckMaxSuccess :: Maybe Int +, configQuickCheckMaxDiscardRatio :: Maybe Int +, configQuickCheckMaxSize :: Maybe Int +, configSmallCheckDepth :: Int +, configColorMode :: ColorMode +, configFormatter :: Maybe Formatter +, configHtmlOutput :: Bool +, configOutputFile :: Either Handle FilePath +} + +defaultConfig :: Config +defaultConfig = Config { + configDryRun = False +, configPrintCpuTime = False +, configFastFail = False +, configRerun = False +, configFilterPredicate = Nothing +, configQuickCheckSeed = Nothing +, configQuickCheckMaxSuccess = Nothing +, configQuickCheckMaxDiscardRatio = Nothing +, configQuickCheckMaxSize = Nothing +, configSmallCheckDepth = 5 +, configColorMode = ColorAuto +, configFormatter = Nothing +, configHtmlOutput = False +, configOutputFile = Left stdout +} + +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} + +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 = Either NoConfig Config + +data NoConfig = Help | InvalidArgument String String + +data Arg a = Arg { + _argumentName :: String +, _argumentParser :: String -> Maybe a +, _argumentSetter :: a -> Config -> Config +} + +mkOption :: [Char] -> String -> Arg a -> String -> OptDescr (Result -> Result) +mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help + where + arg :: String -> Result -> Result + arg input x = x >>= \c -> case parser input of + Just n -> Right (setter n c) + Nothing -> Left (InvalidArgument name input) + +addLineBreaks :: String -> [String] +addLineBreaks = lineBreaksAt 44 + +options :: [OptDescr (Result -> Result)] +options = [ + Option [] ["help"] (NoArg (const $ Left Help)) (h "display this help and exit") + , mkOption "m" "match" (Arg "PATTERN" return addMatch) (h "only run examples that match given PATTERN") + , Option [] ["color"] (NoArg setColor) (h "colorize the output") + , Option [] ["no-color"] (NoArg setNoColor) (h "do not colorize the output") + , 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 previously test run (only works in GHCi)") + ] + where + h = unlines . addLineBreaks + + readFormatter :: String -> Maybe Formatter + readFormatter = (`lookup` formatters) + + setFormatter :: Formatter -> Config -> Config + setFormatter f c = c {configFormatter = Just f} + + setOutputFile :: String -> Config -> Config + setOutputFile file c = c {configOutputFile = Right file} + + setPrintCpuTime x = x >>= \c -> return c {configPrintCpuTime = True} + setDryRun x = x >>= \c -> return c {configDryRun = True} + setFastFail x = x >>= \c -> return c {configFastFail = True} + setRerun x = x >>= \c -> return c {configRerun = True} + setNoColor x = x >>= \c -> return c {configColorMode = ColorNever} + setColor x = x >>= \c -> return c {configColorMode = ColorAlways} + +undocumentedOptions :: [OptDescr (Result -> Result)] +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 -> Result + setHtml x = x >>= \c -> return c {configHtmlOutput = True} + +parseOptions :: Config -> String -> [String] -> Either (ExitCode, String) Config +parseOptions c prog args = case getOpt Permute (options ++ undocumentedOptions) args of + (opts, [], []) -> case foldl' (flip id) (Right c) opts of + Left Help -> Left (ExitSuccess, usageInfo ("Usage: " ++ prog ++ " [OPTION]...\n\nOPTIONS") options) + Left (InvalidArgument flag value) -> tryHelp ("invalid argument `" ++ value ++ "' for `--" ++ flag ++ "'\n") + Right x -> Right x + (_, _, err:_) -> tryHelp err + (_, arg:_, _) -> tryHelp ("unexpected argument `" ++ arg ++ "'\n") + where + tryHelp msg = Left (ExitFailure 1, prog ++ ": " ++ msg ++ "Try `" ++ prog ++ " --help' for more information.\n") diff --git a/src/Test/Hspec/Timer.hs b/src/Test/Hspec/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Timer.hs @@ -0,0 +1,14 @@ +module Test.Hspec.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/test/Helper.hs b/test/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Helper.hs @@ -0,0 +1,89 @@ +module Helper ( + module Test.Hspec.Meta +, module Test.QuickCheck +, module Control.Applicative +, module System.IO.Silently +, sleep +, timeout +, defaultParams +, noOpProgressCallback +, captureLines +, normalizeSummary + +, ignoreExitCode +, ignoreUserInterrupt +, throwException + +, shouldStartWith +, shouldEndWith + +, shouldUseArgs +) where + +import Data.List +import Data.Char +import Data.IORef +import Control.Monad +import Control.Applicative +import System.Environment (withArgs) +import System.Exit +import Control.Concurrent +import qualified Control.Exception as E +import qualified System.Timeout as System +import Data.Time.Clock.POSIX +import System.IO.Silently + +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_ + +shouldStartWith :: (Eq a, Show a) => [a] -> [a] -> Expectation +x `shouldStartWith` y = x `shouldSatisfy` isPrefixOf y + +shouldEndWith :: (Eq a, Show a) => [a] -> [a] -> Expectation +x `shouldEndWith` y = x `shouldSatisfy` isSuffixOf y + +-- 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.Params stdArgs {replay = Just (mkGen 23, 0), maxSuccess = 1000} (H.configSmallCheckDepth H.defaultConfig) + +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) diff --git a/test/Mock.hs b/test/Mock.hs new file mode 100644 --- /dev/null +++ b/test/Mock.hs @@ -0,0 +1,15 @@ +module Mock where + +import Control.Applicative +import Data.IORef + +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 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-} diff --git a/test/Test/Hspec/CompatSpec.hs b/test/Test/Hspec/CompatSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/CompatSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Test.Hspec.CompatSpec (main, spec) where + +import Helper +import System.SetEnv + +import Test.Hspec.Compat +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.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/ExampleSpec.hs b/test/Test/Hspec/Core/ExampleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/ExampleSpec.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-} +module Test.Hspec.Core.ExampleSpec (main, spec) where + +import Helper +import Mock +import Data.List +import Data.IORef + +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 + +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 + +spec :: Spec +spec = do + describe "evaluateExample" $ do + context "for Bool" $ do + it "returns Success on True" $ do + evaluateExample True `shouldReturn` H.Success + + it "returns Fail on False" $ do + evaluateExample False `shouldReturn` H.Fail "" + + it "propagates exceptions" $ do + evaluateExample (error "foobar" :: Bool) `shouldThrow` errorCall "foobar" + + context "for Expectation" $ do + it "returns Success if all expectations hold" $ do + evaluateExample (23 `shouldBe` (23 :: Int)) `shouldReturn` H.Success + + it "returns Fail if an expectation does not hold" $ do + evaluateExample (23 `shouldBe` (42 :: Int)) `shouldReturn` H.Fail "expected: 42\n but got: 23" + + it "propagates exceptions" $ do + evaluateExample (error "foobar" :: Expectation) `shouldThrow` errorCall "foobar" + + it "runs provided action around expectation" $ 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 "when used with `pending`" $ do + it "returns Pending" $ do + evaluateExample (H.pending) `shouldReturn` H.Pending Nothing + + context "when used with `pendingWith`" $ do + it "includes the optional reason" $ do + evaluateExample (H.pendingWith "foo") `shouldReturn` H.Pending (Just "foo") + + context "for Property" $ do + it "returns Success if property holds" $ do + evaluateExample (property $ \n -> n == (n :: Int)) `shouldReturn` H.Success + + it "returns Fail if property does not hold" $ do + H.Fail _ <- evaluateExample $ property $ \n -> n /= (n :: Int) + return () + + it "shows what falsified it" $ do + H.Fail r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False + r `shouldBe` intercalate "\n" [ + "Falsifiable (after 1 test): " + , "0" + , "1" + ] + + it "runs provided action around 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 $ modifyIORef ref succ) + readIORef ref `shouldReturn` 2000 + + it "pretty-prints exceptions" $ do + H.Fail r <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (error "foobar" :: Bool)) + r `shouldBe` 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.Fail r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> 23 `shouldBe` (42 :: Int) + r `shouldBe` intercalate "\n" [ + "Falsifiable (after 1 test): " + , "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/FormattersSpec.hs b/test/Test/Hspec/Core/FormattersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/FormattersSpec.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.FormattersSpec (main, spec) where + +import Helper + +import qualified Test.Hspec.Core.Spec as H +import qualified Test.Hspec.Core.Runner as H +import qualified Test.Hspec.Core.Formatters as H + +#ifndef mingw32_HOST_OS +import System.Console.ANSI +#endif + +main :: IO () +main = hspec spec + +testSpec :: H.Spec +testSpec = do + H.describe "Example" $ do + H.it "success" (H.Success) + H.it "fail 1" (H.Fail "fail message") + H.it "pending" (H.pendingWith "pending message") + H.it "fail 2" (H.Fail "") + H.it "exceptions" (undefined :: H.Result) + H.it "fail 3" (H.Fail "") + +spec :: Spec +spec = do + describe "silent" $ do + let runSpec = fmap fst . capture . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.silent} + it "produces no output" $ do + runSpec testSpec `shouldReturn` "" + + describe "failed_examples" $ do + failed_examplesSpec H.failed_examples + + describe "progress" $ do + let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.progress} + + it "produces '..F...FF.F' style output" $ do + r <- runSpec testSpec + head r `shouldBe` ".F.FFF" + + context "same as failed_examples" $ do + failed_examplesSpec H.progress + + describe "specdoc" $ do + let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.specdoc} + + 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" + ] + + context "same as failed_examples" $ do + failed_examplesSpec H.progress + +failed_examplesSpec :: H.Formatter -> Spec +failed_examplesSpec formatter = do + let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter} + + it "summarizes the time it takes to finish" $ do + r <- runSpec (return ()) + normalizeSummary r `shouldSatisfy` any (== "Finished in 0.0000 seconds") + + 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" (undefined :: Bool) + r `shouldContain` [ + "1) foobar" + , "uncaught exception: ErrorCall (Prelude.undefined)" + ] + + 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." + + 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) + + it "summarizes the number of examples and failures" $ do + r <- runSpec testSpec + r `shouldSatisfy` any (== "6 examples, 4 failures, 1 pending") + + -- Windows has no support for ANSI escape codes. The Console API is used for + -- colorized output, hence the following tests do not work on Windows. +#ifndef mingw32_HOST_OS + it "shows summary in green if there are no failures" $ do + r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do + H.it "foobar" True + r `shouldSatisfy` any (== (green ++ "1 example, 0 failures" ++ reset)) + + it "shows summary in yellow if there are pending examples" $ do + r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do + H.it "foobar" H.pending + r `shouldSatisfy` any (== (yellow ++ "1 example, 0 failures, 1 pending" ++ reset)) + + it "shows summary in red if there are failures" $ do + r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do + H.it "foobar" False + r `shouldSatisfy` any (== (red ++ "1 example, 1 failure" ++ reset)) + + it "shows summary in red if there are both failures and pending examples" $ do + r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do + H.it "foo" False + H.it "bar" H.pending + r `shouldSatisfy` any (== (red ++ "2 examples, 1 failure, 1 pending" ++ reset)) + where + green = setSGRCode [SetColor Foreground Dull Green] + yellow = setSGRCode [SetColor Foreground Dull Yellow] + red = setSGRCode [SetColor Foreground Dull Red] + reset = setSGRCode [Reset] +#endif diff --git a/test/Test/Hspec/Core/HooksSpec.hs b/test/Test/Hspec/Core/HooksSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/HooksSpec.hs @@ -0,0 +1,230 @@ +module Test.Hspec.Core.HooksSpec (main, spec) where + +import Helper +import Data.IORef + +import qualified Test.Hspec.Core.Spec as H +import qualified Test.Hspec.Core.Runner as H + +import qualified Test.Hspec.Core.Hooks as H + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "before" $ do + it "runs an action before every spec item" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.before (append "before") $ do + H.it "foo" $ do + append "foo" + H.it "bar" $ do + append "bar" + readIORef ref `shouldReturn` [ + "before" + , "foo" + , "before" + , "bar" + ] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.before (append "before outer") $ H.before (append "before inner") $ do + H.it "foo" $ do + append "foo" + readIORef ref `shouldReturn` [ + "before outer" + , "before inner" + , "foo" + ] + + context "when used with an action that returns a value" $ do + it "passes that value to the spec item" $ do + property $ \n -> do + silence $ H.hspec $ H.before (return n) $ do + H.it "foo" $ \m -> do + m `shouldBe` (n :: Int) + + context "when used with a QuickCheck property" $ do + it "runs action before every check of the property" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.before (append "before") $ do + H.it "foo" $ property $ append "foo" + readIORef ref `shouldReturn` (take 200 . cycle) ["before", "foo"] + + describe "beforeWith" $ do + it "runs an action before every spec item" $ do + let action :: Int -> IO String + action n = return (show n) + property $ \n -> do + silence $ H.hspec $ H.before (return n) $ H.beforeWith action $ do + H.it "foo" $ (`shouldBe` show n) + + describe "beforeAll" $ do + it "runs an action before the first spec item" $ do + ref <- newIORef [] + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.beforeAll (append "beforeAll") $ do + H.it "foo" $ do + append "foo" + H.it "bar" $ do + append "bar" + readIORef ref `shouldReturn` [ + "beforeAll" + , "foo" + , "bar" + ] + + context "when used with an empty list of examples" $ do + it "does not run specified action" $ do + ref <- newIORef [] + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.beforeAll (append "beforeAll") $ do + return () + readIORef ref `shouldReturn` [] + + context "when used with an action that returns a value" $ do + it "passes that value to the spec item" $ do + property $ \n -> do + silence $ H.hspec $ H.beforeAll (return n) $ do + H.it "foo" $ \m -> do + m `shouldBe` (n :: Int) + + describe "after" $ do + it "must be used with a before action" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.before (return "from before") $ H.after append $ do + H.it "foo" $ \_ -> do + append "foo" + readIORef ref `shouldReturn` [ + "foo" + , "from before" + ] + + describe "after_" $ do + it "runs an action after every spec item" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.after_ (append "after") $ do + H.it "foo" $ do + append "foo" + H.it "bar" $ do + append "bar" + readIORef ref `shouldReturn` [ + "foo" + , "after" + , "bar" + , "after" + ] + + it "guarantees that action is run" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence . ignoreExitCode $ H.hspec $ H.after_ (append "after") $ do + H.it "foo" $ do + ioError $ userError "foo" :: IO () + append "foo" + readIORef ref `shouldReturn` ["after"] + + context "when used multiple times" $ do + it "is evaluated inside out" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.after_ (append "after outer") $ H.after_ (append "after inner") $ do + H.it "foo" $ do + append "foo" + readIORef ref `shouldReturn` [ + "foo" + , "after inner" + , "after outer" + ] + + describe "afterAll_" $ do + it "runs an action after the last spec item" $ do + ref <- newIORef [] + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.afterAll_ (append "afterAll") $ do + H.it "foo" $ do + append "foo" + H.it "bar" $ do + append "bar" + readIORef ref `shouldReturn` [ + "foo" + , "bar" + , "afterAll" + ] + + context "when used with an empty list of examples" $ do + it "does not run specified action" $ do + ref <- newIORef [] + let append n = modifyIORef ref (++ return n) + silence $ H.hspec $ H.afterAll_ (append "afterAll") $ do + return () + readIORef ref `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 + property $ \n -> do + silence $ H.hspec $ H.around ($ n) $ do + H.it "foo" $ \m -> do + m `shouldBe` (n :: Int) + + describe "around_" $ do + it "wraps every spec item with an action" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + action e = append "before" >> e >> append "after" + silence $ H.hspec $ H.around_ action $ do + H.it "foo" $ do + append "foo" + H.it "bar" $ do + append "bar" + readIORef ref `shouldReturn` [ + "before" + , "foo" + , "after" + , "before" + , "bar" + , "after" + ] + + context "when used multiple times" $ do + it "is evaluated outside in" $ do + ref <- newIORef ([] :: [String]) + let append n = modifyIORef ref (++ return n) + actionOuter e = append "before outer" >> e >> append "after outer" + actionInner e = append "before inner" >> e >> append "after inner" + silence $ H.hspec $ H.around_ actionOuter $ H.around_ actionInner $ do + H.it "foo" $ do + append "foo" + readIORef ref `shouldReturn` [ + "before outer" + , "before inner" + , "foo" + , "after inner" + , "after outer" + ] + + describe "aroundWith" $ do + it "wraps every spec item with an action" $ do + let action :: H.ActionWith String -> H.ActionWith Int + action e n = e (show n) + property $ \n -> do + silence $ H.hspec $ H.before (return n) $ H.aroundWith action $ do + H.it "foo" $ (`shouldBe` show n) + where + runSpec :: H.Spec -> IO [String] + runSpec = captureLines . H.hspecResult diff --git a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs b/test/Test/Hspec/Core/QuickCheckUtilSpec.hs new file mode 100644 --- /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 --- /dev/null +++ b/test/Test/Hspec/Core/RunnerSpec.hs @@ -0,0 +1,399 @@ +module Test.Hspec.Core.RunnerSpec (main, spec) where + +import Helper +import System.IO (stderr) +import Control.Monad +import System.Environment (withArgs, withProgName, getArgs) +import System.Exit +import Control.Concurrent +import qualified Control.Exception as E +import Mock +import System.SetEnv +import Test.Hspec.Compat + +import Test.Hspec.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 ["-r"] `shouldReturn` r + + forM_ quickCheckOptions $ \(flag, accessor) -> do + it ("reuses same " ++ flag) $ do + [flag, "23"] `shouldUseArgs` ((== 23) . accessor) + ["--rerun"] `shouldUseArgs` ((== 23) . accessor) + + context "when there is no failure report in the environment" $ do + it "runs everything" $ do + unsetEnv "HSPEC_FAILURES" + r <- hSilence [stderr] $ withArgs ["-r"] runSpec + r `shouldSatisfy` elem "5 examples, 3 failures" + + it "prints a warning to stderr" $ do + unsetEnv "HSPEC_FAILURES" + r <- hCapture_ [stderr] $ withArgs ["-r"] 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 ["-r"] 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 ["-r"] runSpec + r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n" + + + it "does not leak command-line flags 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 $ 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]" + , "" + , "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 $ do + H.it "foo" True + H.it "bar" False + H.it "baz" False + normalizeSummary r `shouldBe` [ + "" + , "foo" + , "bar FAILED [1]" + , "" + , "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 $ do + H.describe "foo" $ do + H.it "bar" False + H.it "baz" True + normalizeSummary r `shouldBe` [ + "" + , "foo" + , " bar FAILED [1]" + , "" + , "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 "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 --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 $ 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.Fail $ "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 . H.hspecResult . H.parallel $ do + replicateM_ n (H.it "foo" $ sleep t) + r `shouldBe` Just (H.Summary n 0) diff --git a/test/Test/Hspec/Core/SpecSpec.hs b/test/Test/Hspec/Core/SpecSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/SpecSpec.hs @@ -0,0 +1,69 @@ +module Test.Hspec.Core.SpecSpec (main, spec) where + +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 "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) + itemExample item defaultParams ($ ()) noOpProgressCallback `shouldReturn` Success + + 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 "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/UtilSpec.hs b/test/Test/Hspec/Core/UtilSpec.hs new file mode 100644 --- /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 undefined) + show e `shouldBe` "Prelude.undefined" + + 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/test/Test/Hspec/FailureReportSpec.hs b/test/Test/Hspec/FailureReportSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/FailureReportSpec.hs @@ -0,0 +1,39 @@ +module Test.Hspec.FailureReportSpec (main, spec) where + +import Helper + +import System.IO +import Test.Hspec.FailureReport +import GHC.Paths (ghc) +import System.Process +import System.Exit + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "writeFailureReport" $ do + it "prints a warning on unexpected exceptions" $ do + r <- hCapture_ [stderr] $ writeFailureReport (error "some error") + r `shouldBe` "WARNING: Could not write environment variable HSPEC_FAILURES (some error)\n" + + -- GHCi needs to keep the environment on :reload, so that we can store + -- failures there. Otherwise --rerun would not be very useful. So we add a + -- test for that. + describe "GHCi" $ do + it "keeps environment variables on :reload" $ do + let flags = ["-v0", "--interactive", "-ignore-dot-ghci"] + (Just hIn, Just hOut, Nothing, processHandle) <- createProcess $ (proc ghc flags) { + std_in = CreatePipe + , std_out = CreatePipe + } + hPutStrLn hIn "import System.SetEnv" + hPutStrLn hIn "setEnv \"FOO\" \"bar\"" + hPutStrLn hIn ":reload" + hPutStrLn hIn "import System.Environment" + hPutStrLn hIn "getEnv \"FOO\"" + hClose hIn + r <- hGetContents hOut + length r `seq` r `shouldBe` "\"bar\"\n" + waitForProcess processHandle `shouldReturn` ExitSuccess diff --git a/test/Test/Hspec/OptionsSpec.hs b/test/Test/Hspec/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/OptionsSpec.hs @@ -0,0 +1,44 @@ +module Test.Hspec.OptionsSpec (main, spec) where + +import Helper +import System.Exit + +import Test.Hspec.Options hiding (parseOptions) +import qualified Test.Hspec.Options as Options + +main :: IO () +main = hspec spec + +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 "sets configColorMode to ColorAuto" $ do + configColorMode <$> parseOptions [] `shouldBe` Right ColorAuto + + context "with --no-color" $ do + it "sets configColorMode to ColorNever" $ do + configColorMode <$> parseOptions ["--no-color"] `shouldBe` Right ColorNever + + context "with --color" $ do + it "sets configColorMode to ColorAlways" $ do + configColorMode <$> parseOptions ["--color"] `shouldBe` Right ColorAlways + + context "with --out" $ do + it "sets configOutputFile" $ do + either (const Nothing) Just . configOutputFile <$> parseOptions ["--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 ["--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 ["--depth", "23"] `shouldBe` Right 23 diff --git a/test/Test/Hspec/TimerSpec.hs b/test/Test/Hspec/TimerSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/TimerSpec.hs @@ -0,0 +1,29 @@ +module Test.Hspec.TimerSpec (main, spec) where + +import Helper + +import Test.Hspec.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