hspec-core 2.3.2 → 2.4.0

raw patch · 46 files changed

+1952/−931 lines, 46 filesdep +arraydep +directorydep +filepath

Dependencies added: array, directory, filepath, temporary

Files

• LICENSE +1/−1
• hspec-core.cabal +37/−16
• src/Test/Hspec/Compat.hs +0/−106
• src/Test/Hspec/Config.hs +0/−86
• src/Test/Hspec/Core/Compat.hs +106/−0
• src/Test/Hspec/Core/Config.hs +126/−0
• src/Test/Hspec/Core/Example.hs +61/−20
• src/Test/Hspec/Core/FailureReport.hs +49/−0
• src/Test/Hspec/Core/Formatters.hs +53/−20
• src/Test/Hspec/Core/Formatters/Diff.hs +33/−0
• src/Test/Hspec/Core/Formatters/Free.hs +22/−0
• src/Test/Hspec/Core/Formatters/Internal.hs +48/−91
• src/Test/Hspec/Core/Formatters/Monad.hs +237/−0
• src/Test/Hspec/Core/Hooks.hs +24/−16
• src/Test/Hspec/Core/Options.hs +261/−0
• src/Test/Hspec/Core/QuickCheckUtil.hs +1/−1
• src/Test/Hspec/Core/Runner.hs +86/−42
• src/Test/Hspec/Core/Runner/Eval.hs +19/−28
• src/Test/Hspec/Core/Spec.hs +41/−4
• src/Test/Hspec/Core/Spec/Monad.hs +1/−1
• src/Test/Hspec/Core/Timer.hs +14/−0
• src/Test/Hspec/Core/Tree.hs +4/−3
• src/Test/Hspec/Core/Util.hs +12/−3
• src/Test/Hspec/FailureReport.hs +0/−49
• src/Test/Hspec/Options.hs +0/−198
• src/Test/Hspec/Timer.hs +0/−14
• test/All.hs +1/−0
• test/Helper.hs +35/−4
• test/Mock.hs +1/−1
• test/Spec.hs +11/−1
• test/Test/Hspec/CompatSpec.hs +0/−31
• test/Test/Hspec/Core/CompatSpec.hs +31/−0
• test/Test/Hspec/Core/ConfigSpec.hs +33/−0
• test/Test/Hspec/Core/ExampleSpec.hs +74/−23
• test/Test/Hspec/Core/FailureReportSpec.hs +17/−0
• test/Test/Hspec/Core/Formatters/DiffSpec.hs +21/−0
• test/Test/Hspec/Core/FormattersSpec.hs +150/−64
• test/Test/Hspec/Core/HooksSpec.hs +12/−2
• test/Test/Hspec/Core/OptionsSpec.hs +98/−0
• test/Test/Hspec/Core/RunnerSpec.hs +69/−2
• test/Test/Hspec/Core/SpecSpec.hs +20/−5
• test/Test/Hspec/Core/TimerSpec.hs +29/−0
• test/Test/Hspec/FailureReportSpec.hs +0/−17
• test/Test/Hspec/OptionsSpec.hs +0/−53
• test/Test/Hspec/TimerSpec.hs +0/−29
• vendor/Data/Algorithm/Diff.hs +114/−0

@@ -1,4 +1,4 @@-Copyright (c) 2011-2015 Simon Hengel <sol@typeful.net>+Copyright (c) 2011-2017 Simon Hengel <sol@typeful.net> Copyright (c) 2011-2012 Trystan Spangler <trystan.s@comcast.net> Copyright (c) 2011-2011 Greg Weber <greg@gregweber.info> 

@@ -3,10 +3,10 @@ -- see: https://github.com/sol/hpack  name:             hspec-core-version:          2.3.2+version:          2.4.0 license:          MIT license-file:     LICENSE-copyright:        (c) 2011-2015 Simon Hengel,+copyright:        (c) 2011-2017 Simon Hengel,                   (c) 2011-2012 Trystan Spangler,                   (c) 2011 Greg Weber maintainer:       Simon Hengel <sol@typeful.net>@@ -27,6 +27,7 @@ library   hs-source-dirs:       src+      vendor   ghc-options: -Wall   build-depends:       base >= 4.5.0.0 && < 5@@ -43,6 +44,9 @@     , hspec-expectations == 0.8.2.*     , async >= 2     , call-stack+    , directory+    , filepath+    , array   exposed-modules:       Test.Hspec.Core.Spec       Test.Hspec.Core.Hooks@@ -51,17 +55,21 @@       Test.Hspec.Core.QuickCheck       Test.Hspec.Core.Util   other-modules:-      Test.Hspec.Compat-      Test.Hspec.Config+      Test.Hspec.Core.Compat+      Test.Hspec.Core.Config       Test.Hspec.Core.Example+      Test.Hspec.Core.FailureReport+      Test.Hspec.Core.Formatters.Diff+      Test.Hspec.Core.Formatters.Free       Test.Hspec.Core.Formatters.Internal+      Test.Hspec.Core.Formatters.Monad+      Test.Hspec.Core.Options       Test.Hspec.Core.QuickCheckUtil       Test.Hspec.Core.Runner.Eval       Test.Hspec.Core.Spec.Monad+      Test.Hspec.Core.Timer       Test.Hspec.Core.Tree-      Test.Hspec.FailureReport-      Test.Hspec.Options-      Test.Hspec.Timer+      Data.Algorithm.Diff       Paths_hspec_core   default-language: Haskell2010 @@ -70,8 +78,10 @@   main-is: Spec.hs   hs-source-dirs:       src+      vendor       test   ghc-options: -Wall+  cpp-options: -DTEST   build-depends:       base >= 4.5.0.0 && < 5     , random@@ -87,38 +97,49 @@     , hspec-expectations == 0.8.2.*     , async >= 2     , call-stack+    , directory+    , filepath+    , array     , hspec-meta >= 2.3.2     , silently >= 1.2.4     , process+    , temporary   other-modules:-      Test.Hspec.Compat-      Test.Hspec.Config+      Test.Hspec.Core.Compat+      Test.Hspec.Core.Config       Test.Hspec.Core.Example+      Test.Hspec.Core.FailureReport       Test.Hspec.Core.Formatters+      Test.Hspec.Core.Formatters.Diff+      Test.Hspec.Core.Formatters.Free       Test.Hspec.Core.Formatters.Internal+      Test.Hspec.Core.Formatters.Monad       Test.Hspec.Core.Hooks+      Test.Hspec.Core.Options       Test.Hspec.Core.QuickCheck       Test.Hspec.Core.QuickCheckUtil       Test.Hspec.Core.Runner       Test.Hspec.Core.Runner.Eval       Test.Hspec.Core.Spec       Test.Hspec.Core.Spec.Monad+      Test.Hspec.Core.Timer       Test.Hspec.Core.Tree       Test.Hspec.Core.Util-      Test.Hspec.FailureReport-      Test.Hspec.Options-      Test.Hspec.Timer+      Data.Algorithm.Diff+      All       Helper       Mock-      Test.Hspec.CompatSpec+      Test.Hspec.Core.CompatSpec+      Test.Hspec.Core.ConfigSpec       Test.Hspec.Core.ExampleSpec+      Test.Hspec.Core.FailureReportSpec+      Test.Hspec.Core.Formatters.DiffSpec       Test.Hspec.Core.FormattersSpec       Test.Hspec.Core.HooksSpec+      Test.Hspec.Core.OptionsSpec       Test.Hspec.Core.QuickCheckUtilSpec       Test.Hspec.Core.RunnerSpec       Test.Hspec.Core.SpecSpec+      Test.Hspec.Core.TimerSpec       Test.Hspec.Core.UtilSpec-      Test.Hspec.FailureReportSpec-      Test.Hspec.OptionsSpec-      Test.Hspec.TimerSpec   default-language: Haskell2010

@@ -1,106 +0,0 @@-{-# LANGUAGE CPP #-}-module Test.Hspec.Compat (-  getDefaultConcurrentJobs-, showType-, showFullType-, readMaybe-, lookupEnv-, module Data.IORef--, module Prelude-, module Control.Applicative-, module Data.Foldable-, module Data.Traversable-, module Data.Monoid--#if !MIN_VERSION_base(4,6,0)-, modifyIORef'-#endif-) where--import           Control.Applicative-import           Data.Foldable-import           Data.Traversable-import           Data.Monoid--import           Prelude hiding (-    all-  , and-  , any-  , concat-  , concatMap-  , elem-  , foldl-  , foldl1-  , foldr-  , foldr1-  , mapM-  , mapM_-  , maximum-  , minimum-  , notElem-  , or-  , product-  , sequence-  , sequence_-  , sum-  )--import           Data.Typeable (Typeable, typeOf, typeRepTyCon)-import           Text.Read-import           Data.IORef-import           System.Environment--import           Data.Typeable.Internal (tyConModule, tyConName)-import           Control.Concurrent--#if !MIN_VERSION_base(4,6,0)-import qualified Text.ParserCombinators.ReadP as P---- |Strict version of 'modifyIORef'-modifyIORef' :: IORef a -> (a -> a) -> IO ()-modifyIORef' ref f = do-    x <- readIORef ref-    let x' = f x-    x' `seq` writeIORef ref x'---- | Parse a string using the 'Read' instance.--- Succeeds if there is exactly one valid result.--- A 'Left' value indicates a parse error.-readEither :: Read a => String -> Either String a-readEither s =-  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of-    [x] -> Right x-    []  -> Left "Prelude.read: no parse"-    _   -> Left "Prelude.read: ambiguous parse"- where-  read' =-    do x <- readPrec-       lift P.skipSpaces-       return x---- | Parse a string using the 'Read' instance.--- Succeeds if there is exactly one valid result.-readMaybe :: Read a => String -> Maybe a-readMaybe s = case readEither s of-                Left _  -> Nothing-                Right a -> Just a---- | Return the value of the environment variable @var@, or @Nothing@ if--- there is no such value.------ For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'.-lookupEnv :: String -> IO (Maybe String)-lookupEnv k = lookup k `fmap` getEnvironment-#endif--showType :: Typeable a => a -> String-showType a = let t = typeRepTyCon (typeOf a) in-  show t--showFullType :: Typeable a => a -> String-showFullType a = let t = typeRepTyCon (typeOf a) in-  tyConModule t ++ "." ++ tyConName t--getDefaultConcurrentJobs :: IO Int-getDefaultConcurrentJobs = getNumCapabilities

@@ -1,86 +0,0 @@-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)-import           Test.Hspec.Core.Example (Params(..), defaultParams)---- | Add a filter predicate to config.  If there is already a filter predicate,--- then combine them with `||`.-configAddFilter :: (Path -> Bool) -> Config -> Config-configAddFilter p1 c = c {-    configFilterPredicate = Just p1 `filterOr` configFilterPredicate c-  }--mkConfig :: Maybe FailureReport -> Config -> Config-mkConfig mFailureReport opts = opts {-    configFilterPredicate = matchFilter `filterOr` rerunFilter-  , configQuickCheckSeed = mSeed-  , configQuickCheckMaxSuccess = mMaxSuccess-  , configQuickCheckMaxDiscardRatio = mMaxDiscardRatio-  , configQuickCheckMaxSize = mMaxSize-  }-  where--    mSeed = configQuickCheckSeed opts <|> (failureReportSeed <$> mFailureReport)-    mMaxSuccess = configQuickCheckMaxSuccess opts <|> (failureReportMaxSuccess <$> mFailureReport)-    mMaxSize = configQuickCheckMaxSize opts <|> (failureReportMaxSize <$> mFailureReport)-    mMaxDiscardRatio = configQuickCheckMaxDiscardRatio opts <|> (failureReportMaxDiscardRatio <$> mFailureReport)--    matchFilter = configFilterPredicate opts--    rerunFilter = case failureReportPaths <$> mFailureReport of-      Just [] -> Nothing-      Just xs -> Just (`elem` xs)-      Nothing -> Nothing--configQuickCheckArgs :: Config -> QC.Args-configQuickCheckArgs c = qcArgs-  where-    qcArgs = (-        maybe id setSeed (configQuickCheckSeed c)-      . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c)-      . maybe id setMaxSize (configQuickCheckMaxSize c)-      . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) (paramsQuickCheckArgs defaultParams)--    setMaxSuccess :: Int -> QC.Args -> QC.Args-    setMaxSuccess n args = args {QC.maxSuccess = n}--    setMaxSize :: Int -> QC.Args -> QC.Args-    setMaxSize n args = args {QC.maxSize = n}--    setMaxDiscardRatio :: Int -> QC.Args -> QC.Args-    setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n}--    setSeed :: Integer -> QC.Args -> QC.Args-    setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)}--getConfig :: Config -> String -> [String] -> IO 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

@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.Compat (+  getDefaultConcurrentJobs+, showType+, showFullType+, readMaybe+, lookupEnv+, module Data.IORef++, module Prelude+, module Control.Applicative+, module Data.Foldable+, module Data.Traversable+, module Data.Monoid++#if !MIN_VERSION_base(4,6,0)+, modifyIORef'+#endif+) where++import           Control.Applicative+import           Data.Foldable+import           Data.Traversable+import           Data.Monoid++import           Prelude hiding (+    all+  , and+  , any+  , concat+  , concatMap+  , elem+  , foldl+  , foldl1+  , foldr+  , foldr1+  , mapM+  , mapM_+  , maximum+  , minimum+  , notElem+  , or+  , product+  , sequence+  , sequence_+  , sum+  )++import           Data.Typeable (Typeable, typeOf, typeRepTyCon)+import           Text.Read+import           Data.IORef+import           System.Environment++import           Data.Typeable.Internal (tyConModule, tyConName)+import           Control.Concurrent++#if !MIN_VERSION_base(4,6,0)+import qualified Text.ParserCombinators.ReadP as P++-- |Strict version of 'modifyIORef'+modifyIORef' :: IORef a -> (a -> a) -> IO ()+modifyIORef' ref f = do+    x <- readIORef ref+    let x' = f x+    x' `seq` writeIORef ref x'++-- | Parse a string using the 'Read' instance.+-- Succeeds if there is exactly one valid result.+-- A 'Left' value indicates a parse error.+readEither :: Read a => String -> Either String a+readEither s =+  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of+    [x] -> Right x+    []  -> Left "Prelude.read: no parse"+    _   -> Left "Prelude.read: ambiguous parse"+ where+  read' =+    do x <- readPrec+       lift P.skipSpaces+       return x++-- | Parse a string using the 'Read' instance.+-- Succeeds if there is exactly one valid result.+readMaybe :: Read a => String -> Maybe a+readMaybe s = case readEither s of+                Left _  -> Nothing+                Right a -> Just a++-- | Return the value of the environment variable @var@, or @Nothing@ if+-- there is no such value.+--+-- For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'.+lookupEnv :: String -> IO (Maybe String)+lookupEnv k = lookup k `fmap` getEnvironment+#endif++showType :: Typeable a => a -> String+showType a = let t = typeRepTyCon (typeOf a) in+  show t++showFullType :: Typeable a => a -> String+showFullType a = let t = typeRepTyCon (typeOf a) in+  tyConModule t ++ "." ++ tyConName t++getDefaultConcurrentJobs :: IO Int+getDefaultConcurrentJobs = getNumCapabilities

@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.Config (+  Config (..)+, ColorMode(..)+, defaultConfig+, getConfig+, configAddFilter+, configQuickCheckArgs+#ifdef TEST+, readConfigFiles+#endif+) where++import           Control.Applicative+import           Control.Exception+import           Control.Monad+import           Data.Maybe+import           System.IO+import           System.IO.Error+import           System.Exit+import           System.FilePath+import           System.Directory+import qualified Test.QuickCheck as QC++import           Test.Hspec.Core.Util+import           Test.Hspec.Core.Options+import           Test.Hspec.Core.FailureReport+import           Test.Hspec.Core.QuickCheckUtil (mkGen)+import           Test.Hspec.Core.Example (Params(..), defaultParams)++-- | Add a filter predicate to config.  If there is already a filter predicate,+-- then combine them with `||`.+configAddFilter :: (Path -> Bool) -> Config -> Config+configAddFilter p1 c = c {+    configFilterPredicate = Just p1 `filterOr` configFilterPredicate c+  }++mkConfig :: Maybe FailureReport -> Config -> Config+mkConfig mFailureReport opts = opts {+    configFilterPredicate = matchFilter `filterOr` rerunFilter+  , configQuickCheckSeed = mSeed+  , configQuickCheckMaxSuccess = mMaxSuccess+  , configQuickCheckMaxDiscardRatio = mMaxDiscardRatio+  , configQuickCheckMaxSize = mMaxSize+  }+  where++    mSeed = configQuickCheckSeed opts <|> (failureReportSeed <$> mFailureReport)+    mMaxSuccess = configQuickCheckMaxSuccess opts <|> (failureReportMaxSuccess <$> mFailureReport)+    mMaxSize = configQuickCheckMaxSize opts <|> (failureReportMaxSize <$> mFailureReport)+    mMaxDiscardRatio = configQuickCheckMaxDiscardRatio opts <|> (failureReportMaxDiscardRatio <$> mFailureReport)++    matchFilter = configFilterPredicate opts++    rerunFilter = case failureReportPaths <$> mFailureReport of+      Just [] -> Nothing+      Just xs -> Just (`elem` xs)+      Nothing -> Nothing++configQuickCheckArgs :: Config -> QC.Args+configQuickCheckArgs c = qcArgs+  where+    qcArgs = (+        maybe id setSeed (configQuickCheckSeed c)+      . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c)+      . maybe id setMaxSize (configQuickCheckMaxSize c)+      . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) (paramsQuickCheckArgs defaultParams)++    setMaxSuccess :: Int -> QC.Args -> QC.Args+    setMaxSuccess n args = args {QC.maxSuccess = n}++    setMaxSize :: Int -> QC.Args -> QC.Args+    setMaxSize n args = args {QC.maxSize = n}++    setMaxDiscardRatio :: Int -> QC.Args -> QC.Args+    setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n}++    setSeed :: Integer -> QC.Args -> QC.Args+    setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)}++getConfig :: Config -> String -> [String] -> IO (Maybe FailureReport, Config)+getConfig opts_ prog args = do+  configFiles <- do+    ignore <- ignoreConfigFile opts_ args+    case ignore of+      True -> return []+      False -> readConfigFiles+  case parseOptions opts_ prog configFiles args of+    Left (err, msg) -> exitWithMessage err msg+    Right opts -> do+      r <- if configRerun opts then readFailureReport else return Nothing+      return (r, mkConfig r opts)++readConfigFiles :: IO [ConfigFile]+readConfigFiles = do+  global <- readGlobalConfigFile+  local <- readLocalConfigFile+  return $ catMaybes [global, local]++readGlobalConfigFile :: IO (Maybe ConfigFile)+readGlobalConfigFile = do+  mHome <- tryJust (guard . isDoesNotExistError) getHomeDirectory+  case mHome of+    Left _ -> return Nothing+    Right home -> readConfigFile (home </> ".hspec")++readLocalConfigFile :: IO (Maybe ConfigFile)+readLocalConfigFile = do+  mName <- tryJust (guard . isDoesNotExistError) (canonicalizePath ".hspec")+  case mName of+    Left _ -> return Nothing+    Right name -> readConfigFile name++readConfigFile :: FilePath -> IO (Maybe ConfigFile)+readConfigFile name = do+  exists <- doesFileExist name+  if exists then Just . (,) name . words <$> readFile name else return Nothing++exitWithMessage :: ExitCode -> String -> IO a+exitWithMessage err msg = do+  hPutStr h msg+  exitWith err+  where+    h = case err of+      ExitSuccess -> stdout+      _           -> stderr

@@ -9,6 +9,8 @@ , Result (..) , Location (..) , LocationAccuracy (..)+, FailureReason (..)+, safeEvaluateExample ) where  import           Data.Maybe (fromMaybe)@@ -20,6 +22,7 @@ #endif  import qualified Control.Exception as E+import           Control.DeepSeq import           Data.Typeable (Typeable) import qualified Test.QuickCheck as QC import           Test.Hspec.Expectations (Expectation)@@ -29,14 +32,12 @@  import           Test.Hspec.Core.QuickCheckUtil import           Test.Hspec.Core.Util-import           Test.Hspec.Compat+import           Test.Hspec.Core.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 {@@ -57,9 +58,18 @@ type ActionWith a = a -> IO ()  -- | The result of running an example-data Result = Success | Pending (Maybe String) | Fail (Maybe Location) String+data Result = Success | Pending (Maybe String) | Failure (Maybe Location) FailureReason   deriving (Eq, Show, Read, Typeable) +data FailureReason = NoReason | Reason String | ExpectedButGot (Maybe String) String String+    deriving (Eq, Show, Read, Typeable)++instance NFData FailureReason where+  rnf reason = case reason of+    NoReason -> ()+    Reason r -> r `deepseq` ()+    ExpectedButGot p e a  -> p `deepseq` e `deepseq` a `deepseq` ()+ instance E.Exception Result  -- | @Location@ is used to represent source locations.@@ -79,10 +89,46 @@   BestEffort   deriving (Eq, Show, Read) +safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO (Either E.SomeException Result)+safeEvaluateExample example params around progress = do+  r <- safeTry $ forceResult <$> evaluateExample example params around progress+  return $ case r of+    Left e | Just result <- E.fromException e -> Right result+    Left e | Just hunit <- E.fromException e -> Right (hunitFailureToResult hunit)+    _ -> r+  where+    forceResult :: Result -> Result+    forceResult r = case r of+      Success -> r+      Pending m -> m `deepseq` r+      Failure _ m -> m `deepseq` r++instance Example Result where+  type Arg Result = ()+  evaluateExample e = evaluateExample (\() -> e)++instance Example (a -> Result) where+  type Arg (a -> Result) = a+  evaluateExample example _params action _callback = do+    ref <- newIORef Success+    action (writeIORef ref . example)+    readIORef ref+ instance Example Bool where   type Arg Bool = ()-  evaluateExample b _ _ _ = if b then return Success else return (Fail Nothing "")+  evaluateExample e = evaluateExample (\() -> e) +instance Example (a -> Bool) where+  type Arg (a -> Bool) = a+  evaluateExample p _params action _callback = do+    ref <- newIORef Success+    action $ \a -> example a >>= writeIORef ref+    readIORef ref+    where+      example a+        | p a = return Success+        | otherwise = return (Failure Nothing NoReason)+ instance Example Expectation where   type Arg Expectation = ()   evaluateExample e = evaluateExample (\() -> e)@@ -92,9 +138,11 @@ #if MIN_VERSION_HUnit(1,3,0)   HUnit.HUnitFailure mLoc err -> #if MIN_VERSION_HUnit(1,5,0)-      Fail location (HUnit.formatFailureReason err)+      case err of+        HUnit.Reason reason -> Failure location (Reason reason)+        HUnit.ExpectedButGot preface expected actual -> Failure location (ExpectedButGot preface expected actual) #else-      Fail location err+      Failure location (Reason err) #endif     where       location = case mLoc of@@ -105,19 +153,12 @@         Just loc -> Just $ Location (HUnit.locationFile loc) (HUnit.locationLine loc) (HUnit.locationColumn loc) ExactLocation #endif #else-  HUnit.HUnitFailure err -> Fail Nothing err+  HUnit.HUnitFailure err -> Failure Nothing err #endif  instance Example (a -> Expectation) where   type Arg (a -> Expectation) = a-  evaluateExample e _ action _ = (action e >> return Success) `E.catches` [-      E.Handler (return . hunitFailureToResult)-    , E.Handler (return :: Result -> IO Result)-    ]--instance Example Result where-  type Arg Result = ()-  evaluateExample r _ _ _ = return r+  evaluateExample e _ action _ = action e >> return Success  instance Example QC.Property where   type Arg QC.Property = ()@@ -130,11 +171,11 @@     return $       case r of         QC.Success {}               -> Success-        QC.Failure {QC.output = m}  -> fromMaybe (Fail Nothing $ sanitizeFailureMessage r) (parsePending m)-        QC.GaveUp {QC.numTests = n} -> Fail Nothing ("Gave up after " ++ pluralize n "test" )-        QC.NoExpectedFailure {}     -> Fail Nothing ("No expected failure")+        QC.Failure {QC.output = m}  -> fromMaybe (Failure Nothing . Reason $ sanitizeFailureMessage r) (parsePending m)+        QC.GaveUp {QC.numTests = n} -> Failure Nothing (Reason $ "Gave up after " ++ pluralize n "test" )+        QC.NoExpectedFailure {}     -> Failure Nothing (Reason $ "No expected failure") #if MIN_VERSION_QuickCheck(2,8,0)-        QC.InsufficientCoverage {}  -> Fail Nothing ("Insufficient coverage")+        QC.InsufficientCoverage {}  -> Failure Nothing (Reason $ "Insufficient coverage") #endif     where       qcProgressCallback = QCP.PostTest QCP.NotCounterexample $

@@ -0,0 +1,49 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.FailureReport (+  FailureReport (..)+, writeFailureReport+, readFailureReport+) where++#ifndef __GHCJS__+import           System.SetEnv+import           Test.Hspec.Core.Util (safeTry)+#endif+import           System.IO+import           Test.Hspec.Core.Compat+import           Test.Hspec.Core.Util (Path)++data FailureReport = FailureReport {+  failureReportSeed :: Integer+, failureReportMaxSuccess :: Int+, failureReportMaxSize :: Int+, failureReportMaxDiscardRatio :: Int+, failureReportPaths :: [Path]+} deriving (Eq, Show, Read)++writeFailureReport :: FailureReport -> IO ()+#ifdef __GHCJS__+writeFailureReport _ = return ()+  -- ghcjs currently does not support setting environment variables+  -- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report+  -- into the environment is a non-essential feature we just disable this to be+  -- able to run hspec test-suites with ghcjs at all. Should be reverted once+  -- the issue is fixed.+#else+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 ++ ")")+#endif++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

@@ -19,6 +19,7 @@ -- Actions live in the `FormatM` monad.  It provides access to the runner state -- and primitives for appending to the generated report. , Formatter (..)+, FailureReason (..) , FormatM  -- ** Accessing the runner state@@ -37,7 +38,6 @@ -- ** Appending to the gerenated report , write , writeLine-, newParagraph  -- ** Dealing with colors , withInfoColor@@ -45,12 +45,15 @@ , withPendingColor , withFailColor +, extraChunk+, missingChunk+ -- ** Helpers , formatException ) where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat hiding (First)  import           Data.Maybe import           Test.Hspec.Core.Util@@ -64,8 +67,9 @@ -- -- Everything imported here has to be re-exported, so that users can implement -- their own formatters.-import Test.Hspec.Core.Formatters.Internal (+import Test.Hspec.Core.Formatters.Monad (     Formatter (..)+  , FailureReason (..)   , FormatM    , getSuccessCount@@ -82,14 +86,18 @@    , write   , writeLine-  , newParagraph    , withInfoColor   , withSuccessColor   , withPendingColor   , withFailColor++  , extraChunk+  , missingChunk   ) +import           Test.Hspec.Core.Formatters.Diff+ silent :: Formatter silent = Formatter {   headerFormatter     = return ()@@ -103,7 +111,6 @@ , footerFormatter     = return () } - specdoc :: Formatter specdoc = silent { @@ -186,11 +193,37 @@         withInfoColor $ writeLine (formatLoc loc)       write ("  " ++ show n ++ ") ")       writeLine (formatRequirement path)-      withFailColor $ do-        forM_ (lines err) $ \x -> do-          writeLine ("       " ++ x)+      case reason of+        Left e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e+        Right NoReason -> return ()+        Right (Reason err) -> withFailColor $ indent err+        Right (ExpectedButGot preface expected actual) -> do+          mapM_ indent preface++          let chunks = diff expected actual++          withFailColor $ write (indentation ++ "expected: ")+          forM_ chunks $ \chunk -> case chunk of+            Both a _ -> indented write a+            First a -> indented extraChunk a+            Second _ -> return ()+          writeLine ""++          withFailColor $ write (indentation ++ " but got: ")+          forM_ chunks $ \chunk -> case chunk of+            Both a _ -> indented write a+            First _ -> return ()+            Second a -> indented missingChunk a+          writeLine ""+          where+            indented output text = case break (== '\n') text of+              (xs, "") -> output xs+              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys       where-        err = either (("uncaught exception: " ++) . formatException) id reason+        indentation = "       "+        indent message = do+          forM_ (lines message) $ \line -> do+            writeLine (indentation ++ line)         formatLoc (Location file line _column accuracy) = "  " ++ file ++ ":" ++ show line ++ ":" ++ message           where             message = case accuracy of@@ -204,19 +237,19 @@ defaultFooter = do    writeLine =<< (++)-    <$> (printf "Finished in %1.4f seconds"-    <$> getRealTime) <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime)+    <$> (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 ""+  let+    output =+         pluralize total   "example"+      ++ ", " ++ pluralize fails "failure"+      ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"+    c | fails /= 0   = withFailColor+      | pending /= 0 = withPendingColor+      | otherwise    = withSuccessColor+  c $ writeLine output

@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.Formatters.Diff (+  Diff (..)+, diff+#ifdef TEST+, partition+, breakList+#endif+) where++import           Data.Char+import           Data.Algorithm.Diff++diff :: String -> String -> [Diff String]+diff expected actual = map (fmap concat) $ getGroupedDiff (partition expected) (partition actual)++partition :: String -> [String]+partition = mergeBackslashes . breakList isAlphaNum+  where+    mergeBackslashes xs = case xs of+      ['\\'] : (y : ys) : zs -> ['\\', y] : ys : mergeBackslashes zs+      z : zs -> z : mergeBackslashes zs+      [] -> []++breakList :: (a -> Bool) -> [a] -> [[a]]+breakList _ [] = []+breakList p xs = case break p xs of+  (y, ys) -> map return y ++ case span p ys of+    (z, zs) -> z `cons` breakList p zs+  where+    cons x+      | null x = id+      | otherwise = (x :)

@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveFunctor #-}+module Test.Hspec.Core.Formatters.Free where++import           Prelude ()+import           Test.Hspec.Core.Compat++data Free f a = Free (f (Free f a)) | Pure a+  deriving Functor++instance Functor f => Applicative (Free f) where+  pure = Pure+  Pure f <*> Pure a = Pure (f a)+  Pure f <*> Free m = Free (fmap f <$> m)+  Free m <*> b = Free (fmap (<*> b) m)++instance Functor f => Monad (Free f) where+  return = pure+  Pure a >>= f = f a+  Free m >>= f = Free (fmap (>>= f) m)++liftF :: Functor f => f a -> Free f a+liftF command = Free (fmap Pure command)

@@ -1,33 +1,8 @@ {-# 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+  FormatM , runFormatM+, interpret , increaseSuccessCount , increasePendingCount , increaseFailCount@@ -36,7 +11,7 @@ ) where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat  import qualified System.IO as IO import           System.IO (Handle)@@ -49,8 +24,31 @@ import           Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)  import           Test.Hspec.Core.Util (Path)-import           Test.Hspec.Core.Spec (Progress, Location)+import           Test.Hspec.Core.Spec (Location)+import           Test.Hspec.Core.Example (FailureReason(..)) +import qualified Test.Hspec.Core.Formatters.Monad as M+import           Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..))++interpret :: M.FormatM a -> FormatM a+interpret = interpretWith Environment {+  environmentGetSuccessCount = getSuccessCount+, environmentGetPendingCount = getPendingCount+, environmentGetFailCount = getFailCount+, environmentGetFailMessages = getFailMessages+, environmentUsedSeed = usedSeed+, environmentGetCPUTime = getCPUTime+, environmentGetRealTime = getRealTime+, environmentWrite = write+, environmentWithFailColor = withFailColor+, environmentWithSuccessColor = withSuccessColor+, environmentWithPendingColor = withPendingColor+, environmentWithInfoColor = withInfoColor+, environmentExtraChunk = extraChunk+, environmentMissingChunk = missingChunk+, environmentLiftIO = liftIO+}+ -- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a gets f = FormatM $ do@@ -64,6 +62,7 @@ data FormatterState = FormatterState {   stateHandle     :: Handle , stateUseColor   :: Bool+, stateUseDiff    :: Bool , produceHTML     :: Bool , successCount    :: Int , pendingCount    :: Int@@ -78,20 +77,16 @@ 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+runFormatM :: Bool -> Bool -> Bool -> Bool -> Integer -> Handle -> FormatM a -> IO a+runFormatM useColor useDiff produceHTML_ printCpuTime seed handle (FormatM action) = do   time <- getPOSIXTime   cpuTime <- if printCpuTime then Just <$> CPUTime.getCPUTime else pure Nothing-  st <- newIORef (FormatterState handle useColor produceHTML_ 0 0 0 [] seed cpuTime time)+  st <- newIORef (FormatterState handle useColor useDiff produceHTML_ 0 0 0 [] seed cpuTime time)   evalStateT action st  -- | Increase the counter for successful examples@@ -118,74 +113,20 @@ 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 :: Maybe Location -> Path -> Either SomeException FailureReason -> FormatM () addFailMessage loc p m = modify $ \s -> s {failMessages = FailureRecord loc p m : failMessages s}  -- | Get the list of accumulated failure messages. getFailMessages :: FormatM [FailureRecord] getFailMessages = reverse `fmap` gets failMessages -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@@ -231,6 +172,22 @@        -- run action       (runStateT action st)++-- | Output given chunk in red.+extraChunk :: String -> FormatM ()+extraChunk s = do+  useDiff <- gets stateUseDiff+  case useDiff of+    True -> withFailColor $ write s+    False -> write s++-- | Output given chunk in green.+missingChunk :: String -> FormatM ()+missingChunk s = do+  useDiff <- gets stateUseDiff+  case useDiff of+    True -> withSuccessColor $ write s+    False -> write s  -- | -- @finally_ actionA actionB@ runs @actionA@ and then @actionB@.  @actionB@ is

@@ -0,0 +1,237 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+module Test.Hspec.Core.Formatters.Monad (+  Formatter (..)+, FailureReason (..)+, FormatM++, getSuccessCount+, getPendingCount+, getFailCount+, getTotalCount++, FailureRecord (..)+, getFailMessages+, usedSeed++, getCPUTime+, getRealTime++, write+, writeLine++, withInfoColor+, withSuccessColor+, withPendingColor+, withFailColor++, extraChunk+, missingChunk++, Environment(..)+, interpretWith+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           System.IO (Handle)+import           Control.Exception+import           Control.Monad.IO.Class++import           Test.Hspec.Core.Formatters.Free++import           Test.Hspec.Core.Example (FailureReason(..))+import           Test.Hspec.Core.Util (Path)+import           Test.Hspec.Core.Spec (Progress, Location)++data Formatter = Formatter {++  headerFormatter :: FormatM ()++-- | evaluated before each test group+--+-- The given number indicates the position within the parent group.+, exampleGroupStarted :: [String] -> String -> FormatM ()++, exampleGroupDone    :: FormatM ()++-- | used to notify the progress of the currently evaluated example+--+-- /Note/: This is only called when interactive/color mode.+, exampleProgress     :: Handle -> Path -> Progress -> IO ()++-- | evaluated after each successful example+, exampleSucceeded    :: Path -> FormatM ()++-- | evaluated after each failed example+, exampleFailed       :: Path -> Either SomeException FailureReason -> FormatM ()++-- | evaluated after each pending example+, examplePending      :: Path -> Maybe String -> FormatM ()++-- | evaluated after a test run+, failedFormatter     :: FormatM ()++-- | evaluated after `failuresFormatter`+, footerFormatter     :: FormatM ()+}++data FailureRecord = FailureRecord {+  failureRecordLocation :: Maybe Location+, failureRecordPath     :: Path+, failureRecordMessage  :: Either SomeException FailureReason+}++data FormatF next =+    GetSuccessCount (Int -> next)+  | GetPendingCount (Int -> next)+  | GetFailCount (Int -> next)+  | GetFailMessages ([FailureRecord] -> next)+  | UsedSeed (Integer -> next)+  | GetCPUTime (Maybe Double -> next)+  | GetRealTime (Double -> next)+  | Write String next+  | forall a. WithFailColor (FormatM a) (a -> next)+  | forall a. WithSuccessColor (FormatM a) (a -> next)+  | forall a. WithPendingColor (FormatM a) (a -> next)+  | forall a. WithInfoColor (FormatM a) (a -> next)+  | ExtraChunk String next+  | MissingChunk String next+  | forall a. LiftIO (IO a) (a -> next)++instance Functor FormatF where -- deriving this instance would require GHC >= 7.10.1+  fmap f x = case x of+    GetSuccessCount next -> GetSuccessCount (fmap f next)+    GetPendingCount next -> GetPendingCount (fmap f next)+    GetFailCount next -> GetFailCount (fmap f next)+    GetFailMessages next -> GetFailMessages (fmap f next)+    UsedSeed next -> UsedSeed (fmap f next)+    GetCPUTime next -> GetCPUTime (fmap f next)+    GetRealTime next -> GetRealTime (fmap f next)+    Write s next -> Write s (f next)+    WithFailColor action next -> WithFailColor action (fmap f next)+    WithSuccessColor action next -> WithSuccessColor action (fmap f next)+    WithPendingColor action next -> WithPendingColor action (fmap f next)+    WithInfoColor action next -> WithInfoColor action (fmap f next)+    ExtraChunk s next -> ExtraChunk s (f next)+    MissingChunk s next -> MissingChunk s (f next)+    LiftIO action next -> LiftIO action (fmap f next)++type FormatM = Free FormatF++instance MonadIO FormatM where+  liftIO s = liftF (LiftIO s id)++data Environment m = Environment {+  environmentGetSuccessCount :: m Int+, environmentGetPendingCount :: m Int+, environmentGetFailCount :: m Int+, environmentGetFailMessages :: m [FailureRecord]+, environmentUsedSeed :: m Integer+, environmentGetCPUTime :: m (Maybe Double)+, environmentGetRealTime :: m Double+, environmentWrite :: String -> m ()+, environmentWithFailColor :: forall a. m a -> m a+, environmentWithSuccessColor :: forall a. m a -> m a+, environmentWithPendingColor :: forall a. m a -> m a+, environmentWithInfoColor :: forall a. m a -> m a+, environmentExtraChunk :: String -> m ()+, environmentMissingChunk :: String -> m ()+, environmentLiftIO :: forall a. IO a -> m a+}++interpretWith :: forall m a. Monad m => Environment m -> FormatM a -> m a+interpretWith Environment{..} = go+  where+    go :: forall b. FormatM b -> m b+    go m = case m of+      Pure value -> return value+      Free action -> case action of+        GetSuccessCount next -> environmentGetSuccessCount >>= go . next+        GetPendingCount next -> environmentGetPendingCount >>= go . next+        GetFailCount next -> environmentGetFailCount >>= go . next+        GetFailMessages next -> environmentGetFailMessages >>= go . next+        UsedSeed next -> environmentUsedSeed >>= go . next+        GetCPUTime next -> environmentGetCPUTime >>= go . next+        GetRealTime next -> environmentGetRealTime >>= go . next+        Write s next -> environmentWrite s >> go next+        WithFailColor inner next -> environmentWithFailColor (go inner) >>= go . next+        WithSuccessColor inner next -> environmentWithSuccessColor (go inner) >>= go . next+        WithPendingColor inner next -> environmentWithPendingColor (go inner) >>= go . next+        WithInfoColor inner next -> environmentWithInfoColor (go inner) >>= go . next+        ExtraChunk s next -> environmentExtraChunk s >> go next+        MissingChunk s next -> environmentMissingChunk s >> go next+        LiftIO inner next -> environmentLiftIO inner >>= go . next++-- | Get the number of successful examples encountered so far.+getSuccessCount :: FormatM Int+getSuccessCount = liftF (GetSuccessCount id)++-- | Get the number of pending examples encountered so far.+getPendingCount :: FormatM Int+getPendingCount = liftF (GetPendingCount id)++-- | Get the number of failed examples encountered so far.+getFailCount :: FormatM Int+getFailCount = liftF (GetFailCount id)++-- | Get the total number of examples encountered so far.+getTotalCount :: FormatM Int+getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount]++-- | Get the list of accumulated failure messages.+getFailMessages :: FormatM [FailureRecord]+getFailMessages = liftF (GetFailMessages id)++-- | The random seed that is used for QuickCheck.+usedSeed :: FormatM Integer+usedSeed = liftF (UsedSeed id)++-- | Get the used CPU time since the test run has been started.+getCPUTime :: FormatM (Maybe Double)+getCPUTime = liftF (GetCPUTime id)++-- | Get the passed real time since the test run has been started.+getRealTime :: FormatM Double+getRealTime = liftF (GetRealTime id)++-- | Append some output to the report.+write :: String -> FormatM ()+write s = liftF (Write s ())++-- | The same as `write`, but adds a newline character.+writeLine :: String -> FormatM ()+writeLine s = write s >> write "\n"++-- | Set output color to red, run given action, and finally restore the default+-- color.+withFailColor :: FormatM a -> FormatM a+withFailColor s = liftF (WithFailColor s id)++-- | Set output color to green, run given action, and finally restore the+-- default color.+withSuccessColor :: FormatM a -> FormatM a+withSuccessColor s = liftF (WithSuccessColor s id)++-- | Set output color to yellow, run given action, and finally restore the+-- default color.+withPendingColor :: FormatM a -> FormatM a+withPendingColor s = liftF (WithPendingColor s id)++-- | Set output color to cyan, run given action, and finally restore the+-- default color.+withInfoColor :: FormatM a -> FormatM a+withInfoColor s = liftF (WithInfoColor s id)++-- | Output given chunk in red.+extraChunk :: String -> FormatM ()+extraChunk s = liftF (ExtraChunk s ())++-- | Output given chunk in green.+missingChunk :: String -> FormatM ()+missingChunk s = liftF (MissingChunk s ())

@@ -14,10 +14,12 @@ , aroundWith ) where -import           Control.Exception (finally)+import           Control.Exception (SomeException, finally, throwIO, try) import           Control.Concurrent.MVar -import           Test.Hspec.Core.Spec+import           Test.Hspec.Core.Example+import           Test.Hspec.Core.Tree+import           Test.Hspec.Core.Spec.Monad  -- | Run a custom action before every spec item. before :: IO a -> SpecWith a -> Spec@@ -34,22 +36,30 @@ -- | Run a custom action before the first spec item. beforeAll :: IO a -> SpecWith a -> Spec beforeAll action spec = do-  mvar <- runIO (newMVar Nothing)+  mvar <- runIO (newMVar Empty)   before (memoize mvar action) spec  -- | Run a custom action before the first spec item. beforeAll_ :: IO () -> SpecWith a -> SpecWith a beforeAll_ action spec = do-  mvar <- runIO (newMVar Nothing)+  mvar <- runIO (newMVar Empty)   before_ (memoize mvar 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)+data Memoized a =+    Empty+  | Memoized a+  | Failed SomeException +memoize :: MVar (Memoized a) -> IO a -> IO a+memoize mvar action = do+  result <- modifyMVar mvar $ \ma -> case ma of+    Empty -> do+      a <- try action+      return (either Failed Memoized a, a)+    Memoized a -> return (ma, Right a)+    Failed _ -> throwIO (Pending (Just "exception in beforeAll-hook (see previous failure)"))+  either throwIO return result+ -- | Run a custom action after every spec item. after :: ActionWith a -> SpecWith a -> SpecWith a after action = aroundWith $ \e x -> e x `finally` action x@@ -76,10 +86,8 @@  -- | 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}+aroundWith action = mapSpecItem action (modifyAroundAction action) -untangle  :: ((ActionWith b -> IO ()) -> ActionWith a -> IO ()) -> ActionWith a -> ActionWith b-untangle f g = \b -> f ($ b) g+modifyAroundAction :: (ActionWith a -> ActionWith b) -> Item a -> Item b+modifyAroundAction action item@Item{itemExample = e} =+  item{ itemExample = \params aroundAction -> e params (aroundAction . action) }

@@ -0,0 +1,261 @@+module Test.Hspec.Core.Options (+  Config(..)+, ColorMode (..)+, defaultConfig+, filterOr+, parseOptions+, ConfigFile+, ignoreConfigFile+) where++import           Prelude ()+import           Control.Monad+import           Test.Hspec.Core.Compat++import           System.IO+import           System.Exit+import           System.Console.GetOpt++import           Test.Hspec.Core.Formatters+import           Test.Hspec.Core.Util+import           Test.Hspec.Core.Example (Params(..), defaultParams)+import           Data.Functor.Identity++type ConfigFile = (FilePath, [String])++data Config = Config {+  configIgnoreConfigFile :: Bool+, configDryRun :: Bool+, configPrintCpuTime :: Bool+, configFastFail :: Bool+, configRerun :: Bool+, configRerunAllOnSuccess :: Bool++-- |+-- A predicate that is used to filter the spec before it is run.  Only examples+-- that satisfy the predicate are run.+, configFilterPredicate :: Maybe (Path -> Bool)+, configSkipPredicate :: Maybe (Path -> Bool)+, configQuickCheckSeed :: Maybe Integer+, configQuickCheckMaxSuccess :: Maybe Int+, configQuickCheckMaxDiscardRatio :: Maybe Int+, configQuickCheckMaxSize :: Maybe Int+, configSmallCheckDepth :: Int+, configColorMode :: ColorMode+, configDiff :: Bool+, configFormatter :: Maybe Formatter+, configHtmlOutput :: Bool+, configOutputFile :: Either Handle FilePath+, configConcurrentJobs :: Maybe Int+}++defaultConfig :: Config+defaultConfig = Config {+  configIgnoreConfigFile = False+, configDryRun = False+, configPrintCpuTime = False+, configFastFail = False+, configRerun = False+, configRerunAllOnSuccess = False+, configFilterPredicate = Nothing+, configSkipPredicate = Nothing+, configQuickCheckSeed = Nothing+, configQuickCheckMaxSuccess = Nothing+, configQuickCheckMaxDiscardRatio = Nothing+, configQuickCheckMaxSize = Nothing+, configSmallCheckDepth = paramsSmallCheckDepth defaultParams+, configColorMode = ColorAuto+, configDiff = False+, configFormatter = Nothing+, configHtmlOutput = False+, configOutputFile = Left stdout+, configConcurrentJobs = Nothing+}++filterOr :: Maybe (Path -> Bool) -> Maybe (Path -> Bool) -> Maybe (Path -> Bool)+filterOr p1_ p2_ = case (p1_, p2_) of+  (Just p1, Just p2) -> Just $ \path -> p1 path || p2 path+  _ -> p1_ <|> p2_++addMatch :: String -> Config -> Config+addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c}++addSkip :: String -> Config -> Config+addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c}++setDepth :: Int -> Config -> Config+setDepth n c = c {configSmallCheckDepth = n}++setMaxSuccess :: Int -> Config -> Config+setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n}++setMaxSize :: Int -> Config -> Config+setMaxSize n c = c {configQuickCheckMaxSize = Just n}++setMaxDiscardRatio :: Int -> Config -> Config+setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n}++setSeed :: Integer -> Config -> Config+setSeed n c = c {configQuickCheckSeed = Just n}++data ColorMode = ColorAuto | ColorNever | ColorAlways+  deriving (Eq, Show)++formatters :: [(String, Formatter)]+formatters = [+    ("specdoc", specdoc)+  , ("progress", progress)+  , ("failed-examples", failed_examples)+  , ("silent", silent)+  ]++formatHelp :: String+formatHelp = unlines (addLineBreaks "use a custom formatter; this can be one of:" ++ map (("   " ++) . fst) formatters)++type Result m = Either InvalidArgument (m Config)++data InvalidArgument = InvalidArgument String String++data Arg a = Arg {+  _argumentName   :: String+, _argumentParser :: String -> Maybe a+, _argumentSetter :: a -> Config -> Config+}++mkOption :: Monad m => [Char] -> String -> Arg a -> String -> OptDescr (Result m -> Result m)+mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help+  where+    arg input x = x >>= \c -> case parser input of+      Just n -> Right (setter n `liftM` c)+      Nothing -> Left (InvalidArgument name input)++addLineBreaks :: String -> [String]+addLineBreaks = lineBreaksAt 40++h :: String -> String+h = unlines . addLineBreaks++commandLineOptions :: [OptDescr (Result Maybe -> Result Maybe)]+commandLineOptions = [+    Option   []  ["help"]             (NoArg (const $ Right Nothing))     (h "display this help and exit")+  , Option   []  ["ignore-dot-hspec"] (NoArg setIgnoreConfigFile)         (h "do not read options from ~/.hspec and .hspec")+  , mkOption "m"  "match"             (Arg "PATTERN" return addMatch)     (h "only run examples that match given PATTERN")+  , mkOption []   "skip"              (Arg "PATTERN" return addSkip)      (h "skip examples that match given PATTERN")+  ]+  where+    setIgnoreConfigFile = set $ \config -> config {configIgnoreConfigFile = True}++configFileOptions :: Monad m => [OptDescr (Result m -> Result m)]+configFileOptions = [+    Option   []  ["color"]            (NoArg setColor)                    (h "colorize the output")+  , Option   []  ["no-color"]         (NoArg setNoColor)                  (h "do not colorize the output")+  , Option   []  ["diff"]             (NoArg setDiff)                     (h "show colorized diffs")+  , Option   []  ["no-diff"]          (NoArg setNoDiff)                   (h "do not show colorized diffs")+  , mkOption "f"  "format"            (Arg "FORMATTER" readFormatter setFormatter) formatHelp+  , mkOption "o"  "out"               (Arg "FILE" return setOutputFile)   (h "write output to a file instead of STDOUT")+  , mkOption []   "depth"             (Arg "N" readMaybe setDepth)        (h "maximum depth of generated test values for SmallCheck properties")+  , mkOption "a"  "qc-max-success"    (Arg "N" readMaybe setMaxSuccess)   (h "maximum number of successful tests before a QuickCheck property succeeds")+  , mkOption ""   "qc-max-size"       (Arg "N" readMaybe setMaxSize)      (h "size to use for the biggest test cases")+  , mkOption ""   "qc-max-discard"    (Arg "N" readMaybe setMaxDiscardRatio) (h "maximum number of discarded tests per successful test before giving up")+  , mkOption []   "seed"              (Arg "N" readMaybe setSeed)         (h "used seed for QuickCheck properties")+  , Option   []  ["print-cpu-time"]   (NoArg setPrintCpuTime)             (h "include used CPU time in summary")+  , Option   []  ["dry-run"]          (NoArg setDryRun)                   (h "pretend that everything passed; don't verify anything")+  , Option   []  ["fail-fast"]        (NoArg setFastFail)                 (h "abort on first failure")+  , Option   "r" ["rerun"]            (NoArg  setRerun)                   (h "rerun all examples that failed in the previous test run (only works in GHCi)")+  , Option   []  ["rerun-all-on-success"] (NoArg setRerunAllOnSuccess)    (h "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)")+  , mkOption "j"  "jobs"              (Arg "N" readMaxJobs setMaxJobs)    (h "run at most N parallelizable tests simultaneously (default: number of available processors)")+  ]+  where+    readFormatter :: String -> Maybe Formatter+    readFormatter = (`lookup` formatters)++    readMaxJobs :: String -> Maybe Int+    readMaxJobs s = do+      n <- readMaybe s+      guard $ n > 0+      return n++    setFormatter :: Formatter -> Config -> Config+    setFormatter f c = c {configFormatter = Just f}++    setOutputFile :: String -> Config -> Config+    setOutputFile file c = c {configOutputFile = Right file}++    setMaxJobs :: Int -> Config -> Config+    setMaxJobs n c = c {configConcurrentJobs = Just n}++    setPrintCpuTime = set $ \config -> config {configPrintCpuTime = True}+    setDryRun       = set $ \config -> config {configDryRun = True}+    setFastFail     = set $ \config -> config {configFastFail = True}+    setRerun        = set $ \config -> config {configRerun = True}+    setRerunAllOnSuccess = set $ \config -> config {configRerunAllOnSuccess = True}+    setColor        = set $ \config -> config {configColorMode = ColorAlways}+    setNoColor      = set $ \config -> config {configColorMode = ColorNever}+    setDiff         = set $ \config -> config {configDiff = True}+    setNoDiff       = set $ \config -> config {configDiff = False}++set :: Monad m => (Config -> Config) -> Either a (m Config) -> Either a (m Config)+set = liftM . liftM++documentedOptions :: [OptDescr (Result Maybe -> Result Maybe)]+documentedOptions = commandLineOptions ++ configFileOptions++undocumentedOptions :: [OptDescr (Result Maybe -> Result Maybe)]+undocumentedOptions = [+    -- for compatibility with test-framework+    mkOption [] "maximum-generated-tests" (Arg "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default"++    -- undocumented for now, as we probably want to change this to produce a+    -- standalone HTML report in the future+  , Option []  ["html"]                    (NoArg setHtml)                    "produce HTML output"++    -- now a noop+  , Option "v" ["verbose"]                 (NoArg id)                         "do not suppress output to stdout when evaluating examples"+  ]+  where+    setHtml :: Result Maybe -> Result Maybe+    setHtml = set $ \config -> config {configHtmlOutput = True}++recognizedOptions :: [OptDescr (Result Maybe -> Result Maybe)]+recognizedOptions = documentedOptions ++ undocumentedOptions++parseOptions :: Config -> String -> [ConfigFile] -> [String] -> Either (ExitCode, String) Config+parseOptions config prog configFiles args = do+  foldM (parseFileOptions prog) config configFiles >>= parseCommandLineOptions prog args++parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config+parseCommandLineOptions prog args config = case parse recognizedOptions config args of+  Right Nothing -> Left (ExitSuccess, usageInfo ("Usage: " ++ prog ++ " [OPTION]...\n\nOPTIONS") documentedOptions)+  Right (Just c) -> Right c+  Left err -> failure err+  where+    failure err = Left (ExitFailure 1, prog ++ ": " ++ err ++ "\nTry `" ++ prog ++ " --help' for more information.\n")++parseFileOptions :: String -> Config -> ConfigFile -> Either (ExitCode, String) Config+parseFileOptions prog config (name, args) = case parse configFileOptions config args of+  Right (Identity c) -> Right c+  Left err -> failure err+  where+    failure err = Left (ExitFailure 1, prog ++ ": " ++ message)+      where+        message = unlines $ case lines err of+          [x] -> [x ++ " " ++ inFile]+          xs -> xs ++ [inFile]+        inFile = "in config file " ++ name++parse :: Monad m => [OptDescr (Result m -> Result m)] -> Config -> [String] -> Either String (m Config)+parse options config args = case getOpt Permute options args of+  (opts, [], []) -> case foldl' (flip id) (Right $ return config) opts of+    Left (InvalidArgument flag value) -> Left ("invalid argument `" ++ value ++ "' for `--" ++ flag ++ "'")+    Right x -> Right x+  (_, _, err:_) -> Left (init err)+  (_, arg:_, _) -> Left ("unexpected argument `" ++ arg ++ "'")++ignoreConfigFile :: Config -> [String] -> IO Bool+ignoreConfigFile config args = do+  ignore <- lookupEnv "IGNORE_DOT_HSPEC"+  case ignore of+    Just _ -> return True+    Nothing -> case parse recognizedOptions config args of+      Right (Just c) -> return (configIgnoreConfigFile c)+      _ -> return False

@@ -2,7 +2,7 @@ module Test.Hspec.Core.QuickCheckUtil where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat  import           Data.Int import           Test.QuickCheck hiding (Result(..))

@@ -21,10 +21,14 @@ , Path , defaultConfig , configAddFilter++#ifdef TEST+, rerunAll+#endif ) where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat  import           Control.Monad import           Data.Maybe@@ -40,10 +44,11 @@  import           Test.Hspec.Core.Util (Path) import           Test.Hspec.Core.Spec-import           Test.Hspec.Config+import           Test.Hspec.Core.Config import           Test.Hspec.Core.Formatters import           Test.Hspec.Core.Formatters.Internal-import           Test.Hspec.FailureReport+import qualified Test.Hspec.Core.Formatters.Internal as Formatter+import           Test.Hspec.Core.FailureReport import           Test.Hspec.Core.QuickCheckUtil  import           Test.Hspec.Core.Runner.Eval@@ -78,7 +83,7 @@   | otherwise = id   where     markSuccess :: Item () -> Item ()-    markSuccess item = item {itemExample = evaluateExample Success}+    markSuccess item = item {itemExample = safeEvaluateExample Success}      removeCleanup :: SpecTree () -> SpecTree ()     removeCleanup spec = case spec of@@ -105,8 +110,11 @@ hspecWith :: Config -> Spec -> IO () hspecWith conf spec = do   r <- hspecWithResult conf spec-  unless (summaryFailures r == 0) exitFailure+  unless (isSuccess r) exitFailure +isSuccess :: Summary -> Bool+isSuccess summary = summaryFailures summary == 0+ -- | Run given spec and returns a summary of the test run. -- -- /Note/: `hspecResult` does not exit with `exitFailure` on failing spec@@ -121,57 +129,93 @@ -- items.  If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary-hspecWithResult conf spec = do+hspecWithResult config 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+  (oldFailureReport, c_) <- getConfig config prog args+  c <- ensureSeed c_+  if configRerunAllOnSuccess c+    -- With --rerun-all we may run the spec twice. For that reason GHC can not+    -- optimize away the spec tree. That means that the whole spec tree has to+    -- be constructed in memory and we loose constant space behavior.+    --+    -- By separating between rerunAllMode and normalMode here, we retain+    -- constant space behavior in normalMode.+    --+    -- see: https://github.com/hspec/hspec/issues/169+    then rerunAllMode c oldFailureReport+    else normalMode c+  where+    normalMode c = runSpec c spec+    rerunAllMode c oldFailureReport = do+      summary <- runSpec c spec+      if rerunAll c oldFailureReport summary+        then hspecWithResult config spec+        else return summary -    jobsSem <- newQSem =<< case configConcurrentJobs c of+runSpec :: Config -> Spec -> IO Summary+runSpec config spec = do+  doNotLeakCommandLineArgumentsToExamples $ withHandle config $ \h -> do+    let formatter = fromMaybe specdoc (configFormatter config)+        seed = (fromJust . configQuickCheckSeed) config+        qcArgs = configQuickCheckArgs config++    jobsSem <- newQSem =<< case configConcurrentJobs config of       Nothing -> getDefaultConcurrentJobs       Just maxJobs -> return maxJobs -    useColor <- doesUseColor h c+    useColor <- doesUseColor h config -    filteredSpec <- filterSpecs c . applyDryRun c <$> runSpecM spec+    filteredSpec <- filterSpecs config . applyDryRun config <$> runSpecM spec      withHiddenCursor useColor h $-      runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) seed h $ do-        runFormatter jobsSem useColor h c formatter filteredSpec `finally_` do-          failedFormatter formatter+      runFormatM useColor (configDiff config) (configHtmlOutput config) (configPrintCpuTime config) seed h $ do+        runFormatter jobsSem useColor h config formatter filteredSpec `finally_` do+          Formatter.interpret $ failedFormatter formatter -        footerFormatter formatter+        Formatter.interpret $ 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-          }+        xs <- map failureRecordPath <$> Formatter.interpret getFailMessages+        liftIO $ dumpFailureReport seed qcArgs xs -        Summary <$> getTotalCount <*> getFailCount-  where-    withHiddenCursor :: Bool -> Handle -> IO a -> IO a-    withHiddenCursor useColor h-      | useColor  = E.bracket_ (hHideCursor h) (hShowCursor h)-      | otherwise = id+        Summary <$> Formatter.interpret getTotalCount <*> Formatter.interpret getFailCount -    doesUseColor :: Handle -> Config -> IO Bool-    doesUseColor h c = case configColorMode c of-      ColorAuto  -> (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb)-      ColorNever -> return False-      ColorAlways -> return True+dumpFailureReport :: Integer -> QC.Args -> [Path] -> IO ()+dumpFailureReport seed qcArgs xs = do+  writeFailureReport FailureReport {+      failureReportSeed = seed+    , failureReportMaxSuccess = QC.maxSuccess qcArgs+    , failureReportMaxSize = QC.maxSize qcArgs+    , failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs+    , failureReportPaths = xs+    } -    withHandle :: Config -> (Handle -> IO a) -> IO a-    withHandle c action = case configOutputFile c of-      Left h -> action h-      Right path -> withFile path WriteMode action+doNotLeakCommandLineArgumentsToExamples :: IO a -> IO a+doNotLeakCommandLineArgumentsToExamples = withArgs []++withHiddenCursor :: Bool -> Handle -> IO a -> IO a+withHiddenCursor useColor h+  | useColor  = E.bracket_ (hHideCursor h) (hShowCursor h)+  | otherwise = id++doesUseColor :: Handle -> Config -> IO Bool+doesUseColor h c = case configColorMode c of+  ColorAuto  -> (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb)+  ColorNever -> return False+  ColorAlways -> return True++withHandle :: Config -> (Handle -> IO a) -> IO a+withHandle c action = case configOutputFile c of+  Left h -> action h+  Right path -> withFile path WriteMode action++rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool+rerunAll _ Nothing _ = False+rerunAll config (Just oldFailureReport) summary =+     configRerunAllOnSuccess config+  && configRerun config+  && isSuccess summary+  && (not . null) (failureReportPaths oldFailureReport)  isDumb :: IO Bool isDumb = maybe False (== "dumb") <$> lookupEnv "TERM"

@@ -8,7 +8,7 @@ module Test.Hspec.Core.Runner.Eval (runFormatter) where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat  import           Control.Monad (unless, when) import qualified Control.Exception as E@@ -16,22 +16,22 @@ 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.Config+import           Test.Hspec.Core.Formatters hiding (FormatM) import           Test.Hspec.Core.Formatters.Internal-import           Test.Hspec.Timer+import qualified Test.Hspec.Core.Formatters.Internal as Formatter+import           Test.Hspec.Core.Timer  type EvalTree = Tree (ActionWith ()) (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ()))  -- | Evaluate all examples of a given spec and produce a report. runFormatter :: QSem -> Bool -> Handle -> Config -> Formatter -> [SpecTree ()] -> FormatM () runFormatter jobsSem useColor h c formatter specs = do-  headerFormatter formatter+  Formatter.interpret $ headerFormatter formatter   chan <- liftIO newChan   reportProgress <- liftIO mkReportProgress   run chan reportProgress c formatter (toEvalTree specs)@@ -60,24 +60,24 @@  type FormatResult = Either E.SomeException Result -> FormatM () -parallelize :: QSem -> Bool -> (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ())+parallelize :: QSem -> Bool -> (ProgressCallback -> IO (Either E.SomeException Result)) -> ProgressCallback -> FormatResult -> IO (FormatM ()) parallelize jobsSem isParallelizable e   | isParallelizable = runParallel jobsSem e   | otherwise = runSequentially e -runSequentially :: (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ())+runSequentially :: (ProgressCallback -> IO (Either E.SomeException Result)) -> ProgressCallback -> FormatResult -> IO (FormatM ()) runSequentially e reportProgress formatResult = return $ do-  result <- liftIO $ evalExample (e reportProgress)+  result <- liftIO $ e reportProgress   formatResult result  data Report = ReportProgress Progress | ReportResult (Either E.SomeException Result) -runParallel :: QSem -> (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ())+runParallel :: QSem -> (ProgressCallback -> IO (Either E.SomeException Result)) -> ProgressCallback -> FormatResult -> IO (FormatM ()) runParallel jobsSem e reportProgress formatResult = do   mvar <- newEmptyMVar   _ <- forkIO $ E.bracket_ (waitQSem jobsSem) (signalQSem jobsSem) $ do     let progressCallback = replaceMVar mvar . ReportProgress-    result <- evalExample (e progressCallback)+    result <- e progressCallback     replaceMVar mvar (ReportResult result)   return $ evalReport mvar   where@@ -93,15 +93,6 @@     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 ()@@ -121,9 +112,9 @@      queueSpec :: [String] -> EvalTree -> IO ()     queueSpec rGroups (Node group xs) = do-      defer (exampleGroupStarted formatter (reverse rGroups) group)+      defer (Formatter.interpret $ exampleGroupStarted formatter (reverse rGroups) group)       forM_ xs (queueSpec (group : rGroups))-      defer (exampleGroupDone formatter)+      defer (Formatter.interpret $ exampleGroupDone formatter)     queueSpec rGroups (NodeWithCleanup action xs) = do       forM_ xs (queueSpec rGroups)       defer (runCleanup (action ()) (reverse rGroups, "afterAll-hook"))@@ -138,22 +129,22 @@          reportProgress = reportProgress_ path -        formatResult :: Either E.SomeException Result -> FormatM ()+        formatResult :: FormatResult         formatResult result = do           case result of             Right Success -> do               increaseSuccessCount-              exampleSucceeded formatter path+              Formatter.interpret $ exampleSucceeded formatter path             Right (Pending reason) -> do               increasePendingCount-              examplePending formatter path reason-            Right (Fail loc_ err) -> failed (loc_ <|> loc) path (Right err)+              Formatter.interpret $ examplePending formatter path reason+            Right (Failure loc_ err) -> failed (loc_ <|> loc) path (Right err)             Left err         -> failed loc path (Left  err)      failed loc path err = do       increaseFailCount       addFailMessage loc path err-      exampleFailed formatter path err+      Formatter.interpret $ exampleFailed formatter path err  processMessages :: IO Message -> Bool -> FormatM () processMessages getMessage fastFail = go@@ -161,6 +152,6 @@     go = liftIO getMessage >>= \m -> case m of       Run action -> do         action-        fails <- getFailCount+        fails <- Formatter.interpret getFailCount         unless (fastFail && fails /= 0) go       Done -> return ()

@@ -8,10 +8,16 @@ module Test.Hspec.Core.Spec (  -- * Defining a spec-  describe-, it+  it+, specify+, describe+, context , pending , pendingWith+, xit+, xspecify+, xdescribe+, xcontext , parallel  -- * The @SpecM@ monad@@ -30,6 +36,7 @@ import           Test.Hspec.Expectations (Expectation)  import           Test.Hspec.Core.Example+import           Test.Hspec.Core.Hooks import           Test.Hspec.Core.Tree import           Test.Hspec.Core.Spec.Monad @@ -37,6 +44,21 @@ describe :: String -> SpecWith a -> SpecWith a describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . specGroup label +-- | @context@ is an alias for `describe`.+context :: String -> SpecWith a -> SpecWith a+context = describe++-- |+-- Changing `describe` to `xdescribe` marks all spec items of the corresponding subtree as pending.+--+-- This can be used to temporarily disable spec items.+xdescribe :: String -> SpecWith a -> SpecWith a+xdescribe label spec = before_ pending $ describe label spec++-- | @xcontext@ is an alias for `xdescribe`.+xcontext :: String -> SpecWith a -> SpecWith a+xcontext = xdescribe+ -- | The @it@ function creates a spec item. -- -- A spec item consists of:@@ -51,12 +73,27 @@ it :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it label action = fromSpecList [specItem label action] +-- | @specify@ is an alias for `it`.+specify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)+specify = it++-- |+-- Changing `it` to `xit` marks the corresponding spec item as pending.+--+-- This can be used to temporarily disable a spec item.+xit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)+xit label action = before_ pending $ it label action++-- | @xspecify@ is an alias for `xit`.+xspecify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)+xspecify = xit+ -- | `parallel` marks all spec items of the given spec to be safe for parallel -- evaluation. parallel :: SpecWith a -> SpecWith a parallel = mapSpecItem_ $ \item -> item {itemIsParallelizable = True} --- | `pending` can be used to indicate that an example is /pending/.+-- | `pending` can be used to mark a spec item as pending. -- -- If you want to textually specify a behavior but do not have an example yet, -- use this:@@ -69,6 +106,6 @@  -- | -- `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.+-- argument that can be used to specify the reason for why the spec item is pending. pendingWith :: String -> Expectation pendingWith = E.throwIO . Pending . Just

@@ -14,7 +14,7 @@ ) where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat  import           Control.Monad.Trans.Writer import           Control.Monad.IO.Class (liftIO)

@@ -0,0 +1,14 @@+module Test.Hspec.Core.Timer where++import           Data.IORef+import           Data.Time.Clock.POSIX++newTimer :: POSIXTime -> IO (IO Bool)+newTimer delay = do+  ref <- getPOSIXTime >>= newIORef+  return $ do+    t0 <- readIORef ref+    t1 <- getPOSIXTime+    if delay < t1 - t0+      then writeIORef ref t1 >> return True+      else return False

@@ -15,9 +15,10 @@ ) where  import           Data.CallStack+import           Control.Exception  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat  import           Test.Hspec.Core.Example @@ -51,7 +52,7 @@   -- parallel with other spec items , itemIsParallelizable :: Bool   -- | Example for behavior-, itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result+, itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO (Either SomeException Result) }  -- | The @specGroup@ function combines a list of specs into a larger spec.@@ -64,7 +65,7 @@  -- | The @specItem@ function creates a spec item. specItem :: (HasCallStack, Example a) => String -> a -> SpecTree (Arg a)-specItem s e = Leaf $ Item requirement location False (evaluateExample e)+specItem s e = Leaf $ Item requirement location False (safeEvaluateExample e)   where     requirement       | null s = "(unspecified behavior)"

@@ -21,7 +21,7 @@ import           Control.Exception import           Control.Concurrent.Async -import           Test.Hspec.Compat (showType)+import           Test.Hspec.Core.Compat (showType)  -- | -- @pluralize count singular@ pluralizes the given @singular@ word unless given@@ -46,7 +46,7 @@ strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse  -- |--- ensure that lines are not longer then given `n`, insert line breaks at word+-- ensure that lines are not longer than given `n`, insert line breaks at word -- boundaries lineBreaksAt :: Int -> String -> [String] lineBreaksAt n input = case words input of@@ -129,4 +129,13 @@ -- 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+safeTry action = bracket runAction cancelAction waitForAction+  where+    runAction = async ((action >>= evaluate))+    waitForAction = waitCatch+    cancelAction a = do+      cancel a+      -- It is important to wait here to make sure all finalizers in action have+      -- been run. Otherwise the main thread can exit before they have finished+      -- and the finalizers are only partially run.+      waitCatch a -- We use waitCatch to hide the ThreadKilled exception

@@ -1,49 +0,0 @@-{-# LANGUAGE CPP #-}-module Test.Hspec.FailureReport (-  FailureReport (..)-, writeFailureReport-, readFailureReport-) where--#ifndef __GHCJS__-import           System.SetEnv-import           Test.Hspec.Core.Util (safeTry)-#endif-import           System.IO-import           Test.Hspec.Compat-import           Test.Hspec.Core.Util (Path)--data FailureReport = FailureReport {-  failureReportSeed :: Integer-, failureReportMaxSuccess :: Int-, failureReportMaxSize :: Int-, failureReportMaxDiscardRatio :: Int-, failureReportPaths :: [Path]-} deriving (Eq, Show, Read)--writeFailureReport :: FailureReport -> IO ()-#ifdef __GHCJS__-writeFailureReport _ = return ()-  -- ghcjs currently does not support setting environment variables-  -- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report-  -- into the environment is a non-essential feature we just disable this to be-  -- able to run hspec test-suites with ghcjs at all. Should be reverted once-  -- the issue is fixed.-#else-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 ++ ")")-#endif--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

@@ -1,198 +0,0 @@-module Test.Hspec.Options (-  Config(..)-, ColorMode (..)-, defaultConfig-, filterOr-, parseOptions-) where--import           Prelude ()-import           Control.Monad-import           Test.Hspec.Compat--import           System.IO-import           System.Exit-import           System.Console.GetOpt--import           Test.Hspec.Core.Formatters-import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Example (Params(..), defaultParams)--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)-, configSkipPredicate :: 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-, configConcurrentJobs :: Maybe Int-}--defaultConfig :: Config-defaultConfig = Config {-  configDryRun = False-, configPrintCpuTime = False-, configFastFail = False-, configRerun = False-, configFilterPredicate = Nothing-, configSkipPredicate = Nothing-, configQuickCheckSeed = Nothing-, configQuickCheckMaxSuccess = Nothing-, configQuickCheckMaxDiscardRatio = Nothing-, configQuickCheckMaxSize = Nothing-, configSmallCheckDepth = paramsSmallCheckDepth defaultParams-, configColorMode = ColorAuto-, configFormatter = Nothing-, configHtmlOutput = False-, configOutputFile = Left stdout-, configConcurrentJobs = Nothing-}--filterOr :: Maybe (Path -> Bool) -> Maybe (Path -> Bool) -> Maybe (Path -> Bool)-filterOr p1_ p2_ = case (p1_, p2_) of-  (Just p1, Just p2) -> Just $ \path -> p1 path || p2 path-  _ -> p1_ <|> p2_--addMatch :: String -> Config -> Config-addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c}--addSkip :: String -> Config -> Config-addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c}--setDepth :: Int -> Config -> Config-setDepth n c = c {configSmallCheckDepth = n}--setMaxSuccess :: Int -> Config -> Config-setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n}--setMaxSize :: Int -> Config -> Config-setMaxSize n c = c {configQuickCheckMaxSize = Just n}--setMaxDiscardRatio :: Int -> Config -> Config-setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n}--setSeed :: Integer -> Config -> Config-setSeed n c = c {configQuickCheckSeed = Just n}--data ColorMode = ColorAuto | ColorNever | ColorAlways-  deriving (Eq, Show)--formatters :: [(String, Formatter)]-formatters = [-    ("specdoc", specdoc)-  , ("progress", progress)-  , ("failed-examples", failed_examples)-  , ("silent", silent)-  ]--formatHelp :: String-formatHelp = unlines (addLineBreaks "use a custom formatter; this can be one of:" ++ map (("   " ++) . fst) formatters)--type Result = 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")-  , mkOption []   "skip"              (Arg "PATTERN" return addSkip)      (h "skip 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)")-  , mkOption "j"  "jobs"              (Arg "N" readMaxJobs setMaxJobs)    (h "run at most N parallelizable tests simultaneously (default: number of available processors)")-  ]-  where-    h = unlines . addLineBreaks--    readFormatter :: String -> Maybe Formatter-    readFormatter = (`lookup` formatters)--    readMaxJobs :: String -> Maybe Int-    readMaxJobs s = do-      n <- readMaybe s-      guard $ n > 0-      return n--    setFormatter :: Formatter -> Config -> Config-    setFormatter f c = c {configFormatter = Just f}--    setOutputFile :: String -> Config -> Config-    setOutputFile file c = c {configOutputFile = Right file}--    setMaxJobs :: Int -> Config -> Config-    setMaxJobs n c = c {configConcurrentJobs = Just n}--    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")

@@ -1,14 +0,0 @@-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

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-meta-discover -optF --module-name=All #-}

@@ -1,6 +1,6 @@ module Helper (   module Test.Hspec.Meta-, module Test.Hspec.Compat+, module Test.Hspec.Core.Compat , module Test.QuickCheck , module System.IO.Silently , sleep@@ -14,24 +14,31 @@ , ignoreUserInterrupt , throwException +, withEnvironment+, inTempDirectory+ , shouldUseArgs  , removeLocations ) where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat  import           Data.List import           Data.Char-import           Control.Monad-import           System.Environment (withArgs)+import           Control.Monad (guard)+import           System.Environment (withArgs, getEnvironment) import           System.Exit import           Control.Concurrent import qualified Control.Exception as E+import           Control.Exception (bracket) import qualified System.Timeout as System import           Data.Time.Clock.POSIX import           System.IO.Silently+import           System.SetEnv+import           System.Directory+import           System.IO.Temp  import           Test.Hspec.Meta import           Test.QuickCheck hiding (Result(..))@@ -84,3 +91,27 @@  removeLocations :: H.SpecWith a -> H.SpecWith a removeLocations = H.mapSpecItem_ (\item -> item{H.itemLocation = Nothing})++withEnvironment :: [(String, String)] -> IO a -> IO a+withEnvironment environment action = bracket saveEnv restoreEnv $ const action+  where+    saveEnv :: IO [(String, String)]+    saveEnv = do+      env <- clearEnv+      forM_ environment $ uncurry setEnv+      return env+    restoreEnv :: [(String, String)] -> IO ()+    restoreEnv env = do+      _ <- clearEnv+      forM_ env $ uncurry setEnv+    clearEnv :: IO [(String, String)]+    clearEnv = do+      env <- getEnvironment+      forM_ env (unsetEnv . fst)+      return env++inTempDirectory :: IO a -> IO a+inTempDirectory action = withSystemTempDirectory "mockery" $ \path -> do+  bracket getCurrentDirectory setCurrentDirectory $ \_ -> do+    setCurrentDirectory path+    action

@@ -1,7 +1,7 @@ module Mock where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat  newtype Mock = Mock (IORef Int) 

@@ -1,1 +1,11 @@-{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-}+module Main where++import           Test.Hspec.Meta+import           System.SetEnv+import qualified All++spec :: Spec+spec = beforeAll_ (setEnv "IGNORE_DOT_HSPEC" "yes") $ afterAll_ (unsetEnv "IGNORE_DOT_HSPEC") All.spec++main :: IO ()+main = hspec spec

@@ -1,31 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-module Test.Hspec.CompatSpec (main, spec) where--import           Helper-import           System.SetEnv-import           Data.Typeable--data SomeType = SomeType-  deriving Typeable--main :: IO ()-main = hspec spec--spec :: Spec-spec = do-  describe "showType" $ do-    it "shows unqualified name of type" $ do-      showType SomeType `shouldBe` "SomeType"--  describe "showFullType (currently unused)" $ do-    it "shows fully qualified name of type" $ do-      showFullType SomeType `shouldBe` "Test.Hspec.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

@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Test.Hspec.Core.CompatSpec (main, spec) where++import           Helper+import           System.SetEnv+import           Data.Typeable++data SomeType = SomeType+  deriving Typeable++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "showType" $ do+    it "shows unqualified name of type" $ do+      showType SomeType `shouldBe` "SomeType"++  describe "showFullType (currently unused)" $ do+    it "shows fully qualified name of type" $ do+      showFullType SomeType `shouldBe` "Test.Hspec.Core.CompatSpec.SomeType"++  describe "lookupEnv" $ do+    it "returns value of specified environment variable" $ do+      setEnv "FOO" "bar"+      lookupEnv "FOO" `shouldReturn` Just "bar"++    it "returns Nothing if specified environment variable is not set" $ do+      unsetEnv "FOO"+      lookupEnv "FOO" `shouldReturn` Nothing

@@ -0,0 +1,33 @@+module Test.Hspec.Core.ConfigSpec (spec) where++import           Helper+import           System.Directory+import           System.FilePath++import           Test.Hspec.Core.Config++spec :: Spec+spec = do+  describe "readConfigFiles" $ around_ (withEnvironment []) $ around_ inTempDirectory $ do+    it "reads .hspec" $ do+      dir <- getCurrentDirectory+      let name = dir </> ".hspec"+      writeFile name "--diff"+      readConfigFiles `shouldReturn` [(name, ["--diff"])]++    it "reads ~/.hspec" $ do+      let name = "my-home/.hspec"+      createDirectory "my-home"+      writeFile name "--diff"+      withEnvironment [("HOME", "my-home")] $ do+        readConfigFiles `shouldReturn` [(name, ["--diff"])]++    context "without $HOME" $ do+      it "returns empty list" $ do+        readConfigFiles `shouldReturn` []++    context "without current directory" $ do+      it "returns empty list" $ do+        dir <- getCurrentDirectory+        removeDirectory dir+        readConfigFiles `shouldReturn` []

@@ -13,37 +13,96 @@ main :: IO () main = hspec spec +safeEvaluateExample :: (H.Example e,  H.Arg e ~ ()) => e -> IO (Either E.SomeException H.Result)+safeEvaluateExample e = H.safeEvaluateExample e defaultParams ($ ()) noOpProgressCallback+ evaluateExample :: (H.Example e,  H.Arg e ~ ()) => e -> IO H.Result evaluateExample e = H.evaluateExample e defaultParams ($ ()) noOpProgressCallback  evaluateExampleWith :: (H.Example e, H.Arg e ~ ()) => (IO () -> IO ()) -> e -> IO H.Result evaluateExampleWith action e = H.evaluateExample e defaultParams (action . ($ ())) noOpProgressCallback +evaluateExampleWithArgument :: H.Example e => (ActionWith (H.Arg e) -> IO ()) -> e -> IO H.Result+evaluateExampleWithArgument action e = H.evaluateExample e defaultParams action noOpProgressCallback+ spec :: Spec spec = do+  describe "safeEvaluateExample" $ do+    context "for Expectation" $ do+      it "returns Failure if an expectation does not hold" $ do+        Right (H.Failure _ msg) <- safeEvaluateExample (23 `shouldBe` (42 :: Int))+#if MIN_VERSION_HUnit(1,5,0)+        msg `shouldBe` H.ExpectedButGot Nothing "42" "23"+#else+        msg `shouldBe` H.Reason "expected: 42\n but got: 23"+#endif++      context "when used with `pending`" $ do+        it "returns Pending" $ do+          Right result <- safeEvaluateExample (H.pending)+          result `shouldBe` H.Pending Nothing++      context "when used with `pendingWith`" $ do+        it "includes the optional reason" $ do+          Right result <- safeEvaluateExample (H.pendingWith "foo")+          result `shouldBe` H.Pending (Just "foo")+   describe "evaluateExample" $ do+    context "for Result" $ do+      it "runs around-action" $ do+        ref <- newIORef (0 :: Int)+        let action :: IO () -> IO ()+            action e = do+              e+              modifyIORef ref succ+        evaluateExampleWith action (H.Failure Nothing H.NoReason) `shouldReturn` H.Failure Nothing H.NoReason+        readIORef ref `shouldReturn` 1++      it "accepts arguments" $ do+        ref <- newIORef (0 :: Int)+        let action :: (Integer -> IO ()) -> IO ()+            action e = do+              e 42+              modifyIORef ref succ+        evaluateExampleWithArgument action (H.Failure Nothing . H.Reason . show) `shouldReturn` H.Failure Nothing (H.Reason "42")+        readIORef ref `shouldReturn` 1+     context "for Bool" $ do       it "returns Success on True" $ do         evaluateExample True `shouldReturn` H.Success -      it "returns Fail on False" $ do-        evaluateExample False `shouldReturn` H.Fail Nothing ""+      it "returns Failure on False" $ do+        evaluateExample False `shouldReturn` H.Failure Nothing H.NoReason        it "propagates exceptions" $ do         evaluateExample (error "foobar" :: Bool) `shouldThrow` errorCall "foobar" +      it "runs around-action" $ do+        ref <- newIORef (0 :: Int)+        let action :: IO () -> IO ()+            action e = do+              e+              modifyIORef ref succ+        evaluateExampleWith action False `shouldReturn` H.Failure Nothing H.NoReason+        readIORef ref `shouldReturn` 1++      it "accepts arguments" $ do+        ref <- newIORef (0 :: Int)+        let action :: (Integer -> IO ()) -> IO ()+            action e = do+              e 42+              modifyIORef ref succ+        evaluateExampleWithArgument action (== (23 :: Integer)) `shouldReturn` H.Failure Nothing H.NoReason+        readIORef ref `shouldReturn` 1+     context "for Expectation" $ do       it "returns Success if all expectations hold" $ do         evaluateExample (23 `shouldBe` (23 :: Int)) `shouldReturn` H.Success -      it "returns Fail if an expectation does not hold" $ do-        H.Fail _ msg <- evaluateExample (23 `shouldBe` (42 :: Int))-        msg `shouldEndWith` "expected: 42\n but got: 23"-       it "propagates exceptions" $ do         evaluateExample (error "foobar" :: Expectation) `shouldThrow` errorCall "foobar" -      it "runs provided action around expectation" $ do+      it "runs around-action" $ do         ref <- newIORef (0 :: Int)         let action :: IO () -> IO ()             action e = do@@ -54,31 +113,23 @@         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)+      it "returns Failure if property does not hold" $ do+        H.Failure _ _ <- evaluateExample $ property $ \n -> n /= (n :: Int)         return ()        it "shows what falsified it" $ do-        H.Fail _ r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False-        r `shouldBe` intercalate "\n"  [+        H.Failure _ r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False+        r `shouldBe` (H.Reason . intercalate "\n")  [             "Falsifiable (after 1 test): "           , "0"           , "1"           ] -      it "runs provided action around each single check of the property" $ do+      it "runs around-action for each single check of the property" $ do         ref <- newIORef (0 :: Int)         let action :: IO () -> IO ()             action e = do@@ -90,8 +141,8 @@         readIORef ref `shouldReturn` 2000        it "pretty-prints exceptions" $ do-        H.Fail _ r <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (E.throw (E.ErrorCall "foobar") :: Bool))-        r `shouldBe` intercalate "\n" [+        H.Failure _ r <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (E.throw (E.ErrorCall "foobar") :: Bool))+        r `shouldBe` (H.Reason . intercalate "\n") [ #if MIN_VERSION_QuickCheck(2,7,0)             "uncaught exception: ErrorCall (foobar) (after 1 test)" #else@@ -102,7 +153,7 @@        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)+          H.Failure _ (H.Reason r) <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> 23 `shouldBe` (42 :: Int)           r `shouldStartWith` "Falsifiable (after 1 test): \n"           r `shouldEndWith` intercalate "\n" [               "expected: 42"

@@ -0,0 +1,17 @@+module Test.Hspec.Core.FailureReportSpec (main, spec) where++import           Helper++import           System.IO+import qualified Control.Exception as E+import           Test.Hspec.Core.FailureReport++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "writeFailureReport" $ do+    it "prints a warning on unexpected exceptions" $ do+      r <- hCapture_ [stderr] $ writeFailureReport (E.throw (E.ErrorCall "some error"))+      r `shouldBe` "WARNING: Could not write environment variable HSPEC_FAILURES (some error)\n"

@@ -0,0 +1,21 @@+module Test.Hspec.Core.Formatters.DiffSpec (spec) where++import           Helper+import           Data.Char++import           Test.Hspec.Core.Formatters.Diff++spec :: Spec+spec = do+  describe "partition" $ do+    it "puts backslash-escaped characters into a separate chunks" $ do+      partition (show "foo\nbar") `shouldBe` ["\"", "foo", "\\n", "bar", "\""]++  describe "breakList" $ do+    context "with a list where the predicate matches at the beginning and the end" $ do+      it "breaks the list into pieces" $ do+        breakList isAlphaNum "foo bar  baz" `shouldBe` ["foo", " ", "bar", " ", " ", "baz"]++    context "with a list where the predicate does not match at the beginning and the end" $ do+      it "breaks the list into pieces" $ do+        breakList isAlphaNum "  foo bar  baz  " `shouldBe` [" ", " ", "foo", " ", "bar", " ", " ", "baz", " ", " "]

@@ -1,53 +1,117 @@-{-# LANGUAGE CPP #-}-module Test.Hspec.Core.FormattersSpec (main, spec) where+{-# LANGUAGE OverloadedStrings #-}+module Test.Hspec.Core.FormattersSpec (spec) where  import           Prelude () import           Helper+import           Data.String+import           Control.Monad.Trans.Writer import qualified Control.Exception as E  import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Formatters as H+import qualified Test.Hspec.Core.Formatters.Monad as H+import           Test.Hspec.Core.Formatters.Monad hiding (interpretWith) -#ifndef mingw32_HOST_OS-import           System.Console.ANSI-#endif+data ColorizedText =+    Plain String+  | Info String+  | Succeeded String+  | Failed String+  | Pending String+  | Extra String+  | Missing String+  deriving (Eq, Show) -main :: IO ()-main = hspec spec+instance IsString ColorizedText where+  fromString = Plain +removeColors :: [ColorizedText] -> String+removeColors input = case input of+  Plain x : xs -> x ++ removeColors xs+  Info x : xs -> x ++ removeColors xs+  Succeeded x : xs -> x ++ removeColors xs+  Failed x : xs -> x ++ removeColors xs+  Pending x : xs -> x ++ removeColors xs+  Extra x : xs -> x ++ removeColors xs+  Missing x : xs -> x ++ removeColors xs+  [] -> ""++simplify :: [ColorizedText] -> [ColorizedText]+simplify input = case input of+  Plain xs : Plain ys : zs -> simplify (Plain (xs ++ ys) : zs)+  Extra xs : Extra ys : zs -> simplify (Extra (xs ++ ys) : zs)+  Missing xs : Missing ys : zs -> simplify (Missing (xs ++ ys) : zs)+  x : xs -> x : simplify xs+  [] -> []++colorize :: (String -> ColorizedText) -> [ColorizedText] -> [ColorizedText]+colorize color input = case simplify input of+  Plain x : xs -> color x : xs+  xs -> xs++interpret :: FormatM a -> [ColorizedText]+interpret = interpretWith environment++interpretWith :: Environment (Writer [ColorizedText]) -> FormatM a -> [ColorizedText]+interpretWith env = simplify . execWriter . H.interpretWith env++environment :: Environment (Writer [ColorizedText])+environment = Environment {+  environmentGetSuccessCount = return 0+, environmentGetPendingCount = return 0+, environmentGetFailCount = return 0+, environmentGetFailMessages = return []+, environmentUsedSeed = return 0+, environmentGetCPUTime = return Nothing+, environmentGetRealTime = return 0+, environmentWrite = tell . return . Plain+, environmentWithFailColor = \action -> let (a, r) = runWriter action in tell (colorize Failed r) >> return a+, environmentWithSuccessColor = \action -> let (a, r) = runWriter action in tell (colorize Succeeded r) >> return a+, environmentWithPendingColor = \action -> let (a, r) = runWriter action in tell (colorize Pending r) >> return a+, environmentWithInfoColor = \action -> let (a, r) = runWriter action in tell (colorize Info r) >> return a+, environmentExtraChunk = tell . return . Extra+, environmentMissingChunk = tell . return . Missing+, environmentLiftIO = undefined+}+ testSpec :: H.Spec testSpec = do   H.describe "Example" $ do     H.it "success"    (H.Success)-    H.it "fail 1"     (H.Fail Nothing "fail message")+    H.it "fail 1"     (H.Failure Nothing $ H.Reason "fail message")     H.it "pending"    (H.pendingWith "pending message")-    H.it "fail 2"     (H.Fail Nothing "")+    H.it "fail 2"     (H.Failure Nothing H.NoReason)     H.it "exceptions" (undefined :: H.Result)-    H.it "fail 3"     (H.Fail Nothing "")+    H.it "fail 3"     (H.Failure Nothing H.NoReason)  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}+    let formatter = H.progress -    it "produces '..F...FF.F' style output" $ do-      r <- runSpec testSpec-      head r `shouldBe` ".F.FFF"+    describe "exampleSucceeded" $ do+      it "marks succeeding examples with ." $ do+        interpret (H.exampleSucceeded formatter undefined) `shouldBe` [+            Succeeded "."+          ] -    context "same as failed_examples" $ do-      failed_examplesSpec H.progress+    describe "exampleFailed" $ do+      it "marks failing examples with F" $ do+        interpret (H.exampleFailed formatter undefined undefined) `shouldBe` [+            Failed "F"+          ] +    describe "examplePending" $ do+      it "marks pending examples with ." $ do+        interpret (H.examplePending formatter undefined undefined) `shouldBe` [+            Pending "."+          ]+   describe "specdoc" $ do-    let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.specdoc}+    let+      formatter = H.specdoc+      runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter}      it "displays a header for each thing being described" $ do       _:x:_ <- runSpec testSpec@@ -129,17 +193,73 @@           , "2 examples, 0 failures"           ] +    describe "failedFormatter" $ do+      let action = H.failedFormatter formatter++      context "when actual/expected contain newlines" $ do+        let+          env = environment {+            environmentGetFailMessages = return [FailureRecord Nothing ([], "") (Right $ ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")]+            }+        it "adds indentation" $ do+          removeColors (interpretWith env action) `shouldBe` unlines [+              ""+            , "Failures:"+            , ""+            , "  1) "+            , "       expected: first"+            , "                 second"+            , "                 third"+            , "        but got: first"+            , "                 two"+            , "                 third"+            , ""+            , "Randomized with seed 0"+            , ""+            ]++    describe "footerFormatter" $ do+      let action = H.footerFormatter formatter++      context "without failures" $ do+        let env = environment {environmentGetSuccessCount = return 1}+        it "shows summary in green if there are no failures" $ do+          interpretWith env action `shouldBe` [+              "Finished in 0.0000 seconds\n"+            , Succeeded "1 example, 0 failures\n"+            ]++      context "with pending examples" $ do+        let env = environment {environmentGetPendingCount = return 1}+        it "shows summary in yellow if there are pending examples" $ do+          interpretWith env action `shouldBe` [+              "Finished in 0.0000 seconds\n"+            , Pending "1 example, 0 failures, 1 pending\n"+            ]++      context "with failures" $ do+        let env = environment {environmentGetFailCount = return 1}+        it "shows summary in red" $ do+          interpretWith env action `shouldBe` [+              "Finished in 0.0000 seconds\n"+            , Failed "1 example, 1 failure\n"+            ]++      context "with both failures and pending examples" $ do+        let env = environment {environmentGetFailCount = return 1, environmentGetPendingCount = return 1}+        it "shows summary in red" $ do+          interpretWith env action `shouldBe` [+              "Finished in 0.0000 seconds\n"+            , Failed "2 examples, 1 failure, 1 pending\n"+            ]+     context "same as failed_examples" $ do-      failed_examplesSpec H.progress+      failed_examplesSpec formatter  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@@ -200,37 +320,3 @@           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

@@ -1,11 +1,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Hspec.Core.HooksSpec (main, spec) where -import           Prelude ()+import           Control.Exception import           Helper+import           Prelude () -import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H+import qualified Test.Hspec.Core.Spec as H  import qualified Test.Hspec.Core.Hooks as H @@ -119,6 +120,15 @@         , "foo value"         , "bar value"         ]++    context "when specified action throws an exception" $ do+      it "sets subsequent spec items to pending" $ do+        result <- silence . H.hspecResult $ H.beforeAll (throwIO (ErrorCall "foo")) $ do+          H.it "foo" $ \n -> do+            n `shouldBe` (23 :: Int)+          H.it "bar" $ \n -> do+            n `shouldBe` 23+        result `shouldBe` H.Summary {H.summaryExamples = 2, H.summaryFailures = 1}      context "when used with an empty list of examples" $ do       it "does not run specified action" $ do

@@ -0,0 +1,98 @@+module Test.Hspec.Core.OptionsSpec (spec) where++import           Control.Monad+import           Helper+import           System.Exit++import qualified Test.Hspec.Core.Options as Options+import           Test.Hspec.Core.Options hiding (parseOptions)++fromLeft :: Either a b -> a+fromLeft (Left a) = a+fromLeft _ = error "fromLeft: No left value!"++spec :: Spec+spec = do+  describe "parseOptions" $ do++    let parseOptions = Options.parseOptions defaultConfig "my-spec"++    it "rejects unexpected arguments" $ do+      fromLeft (parseOptions [] ["foo"]) `shouldBe` (ExitFailure 1, "my-spec: unexpected argument `foo'\nTry `my-spec --help' for more information.\n")++    it "rejects unrecognized options" $ do+      fromLeft (parseOptions [] ["--foo"]) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--foo'\nTry `my-spec --help' for more information.\n")++    it "sets configColorMode to ColorAuto" $ do+      configColorMode <$> parseOptions [] [] `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++    context "with --jobs" $ do+      it "sets number of concurrent jobs" $ do+        configConcurrentJobs <$> parseOptions [] ["--jobs=23"] `shouldBe` Right (Just 23)++      it "rejects values < 1" $ do+        let msg = "my-spec: invalid argument `0' for `--jobs'\nTry `my-spec --help' for more information.\n"+        void (parseOptions [] ["--jobs=0"]) `shouldBe` Left (ExitFailure 1, msg)++    context "when given a config file" $ do+      it "uses options from config file" $ do+        configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] [] `shouldBe` Right ColorNever++      it "gives command-line options precedence" $ do+        configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] ["--color"] `shouldBe` Right ColorAlways++      it "rejects --help" $ do+        fromLeft (parseOptions [("~/.hspec", ["--help"])] []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--help' in config file ~/.hspec\n")++      it "rejects unrecognized options" $ do+        fromLeft (parseOptions [("~/.hspec", ["--invalid"])] []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' in config file ~/.hspec\n")++      it "rejects ambiguous options" $ do+        fromLeft (parseOptions [("~/.hspec", ["--qc-max-s"])] []) `shouldBe` (ExitFailure 1,+          unlines [+            "my-spec: option `--qc-max-s' is ambiguous; could be one of:"+          , "  -a N  --qc-max-success=N  maximum number of successful tests"+          , "                            before a QuickCheck property succeeds"+          , "        --qc-max-size=N     size to use for the biggest test cases"+          , "in config file ~/.hspec"+          ]+          )++    context "when given multiple config files" $ do+      it "gives later config files precedence" $ do+        configColorMode <$> parseOptions [("~/.hspec", ["--no-color"]), (".hspec", ["--color"])] [] `shouldBe` Right ColorAlways++  describe "ignoreConfigFile" $ around_ (withEnvironment []) $ do+    context "by default" $ do+      it "returns False" $ do+        ignoreConfigFile defaultConfig [] `shouldReturn` False++    context "with --ignore-dot-hspec" $ do+      it "returns True" $ do+        ignoreConfigFile defaultConfig ["--ignore-dot-hspec"] `shouldReturn` True++    context "with IGNORE_DOT_HSPEC" $ do+      it "returns True" $ do+        withEnvironment [("IGNORE_DOT_HSPEC", "yes")] $ do+          ignoreConfigFile defaultConfig [] `shouldReturn` True

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Hspec.Core.RunnerSpec (main, spec) where @@ -12,8 +13,11 @@ import qualified Control.Exception as E import           Mock import           System.SetEnv+#if MIN_VERSION_HUnit(1,5,0)+import           System.Console.ANSI+#endif -import           Test.Hspec.FailureReport (FailureReport(..))+import           Test.Hspec.Core.FailureReport (FailureReport(..)) import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Formatters as H (silent)@@ -312,6 +316,34 @@             H.it "example 3" $ mockAction e3         (,,) <$> mockCounter e1 <*> mockCounter e2 <*> mockCounter e3 `shouldReturn` (1, 0, 1) +    context "with --diff" $ do+      it "shows colorized diffs" $ do+#if MIN_VERSION_HUnit(1,5,0)+        r <- capture_ . ignoreExitCode . withArgs ["--diff", "--color"] . H.hspec $ do+          H.it "foo" $ do+            23 `shouldBe` (42 :: Int)+        r `shouldContain` unlines [+            red ++ "       expected: " ++ reset ++ red ++ "42" ++ reset+          , red ++ "        but got: " ++ reset ++ green ++ "23" ++ reset+          ]+#else+        pending+#endif++    context "with --no-diff" $ do+      it "it does not show colorized diffs" $ do+#if MIN_VERSION_HUnit(1,5,0)+        r <- capture_ . ignoreExitCode . withArgs ["--no-diff", "--color"] . H.hspec $ do+          H.it "foo" $ do+            23 `shouldBe` (42 :: Int)+        r `shouldContain` unlines [+            red ++ "       expected: " ++ reset ++ "42"+          , red ++ "        but got: " ++ reset ++ "23"+          ]+#else+        pending+#endif+     context "with --format" $ do       it "uses specified formatter" $ do         r <- capture_ . ignoreExitCode . withArgs ["--format", "progress"] . H.hspec $ do@@ -424,7 +456,7 @@      it "does not let escape error thunks from failure messages" $ do       r <- silence . H.hspecResult $ do-        H.it "some example" (H.Fail Nothing $ "foobar" ++ undefined)+        H.it "some example" (H.Failure Nothing . H.Reason $ "foobar" ++ undefined)       r `shouldBe` H.Summary 1 1      it "runs specs in parallel" $ do@@ -451,3 +483,38 @@         r `shouldBe` H.Summary n 0         high <- readIORef highRef         high `shouldBe` j++  describe "rerunAll" $ do+    let+      report = FailureReport 0 0 0 0 [([], "foo")]+      config = H.defaultConfig {H.configRerun = True, H.configRerunAllOnSuccess = True}+      summary = H.Summary 1 0+    context "with --rerun, --rerun-all-on-success, previous failures, on success" $ do+      it "returns True" $ do+        H.rerunAll config (Just report) summary `shouldBe` True++    context "without --rerun" $ do+      it "returns False" $ do+        H.rerunAll config {H.configRerun = False} (Just report) summary `shouldBe` False++    context "without --rerun-all-on-success" $ do+      it "returns False" $ do+        H.rerunAll config {H.configRerunAllOnSuccess = False} (Just report) summary `shouldBe` False++    context "without previous failures" $ do+      it "returns False" $ do+        H.rerunAll config (Just report {failureReportPaths = []}) summary `shouldBe` False++    context "without failure report" $ do+      it "returns False" $ do+        H.rerunAll config Nothing summary `shouldBe` False++    context "on failure" $ do+      it "returns False" $ do+        H.rerunAll config (Just report) summary {H.summaryFailures = 1} `shouldBe` False+  where+#if MIN_VERSION_HUnit(1,5,0)+    green  = setSGRCode [SetColor Foreground Dull Green]+    red    = setSGRCode [SetColor Foreground Dull Red]+    reset  = setSGRCode [Reset]+#endif

@@ -1,4 +1,3 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module Test.Hspec.Core.SpecSpec (main, spec) where @@ -32,6 +31,12 @@         [Node d _] <- runSpecM (H.describe "" (pure ()))         d `shouldBe` "(no description given)" +  describe "xdescribe" $ do+    it "creates a tree of pending spec items" $ do+      [Node _ [Leaf item]] <- runSpecM (H.xdescribe "" $ H.it "whatever" True)+      Right r <- itemExample item defaultParams ($ ()) noOpProgressCallback+      r `shouldBe` Pending Nothing+   describe "it" $ do     it "takes a description of a desired behavior" $ do       [Leaf item] <- runSpecM (H.it "whatever" True)@@ -39,19 +44,29 @@      it "takes an example of that behavior" $ do       [Leaf item] <- runSpecM (H.it "whatever" True)-      itemExample item defaultParams ($ ()) noOpProgressCallback `shouldReturn` Success+      Right r <- itemExample item defaultParams ($ ()) noOpProgressCallback+      r `shouldBe` Success -#ifdef HAS_SOURCE_LOCATIONS     it "adds source locations" $ do       [Leaf item] <- runSpecM (H.it "foo" True)-      let location = H.Location __FILE__ (pred $ __LINE__) 32 H.ExactLocation-      itemLocation item `shouldBe` Just location+      let location =+#if MIN_VERSION_base(4,8,1)+            Just $ H.Location __FILE__ (__LINE__ - 3) 32 H.ExactLocation+#else+            Nothing #endif+      itemLocation item `shouldBe` location      context "when no description is given" $ do       it "uses a default description" $ do         [Leaf item] <- runSpecM (H.it "" True)         itemRequirement item `shouldBe` "(unspecified behavior)"++  describe "xit" $ do+    it "creates a pending spec item" $ do+      [Leaf item] <- runSpecM (H.xit "whatever" True)+      Right r <- itemExample item defaultParams ($ ()) noOpProgressCallback+      r `shouldBe` Pending Nothing    describe "pending" $ do     it "specifies a pending example" $ do

@@ -0,0 +1,29 @@+module Test.Hspec.Core.TimerSpec (main, spec) where++import           Helper++import           Test.Hspec.Core.Timer++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "timer action returned by newTimer" $ do++    let dt = 0.01++    it "returns False" $ do+      timer <- newTimer dt+      timer `shouldReturn` False++    context "after specified time" $ do+      it "returns True" $ do+        timer <- newTimer dt+        sleep dt+        timer `shouldReturn` True+        timer `shouldReturn` False+        sleep dt+        sleep dt+        timer `shouldReturn` True+        timer `shouldReturn` False

@@ -1,17 +0,0 @@-module Test.Hspec.FailureReportSpec (main, spec) where--import           Helper--import           System.IO-import qualified Control.Exception as E-import           Test.Hspec.FailureReport--main :: IO ()-main = hspec spec--spec :: Spec-spec = do-  describe "writeFailureReport" $ do-    it "prints a warning on unexpected exceptions" $ do-      r <- hCapture_ [stderr] $ writeFailureReport (E.throw (E.ErrorCall "some error"))-      r `shouldBe` "WARNING: Could not write environment variable HSPEC_FAILURES (some error)\n"

@@ -1,53 +0,0 @@-module Test.Hspec.OptionsSpec (main, spec) where--import           Control.Monad-import           Helper-import           System.Exit--import qualified Test.Hspec.Options as Options-import           Test.Hspec.Options hiding (parseOptions)--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--    context "with --jobs" $ do-      it "sets number of concurrent jobs" $ do-        configConcurrentJobs <$> parseOptions ["--jobs=23"] `shouldBe` Right (Just 23)--      it "rejects values < 1" $ do-        let msg = "my-spec: invalid argument `0' for `--jobs'\nTry `my-spec --help' for more information.\n"-        void (parseOptions ["--jobs=0"]) `shouldBe` Left (ExitFailure 1, msg)

@@ -1,29 +0,0 @@-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

@@ -0,0 +1,114 @@+{-# LANGUAGE DeriveFunctor #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Algorithm.Diff+-- Copyright   :  (c) Sterling Clover 2008-2011, Kevin Charter 2011+-- License     :  BSD 3 Clause+-- Maintainer  :  s.clover@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- This is an implementation of the O(ND) diff algorithm as described in+-- \"An O(ND) Difference Algorithm and Its Variations (1986)\"+-- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.4.6927>. It is O(mn) in space.+-- The algorithm is the same one used by standared Unix diff.+-----------------------------------------------------------------------------++module Data.Algorithm.Diff+    ( Diff(..)+    -- * Comparing lists for differences+    , getDiff+    , getDiffBy++    -- * Finding chunks of differences+    , getGroupedDiff+    , getGroupedDiffBy+    ) where++import Prelude hiding (pi)++import Data.Array++data DI = F | S | B deriving (Show, Eq)++-- | A value is either from the 'First' list, the 'Second' or from 'Both'.+-- 'Both' contains both the left and right values, in case you are using a form+-- of equality that doesn't check all data (for example, if you are using a+-- newtype to only perform equality on side of a tuple).+data Diff a = First a | Second a | Both a a deriving (Show, Eq, Functor)++data DL = DL {poi :: !Int, poj :: !Int, path::[DI]} deriving (Show, Eq)++instance Ord DL+        where x <= y = if poi x == poi y+                then  poj x > poj y+                else poi x <= poi y++canDiag :: (a -> a -> Bool) -> [a] -> [a] -> Int -> Int -> Int -> Int -> Bool+canDiag eq as bs lena lenb = \ i j ->+   if i < lena && j < lenb then (arAs ! i) `eq` (arBs ! j) else False+    where arAs = listArray (0,lena - 1) as+          arBs = listArray (0,lenb - 1) bs++dstep :: (Int -> Int -> Bool) -> [DL] -> [DL]+dstep cd dls = hd:pairMaxes rst+  where (hd:rst) = nextDLs dls+        nextDLs [] = []+        nextDLs (dl:rest) = dl':dl'':nextDLs rest+          where dl'  = addsnake cd $ dl {poi=poi dl + 1, path=(F : pdl)}+                dl'' = addsnake cd $ dl {poj=poj dl + 1, path=(S : pdl)}+                pdl = path dl+        pairMaxes [] = []+        pairMaxes [x] = [x]+        pairMaxes (x:y:rest) = max x y:pairMaxes rest++addsnake :: (Int -> Int -> Bool) -> DL -> DL+addsnake cd dl+    | cd pi pj = addsnake cd $+                 dl {poi = pi + 1, poj = pj + 1, path=(B : path dl)}+    | otherwise   = dl+    where pi = poi dl; pj = poj dl++lcs :: (a -> a -> Bool) -> [a] -> [a] -> [DI]+lcs eq as bs = path . head . dropWhile (\dl -> poi dl /= lena || poj dl /= lenb) .+            concat . iterate (dstep cd) . (:[]) . addsnake cd $+            DL {poi=0,poj=0,path=[]}+            where cd = canDiag eq as bs lena lenb+                  lena = length as; lenb = length bs++-- | Takes two lists and returns a list of differences between them. This is+-- 'getDiffBy' with '==' used as predicate.+getDiff :: (Eq t) => [t] -> [t] -> [Diff t]+getDiff = getDiffBy (==)++-- | Takes two lists and returns a list of differences between them, grouped+-- into chunks. This is 'getGroupedDiffBy' with '==' used as predicate.+getGroupedDiff :: (Eq t) => [t] -> [t] -> [Diff [t]]+getGroupedDiff = getGroupedDiffBy (==)++-- | A form of 'getDiff' with no 'Eq' constraint. Instead, an equality predicate+-- is taken as the first argument.+getDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff t]+getDiffBy eq a b = markup a b . reverse $ lcs eq a b+    where markup (x:xs)   ys   (F:ds) = First x  : markup xs ys ds+          markup   xs   (y:ys) (S:ds) = Second y : markup xs ys ds+          markup (x:xs) (y:ys) (B:ds) = Both x y : markup xs ys ds+          markup _ _ _ = []++getGroupedDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff [t]]+getGroupedDiffBy eq a b = go $ getDiffBy eq a b+    where go (First x  : xs) = let (fs, rest) = goFirsts  xs in First  (x:fs)     : go rest+          go (Second x : xs) = let (fs, rest) = goSeconds xs in Second (x:fs)     : go rest+          go (Both x y : xs) = let (fs, rest) = goBoth    xs+                                   (fxs, fys) = unzip fs+                               in Both (x:fxs) (y:fys) : go rest+          go [] = []++          goFirsts  (First x  : xs) = let (fs, rest) = goFirsts  xs in (x:fs, rest)+          goFirsts  xs = ([],xs)++          goSeconds (Second x : xs) = let (fs, rest) = goSeconds xs in (x:fs, rest)+          goSeconds xs = ([],xs)++          goBoth    (Both x y : xs) = let (fs, rest) = goBoth xs    in ((x,y):fs, rest)+          goBoth    xs = ([],xs)