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