hspec-core-2.10.10/0000755000000000000000000000000007346545000012074 5ustar0000000000000000hspec-core-2.10.10/LICENSE0000644000000000000000000000226107346545000013102 0ustar0000000000000000Copyright (c) 2011-2023 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.10.10/Setup.lhs0000644000000000000000000000011407346545000013700 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain hspec-core-2.10.10/help.txt0000644000000000000000000000634707346545000013577 0ustar0000000000000000Usage: spec [OPTION]... OPTIONS --help display this help and exit --ignore-dot-hspec do not read options from ~/.hspec and .hspec -m PATTERN --match=PATTERN only run examples that match given PATTERN --skip=PATTERN skip examples that match given PATTERN RUNNER OPTIONS --[no-]dry-run pretend that everything passed; don't verify anything --[no-]focused-only do not run anything, unless there are focused spec items --[no-]fail-on=ITEMS empty: fail if all spec items have been filtered focused: fail on focused spec items pending: fail on pending spec items --[no-]strict same as --fail-on=focused,pending --[no-]fail-fast abort on first failure --[no-]randomize randomize execution order -r --rerun rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi) --failure-report=FILE read/write a failure report for use with --rerun --rerun-all-on-success run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun) -j N --jobs=N run at most N parallelizable tests simultaneously (default: number of available processors) FORMATTER OPTIONS -f NAME --format=NAME use a custom formatter; this can be one of checks, specdoc, progress, failed-examples or silent --[no-]color colorize the output --[no-]unicode output unicode --[no-]diff show colorized diffs --diff-context=N output N lines of diff context (default: 3) use a value of 'full' to see the full context --diff-command=CMD use an external diff command example: --diff-command="git diff" --[no-]pretty try to pretty-print diff values --[no-]times report times for individual spec items --print-cpu-time include used CPU time in summary -p[N] --print-slow-items[=N] print the N slowest spec items (default: 10) OPTIONS FOR QUICKCHECK -a N --qc-max-success=N maximum number of successful tests before a QuickCheck property succeeds --qc-max-discard=N maximum number of discarded tests per successful test before giving up --qc-max-size=N size to use for the biggest test cases --qc-max-shrinks=N maximum number of shrinks to perform before giving up (a value of 0 turns shrinking off) --seed=N used seed for QuickCheck properties OPTIONS FOR SMALLCHECK --depth=N maximum depth of generated test values for SmallCheck properties hspec-core-2.10.10/hspec-core.cabal0000644000000000000000000001501707346545000015114 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack name: hspec-core version: 2.10.10 license: MIT license-file: LICENSE copyright: (c) 2011-2023 Simon Hengel, (c) 2011-2012 Trystan Spangler, (c) 2011 Greg Weber maintainer: Simon Hengel build-type: Simple extra-source-files: version.yaml help.txt category: Testing stability: experimental bug-reports: https://github.com/hspec/hspec/issues homepage: https://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 -fno-warn-incomplete-uni-patterns build-depends: HUnit ==1.6.* , QuickCheck >=2.13.1 , ansi-terminal >=0.6.2 , array , base >=4.5.0.0 && <5 , call-stack >=0.2.0 , deepseq , directory , filepath , haskell-lexer , hspec-expectations ==0.8.2.* , process , quickcheck-io >=0.2.0 , random , setenv , tf-random , time , transformers >=0.2.2.0 exposed-modules: Test.Hspec.Core.Spec Test.Hspec.Core.Hooks Test.Hspec.Core.Runner Test.Hspec.Core.Format Test.Hspec.Core.Formatters Test.Hspec.Core.Formatters.V1 Test.Hspec.Core.Formatters.V2 Test.Hspec.Core.QuickCheck Test.Hspec.Core.Util other-modules: GetOpt.Declarative GetOpt.Declarative.Environment GetOpt.Declarative.Interpret GetOpt.Declarative.Types GetOpt.Declarative.Util NonEmpty Test.Hspec.Core.Clock Test.Hspec.Core.Compat Test.Hspec.Core.Config Test.Hspec.Core.Config.Definition Test.Hspec.Core.Config.Options Test.Hspec.Core.Example Test.Hspec.Core.Example.Location Test.Hspec.Core.FailureReport Test.Hspec.Core.Formatters.Diff Test.Hspec.Core.Formatters.Internal Test.Hspec.Core.Formatters.Pretty Test.Hspec.Core.Formatters.Pretty.Parser Test.Hspec.Core.Formatters.Pretty.Parser.Parser Test.Hspec.Core.Formatters.Pretty.Unicode Test.Hspec.Core.Formatters.V1.Free Test.Hspec.Core.Formatters.V1.Monad Test.Hspec.Core.QuickCheckUtil Test.Hspec.Core.Runner.Eval Test.Hspec.Core.Runner.JobQueue Test.Hspec.Core.Runner.PrintSlowSpecItems Test.Hspec.Core.Runner.Result Test.Hspec.Core.Shuffle Test.Hspec.Core.Spec.Monad Test.Hspec.Core.Timer Test.Hspec.Core.Tree Control.Concurrent.Async Data.Algorithm.Diff Paths_hspec_core default-language: Haskell2010 if impl(ghc >= 8.4.1) build-depends: stm >=2.2 else other-modules: Control.Concurrent.STM.TMVar hs-source-dirs: vendor/stm-2.5.0.1/ test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: src vendor test ghc-options: -Wall -fno-warn-incomplete-uni-patterns cpp-options: -DTEST build-depends: HUnit ==1.6.* , QuickCheck >=2.14 , ansi-terminal >=0.6.2 , array , base >=4.5.0.0 && <5 , base-orphans , call-stack >=0.2.0 , deepseq , directory , filepath , haskell-lexer , hspec-expectations ==0.8.2.* , hspec-meta ==2.10.5 , process , quickcheck-io >=0.2.0 , random , setenv , silently >=1.2.4 , temporary , tf-random , time , transformers >=0.2.2.0 build-tool-depends: hspec-meta:hspec-meta-discover other-modules: GetOpt.Declarative GetOpt.Declarative.Environment GetOpt.Declarative.Interpret GetOpt.Declarative.Types GetOpt.Declarative.Util NonEmpty Test.Hspec.Core.Clock Test.Hspec.Core.Compat Test.Hspec.Core.Config Test.Hspec.Core.Config.Definition Test.Hspec.Core.Config.Options Test.Hspec.Core.Example Test.Hspec.Core.Example.Location Test.Hspec.Core.FailureReport Test.Hspec.Core.Format Test.Hspec.Core.Formatters Test.Hspec.Core.Formatters.Diff Test.Hspec.Core.Formatters.Internal Test.Hspec.Core.Formatters.Pretty Test.Hspec.Core.Formatters.Pretty.Parser Test.Hspec.Core.Formatters.Pretty.Parser.Parser Test.Hspec.Core.Formatters.Pretty.Unicode Test.Hspec.Core.Formatters.V1 Test.Hspec.Core.Formatters.V1.Free Test.Hspec.Core.Formatters.V1.Monad Test.Hspec.Core.Formatters.V2 Test.Hspec.Core.Hooks Test.Hspec.Core.QuickCheck Test.Hspec.Core.QuickCheckUtil Test.Hspec.Core.Runner Test.Hspec.Core.Runner.Eval Test.Hspec.Core.Runner.JobQueue Test.Hspec.Core.Runner.PrintSlowSpecItems Test.Hspec.Core.Runner.Result Test.Hspec.Core.Shuffle Test.Hspec.Core.Spec Test.Hspec.Core.Spec.Monad Test.Hspec.Core.Timer Test.Hspec.Core.Tree Test.Hspec.Core.Util Control.Concurrent.Async Data.Algorithm.Diff GetOpt.Declarative.EnvironmentSpec GetOpt.Declarative.UtilSpec Helper Mock SpecHook Test.Hspec.Core.ClockSpec Test.Hspec.Core.CompatSpec Test.Hspec.Core.Config.DefinitionSpec Test.Hspec.Core.Config.OptionsSpec Test.Hspec.Core.ConfigSpec Test.Hspec.Core.Example.LocationSpec Test.Hspec.Core.ExampleSpec Test.Hspec.Core.FailureReportSpec Test.Hspec.Core.FormatSpec Test.Hspec.Core.Formatters.DiffSpec Test.Hspec.Core.Formatters.InternalSpec Test.Hspec.Core.Formatters.Pretty.ParserSpec Test.Hspec.Core.Formatters.Pretty.UnicodeSpec Test.Hspec.Core.Formatters.PrettySpec Test.Hspec.Core.Formatters.V1Spec Test.Hspec.Core.Formatters.V2Spec Test.Hspec.Core.HooksSpec Test.Hspec.Core.QuickCheckUtilSpec Test.Hspec.Core.Runner.EvalSpec Test.Hspec.Core.Runner.JobQueueSpec Test.Hspec.Core.Runner.PrintSlowSpecItemsSpec Test.Hspec.Core.Runner.ResultSpec Test.Hspec.Core.RunnerSpec Test.Hspec.Core.ShuffleSpec Test.Hspec.Core.SpecSpec Test.Hspec.Core.TimerSpec Test.Hspec.Core.UtilSpec Paths_hspec_core default-language: Haskell2010 if impl(ghc >= 8.4.1) build-depends: stm >=2.2 else other-modules: Control.Concurrent.STM.TMVar hs-source-dirs: vendor/stm-2.5.0.1/ hspec-core-2.10.10/src/GetOpt/0000755000000000000000000000000007346545000014065 5ustar0000000000000000hspec-core-2.10.10/src/GetOpt/Declarative.hs0000644000000000000000000000044207346545000016644 0ustar0000000000000000module GetOpt.Declarative (module GetOpt.Declarative) where import Prelude () import GetOpt.Declarative.Types as GetOpt.Declarative import GetOpt.Declarative.Interpret as GetOpt.Declarative import GetOpt.Declarative.Environment as GetOpt.Declarative hspec-core-2.10.10/src/GetOpt/Declarative/0000755000000000000000000000000007346545000016310 5ustar0000000000000000hspec-core-2.10.10/src/GetOpt/Declarative/Environment.hs0000644000000000000000000000330707346545000021153 0ustar0000000000000000module GetOpt.Declarative.Environment ( InvalidValue(..) , parseEnvironmentOptions , parseEnvironmentOption ) where import Prelude () import Test.Hspec.Core.Compat import Data.Char import GetOpt.Declarative.Types data InvalidValue = InvalidValue String String deriving (Eq, Show) parseEnvironmentOptions :: String -> [(String, String)] -> config -> [Option config] -> ([InvalidValue], config) parseEnvironmentOptions prefix env = foldr f . (,) [] where f :: Option config -> ([InvalidValue], config) -> ([InvalidValue], config) f option (errs, config) = case parseEnvironmentOption prefix env config option of Left err -> (err : errs, config) Right c -> (errs, c) parseEnvironmentOption :: String -> [(String, String)] -> config -> Option config -> Either InvalidValue config parseEnvironmentOption prefix env config option = case lookup name env of Nothing -> Right config Just value -> case optionSetter option of NoArg setter -> case value of "yes" -> Right $ setter config _ -> invalidValue Flag setter -> case value of "yes" -> Right $ setter True config "no" -> Right $ setter False config _ -> invalidValue OptArg _ setter -> case setter (Just value) config of Just c -> Right c Nothing -> invalidValue Arg _ setter -> case setter value config of Just c -> Right c Nothing -> invalidValue where invalidValue = Left (InvalidValue name value) where name = envVarName prefix option envVarName :: String -> Option config -> String envVarName prefix option = prefix ++ '_' : map f (optionName option) where f c = case c of '-' -> '_' _ -> toUpper c hspec-core-2.10.10/src/GetOpt/Declarative/Interpret.hs0000644000000000000000000000760007346545000020623 0ustar0000000000000000module GetOpt.Declarative.Interpret ( ParseResult(..) , parseCommandLineOptions , parse , interpretOptions ) where import Prelude () import Test.Hspec.Core.Compat import System.Console.GetOpt (OptDescr, ArgOrder(..), getOpt) import qualified System.Console.GetOpt as GetOpt import GetOpt.Declarative.Types import GetOpt.Declarative.Util (mkUsageInfo, mapOptDescr) data InvalidArgument = InvalidArgument String String data ParseResult config = Help String | Failure String | Success config parseCommandLineOptions :: [(String, [Option config])] -> String -> [String] -> config -> ParseResult config parseCommandLineOptions opts prog args config = case parseWithHelp (concatMap snd options) config args of Nothing -> Help usage Just (Right c) -> Success c Just (Left err) -> Failure $ prog ++ ": " ++ err ++ "\nTry `" ++ prog ++ " --help' for more information.\n" where options = addHelpFlag $ map (fmap interpretOptions) opts documentedOptions = addHelpFlag $ map (fmap $ interpretOptions . filter optionDocumented) opts usage :: String usage = "Usage: " ++ prog ++ " [OPTION]...\n\n" ++ (intercalate "\n" $ map (uncurry mkUsageInfo) documentedOptions) addHelpFlag :: [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])] addHelpFlag opts = case opts of (section, xs) : ys -> (section, GetOpt.Option [] ["help"] (GetOpt.NoArg help) "display this help and exit" : noHelp xs) : map (fmap noHelp) ys [] -> [] where help = Nothing noHelp :: [OptDescr a] -> [OptDescr (Maybe a)] noHelp = map (mapOptDescr Just) parseWithHelp :: [OptDescr (Maybe (config -> Either InvalidArgument config))] -> config -> [String] -> Maybe (Either String config) parseWithHelp options config args = case getOpt Permute options args of (opts, [], []) | _ : _ <- [() | Nothing <- opts] -> Nothing (opts, xs, ys) -> Just $ interpretResult config (catMaybes opts, xs, ys) parse :: [OptDescr (config -> Either InvalidArgument config)] -> config -> [String] -> Either String config parse options config = interpretResult config . getOpt Permute options interpretResult :: config -> ([config -> Either InvalidArgument config], [String], [String]) -> Either String config interpretResult config = interpretGetOptResult >=> foldResult config foldResult :: config -> [config -> Either InvalidArgument config] -> Either String config foldResult config opts = either (Left . renderInvalidArgument) return $ foldlM (flip id) config opts renderInvalidArgument :: InvalidArgument -> String renderInvalidArgument (InvalidArgument name value) = "invalid argument `" ++ value ++ "' for `--" ++ name ++ "'" interpretGetOptResult :: ([a], [String], [String]) -> Either String [a] interpretGetOptResult result = case result of (opts, [], []) -> Right opts (_, _, err:_) -> Left (init err) (_, arg:_, _) -> Left ("unexpected argument `" ++ arg ++ "'") interpretOptions :: [Option config] -> [OptDescr (config -> Either InvalidArgument config)] interpretOptions = concatMap interpretOption interpretOption :: Option config -> [OptDescr (config -> Either InvalidArgument config)] interpretOption (Option name shortcut argDesc help _) = case argDesc of NoArg setter -> [option $ GetOpt.NoArg (Right . setter)] Flag setter -> [ option (arg True) , GetOpt.Option [] ["no-" ++ name] (arg False) ("do not " ++ help) ] where arg v = GetOpt.NoArg (Right . setter v) OptArg argName setter -> [option $ GetOpt.OptArg arg argName] where arg mInput c = case setter mInput c of Just c_ -> Right c_ Nothing -> case mInput of Just input -> invalid input Nothing -> Right c Arg argName setter -> [option (GetOpt.ReqArg arg argName)] where arg input = maybe (invalid input) Right . setter input where invalid = Left . InvalidArgument name option arg = GetOpt.Option (maybeToList shortcut) [name] arg help hspec-core-2.10.10/src/GetOpt/Declarative/Types.hs0000644000000000000000000000074407346545000017755 0ustar0000000000000000module GetOpt.Declarative.Types where import Prelude () import Test.Hspec.Core.Compat data Option config = Option { optionName :: String , optionShortcut :: Maybe Char , optionSetter :: OptionSetter config , optionHelp :: String , optionDocumented :: Bool } data OptionSetter config = NoArg (config -> config) | Flag (Bool -> config -> config) | OptArg String (Maybe String -> config -> Maybe config) | Arg String (String -> config -> Maybe config) hspec-core-2.10.10/src/GetOpt/Declarative/Util.hs0000644000000000000000000000311107346545000017555 0ustar0000000000000000{-# LANGUAGE CPP #-} module GetOpt.Declarative.Util (mkUsageInfo, mapOptDescr) where import Prelude () import Test.Hspec.Core.Compat import System.Console.GetOpt import Test.Hspec.Core.Util modifyHelp :: (String -> String) -> OptDescr a -> OptDescr a modifyHelp modify (Option s n a help) = Option s n a (modify help) mkUsageInfo :: String -> [OptDescr a] -> String mkUsageInfo title = usageInfo title . addLineBreaksForHelp . condenseNoOptions addLineBreaksForHelp :: [OptDescr a] -> [OptDescr a] addLineBreaksForHelp options = map (modifyHelp addLineBreaks) options where withoutHelpWidth = maxLength . usageInfo "" . map removeHelp helpWidth = 80 - withoutHelpWidth options addLineBreaks = unlines . lineBreaksAt helpWidth maxLength = maximum . map length . lines removeHelp = modifyHelp (const "") condenseNoOptions :: [OptDescr a] -> [OptDescr a] condenseNoOptions options = case options of Option "" [optionA] arg help : Option "" [optionB] _ _ : ys | optionB == ("no-" ++ optionA) -> Option "" ["[no-]" ++ optionA] arg help : condenseNoOptions ys x : xs -> x : condenseNoOptions xs [] -> [] mapOptDescr :: (a -> b) -> OptDescr a -> OptDescr b #if MIN_VERSION_base(4,7,0) mapOptDescr = fmap #else mapOptDescr f opt = case opt of Option short long arg help -> Option short long (mapArgDescr f arg) help mapArgDescr :: (a -> b) -> ArgDescr a -> ArgDescr b mapArgDescr f arg = case arg of NoArg a -> NoArg (f a) ReqArg parse name -> ReqArg (fmap f parse) name OptArg parse name -> OptArg (fmap f parse) name #endif hspec-core-2.10.10/src/0000755000000000000000000000000007346545000012663 5ustar0000000000000000hspec-core-2.10.10/src/NonEmpty.hs0000644000000000000000000000151007346545000014765 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} module NonEmpty ( NonEmpty(..) , nonEmpty , reverse #ifdef TEST , fromList #endif ) where import Prelude () import Test.Hspec.Core.Compat hiding (reverse) import qualified Data.List as List import qualified Data.Foldable as Foldable data NonEmpty a = a :| [a] deriving (Eq, Show, Functor, Foldable, Traversable) infixr 5 :| nonEmpty :: [a] -> Maybe (NonEmpty a) nonEmpty [] = Nothing nonEmpty (a:as) = Just (a :| as) reverse :: NonEmpty a -> NonEmpty a reverse = lift List.reverse lift :: Foldable f => ([a] -> [b]) -> f a -> NonEmpty b lift f = fromList . f . Foldable.toList fromList :: [a] -> NonEmpty a fromList (a:as) = a :| as fromList [] = error "NonEmpty.fromList: empty list" hspec-core-2.10.10/src/Test/Hspec/Core/0000755000000000000000000000000007346545000015534 5ustar0000000000000000hspec-core-2.10.10/src/Test/Hspec/Core/Clock.hs0000644000000000000000000000232607346545000017126 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} module Test.Hspec.Core.Clock ( Seconds(..) , toMilliseconds , toMicroseconds , getMonotonicTime , measure , sleep , timeout ) where import Prelude () import Test.Hspec.Core.Compat import Text.Printf import Control.Concurrent import qualified System.Timeout as System #if MIN_VERSION_base(4,11,0) import qualified GHC.Clock as GHC #else import Data.Time.Clock.POSIX #endif newtype Seconds = Seconds Double deriving (Eq, Show, Ord, Num, Fractional, PrintfArg) toMilliseconds :: Seconds -> Int toMilliseconds (Seconds s) = floor (s * 1000) toMicroseconds :: Seconds -> Int toMicroseconds (Seconds s) = floor (s * 1000000) getMonotonicTime :: IO Seconds #if MIN_VERSION_base(4,11,0) getMonotonicTime = Seconds <$> GHC.getMonotonicTime #else getMonotonicTime = do t <- getPOSIXTime return $ Seconds (realToFrac t) #endif measure :: IO a -> IO (Seconds, a) measure action = do t0 <- getMonotonicTime a <- action t1 <- getMonotonicTime return (t1 - t0, a) sleep :: Seconds -> IO () sleep = threadDelay . toMicroseconds timeout :: Seconds -> IO a -> IO (Maybe a) timeout = System.timeout . toMicroseconds hspec-core-2.10.10/src/Test/Hspec/Core/Compat.hs0000644000000000000000000001123107346545000017311 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.Compat ( module Imports , module Test.Hspec.Core.Compat ) where import Control.Exception as Imports import Control.Arrow as Imports ((>>>), (&&&), first, second) import Control.Applicative as Imports import Control.Monad as Imports hiding ( mapM , mapM_ , forM , forM_ , msum , sequence , sequence_ ) import Data.Maybe as Imports import Data.Foldable as Imports import Data.CallStack as Imports (HasCallStack) import System.IO import System.Exit import System.Environment #if MIN_VERSION_base(4,11,0) import Data.Functor as Imports #endif import Data.Traversable as Imports import Data.Monoid as Imports import Data.List as Imports ( stripPrefix , isPrefixOf , isInfixOf , isSuffixOf , intercalate , inits , tails , sortBy #if MIN_VERSION_base(4,8,0) , sortOn #endif ) import Prelude as Imports hiding ( all , and , any , concat , concatMap , elem , foldl , foldl1 , foldr , foldr1 , mapM , mapM_ , maximum , minimum , notElem , or , product , sequence , sequence_ , sum #if !MIN_VERSION_base(4,6,0) , catch #endif ) import Data.Typeable (Typeable, typeOf, typeRepTyCon) import Data.IORef as Imports #if MIN_VERSION_base(4,6,0) import Text.Read as Imports (readMaybe) import System.Environment as Imports (lookupEnv) #else import Text.Read import qualified Text.ParserCombinators.ReadP as P #endif #if !MIN_VERSION_base(4,8,0) import Data.Ord (comparing) #endif #if MIN_VERSION_base(4,7,0) import Data.Bool as Imports (bool) #endif import Data.Typeable (tyConModule, tyConName) import Control.Concurrent #if !MIN_VERSION_base(4,9,0) import GHC.IO #endif #if !MIN_VERSION_base(4,6,0) forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId forkFinally action and_then = mask $ \restore -> forkIO $ try (restore action) >>= and_then -- |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' atomicWriteIORef :: IORef a -> a -> IO () atomicWriteIORef ref a = do x <- atomicModifyIORef ref (\_ -> (a, ())) x `seq` pass -- | 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 #if !MIN_VERSION_base(4,9,0) interruptible :: IO a -> IO a interruptible act = do st <- getMaskingState case st of Unmasked -> act MaskedInterruptible -> unsafeUnmask act MaskedUninterruptible -> act #endif guarded :: Alternative m => (a -> Bool) -> a -> m a guarded p a = if p a then pure a else empty #if !MIN_VERSION_base(4,8,0) sortOn :: Ord b => (a -> b) -> [a] -> [a] sortOn f = map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) #endif #if !MIN_VERSION_base(4,7,0) bool :: a -> a -> Bool -> a bool f _ False = f bool _ t True = t #endif #if !MIN_VERSION_base(4,11,0) infixl 1 <&> (<&>) :: Functor f => f a -> (a -> b) -> f b (<&>) = flip (<$>) #endif endsWith :: Eq a => [a] -> [a] -> Bool endsWith = flip isSuffixOf #if MIN_VERSION_base(4,8,0) pass :: Applicative m => m () pass = pure () #else pass :: Monad m => m () pass = return () #endif die :: String -> IO a die err = do name <- getProgName hPutStrLn stderr $ name <> ": " <> err exitFailure hspec-core-2.10.10/src/Test/Hspec/Core/Config.hs0000644000000000000000000001361107346545000017277 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.Config ( Config (..) , ColorMode(..) , UnicodeMode(..) , defaultConfig , readConfig , configAddFilter , configQuickCheckArgs , readFailureReportOnRerun , applyFailureReport #ifdef TEST , readConfigFiles #endif ) where import Prelude () import Test.Hspec.Core.Compat import System.IO import System.IO.Error import System.Exit import System.FilePath import System.Directory import System.Environment (getProgName, getEnvironment) import qualified Test.QuickCheck as QC import Test.Hspec.Core.Util import Test.Hspec.Core.Config.Options import Test.Hspec.Core.Config.Definition (Config(..), ColorMode(..), UnicodeMode(..), mkDefaultConfig, filterOr) import Test.Hspec.Core.FailureReport import Test.Hspec.Core.QuickCheckUtil (mkGen) import Test.Hspec.Core.Example (Params(..), defaultParams) import qualified Test.Hspec.Core.Formatters.V2 as V2 defaultConfig :: Config defaultConfig = mkDefaultConfig $ map (fmap V2.formatterToFormat) [ ("checks", V2.checks) , ("specdoc", V2.specdoc) , ("progress", V2.progress) , ("failed-examples", V2.failed_examples) , ("silent", V2.silent) ] -- | 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 } applyFailureReport :: Maybe FailureReport -> Config -> Config applyFailureReport 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 setMaxShrinks (configQuickCheckMaxShrinks c) . maybe id setMaxSize (configQuickCheckMaxSize c) . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c) . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) (paramsQuickCheckArgs defaultParams) setMaxSuccess :: Int -> QC.Args -> QC.Args setMaxSuccess n args = args {QC.maxSuccess = n} setMaxDiscardRatio :: Int -> QC.Args -> QC.Args setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n} setMaxSize :: Int -> QC.Args -> QC.Args setMaxSize n args = args {QC.maxSize = n} setMaxShrinks :: Int -> QC.Args -> QC.Args setMaxShrinks n args = args {QC.maxShrinks = n} setSeed :: Integer -> QC.Args -> QC.Args setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)} -- | -- `readConfig` parses config options from several sources and constructs a -- `Config` value. It takes options from: -- -- 1. @~/.hspec@ (a config file in the user's home directory) -- 1. @.hspec@ (a config file in the current working directory) -- 1. [environment variables starting with @HSPEC_@](https://hspec.github.io/options.html#specifying-options-through-environment-variables) -- 1. the provided list of command-line options (the second argument to @readConfig@) -- -- (precedence from low to high) -- -- When parsing fails then @readConfig@ writes an error message to `stderr` and -- exits with `exitFailure`. -- -- When @--help@ is provided as a command-line option then @readConfig@ writes -- a help message to `stdout` and exits with `exitSuccess`. -- -- A common way to use @readConfig@ is: -- -- @ -- `System.Environment.getArgs` >>= readConfig `defaultConfig` -- @ readConfig :: Config -> [String] -> IO Config readConfig opts_ args = do prog <- getProgName configFiles <- do ignore <- ignoreConfigFile opts_ args case ignore of True -> return [] False -> readConfigFiles env <- getEnvironment let envVar = words <$> lookup envVarName env case parseOptions opts_ prog configFiles envVar env args of Left (err, msg) -> exitWithMessage err msg Right (warnings, opts) -> do mapM_ (hPutStrLn stderr) warnings return opts readFailureReportOnRerun :: Config -> IO (Maybe FailureReport) readFailureReportOnRerun config | configRerun config = readFailureReport config | otherwise = return Nothing 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.10.10/src/Test/Hspec/Core/Config/0000755000000000000000000000000007346545000016741 5ustar0000000000000000hspec-core-2.10.10/src/Test/Hspec/Core/Config/Definition.hs0000644000000000000000000003701707346545000021375 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.Config.Definition ( Config(..) , ColorMode(..) , UnicodeMode(..) , filterOr , mkDefaultConfig , commandLineOnlyOptions , formatterOptions , smallCheckOptions , quickCheckOptions , runnerOptions #ifdef TEST , splitOn #endif ) where import Prelude () import Test.Hspec.Core.Compat import System.Directory (getTemporaryDirectory, removeFile) import System.IO (openTempFile, hClose) import System.Process (system) import Test.Hspec.Core.Example (Params(..), defaultParams) import Test.Hspec.Core.Format (Format, FormatConfig) import Test.Hspec.Core.Formatters.Pretty (pretty2) import qualified Test.Hspec.Core.Formatters.V1.Monad as V1 import Test.Hspec.Core.Util import GetOpt.Declarative data ColorMode = ColorAuto | ColorNever | ColorAlways deriving (Eq, Show) data UnicodeMode = UnicodeAuto | UnicodeNever | UnicodeAlways deriving (Eq, Show) data Config = Config { configIgnoreConfigFile :: Bool , configDryRun :: Bool , configFocusedOnly :: Bool , configFailOnEmpty :: Bool , configFailOnFocused :: Bool , configFailOnPending :: Bool , configPrintSlowItems :: Maybe Int , configPrintCpuTime :: Bool , configFailFast :: Bool , configRandomize :: 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 , configQuickCheckMaxShrinks :: Maybe Int , configSmallCheckDepth :: Maybe Int , configColorMode :: ColorMode , configUnicodeMode :: UnicodeMode , configDiff :: Bool , configDiffContext :: Maybe Int -- | -- An action that is used to print diffs. The first argument is the value of -- `configDiffContext`. The remaining two arguments are the @expected@ and -- @actual@ value. -- -- @since 2.10.6 , configExternalDiff :: Maybe (Maybe Int -> String -> String -> IO ()) , configPrettyPrint :: Bool , configPrettyPrintFunction :: Bool -> String -> String -> (String, String) , configTimes :: Bool , configAvailableFormatters :: [(String, FormatConfig -> IO Format)] -- ^ @since 2.9.0 , configFormat :: Maybe (FormatConfig -> IO Format) , configFormatter :: Maybe V1.Formatter -- ^ deprecated, use `configFormat` instead , configHtmlOutput :: Bool , configConcurrentJobs :: Maybe Int } mkDefaultConfig :: [(String, FormatConfig -> IO Format)] -> Config mkDefaultConfig formatters = Config { configIgnoreConfigFile = False , configDryRun = False , configFocusedOnly = False , configFailOnEmpty = False , configFailOnFocused = False , configFailOnPending = False , configPrintSlowItems = Nothing , configPrintCpuTime = False , configFailFast = False , configRandomize = False , configFailureReport = Nothing , configRerun = False , configRerunAllOnSuccess = False , configFilterPredicate = Nothing , configSkipPredicate = Nothing , configQuickCheckSeed = Nothing , configQuickCheckMaxSuccess = Nothing , configQuickCheckMaxDiscardRatio = Nothing , configQuickCheckMaxSize = Nothing , configQuickCheckMaxShrinks = Nothing , configSmallCheckDepth = paramsSmallCheckDepth defaultParams , configColorMode = ColorAuto , configUnicodeMode = UnicodeAuto , configDiff = True , configDiffContext = Just defaultDiffContext , configExternalDiff = Nothing , configPrettyPrint = True , configPrettyPrintFunction = pretty2 , configTimes = False , configAvailableFormatters = formatters , configFormat = Nothing , configFormatter = Nothing , configHtmlOutput = False , configConcurrentJobs = Nothing } defaultDiffContext :: Int defaultDiffContext = 3 externalDiff :: String -> String -> String -> IO () externalDiff command expected actual = do tmp <- getTemporaryDirectory withTempFile tmp "hspec-expected" expected $ \ expectedFile -> do withTempFile tmp "hspec-actual" actual $ \ actualFile -> do void . system $ unwords [command, expectedFile, actualFile] withTempFile :: FilePath -> FilePath -> String -> (FilePath -> IO a) -> IO a withTempFile dir file contents action = do bracket (openTempFile dir file) (removeFile . fst) $ \ (path, h) -> do hClose h writeFile path contents action path option :: String -> OptionSetter config -> String -> Option config option name arg help = Option name Nothing arg help True mkFlag :: String -> (Bool -> Config -> Config) -> String -> Option Config mkFlag name setter = option name (Flag setter) mkOptionNoArg :: String -> Maybe Char -> (Config -> Config) -> String -> Option Config mkOptionNoArg name shortcut setter help = Option name shortcut (NoArg setter) help True mkOption :: String -> Maybe Char -> OptionSetter Config -> String -> Option Config mkOption name shortcut arg help = Option name shortcut arg help True undocumented :: Option config -> Option config undocumented opt = opt {optionDocumented = False} argument :: String -> (String -> Maybe a) -> (a -> Config -> Config) -> OptionSetter Config argument name parser setter = Arg name $ \ input c -> flip setter c <$> parser input formatterOptions :: [(String, FormatConfig -> IO Format)] -> [Option Config] formatterOptions formatters = [ mkOption "format" (Just 'f') (argument "NAME" readFormatter setFormatter) helpForFormat , mkFlag "color" setColor "colorize the output" , mkFlag "unicode" setUnicode "output unicode" , mkFlag "diff" setDiff "show colorized diffs" , option "diff-context" (argument "N" readDiffContext setDiffContext) $ unlines [ "output N lines of diff context (default: " <> show defaultDiffContext <> ")" , "use a value of 'full' to see the full context" ] , option "diff-command" (argument "CMD" return setDiffCommand) "use an external diff command\nexample: --diff-command=\"git diff\"" , mkFlag "pretty" setPretty "try to pretty-print diff values" , mkFlag "times" setTimes "report times for individual spec items" , mkOptionNoArg "print-cpu-time" Nothing setPrintCpuTime "include used CPU time in summary" , printSlowItemsOption -- undocumented for now, as we probably want to change this to produce a -- standalone HTML report in the future , undocumented $ mkOptionNoArg "html" Nothing setHtml "produce HTML output" ] where setDiffCommand :: String -> Config -> Config setDiffCommand command config = config { configExternalDiff = case strip command of "" -> Nothing _ -> Just $ \ _context -> externalDiff command } setHtml config = config {configHtmlOutput = True} helpForFormat :: String helpForFormat = "use a custom formatter; this can be one of " ++ (formatOrList $ map fst formatters) readFormatter :: String -> Maybe (FormatConfig -> IO Format) readFormatter = (`lookup` formatters) setFormatter :: (FormatConfig -> IO Format) -> Config -> Config setFormatter f c = c {configFormat = Just f} setColor :: Bool -> Config -> Config setColor v config = config {configColorMode = if v then ColorAlways else ColorNever} setUnicode :: Bool -> Config -> Config setUnicode v config = config {configUnicodeMode = if v then UnicodeAlways else UnicodeNever} setDiff :: Bool -> Config -> Config setDiff v config = config {configDiff = v} readDiffContext :: String -> Maybe (Maybe Int) readDiffContext input = case input of "full" -> Just Nothing _ -> case readMaybe input of Nothing -> Nothing mn -> Just (find (>= 0) mn) setDiffContext :: Maybe Int -> Config -> Config setDiffContext value c = c { configDiffContext = value } setPretty :: Bool -> Config -> Config setPretty v config = config {configPrettyPrint = v} setTimes :: Bool -> Config -> Config setTimes v config = config {configTimes = v} setPrintCpuTime config = config {configPrintCpuTime = True} printSlowItemsOption :: Option Config printSlowItemsOption = Option name (Just 'p') (OptArg "N" arg) "print the N slowest spec items (default: 10)" True where name = "print-slow-items" setter :: Maybe Int -> Config -> Config setter v c = c {configPrintSlowItems = v} arg :: Maybe String -> Config -> Maybe Config arg = maybe (Just . (setter $ Just 10)) parseArg parseArg :: String -> Config -> Maybe Config parseArg input c = case readMaybe input of Nothing -> Nothing mn -> Just (setter (find (> 0) mn) c) smallCheckOptions :: [Option Config] smallCheckOptions = [ option "depth" (argument "N" readMaybe setDepth) "maximum depth of generated test values for SmallCheck properties" ] setDepth :: Int -> Config -> Config setDepth n c = c {configSmallCheckDepth = Just n} quickCheckOptions :: [Option Config] quickCheckOptions = [ Option "qc-max-success" (Just 'a') (argument "N" readMaybe setMaxSuccess) "maximum number of successful tests before a QuickCheck property succeeds" True , option "qc-max-discard" (argument "N" readMaybe setMaxDiscardRatio) "maximum number of discarded tests per successful test before giving up" , option "qc-max-size" (argument "N" readMaybe setMaxSize) "size to use for the biggest test cases" , option "qc-max-shrinks" (argument "N" readMaybe setMaxShrinks) "maximum number of shrinks to perform before giving up (a value of 0 turns shrinking off)" , option "seed" (argument "N" readMaybe setSeed) "used seed for QuickCheck properties" -- for compatibility with test-framework , undocumented $ option "maximum-generated-tests" (argument "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default" ] setMaxSuccess :: Int -> Config -> Config setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n} setMaxDiscardRatio :: Int -> Config -> Config setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n} setMaxSize :: Int -> Config -> Config setMaxSize n c = c {configQuickCheckMaxSize = Just n} setMaxShrinks :: Int -> Config -> Config setMaxShrinks n c = c {configQuickCheckMaxShrinks = Just n} setSeed :: Integer -> Config -> Config setSeed n c = c {configQuickCheckSeed = Just n} data FailOn = FailOnEmpty | FailOnFocused | FailOnPending deriving (Bounded, Enum) allFailOnItems :: [FailOn] allFailOnItems = [minBound .. maxBound] showFailOn :: FailOn -> String showFailOn item = case item of FailOnEmpty -> "empty" FailOnFocused -> "focused" FailOnPending -> "pending" readFailOn :: String -> Maybe FailOn readFailOn = (`lookup` items) where items = map (showFailOn &&& id) allFailOnItems splitOn :: Char -> String -> [String] splitOn sep = go where go xs = case break (== sep) xs of ("", "") -> [] (y, "") -> [y] (y, _ : ys) -> y : go ys runnerOptions :: [Option Config] runnerOptions = [ mkFlag "dry-run" setDryRun "pretend that everything passed; don't verify anything" , mkFlag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items" , undocumented $ mkFlag "fail-on-focused" setFailOnFocused "fail on focused spec items" , undocumented $ mkFlag "fail-on-pending" setFailOnPending "fail on pending spec items" , mkOption "fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems True )) helpForFailOn , mkOption "no-fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems False)) helpForFailOn , mkFlag "strict" setStrict $ "same as --fail-on=" <> showFailOnItems strict , mkFlag "fail-fast" setFailFast "abort on first failure" , mkFlag "randomize" setRandomize "randomize execution order" , mkOptionNoArg "rerun" (Just 'r') setRerun "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)" , option "failure-report" (argument "FILE" return setFailureReport) "read/write a failure report for use with --rerun" , mkOptionNoArg "rerun-all-on-success" Nothing setRerunAllOnSuccess "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)" , mkOption "jobs" (Just 'j') (argument "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)" ] where strict = [FailOnFocused, FailOnPending] readFailOnItems :: String -> Maybe [FailOn] readFailOnItems = mapM readFailOn . splitOn ',' showFailOnItems :: [FailOn] -> String showFailOnItems = intercalate "," . map showFailOn helpForFailOn :: String helpForFailOn = unlines . flip map allFailOnItems $ \ item -> showFailOn item <> ": " <> help item where help item = case item of FailOnEmpty -> "fail if all spec items have been filtered" FailOnFocused -> "fail on focused spec items" FailOnPending -> "fail on pending spec items" setFailOnItems :: Bool -> [FailOn] -> Config -> Config setFailOnItems value = flip $ foldr (`setItem` value) where setItem item = case item of FailOnEmpty -> setFailOnEmpty FailOnFocused -> setFailOnFocused FailOnPending -> setFailOnPending readMaxJobs :: String -> Maybe Int readMaxJobs s = do n <- readMaybe s guard $ n > 0 return n setFailureReport :: String -> Config -> Config setFailureReport file c = c {configFailureReport = Just file} setMaxJobs :: Int -> Config -> Config setMaxJobs n c = c {configConcurrentJobs = Just n} setDryRun :: Bool -> Config -> Config setDryRun value config = config {configDryRun = value} setFocusedOnly :: Bool -> Config -> Config setFocusedOnly value config = config {configFocusedOnly = value} setFailOnEmpty :: Bool -> Config -> Config setFailOnEmpty value config = config {configFailOnEmpty = value} setFailOnFocused :: Bool -> Config -> Config setFailOnFocused value config = config {configFailOnFocused = value} setFailOnPending :: Bool -> Config -> Config setFailOnPending value config = config {configFailOnPending = value} setStrict :: Bool -> Config -> Config setStrict = (`setFailOnItems` strict) setFailFast :: Bool -> Config -> Config setFailFast value config = config {configFailFast = value} setRandomize :: Bool -> Config -> Config setRandomize value config = config {configRandomize = value} setRerun config = config {configRerun = True} setRerunAllOnSuccess config = config {configRerunAllOnSuccess = True} commandLineOnlyOptions :: [Option Config] commandLineOnlyOptions = [ mkOptionNoArg "ignore-dot-hspec" Nothing setIgnoreConfigFile "do not read options from ~/.hspec and .hspec" , mkOption "match" (Just 'm') (argument "PATTERN" return addMatch) "only run examples that match given PATTERN" , option "skip" (argument "PATTERN" return addSkip) "skip examples that match given PATTERN" ] where setIgnoreConfigFile config = config {configIgnoreConfigFile = True} 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} 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_ formatOrList :: [String] -> String formatOrList xs = case xs of [] -> "" x : ys -> (case ys of [] -> x _ : [] -> x ++ " or " _ : _ : _ -> x ++ ", ") ++ formatOrList ys hspec-core-2.10.10/src/Test/Hspec/Core/Config/Options.hs0000644000000000000000000000751107346545000020734 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.Config.Options ( ConfigFile , envVarName , ignoreConfigFile , parseOptions ) where import Prelude () import Test.Hspec.Core.Compat import System.Exit import Test.Hspec.Core.Format (Format, FormatConfig) import Test.Hspec.Core.Config.Definition import qualified GetOpt.Declarative as Declarative import GetOpt.Declarative.Interpret (parse, interpretOptions, ParseResult(..)) type ConfigFile = (FilePath, [String]) type EnvVar = [String] envVarName :: String envVarName = "HSPEC_OPTIONS" commandLineOptions :: [(String, FormatConfig -> IO Format)] -> [(String, [Declarative.Option Config])] commandLineOptions formatters = ("OPTIONS", commandLineOnlyOptions) : otherOptions formatters otherOptions :: [(String, FormatConfig -> IO Format)] -> [(String, [Declarative.Option Config])] otherOptions formatters = [ ("RUNNER OPTIONS", runnerOptions) , ("FORMATTER OPTIONS", formatterOptions formatters) , ("OPTIONS FOR QUICKCHECK", quickCheckOptions) , ("OPTIONS FOR SMALLCHECK", smallCheckOptions) ] ignoreConfigFile :: Config -> [String] -> IO Bool ignoreConfigFile config args = do ignore <- lookupEnv "IGNORE_DOT_HSPEC" case ignore of Just _ -> return True Nothing -> case parseCommandLineOptions "" args config of Right c -> return (configIgnoreConfigFile c) _ -> return False parseOptions :: Config -> String -> [ConfigFile] -> Maybe EnvVar -> [(String, String)] -> [String] -> Either (ExitCode, String) ([String], Config) parseOptions config prog configFiles envVar env args = do foldM (parseFileOptions prog) config configFiles >>= maybe return (parseEnvVarOptions prog) envVar >>= parseEnvironmentOptions env >>= traverseTuple (parseCommandLineOptions prog args) traverseTuple :: Applicative f => (a -> f b) -> (c, a) -> f (c, b) #if MIN_VERSION_base(4,7,0) traverseTuple = traverse #else traverseTuple f (c, a) = (,) c <$> f a #endif parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config parseCommandLineOptions prog args config = case Declarative.parseCommandLineOptions (commandLineOptions formatters) prog args config of Success c -> Right c Help message -> Left (ExitSuccess, message) Failure message -> Left (ExitFailure 1, message) where formatters = configAvailableFormatters config parseEnvironmentOptions :: [(String, String)] -> Config -> Either (ExitCode, String) ([String], Config) parseEnvironmentOptions env config = case Declarative.parseEnvironmentOptions "HSPEC" env config (concatMap snd $ commandLineOptions formatters) of (warnings, c) -> Right (map formatWarning warnings, c) where formatters = configAvailableFormatters config formatWarning (Declarative.InvalidValue name value) = "invalid value `" ++ value ++ "' for environment variable " ++ name parseFileOptions :: String -> Config -> ConfigFile -> Either (ExitCode, String) Config parseFileOptions prog config (name, args) = parseOtherOptions prog ("in config file " ++ name) args config parseEnvVarOptions :: String -> EnvVar -> Config -> Either (ExitCode, String) Config parseEnvVarOptions prog = parseOtherOptions prog ("from environment variable " ++ envVarName) parseOtherOptions :: String -> String -> [String] -> Config -> Either (ExitCode, String) Config parseOtherOptions prog source args config = case parse (interpretOptions options) config args of Right c -> Right c Left err -> failure err where options :: [Declarative.Option Config] options = filter Declarative.optionDocumented $ concatMap snd (otherOptions formatters) formatters = configAvailableFormatters config failure err = Left (ExitFailure 1, prog ++ ": " ++ message) where message = unlines $ case lines err of [x] -> [x ++ " " ++ source] xs -> xs ++ [source] hspec-core-2.10.10/src/Test/Hspec/Core/Example.hs0000644000000000000000000001667107346545000017476 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} module Test.Hspec.Core.Example ( -- RE-EXPORTED from Test.Hspec.Core.Spec Example (..) , Params (..) , defaultParams , ActionWith , Progress , ProgressCallback , Result(..) , ResultStatus (..) , Location (..) , FailureReason (..) , safeEvaluate , safeEvaluateExample -- END RE-EXPORTED from Test.Hspec.Core.Spec , safeEvaluateResultStatus , exceptionToResultStatus , toLocation ) where import Prelude () import Test.Hspec.Core.Compat import qualified Test.HUnit.Lang as HUnit import Data.CallStack (SrcLoc(..)) 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 (numSuccessTests, maxSuccessTests) import qualified Test.QuickCheck.Property as QCP import Test.Hspec.Core.QuickCheckUtil import Test.Hspec.Core.Util import Test.Hspec.Core.Example.Location -- | 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 :: Maybe Int } deriving (Show) defaultParams :: Params defaultParams = Params { paramsQuickCheckArgs = QC.stdArgs , paramsSmallCheckDepth = Nothing } 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 = Result { resultInfo :: String , resultStatus :: ResultStatus } deriving (Show, Typeable) data ResultStatus = Success | Pending (Maybe Location) (Maybe String) | Failure (Maybe Location) FailureReason deriving (Show, Typeable) data FailureReason = NoReason | Reason String | ExpectedButGot (Maybe String) String String | Error (Maybe String) SomeException deriving (Show, 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` () Error m e -> m `deepseq` show e `deepseq` () instance Exception ResultStatus forceResult :: Result -> Result forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r forceResultStatus :: ResultStatus -> ResultStatus forceResultStatus r = case r of Success -> r Pending _ m -> m `deepseq` r Failure _ m -> m `deepseq` r safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result safeEvaluateExample example params around progress = safeEvaluate $ evaluateExample example params around progress safeEvaluate :: IO Result -> IO Result safeEvaluate action = do r <- safeTry $ forceResult <$> action case r of Left e -> Result "" <$> exceptionToResultStatus e Right result -> return result safeEvaluateResultStatus :: IO ResultStatus -> IO ResultStatus safeEvaluateResultStatus action = do r <- safeTry $ forceResultStatus <$> action case r of Left e -> exceptionToResultStatus e Right status -> return status exceptionToResultStatus :: SomeException -> IO ResultStatus exceptionToResultStatus = safeEvaluateResultStatus . pure . toResultStatus where toResultStatus :: SomeException -> ResultStatus toResultStatus e | Just result <- fromException e = result | Just hunit <- fromException e = hunitFailureToResult Nothing hunit | otherwise = Failure Nothing $ Error Nothing e instance Example Result where type Arg Result = () evaluateExample e = evaluateExample (\() -> e) instance Example (a -> Result) where type Arg (a -> Result) = a evaluateExample example _params hook _callback = do liftHook (Result "" Success) hook (evaluate . example) instance Example Bool where type Arg Bool = () evaluateExample e = evaluateExample (\() -> e) instance Example (a -> Bool) where type Arg (a -> Bool) = a evaluateExample p _params hook _callback = do liftHook (Result "" Success) hook (evaluate . example) where example a | p a = Result "" Success | otherwise = Result "" $ Failure Nothing NoReason instance Example Expectation where type Arg Expectation = () evaluateExample e = evaluateExample (\() -> e) hunitFailureToResult :: Maybe String -> HUnit.HUnitFailure -> ResultStatus hunitFailureToResult pre e = case e of HUnit.HUnitFailure mLoc err -> case err of HUnit.Reason reason -> Failure location (Reason $ addPre reason) HUnit.ExpectedButGot preface expected actual -> Failure location (ExpectedButGot (addPreMaybe preface) expected actual) where addPreMaybe :: Maybe String -> Maybe String addPreMaybe xs = case (pre, xs) of (Just x, Just y) -> Just (x ++ "\n" ++ y) _ -> pre <|> xs where location = case mLoc of Nothing -> Nothing Just loc -> Just $ toLocation loc where addPre :: String -> String addPre xs = case pre of Just x -> x ++ "\n" ++ xs Nothing -> xs toLocation :: SrcLoc -> Location toLocation loc = Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) instance Example (a -> Expectation) where type Arg (a -> Expectation) = a evaluateExample e _ hook _ = hook e >> return (Result "" 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 hook progressCallback = do r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty hook p) return $ fromQuickCheckResult r where qcProgressCallback = QCP.PostTest QCP.NotCounterexample $ \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st) fromQuickCheckResult :: QC.Result -> Result fromQuickCheckResult r = case parseQuickCheckResult r of QuickCheckResult _ info (QuickCheckOtherFailure err) -> Result info $ Failure Nothing (Reason err) QuickCheckResult _ info QuickCheckSuccess -> Result info Success QuickCheckResult n info (QuickCheckFailure QCFailure{..}) -> case quickCheckFailureException of Just e | Just result <- fromException e -> Result info result Just e | Just hunit <- fromException e -> Result info $ hunitFailureToResult (Just hunitAssertion) hunit Just e -> failure (uncaughtException e) Nothing -> failure falsifiable where failure = Result info . Failure Nothing . Reason numbers = formatNumbers n quickCheckFailureNumShrinks hunitAssertion :: String hunitAssertion = intercalate "\n" [ "Falsifiable " ++ numbers ++ ":" , indent (unlines quickCheckFailureCounterexample) ] uncaughtException e = intercalate "\n" [ "uncaught exception: " ++ formatException e , numbers , indent (unlines quickCheckFailureCounterexample) ] falsifiable = intercalate "\n" [ quickCheckFailureReason ++ " " ++ numbers ++ ":" , indent (unlines quickCheckFailureCounterexample) ] indent :: String -> String indent = intercalate "\n" . map (" " ++) . lines hspec-core-2.10.10/src/Test/Hspec/Core/Example/0000755000000000000000000000000007346545000017127 5ustar0000000000000000hspec-core-2.10.10/src/Test/Hspec/Core/Example/Location.hs0000644000000000000000000001011707346545000021233 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.Example.Location ( Location(..) , extractLocation #ifdef TEST , parseAssertionFailed , parseCallStack , parseLocation , parseSourceSpan , workaroundForIssue19236 #endif ) where import Prelude () import Test.Hspec.Core.Compat import Data.Char import GHC.IO.Exception #ifdef mingw32_HOST_OS import System.FilePath #endif -- | @Location@ is used to represent source locations. data Location = Location { locationFile :: FilePath , locationLine :: Int , locationColumn :: Int } deriving (Eq, Show, Read) extractLocation :: SomeException -> Maybe Location extractLocation e = locationFromErrorCall e <|> locationFromPatternMatchFail e <|> locationFromRecConError e <|> locationFromIOException e <|> locationFromNoMethodError e <|> locationFromAssertionFailed e locationFromNoMethodError :: SomeException -> Maybe Location locationFromNoMethodError e = case fromException e of Just (NoMethodError s) -> listToMaybe (words s) >>= parseSourceSpan Nothing -> Nothing locationFromAssertionFailed :: SomeException -> Maybe Location locationFromAssertionFailed e = case fromException e of Just (AssertionFailed loc) -> parseAssertionFailed loc Nothing -> Nothing parseAssertionFailed :: String -> Maybe Location parseAssertionFailed loc = parseCallStack loc <|> parseSourceSpan loc locationFromErrorCall :: SomeException -> Maybe Location locationFromErrorCall e = case fromException e of #if MIN_VERSION_base(4,9,0) Just (ErrorCallWithLocation err loc) -> parseCallStack loc <|> #else Just (ErrorCall err) -> #endif fromPatternMatchFailureInDoExpression err Nothing -> Nothing locationFromPatternMatchFail :: SomeException -> Maybe Location locationFromPatternMatchFail e = case fromException e of Just (PatternMatchFail s) -> listToMaybe (words s) >>= parseSourceSpan Nothing -> Nothing locationFromRecConError :: SomeException -> Maybe Location locationFromRecConError e = case fromException e of Just (RecConError s) -> listToMaybe (words s) >>= parseSourceSpan Nothing -> Nothing locationFromIOException :: SomeException -> Maybe Location locationFromIOException e = case fromException e of Just (IOError {ioe_type = UserError, ioe_description = xs}) -> fromPatternMatchFailureInDoExpression xs Just _ -> Nothing Nothing -> Nothing fromPatternMatchFailureInDoExpression :: String -> Maybe Location fromPatternMatchFailureInDoExpression input = #if MIN_VERSION_base(4,16,0) stripPrefix "Pattern match failure in 'do' block at " input >>= parseSourceSpan #else stripPrefix "Pattern match failure in do expression at " input >>= parseSourceSpan #endif parseCallStack :: String -> Maybe Location parseCallStack input = case reverse (lines input) of [] -> Nothing line : _ -> findLocation line where findLocation xs = case xs of [] -> Nothing _ : ys -> case stripPrefix prefix xs of Just zs -> parseLocation (takeWhile (not . isSpace) zs) Nothing -> findLocation ys prefix = ", called at " parseLocation :: String -> Maybe Location parseLocation input = case fmap breakColon (breakColon input) of (file, (line, column)) -> mkLocation file <$> readMaybe line <*> readMaybe column parseSourceSpan :: String -> Maybe Location parseSourceSpan input = case breakColon input of (file, xs) -> (uncurry $ mkLocation file) <$> (tuple <|> colonSeparated) where lineAndColumn :: String lineAndColumn = takeWhile (/= '-') xs tuple :: Maybe (Int, Int) tuple = readMaybe lineAndColumn colonSeparated :: Maybe (Int, Int) colonSeparated = case breakColon lineAndColumn of (l, c) -> (,) <$> readMaybe l <*> readMaybe c breakColon :: String -> (String, String) breakColon = fmap (drop 1) . break (== ':') mkLocation :: FilePath -> Int -> Int -> Location mkLocation file line column = Location (workaroundForIssue19236 file) line column workaroundForIssue19236 :: FilePath -> FilePath -- https://gitlab.haskell.org/ghc/ghc/-/issues/19236 workaroundForIssue19236 = #ifdef mingw32_HOST_OS joinPath . splitDirectories #else id #endif hspec-core-2.10.10/src/Test/Hspec/Core/FailureReport.hs0000644000000000000000000000442107346545000020654 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.FailureReport ( FailureReport (..) , writeFailureReport , readFailureReport ) where import Prelude () import Test.Hspec.Core.Compat #ifndef __GHCJS__ import System.SetEnv (setEnv) import Test.Hspec.Core.Util (safeTry) #endif import System.IO import System.Directory import Test.Hspec.Core.Util (Path) import Test.Hspec.Core.Config.Definition (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. pass #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.10.10/src/Test/Hspec/Core/Format.hs0000644000000000000000000000543107346545000017323 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ExistentialQuantification #-} -- | -- Stability: experimental module Test.Hspec.Core.Format ( Format , FormatConfig(..) , Event(..) , Progress , Path , Location(..) , Seconds(..) , Item(..) , Result(..) , FailureReason(..) , monadic ) where import Prelude () import Test.Hspec.Core.Compat import Control.Concurrent import Control.Concurrent.Async (Async, async) import qualified Control.Concurrent.Async as Async import Control.Monad.IO.Class import Test.Hspec.Core.Example (Progress, Location(..), FailureReason(..)) import Test.Hspec.Core.Util (Path) import Test.Hspec.Core.Clock (Seconds(..)) type Format = Event -> IO () data Item = Item { itemLocation :: Maybe Location , itemDuration :: Seconds , itemInfo :: String , itemResult :: Result } deriving Show data Result = Success | Pending (Maybe Location) (Maybe String) | Failure (Maybe Location) FailureReason deriving Show data Event = Started | GroupStarted Path | GroupDone Path | Progress Path Progress | ItemStarted Path | ItemDone Path Item | Done [(Path, Item)] deriving Show data FormatConfig = FormatConfig { formatConfigUseColor :: Bool , formatConfigReportProgress :: Bool , formatConfigOutputUnicode :: Bool , formatConfigUseDiff :: Bool , formatConfigDiffContext :: Maybe Int , formatConfigExternalDiff :: Maybe (String -> String -> IO ()) , formatConfigPrettyPrint :: Bool -- ^ Deprecated: use `formatConfigPrettyPrintFunction` instead , formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String)) , formatConfigPrintTimes :: Bool , formatConfigHtmlOutput :: Bool , formatConfigPrintCpuTime :: Bool , formatConfigUsedSeed :: Integer , formatConfigExpectedTotalCount :: Int } data Signal = Ok | NotOk SomeException monadic :: MonadIO m => (m () -> IO ()) -> (Event -> m ()) -> IO Format monadic run format = do mvar <- newEmptyMVar done <- newEmptyMVar let putEvent :: Event -> IO () putEvent = putMVar mvar takeEvent :: MonadIO m => m Event takeEvent = liftIO $ takeMVar mvar signal :: MonadIO m => Signal -> m () signal = liftIO . putMVar done wait :: IO Signal wait = takeMVar done go = do event <- takeEvent format event case event of Done {} -> pass _ -> do signal Ok go worker <- async $ do (run go >> signal Ok) `catch` (signal . NotOk) return $ \ event -> do running <- asyncRunning worker when running $ do putEvent event r <- wait case r of Ok -> pass NotOk err -> do Async.wait worker throwIO err asyncRunning :: Async () -> IO Bool asyncRunning worker = maybe True (const False) <$> Async.poll worker hspec-core-2.10.10/src/Test/Hspec/Core/Formatters.hs0000644000000000000000000000036207346545000020217 0ustar0000000000000000-- | -- Deprecated\: Use "Test.Hspec.Core.Formatters.V1" instead. module Test.Hspec.Core.Formatters -- {-# DEPRECATED "Use \"Test.Hspec.Core.Formatters.V1\" instead." #-} (module V1) where import Test.Hspec.Core.Formatters.V1 as V1 hspec-core-2.10.10/src/Test/Hspec/Core/Formatters/0000755000000000000000000000000007346545000017662 5ustar0000000000000000hspec-core-2.10.10/src/Test/Hspec/Core/Formatters/Diff.hs0000644000000000000000000000704707346545000021076 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} module Test.Hspec.Core.Formatters.Diff ( Diff (..) , diff #ifdef TEST , partition , breakList #endif ) where import Prelude () import Test.Hspec.Core.Compat hiding (First) import Data.Char import qualified Data.Algorithm.Diff as Diff data Diff = First String | Second String | Both String | Omitted Int deriving (Eq, Show) -- | -- Split a string at line boundaries. -- -- >>> splitLines "foo\nbar\nbaz" -- ["foo\n","bar\n","baz"] -- -- prop> concat (splitLines xs) == xs splitLines :: String -> [String] splitLines = go where go xs = case break (== '\n') xs of (ys, '\n' : zs) -> (ys ++ ['\n']) : go zs ("", "") -> [] _ -> [xs] data TrimMode = FirstChunck | Chunck | LastChunck trim :: Int -> [Diff] -> [Diff] trim context = \ chunks -> case chunks of [] -> [] x : xs -> trimChunk FirstChunck x (go xs) where omitThreshold = 3 go chunks = case chunks of [] -> [] [x] -> trimChunk LastChunck x [] x : xs -> trimChunk Chunck x (go xs) trimChunk mode chunk = case chunk of Both xs | omitted >= omitThreshold -> keep start . (Omitted omitted :) . keep end where omitted :: Int omitted = n - keepStart - keepEnd keepStart :: Int keepStart = case mode of FirstChunck -> 0 _ -> succ context keepEnd :: Int keepEnd = case mode of LastChunck -> 0 _ -> if xs `endsWith` "\n" then context else succ context n :: Int n = length allLines allLines :: [String] allLines = splitLines xs start :: [String] start = take keepStart allLines end :: [String] end = drop (keepStart + omitted) allLines _ -> (chunk :) keep xs | null xs = id | otherwise = (Both (concat xs) :) diff :: Maybe Int -> String -> String -> [Diff] diff context expected actual = maybe id trim context $ map (toDiff . fmap concat) $ Diff.getGroupedDiff (partition expected) (partition actual) toDiff :: Diff.Diff String -> Diff toDiff d = case d of Diff.First xs -> First xs Diff.Second xs -> Second xs Diff.Both xs _ -> Both xs partition :: String -> [String] partition = filter (not . null) . mergeBackslashes . breakList isAlphaNum where mergeBackslashes :: [String] -> [String] mergeBackslashes xs = case xs of ['\\'] : (splitEscape -> Just (escape, ys)) : zs -> ("\\" ++ escape) : 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 :) splitEscape :: String -> Maybe (String, String) splitEscape xs = splitNumericEscape xs <|> (msum $ map split escapes) where split :: String -> Maybe (String, String) split escape = (,) escape <$> stripPrefix escape xs splitNumericEscape :: String -> Maybe (String, String) splitNumericEscape xs = case span isDigit xs of ("", _) -> Nothing r -> Just r escapes :: [String] escapes = [ "ACK" , "CAN" , "DC1" , "DC2" , "DC3" , "DC4" , "DEL" , "DLE" , "ENQ" , "EOT" , "ESC" , "ETB" , "ETX" , "NAK" , "NUL" , "SOH" , "STX" , "SUB" , "SYN" , "EM" , "FS" , "GS" , "RS" , "SI" , "SO" , "US" , "a" , "b" , "f" , "n" , "r" , "t" , "v" , "&" , "'" , "\"" , "\\" ] hspec-core-2.10.10/src/Test/Hspec/Core/Formatters/Internal.hs0000644000000000000000000002616407346545000022003 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} module Test.Hspec.Core.Formatters.Internal ( Formatter(..) , Item(..) , Result(..) , FailureReason(..) , FormatM , formatterToFormat , getSuccessCount , getPendingCount , getFailCount , getTotalCount , getExpectedTotalCount , FailureRecord(..) , getFailMessages , usedSeed , printTimes , getCPUTime , getRealTime , write , writeLine , writeTransient , withInfoColor , withSuccessColor , withPendingColor , withFailColor , outputUnicode , useDiff , diffContext , externalDiffAction , prettyPrint , prettyPrintFunction , extraChunk , missingChunk #ifdef TEST , runFormatM , splitLines #endif ) where import Prelude () import Test.Hspec.Core.Compat import qualified System.IO as IO import System.IO (Handle, stdout) import System.Console.ANSI import Control.Monad.Trans.State hiding (state, gets, modify) import Control.Monad.IO.Class import Data.Char (isSpace) import Data.List (groupBy) import qualified System.CPUTime as CPUTime import Test.Hspec.Core.Formatters.V1.Monad (FailureRecord(..)) import Test.Hspec.Core.Format import Test.Hspec.Core.Clock data Formatter = Formatter { -- | evaluated before a test run formatterStarted :: FormatM () -- | evaluated before each spec group , formatterGroupStarted :: Path -> FormatM () -- | evaluated after each spec group , formatterGroupDone :: Path -> FormatM () -- | used to notify the progress of the currently evaluated example , formatterProgress :: Path -> Progress -> FormatM () -- | evaluated before each spec item , formatterItemStarted :: Path -> FormatM () -- | evaluated after each spec item , formatterItemDone :: Path -> Item -> FormatM () -- | evaluated after a test run , formatterDone :: FormatM () } formatterToFormat :: Formatter -> FormatConfig -> IO Format formatterToFormat Formatter{..} config = monadic (runFormatM config) $ \ event -> case event of Started -> formatterStarted GroupStarted path -> formatterGroupStarted path GroupDone path -> formatterGroupDone path Progress path progress -> formatterProgress path progress ItemStarted path -> formatterItemStarted path ItemDone path item -> do case itemResult item of Success {} -> increaseSuccessCount Pending {} -> increasePendingCount Failure loc err -> addFailure $ FailureRecord (loc <|> itemLocation item) path err formatterItemDone path item Done _ -> formatterDone where addFailure r = modify $ \ s -> s { stateFailMessages = r : stateFailMessages s } -- | Get the number of failed examples encountered so far. getFailCount :: FormatM Int getFailCount = length <$> getFailMessages -- | Return `True` if the user requested colorized diffs, `False` otherwise. useDiff :: FormatM Bool useDiff = getConfig formatConfigUseDiff -- | -- Return the value of `Test.Hspec.Core.Runner.configDiffContext`. -- -- @since 2.10.6 diffContext :: FormatM (Maybe Int) diffContext = getConfig formatConfigDiffContext -- | An action for printing diffs. -- -- The action takes @expected@ and @actual@ as arguments. -- -- When this is a `Just`-value then it should be used instead of any built-in -- diff implementation. A `Just`-value also implies that `useDiff` returns -- `True`. -- -- @since 2.10.6 externalDiffAction :: FormatM (Maybe (String -> String -> IO ())) externalDiffAction = getConfig formatConfigExternalDiff -- | Return `True` if the user requested pretty diffs, `False` otherwise. prettyPrint :: FormatM Bool prettyPrint = maybe False (const True) <$> getConfig formatConfigPrettyPrintFunction {-# DEPRECATED prettyPrint "use `prettyPrintFunction` instead" #-} -- | Return a function for pretty-printing if the user requested pretty diffs, -- `Nothing` otherwise. -- -- @since 2.10.0 prettyPrintFunction :: FormatM (Maybe (String -> String -> (String, String))) prettyPrintFunction = getConfig formatConfigPrettyPrintFunction -- | Return `True` if the user requested unicode output, `False` otherwise. -- -- @since 2.9.0 outputUnicode :: FormatM Bool outputUnicode = getConfig formatConfigOutputUnicode -- | The same as `write`, but adds a newline character. writeLine :: String -> FormatM () writeLine s = write s >> write "\n" -- | Return `True` if the user requested time reporting for individual spec -- items, `False` otherwise. printTimes :: FormatM Bool printTimes = gets (formatConfigPrintTimes . stateConfig) -- | Get the total number of examples encountered so far. getTotalCount :: FormatM Int getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount] -- | 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 { stateSuccessCount :: !Int , statePendingCount :: !Int , stateFailMessages :: [FailureRecord] , stateCpuStartTime :: Maybe Integer , stateStartTime :: Seconds , stateConfig :: FormatConfig , stateColor :: Maybe SGR } getConfig :: (FormatConfig -> a) -> FormatM a getConfig f = gets (f . stateConfig) getHandle :: FormatM Handle getHandle = return stdout -- | The random seed that is used for QuickCheck. usedSeed :: FormatM Integer usedSeed = getConfig formatConfigUsedSeed -- 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 :: FormatConfig -> FormatM a -> IO a runFormatM config (FormatM action) = withLineBuffering $ do time <- getMonotonicTime cpuTime <- if formatConfigPrintCpuTime config then Just <$> CPUTime.getCPUTime else pure Nothing let progress = formatConfigReportProgress config && not (formatConfigHtmlOutput config) state = FormatterState { stateSuccessCount = 0 , statePendingCount = 0 , stateFailMessages = [] , stateCpuStartTime = cpuTime , stateStartTime = time , stateConfig = config { formatConfigReportProgress = progress } , stateColor = Nothing } newIORef state >>= evalStateT action withLineBuffering :: IO a -> IO a withLineBuffering action = bracket (IO.hGetBuffering stdout) (IO.hSetBuffering stdout) $ \ _ -> do IO.hSetBuffering stdout IO.LineBuffering >> action -- | Increase the counter for successful examples increaseSuccessCount :: FormatM () increaseSuccessCount = modify $ \s -> s {stateSuccessCount = succ $ stateSuccessCount s} -- | Increase the counter for pending examples increasePendingCount :: FormatM () increasePendingCount = modify $ \s -> s {statePendingCount = succ $ statePendingCount s} -- | Get the number of successful examples encountered so far. getSuccessCount :: FormatM Int getSuccessCount = gets stateSuccessCount -- | Get the number of pending examples encountered so far. getPendingCount :: FormatM Int getPendingCount = gets statePendingCount -- | Get the list of accumulated failure messages. getFailMessages :: FormatM [FailureRecord] getFailMessages = reverse `fmap` gets stateFailMessages -- | Get the number of spec items that will have been encountered when this run -- completes (if it is not terminated early). -- -- @since 2.9.0 getExpectedTotalCount :: FormatM Int getExpectedTotalCount = getConfig formatConfigExpectedTotalCount writeTransient :: String -> FormatM () writeTransient new = do reportProgress <- getConfig formatConfigReportProgress when reportProgress $ do h <- getHandle write new liftIO $ IO.hFlush h write $ "\r" ++ replicate (length new) ' ' ++ "\r" -- | Append some output to the report. write :: String -> FormatM () write = mapM_ writeChunk . splitLines splitLines :: String -> [String] splitLines = groupBy (\ a b -> isNewline a == isNewline b) where isNewline = (== '\n') writeChunk :: String -> FormatM () writeChunk str = do h <- getHandle let plainOutput = IO.hPutStr h str colorOutput color = bracket_ (hSetSGR h [color]) (hSetSGR h [Reset]) plainOutput mColor <- gets stateColor liftIO $ case mColor of Just (SetColor Foreground _ _) | all isSpace str -> plainOutput Just color -> colorOutput color Nothing -> plainOutput -- | 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 produceHTML <- getConfig formatConfigHtmlOutput (if produceHTML 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 action = do oldColor <- gets stateColor setColor (Just color) *> action <* setColor oldColor setColor :: Maybe SGR -> FormatM () setColor color = do useColor <- getConfig formatConfigUseColor when useColor $ do modify (\ state -> state { stateColor = color }) -- | Output given chunk in red. extraChunk :: String -> FormatM () extraChunk s = do diff <- getConfig formatConfigUseDiff case diff of True -> extra s False -> write s where extra :: String -> FormatM () extra = diffColorize Red "hspec-failure" -- | Output given chunk in green. missingChunk :: String -> FormatM () missingChunk s = do diff <- getConfig formatConfigUseDiff case diff of True -> missing s False -> write s where missing :: String-> FormatM () missing = diffColorize Green "hspec-success" diffColorize :: Color -> String -> String-> FormatM () diffColorize color cls s = withColor (SetColor layer Dull color) cls $ do write s where layer | all isSpace s = Background | otherwise = Foreground -- | Get the used CPU time since the test run has been started. getCPUTime :: FormatM (Maybe Seconds) getCPUTime = do t1 <- liftIO CPUTime.getCPUTime mt0 <- gets stateCpuStartTime return $ toSeconds <$> ((t1 -) <$> mt0) where toSeconds x = Seconds (fromIntegral x / (10.0 ^ (12 :: Integer))) -- | Get the passed real time since the test run has been started. getRealTime :: FormatM Seconds getRealTime = do t1 <- liftIO getMonotonicTime t0 <- gets stateStartTime return (t1 - t0) hspec-core-2.10.10/src/Test/Hspec/Core/Formatters/Pretty.hs0000644000000000000000000000644707346545000021520 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Test.Hspec.Core.Formatters.Pretty ( pretty2 #ifdef TEST , pretty , recoverString , recoverMultiLineString #endif ) where import Prelude () import Test.Hspec.Core.Compat hiding (shows, intercalate) import Data.Char import Data.String import Data.List (intersperse) import qualified Text.Show as Show import Test.Hspec.Core.Formatters.Pretty.Unicode import Test.Hspec.Core.Formatters.Pretty.Parser pretty2 :: Bool -> String -> String -> (String, String) pretty2 unicode expected actual = case (recoverMultiLineString unicode expected, recoverMultiLineString unicode actual) of (Just expected_, Just actual_) -> (expected_, actual_) _ -> case (pretty unicode expected, pretty unicode actual) of (Just expected_, Just actual_) | expected_ /= actual_ -> (expected_, actual_) _ -> (expected, actual) recoverString :: String -> Maybe String recoverString xs = case xs of '"' : _ -> case reverse xs of '"' : _ -> readMaybe xs _ -> Nothing _ -> Nothing recoverMultiLineString :: Bool -> String -> Maybe String recoverMultiLineString unicode input = case recoverString input of Just r | shouldParseBack r -> Just r _ -> Nothing where shouldParseBack = (&&) <$> all isSafe <*> isMultiLine isMultiLine = lines >>> length >>> (> 1) isSafe c = (unicode || isAscii c) && not (isControl c) || c == '\n' pretty :: Bool -> String -> Maybe String pretty unicode = parseValue >=> render_ where render_ :: Value -> Maybe String render_ value = guard (shouldParseBack value) >> Just (renderValue unicode value) shouldParseBack :: Value -> Bool shouldParseBack = go where go value = case value of Char _ -> False String _ -> True Rational _ _ -> False Number _ -> False Record _ _ -> True Constructor _ xs -> any go xs Tuple xs -> any go xs List xs -> any go xs newtype Builder = Builder ShowS instance Monoid Builder where mempty = Builder id #if MIN_VERSION_base(4,11,0) instance Semigroup Builder where #endif Builder xs #if MIN_VERSION_base(4,11,0) <> #else `mappend` #endif Builder ys = Builder (xs . ys) runBuilder :: Builder -> String runBuilder (Builder xs) = xs "" intercalate :: Builder -> [Builder] -> Builder intercalate x xs = mconcat $ intersperse x xs shows :: Show a => a -> Builder shows = Builder . Show.shows instance IsString Builder where fromString = Builder . showString renderValue :: Bool -> Value -> String renderValue unicode = runBuilder . render where render :: Value -> Builder render value = case value of Char c -> shows c String str -> if unicode then Builder $ ushows str else shows str Rational n d -> render n <> " % " <> render d Number n -> fromString n Record name fields -> fromString name <> " {\n " <> (intercalate ",\n " $ map renderField fields) <> "\n}" Constructor name values -> intercalate " " (fromString name : map render values) Tuple [e@Record{}] -> render e Tuple xs -> "(" <> intercalate ", " (map render xs) <> ")" List xs -> "[" <> intercalate ", " (map render xs) <> "]" renderField (name, value) = fromString name <> " = " <> render value hspec-core-2.10.10/src/Test/Hspec/Core/Formatters/Pretty/0000755000000000000000000000000007346545000021151 5ustar0000000000000000hspec-core-2.10.10/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs0000644000000000000000000000501107346545000022736 0ustar0000000000000000module Test.Hspec.Core.Formatters.Pretty.Parser ( Value(..) , parseValue ) where import Prelude () import Test.Hspec.Core.Compat import Test.Hspec.Core.Formatters.Pretty.Parser.Parser hiding (Parser) import qualified Test.Hspec.Core.Formatters.Pretty.Parser.Parser as P import Language.Haskell.Lexer hiding (Pos(..)) type Name = String data Value = Char Char | String String | Rational Value Value | Number String | Record Name [(Name, Value)] | Constructor Name [Value] | Tuple [Value] | List [Value] deriving (Eq, Show) type Parser = P.Parser (Token, String) parseValue :: String -> Maybe Value parseValue input = case runParser value (tokenize input) of Just (v, []) -> Just v _ -> Nothing value :: Parser Value value = char <|> string <|> rational <|> number <|> record <|> constructor <|> tuple <|> list char :: Parser Value char = Char <$> (token CharLit >>= readA) string :: Parser Value string = String <$> (token StringLit >>= readA) rational :: Parser Value rational = Rational <$> (number <|> tuple) <* require (Varsym, "%") <*> number number :: Parser Value number = integer <|> float where integer :: Parser Value integer = Number <$> token IntLit float :: Parser Value float = Number <$> token FloatLit record :: Parser Value record = Record <$> token Conid <* special "{" <*> fields <* special "}" where fields :: Parser [(Name, Value)] fields = field `sepBy1` comma field :: Parser (Name, Value) field = (,) <$> token Varid <* equals <*> value constructor :: Parser Value constructor = Constructor <$> token Conid <*> many value tuple :: Parser Value tuple = Tuple <$> (special "(" *> items) <* special ")" list :: Parser Value list = List <$> (special "[" *> items) <* special "]" items :: Parser [Value] items = value `sepBy` comma special :: String -> Parser () special s = require (Special, s) comma :: Parser () comma = special "," equals :: Parser () equals = require (Reservedop, "=") token :: Token -> Parser String token t = snd <$> satisfy (fst >>> (== t)) require :: (Token, String) -> Parser () require t = void $ satisfy (== t) tokenize :: String -> [(Token, String)] tokenize = go . map (fmap snd) . rmSpace . lexerPass0 where go :: [(Token, String)] -> [(Token, String)] go tokens = case tokens of [] -> [] (Varsym, "-") : (IntLit, n) : xs -> (IntLit, "-" ++ n) : go xs (Varsym, "-") : (FloatLit, n) : xs -> (FloatLit, "-" ++ n) : go xs x : xs -> x : go xs hspec-core-2.10.10/src/Test/Hspec/Core/Formatters/Pretty/Parser/0000755000000000000000000000000007346545000022405 5ustar0000000000000000hspec-core-2.10.10/src/Test/Hspec/Core/Formatters/Pretty/Parser/Parser.hs0000644000000000000000000000202607346545000024175 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} module Test.Hspec.Core.Formatters.Pretty.Parser.Parser where import Prelude () import Test.Hspec.Core.Compat newtype Parser token a = Parser { runParser :: [token] -> Maybe (a, [token]) } deriving Functor instance Applicative (Parser token) where pure a = Parser $ \ input -> Just (a, input) (<*>) = ap instance Monad (Parser token) where return = pure p1 >>= p2 = Parser $ runParser p1 >=> uncurry (runParser . p2) instance Alternative (Parser token) where empty = Parser $ const Nothing p1 <|> p2 = Parser $ \ input -> runParser p1 input <|> runParser p2 input satisfy :: (token -> Bool) -> Parser token token satisfy p = Parser $ \ input -> case input of t : ts | p t -> Just (t, ts) _ -> Nothing sepBy :: Alternative m => m a -> m sep -> m [a] sepBy p sep = sepBy1 p sep <|> pure [] sepBy1 :: Alternative m => m a -> m sep -> m [a] sepBy1 p sep = (:) <$> p <*> many (sep *> p) readA :: (Alternative m, Read a) => String -> m a readA = maybe empty pure . readMaybe hspec-core-2.10.10/src/Test/Hspec/Core/Formatters/Pretty/Unicode.hs0000644000000000000000000000126007346545000023072 0ustar0000000000000000module Test.Hspec.Core.Formatters.Pretty.Unicode ( ushow , ushows ) where import Prelude () import Test.Hspec.Core.Compat import Data.Char ushow :: String -> String ushow xs = ushows xs "" ushows :: String -> ShowS ushows = uShowString uShowString :: String -> ShowS uShowString cs = showChar '"' . showLitString cs . showChar '"' showLitString :: String -> ShowS showLitString [] s = s showLitString ('"' : cs) s = showString "\\\"" (showLitString cs s) showLitString (c : cs) s = uShowLitChar c (showLitString cs s) uShowLitChar :: Char -> ShowS uShowLitChar c | isPrint c && not (isAscii c) = showChar c | otherwise = showLitChar c hspec-core-2.10.10/src/Test/Hspec/Core/Formatters/V1.hs0000644000000000000000000002476207346545000020517 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -- | -- Stability: deprecated -- -- This module contains formatters that can be used with -- `Test.Hspec.Core.Runner.hspecWith`. module Test.Hspec.Core.Formatters.V1 ( -- * Formatters silent , checks , 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 , formatterToFormat -- ** Accessing the runner state , getSuccessCount , getPendingCount , getFailCount , getTotalCount , FailureRecord (..) , getFailMessages , usedSeed , Seconds(..) , getCPUTime , getRealTime -- ** Appending to the generated report , write , writeLine , writeTransient -- ** Dealing with colors , withInfoColor , withSuccessColor , withPendingColor , withFailColor , useDiff , extraChunk , missingChunk -- ** Helpers , formatException ) where import Prelude () import Test.Hspec.Core.Compat hiding (First) import Test.Hspec.Core.Util import Test.Hspec.Core.Clock import Test.Hspec.Core.Example (Location(..)) import Text.Printf import Control.Monad.IO.Class -- 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.V1.Monad ( Formatter(..) , FailureReason(..) , FormatM , getSuccessCount , getPendingCount , getFailCount , getTotalCount , FailureRecord(..) , getFailMessages , usedSeed , getCPUTime , getRealTime , write , writeLine , writeTransient , withInfoColor , withSuccessColor , withPendingColor , withFailColor , useDiff , extraChunk , missingChunk ) import Test.Hspec.Core.Format (FormatConfig, Format) import Test.Hspec.Core.Formatters.Diff import qualified Test.Hspec.Core.Formatters.V2 as V2 import Test.Hspec.Core.Formatters.V1.Monad (Item(..), Result(..), Environment(..), interpretWith) formatterToFormat :: Formatter -> FormatConfig -> IO Format formatterToFormat = V2.formatterToFormat . legacyFormatterToFormatter legacyFormatterToFormatter :: Formatter -> V2.Formatter legacyFormatterToFormatter Formatter{..} = V2.Formatter { V2.formatterStarted = interpret headerFormatter , V2.formatterGroupStarted = interpret . uncurry exampleGroupStarted , V2.formatterGroupDone = interpret . const exampleGroupDone , V2.formatterProgress = \ path -> interpret . exampleProgress path , V2.formatterItemStarted = interpret . exampleStarted , V2.formatterItemDone = \ path item -> interpret $ do case itemResult item of Success -> exampleSucceeded path (itemInfo item) Pending _ reason -> examplePending path (itemInfo item) reason Failure _ reason -> exampleFailed path (itemInfo item) reason , V2.formatterDone = interpret $ failedFormatter >> footerFormatter } interpret :: FormatM a -> V2.FormatM a interpret = interpretWith Environment { environmentGetSuccessCount = V2.getSuccessCount , environmentGetPendingCount = V2.getPendingCount , environmentGetFailMessages = V2.getFailMessages , environmentUsedSeed = V2.usedSeed , environmentPrintTimes = V2.printTimes , environmentGetCPUTime = V2.getCPUTime , environmentGetRealTime = V2.getRealTime , environmentWrite = V2.write , environmentWriteTransient = V2.writeTransient , environmentWithFailColor = V2.withFailColor , environmentWithSuccessColor = V2.withSuccessColor , environmentWithPendingColor = V2.withPendingColor , environmentWithInfoColor = V2.withInfoColor , environmentUseDiff = V2.useDiff , environmentExtraChunk = V2.extraChunk , environmentMissingChunk = V2.missingChunk , environmentLiftIO = liftIO } silent :: Formatter silent = Formatter { headerFormatter = pass , exampleGroupStarted = \_ _ -> pass , exampleGroupDone = pass , exampleStarted = \_ -> pass , exampleProgress = \_ _ -> pass , exampleSucceeded = \ _ _ -> pass , exampleFailed = \_ _ _ -> pass , examplePending = \_ _ _ -> pass , failedFormatter = pass , footerFormatter = pass } checks :: Formatter checks = specdoc { exampleStarted = \(nesting, requirement) -> do writeTransient $ indentationFor nesting ++ requirement ++ " [ ]" , exampleProgress = \(nesting, requirement) p -> do writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]" , exampleSucceeded = \(nesting, requirement) info -> do writeResult nesting requirement info $ withSuccessColor $ write "✔" , exampleFailed = \(nesting, requirement) info _ -> do writeResult nesting requirement info $ withFailColor $ write "✘" , examplePending = \(nesting, requirement) info reason -> do writeResult nesting requirement info $ withPendingColor $ write "‐" withPendingColor $ do writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason } where indentationFor nesting = replicate (length nesting * 2) ' ' writeResult :: [String] -> String -> String -> FormatM () -> FormatM () writeResult nesting requirement info action = do write $ indentationFor nesting ++ requirement ++ " [" action writeLine "]" forM_ (lines info) $ \ s -> writeLine $ indentationFor ("" : nesting) ++ s formatProgress (current, total) | total == 0 = show current | otherwise = show current ++ "/" ++ show total specdoc :: Formatter specdoc = silent { headerFormatter = do writeLine "" , exampleGroupStarted = \nesting name -> do writeLine (indentationFor nesting ++ name) , exampleProgress = \_ p -> do writeTransient (formatProgress p) , exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do writeLine $ indentationFor nesting ++ requirement forM_ (lines info) $ \ s -> writeLine $ indentationFor ("" : nesting) ++ s , exampleFailed = \(nesting, requirement) info _ -> withFailColor $ do n <- getFailCount writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]" forM_ (lines info) $ \ s -> writeLine $ indentationFor ("" : nesting) ++ s , examplePending = \(nesting, requirement) info reason -> withPendingColor $ do writeLine $ indentationFor nesting ++ requirement forM_ (lines info) $ \ s -> writeLine $ indentationFor ("" : nesting) ++ s writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason , failedFormatter = defaultFailedFormatter , footerFormatter = defaultFooter } where indentationFor nesting = replicate (length nesting * 2) ' ' formatProgress (current, total) | total == 0 = show current | otherwise = show current ++ "/" ++ show total 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 "" write "Randomized with seed " >> usedSeed >>= writeLine . show writeLine "" where 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 NoReason -> pass Reason err -> withFailColor $ indent err ExpectedButGot preface expected actual -> do mapM_ indent preface b <- useDiff let threshold = 2 :: Seconds mchunks <- liftIO $ if b then timeout threshold (evaluate $ diff Nothing expected actual) else return Nothing case mchunks of Just chunks -> do writeDiff chunks extraChunk missingChunk Nothing -> do writeDiff [First expected, Second actual] write write where indented output text = case break (== '\n') text of (xs, "") -> output xs (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ " ") >> indented output ys writeDiff chunks extra missing = do withFailColor $ write (indentation ++ "expected: ") forM_ chunks $ \ chunk -> case chunk of Both a -> indented write a First a -> indented extra a Second _ -> pass Omitted _ -> pass writeLine "" withFailColor $ write (indentation ++ " but got: ") forM_ chunks $ \ chunk -> case chunk of Both a -> indented write a First _ -> pass Second a -> indented missing a Omitted _ -> pass writeLine "" Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e writeLine "" writeLine (" To rerun use: --match " ++ show (joinPath path)) where indentation = " " indent message = do forM_ (lines message) $ \line -> do writeLine (indentation ++ line) formatLoc (Location file line column) = " " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": " 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.10.10/src/Test/Hspec/Core/Formatters/V1/0000755000000000000000000000000007346545000020150 5ustar0000000000000000hspec-core-2.10.10/src/Test/Hspec/Core/Formatters/V1/Free.hs0000644000000000000000000000111707346545000021365 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} module Test.Hspec.Core.Formatters.V1.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.10.10/src/Test/Hspec/Core/Formatters/V1/Monad.hs0000644000000000000000000002067407346545000021553 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ExistentialQuantification #-} module Test.Hspec.Core.Formatters.V1.Monad ( Formatter(..) , Item(..) , Result(..) , FailureReason (..) , FormatM , getSuccessCount , getPendingCount , getFailCount , getTotalCount , FailureRecord (..) , getFailMessages , usedSeed , printTimes , getCPUTime , getRealTime , write , writeLine , writeTransient , withInfoColor , withSuccessColor , withPendingColor , withFailColor , useDiff , extraChunk , missingChunk , Environment(..) , interpretWith ) where import Prelude () import Test.Hspec.Core.Compat import Control.Monad.IO.Class import Test.Hspec.Core.Formatters.V1.Free import Test.Hspec.Core.Clock import Test.Hspec.Core.Format data Formatter = Formatter { headerFormatter :: FormatM () -- | evaluated before each test group , exampleGroupStarted :: [String] -> String -> FormatM () -- | evaluated after each test group , exampleGroupDone :: FormatM () -- | evaluated before each example , exampleStarted :: Path -> FormatM () -- | used to notify the progress of the currently evaluated example , exampleProgress :: Path -> Progress -> FormatM () -- | evaluated after each successful example , exampleSucceeded :: Path -> String -> FormatM () -- | evaluated after each failed example , exampleFailed :: Path -> String -> FailureReason -> FormatM () -- | evaluated after each pending example , examplePending :: Path -> String -> Maybe String -> FormatM () -- | evaluated after a test run , failedFormatter :: FormatM () -- | evaluated after `failedFormatter` , footerFormatter :: FormatM () } data FailureRecord = FailureRecord { failureRecordLocation :: Maybe Location , failureRecordPath :: Path , failureRecordMessage :: FailureReason } data FormatF next = GetSuccessCount (Int -> next) | GetPendingCount (Int -> next) | GetFailMessages ([FailureRecord] -> next) | UsedSeed (Integer -> next) | PrintTimes (Bool -> next) | GetCPUTime (Maybe Seconds -> next) | GetRealTime (Seconds -> next) | Write String next | WriteTransient 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) | UseDiff (Bool -> 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) GetFailMessages next -> GetFailMessages (fmap f next) UsedSeed next -> UsedSeed (fmap f next) PrintTimes next -> PrintTimes (fmap f next) GetCPUTime next -> GetCPUTime (fmap f next) GetRealTime next -> GetRealTime (fmap f next) Write s next -> Write s (f next) WriteTransient s next -> WriteTransient 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) UseDiff next -> UseDiff (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 , environmentGetFailMessages :: m [FailureRecord] , environmentUsedSeed :: m Integer , environmentPrintTimes :: m Bool , environmentGetCPUTime :: m (Maybe Seconds) , environmentGetRealTime :: m Seconds , environmentWrite :: String -> m () , environmentWriteTransient :: 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 , environmentUseDiff :: m Bool , 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 GetFailMessages next -> environmentGetFailMessages >>= go . next UsedSeed next -> environmentUsedSeed >>= go . next PrintTimes next -> environmentPrintTimes >>= go . next GetCPUTime next -> environmentGetCPUTime >>= go . next GetRealTime next -> environmentGetRealTime >>= go . next Write s next -> environmentWrite s >> go next WriteTransient s next -> environmentWriteTransient 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 UseDiff next -> environmentUseDiff >>= 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 = length <$> getFailMessages -- | 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) -- | Return `True` if the user requested time reporting for individual spec -- items, `False` otherwise. printTimes :: FormatM Bool printTimes = liftF (PrintTimes id) -- | Get the used CPU time since the test run has been started. getCPUTime :: FormatM (Maybe Seconds) getCPUTime = liftF (GetCPUTime id) -- | Get the passed real time since the test run has been started. getRealTime :: FormatM Seconds 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" writeTransient :: String -> FormatM () writeTransient s = liftF (WriteTransient s ()) -- | 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) -- | Return `True` if the user requested colorized diffs, `False` otherwise. useDiff :: FormatM Bool useDiff = liftF (UseDiff 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.10.10/src/Test/Hspec/Core/Formatters/V2.hs0000644000000000000000000002750107346545000020512 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Stability: experimental -- -- This module contains formatters that can be used with -- `Test.Hspec.Core.Runner.hspecWith`. module Test.Hspec.Core.Formatters.V2 ( -- * Formatters silent , checks , 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 (..) , Path , Progress , Location(..) , Item(..) , Result(..) , FailureReason (..) , FormatM , formatterToFormat -- ** Accessing the runner state , getSuccessCount , getPendingCount , getFailCount , getTotalCount , getExpectedTotalCount , FailureRecord (..) , getFailMessages , usedSeed , printTimes , Seconds(..) , getCPUTime , getRealTime -- ** Appending to the generated report , write , writeLine , writeTransient -- ** Dealing with colors , withInfoColor , withSuccessColor , withPendingColor , withFailColor , outputUnicode , useDiff , diffContext , externalDiffAction , prettyPrint , prettyPrintFunction , extraChunk , missingChunk -- ** Helpers , formatLocation , formatException #ifdef TEST , Chunk(..) , ColorChunk(..) , indentChunks #endif ) where import Prelude () import Test.Hspec.Core.Compat hiding (First) import Data.Char import Test.Hspec.Core.Util import Test.Hspec.Core.Clock import Test.Hspec.Core.Example (Location(..), Progress) import Text.Printf import Test.Hspec.Core.Formatters.Pretty.Unicode (ushow) import Control.Monad.IO.Class -- We use an explicit import list for "Test.Hspec.Formatters.Monad", to make -- sure, that we only use the public API to implement formatters. -- -- Everything imported here has to be re-exported, so that users can implement -- their own formatters. import Test.Hspec.Core.Formatters.Internal ( Formatter(..) , Item(..) , Result(..) , FailureReason (..) , FormatM , formatterToFormat , getSuccessCount , getPendingCount , getFailCount , getTotalCount , getExpectedTotalCount , FailureRecord (..) , getFailMessages , usedSeed , printTimes , getCPUTime , getRealTime , write , writeLine , writeTransient , withInfoColor , withSuccessColor , withPendingColor , withFailColor , outputUnicode , useDiff , diffContext , externalDiffAction , prettyPrint , prettyPrintFunction , extraChunk , missingChunk ) import Test.Hspec.Core.Formatters.Diff silent :: Formatter silent = Formatter { formatterStarted = pass , formatterGroupStarted = \ _ -> pass , formatterGroupDone = \ _ -> pass , formatterProgress = \ _ _ -> pass , formatterItemStarted = \ _ -> pass , formatterItemDone = \ _ _ -> pass , formatterDone = pass } checks :: Formatter checks = specdoc { formatterProgress = \(nesting, requirement) p -> do writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]" , formatterItemStarted = \(nesting, requirement) -> do writeTransient $ indentationFor nesting ++ requirement ++ " [ ]" , formatterItemDone = \ (nesting, requirement) item -> do unicode <- outputUnicode let fallback a b = if unicode then a else b uncurry (writeResult nesting requirement (itemDuration item) (itemInfo item)) $ case itemResult item of Success {} -> (withSuccessColor, fallback "✔" "v") Pending {} -> (withPendingColor, fallback "‐" "-") Failure {} -> (withFailColor, fallback "✘" "x") case itemResult item of Success {} -> pass Failure {} -> pass Pending _ reason -> withPendingColor $ do writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason } where indentationFor nesting = replicate (length nesting * 2) ' ' writeResult :: [String] -> String -> Seconds -> String -> (FormatM () -> FormatM ()) -> String -> FormatM () writeResult nesting requirement duration info withColor symbol = do shouldPrintTimes <- printTimes write $ indentationFor nesting ++ requirement ++ " [" withColor $ write symbol writeLine $ "]" ++ if shouldPrintTimes then times else "" forM_ (lines info) $ \ s -> writeLine $ indentationFor ("" : nesting) ++ s where dt :: Int dt = toMilliseconds duration times | dt == 0 = "" | otherwise = " (" ++ show dt ++ "ms)" formatProgress (current, total) | total == 0 = show current | otherwise = show current ++ "/" ++ show total specdoc :: Formatter specdoc = silent { formatterStarted = do writeLine "" , formatterGroupStarted = \ (nesting, name) -> do writeLine (indentationFor nesting ++ name) , formatterProgress = \_ p -> do writeTransient (formatProgress p) , formatterItemDone = \(nesting, requirement) item -> do let duration = itemDuration item info = itemInfo item case itemResult item of Success -> withSuccessColor $ do writeResult nesting requirement duration info Pending _ reason -> withPendingColor $ do writeResult nesting requirement duration info writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason Failure {} -> withFailColor $ do n <- getFailCount writeResult nesting (requirement ++ " FAILED [" ++ show n ++ "]") duration info , formatterDone = defaultFailedFormatter >> defaultFooter } where indentationFor nesting = replicate (length nesting * 2) ' ' writeResult nesting requirement (Seconds duration) info = do shouldPrintTimes <- printTimes writeLine $ indentationFor nesting ++ requirement ++ if shouldPrintTimes then times else "" forM_ (lines info) $ \ s -> writeLine $ indentationFor ("" : nesting) ++ s where dt :: Int dt = floor (duration * 1000) times | dt == 0 = "" | otherwise = " (" ++ show dt ++ "ms)" formatProgress (current, total) | total == 0 = show current | otherwise = show current ++ "/" ++ show total progress :: Formatter progress = failed_examples { formatterItemDone = \ _ item -> case itemResult item of Success{} -> withSuccessColor $ write "." Pending{} -> withPendingColor $ write "." Failure{} -> withFailColor $ write "F" } failed_examples :: Formatter failed_examples = silent { formatterDone = defaultFailedFormatter >> defaultFooter } defaultFailedFormatter :: FormatM () defaultFailedFormatter = do writeLine "" failures <- getFailMessages unless (null failures) $ do writeLine "Failures:" writeLine "" forM_ (zip [1..] failures) $ \x -> do formatFailure x writeLine "" write "Randomized with seed " >> usedSeed >>= writeLine . show writeLine "" where formatFailure :: (Int, FailureRecord) -> FormatM () formatFailure (n, FailureRecord mLoc path reason) = do unicode <- outputUnicode forM_ mLoc $ \loc -> do withInfoColor $ writeLine (" " ++ formatLocation loc) write (" " ++ show n ++ ") ") writeLine (formatRequirement path) case reason of NoReason -> pass Reason err -> withFailColor $ indent err ExpectedButGot preface expected_ actual_ -> do pretty <- prettyPrintFunction let (expected, actual) = case pretty of Just f -> f expected_ actual_ Nothing -> (expected_, actual_) mapM_ indent preface b <- useDiff let threshold = 2 :: Seconds mExternalDiff <- externalDiffAction case mExternalDiff of Just externalDiff -> do liftIO $ externalDiff expected actual Nothing -> do context <- diffContext mchunks <- liftIO $ if b then timeout threshold (evaluate $ diff context expected actual) else return Nothing case mchunks of Just chunks -> do writeDiff chunks extraChunk missingChunk Nothing -> do writeDiff [First expected, Second actual] write write where writeDiff chunks extra missing = do writeChunks "expected: " (expectedChunks chunks) extra writeChunks " but got: " (actualChunks chunks) missing writeChunks :: String -> [Chunk] -> (String -> FormatM ()) -> FormatM () writeChunks pre chunks colorize = do withFailColor $ write (indentation ++ pre) forM_ (indentChunks indentation_ chunks) $ \ chunk -> case chunk of PlainChunk a -> write a ColorChunk a -> colorize a Informational a -> withInfoColor $ write a writeLine "" where indentation_ = indentation ++ replicate (length pre) ' ' Error info e -> do mapM_ indent info withFailColor . indent $ "uncaught exception: " ++ formatException e writeLine "" let path_ = (if unicode then ushow else show) (joinPath path) writeLine (" To rerun use: --match " ++ path_) where indentation = " " indent message = do forM_ (lines message) $ \line -> do writeLine (indentation ++ line) data Chunk = Original String | Modified String | OmittedLines Int deriving (Eq, Show) expectedChunks :: [Diff] -> [Chunk] expectedChunks = mapMaybe $ \ chunk -> case chunk of Both a -> Just $ Original a First a -> Just $ Modified a Second _ -> Nothing Omitted n -> Just $ OmittedLines n actualChunks :: [Diff] -> [Chunk] actualChunks = mapMaybe $ \ chunk -> case chunk of Both a -> Just $ Original a First _ -> Nothing Second a -> Just $ Modified a Omitted n -> Just $ OmittedLines n data ColorChunk = PlainChunk String | ColorChunk String | Informational String deriving (Eq, Show) indentChunks :: String -> [Chunk] -> [ColorChunk] indentChunks indentation = concatMap $ \ chunk -> case chunk of Original y -> [indentOriginal indentation y] Modified y -> indentModified indentation y OmittedLines n -> [Informational $ "@@ " <> show n <> " lines omitted @@\n" <> indentation] indentOriginal :: String -> String -> ColorChunk indentOriginal indentation = PlainChunk . go where go text = case break (== '\n') text of (xs, _ : ys) -> xs ++ "\n" ++ indentation ++ go ys (xs, "") -> xs indentModified :: String -> String -> [ColorChunk] indentModified indentation = go where go text = case text of "\n" -> [PlainChunk "\n", ColorChunk indentation] '\n' : ys@('\n' : _) -> PlainChunk "\n" : ColorChunk indentation : go ys _ -> case break (== '\n') text of (xs, _ : ys) -> segment xs ++ PlainChunk ('\n' : indentation) : go ys (xs, "") -> segment xs segment xs = case span isSpace $ reverse xs of ("", "") -> [] ("", _) -> [ColorChunk xs] (_, "") -> [ColorChunk xs] (ys, zs) -> [ColorChunk (reverse zs), ColorChunk (reverse ys)] 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" color | fails /= 0 = withFailColor | pending /= 0 = withPendingColor | otherwise = withSuccessColor color $ writeLine output formatLocation :: Location -> String formatLocation (Location file line column) = file ++ ":" ++ show line ++ ":" ++ show column ++ ": " hspec-core-2.10.10/src/Test/Hspec/Core/Hooks.hs0000644000000000000000000001513107346545000017154 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} -- | Stability: provisional module Test.Hspec.Core.Hooks ( -- * Types Spec , SpecWith , ActionWith -- * Hooks , before , before_ , beforeWith , beforeAll , beforeAll_ , beforeAllWith , after , after_ , afterAll , afterAll_ , around , around_ , aroundWith , aroundAll , aroundAll_ , aroundAllWith , mapSubject , ignoreSubject #ifdef TEST , decompose #endif ) where import Prelude () import Test.Hspec.Core.Compat import Control.Concurrent 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 :: HasCallStack => 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_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a beforeAll_ action spec = do mvar <- runIO (newMVar Empty) before_ (memoize mvar action) spec -- | Run a custom action with an argument before the first spec item. beforeAllWith :: HasCallStack => (b -> IO a) -> SpecWith a -> SpecWith b beforeAllWith action spec = do mvar <- runIO (newMVar Empty) beforeWith (memoize mvar . action) spec data Memoized a = Empty | Memoized a | Failed SomeException memoize :: HasCallStack => 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 Nothing (Just $ "exception in " <> maybe "beforeAll" fst callSite <> "-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 :: HasCallStack => ActionWith a -> SpecWith a -> SpecWith a afterAll action = aroundAllWith (\ hook a -> hook a >> action a) -- | Run a custom action after the last spec item. afterAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a afterAll_ action = mapSpecForest (return . NodeWithCleanup callSite 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 = mapSpecItem_ . modifyHook modifyHook :: (ActionWith a -> ActionWith b) -> Item a -> Item b modifyHook action item = item { itemExample = \ params hook -> itemExample item params (hook . action) } -- | Wrap an action around the given spec. aroundAll :: HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec aroundAll action = aroundAllWith $ \ e () -> action e -- | Wrap an action around the given spec. aroundAll_ :: HasCallStack => (IO () -> IO ()) -> SpecWith a -> SpecWith a aroundAll_ action spec = do (acquire, release) <- runIO $ decompose (action .) beforeAll_ (acquire ()) $ afterAll_ release spec -- | Wrap an action around the given spec. Changes the arg type inside. aroundAllWith :: forall a b. HasCallStack => (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b aroundAllWith action spec = do (acquire, release) <- runIO $ decompose action beforeAllWith acquire $ afterAll_ release spec data Acquired a = Acquired a | ExceptionDuringAcquire SomeException data Released = Released | ExceptionDuringRelease SomeException decompose :: forall a b. ((a -> IO ()) -> b -> IO ()) -> IO (b -> IO a, IO ()) decompose action = do doCleanupNow <- newEmptyMVar acquired <- newEmptyMVar released <- newEmptyMVar let notify :: Either SomeException () -> IO () -- `notify` is guaranteed to run without being interrupted by an async -- exception for the following reasons: -- -- 1. `forkFinally` runs the final action within `mask` -- 2. `tryPutMVar` is guaranteed not to be interruptible -- 3. `putMVar` is guaranteed not to be interruptible on an empty `MVar` notify r = case r of Left err -> do exceptionDuringAcquire <- tryPutMVar acquired (ExceptionDuringAcquire err) putMVar released $ if exceptionDuringAcquire then Released else ExceptionDuringRelease err Right () -> do putMVar released Released forkWorker :: b -> IO () forkWorker b = void . flip forkFinally notify $ do flip action b $ \ a -> do putMVar acquired (Acquired a) waitFor doCleanupNow acquire :: b -> IO a acquire b = do forkWorker b r <- readMVar acquired -- This does not work reliably with base < 4.7 case r of Acquired a -> return a ExceptionDuringAcquire err -> throwIO err release :: IO () release = do acquireHasNotBeenCalled <- isEmptyMVar acquired -- NOTE: This can happen if an outer beforeAll fails unless acquireHasNotBeenCalled $ do signal doCleanupNow r <- takeMVar released case r of Released -> pass ExceptionDuringRelease err -> throwIO err return (acquire, release) type BinarySemaphore = MVar () signal :: BinarySemaphore -> IO () signal = flip putMVar () waitFor :: BinarySemaphore -> IO () waitFor = takeMVar -- | Modify the subject under test. -- -- Note that this resembles a contravariant functor on the first type parameter -- of `SpecM`. This is because the subject is passed inwards, as an argument -- to the spec item. mapSubject :: (b -> a) -> SpecWith a -> SpecWith b mapSubject f = aroundWith (. f) -- | Ignore the subject under test for a given spec. ignoreSubject :: SpecWith () -> SpecWith a ignoreSubject = mapSubject (const ()) hspec-core-2.10.10/src/Test/Hspec/Core/QuickCheck.hs0000644000000000000000000000312407346545000020102 0ustar0000000000000000-- | Stability: provisional module Test.Hspec.Core.QuickCheck ( modifyArgs , modifyMaxSuccess , modifyMaxDiscardRatio , modifyMaxSize , modifyMaxShrinks ) where import Prelude () import Test.Hspec.Core.Compat 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)} -- | Use a modified `maxShrinks` for given spec. modifyMaxShrinks :: (Int -> Int) -> SpecWith a -> SpecWith a modifyMaxShrinks = modifyArgs . modify where modify :: (Int -> Int) -> Args -> Args modify f args = args {maxShrinks = f (maxShrinks args)} -- | Use modified `Args` for given spec. 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.10.10/src/Test/Hspec/Core/QuickCheckUtil.hs0000644000000000000000000001246007346545000020743 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module Test.Hspec.Core.QuickCheckUtil ( liftHook , aroundProperty , QuickCheckResult(..) , Status(..) , QuickCheckFailure(..) , parseQuickCheckResult , formatNumbers , mkGen , newSeed #ifdef TEST , stripSuffix , splitBy #endif ) where import Prelude () import Test.Hspec.Core.Compat import Data.Int import System.Random import Test.QuickCheck import Test.QuickCheck.Text (isOneLine) import qualified Test.QuickCheck.Property as QCP import Test.QuickCheck.Property hiding (Result(..)) import Test.QuickCheck.Gen import Test.QuickCheck.IO () import Test.QuickCheck.Random import qualified Test.QuickCheck.Test as QC (showTestCount) import Test.QuickCheck.State (State(..)) import Test.Hspec.Core.Util liftHook :: r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r liftHook def hook inner = do ref <- newIORef def hook $ inner >=> writeIORef ref readIORef ref aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property aroundProperty hook p = MkProperty . MkGen $ \r n -> aroundProp hook $ \a -> (unGen . unProperty $ p a) r n aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop aroundProp hook p = MkProp $ aroundRose hook (\a -> unProp $ p a) aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result aroundRose hook r = ioRose $ do liftHook (return QCP.succeeded) hook $ \ a -> reduceRose (r a) newSeed :: IO Int newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$> newQCGen mkGen :: Int -> QCGen mkGen = mkQCGen formatNumbers :: Int -> Int -> String formatNumbers n shrinks = "(after " ++ pluralize n "test" ++ shrinks_ ++ ")" where shrinks_ | shrinks > 0 = " and " ++ pluralize shrinks "shrink" | otherwise = "" data QuickCheckResult = QuickCheckResult { quickCheckResultNumTests :: Int , quickCheckResultInfo :: String , quickCheckResultStatus :: Status } deriving Show data Status = QuickCheckSuccess | QuickCheckFailure QuickCheckFailure | QuickCheckOtherFailure String deriving Show data QuickCheckFailure = QCFailure { quickCheckFailureNumShrinks :: Int , quickCheckFailureException :: Maybe SomeException , quickCheckFailureReason :: String , quickCheckFailureCounterexample :: [String] } deriving Show parseQuickCheckResult :: Result -> QuickCheckResult parseQuickCheckResult r = case r of Success {..} -> result output QuickCheckSuccess Failure {..} -> case stripSuffix outputWithoutVerbose output of Just xs -> result verboseOutput (QuickCheckFailure $ QCFailure numShrinks theException reason failingTestCase) where verboseOutput | xs == "*** Failed! " = "" | otherwise = maybeStripSuffix "*** Failed!" (strip xs) Nothing -> couldNotParse output where outputWithoutVerbose = reasonAndNumbers ++ unlines failingTestCase reasonAndNumbers | isOneLine reason = reason ++ " " ++ numbers ++ colonNewline | otherwise = numbers ++ colonNewline ++ ensureTrailingNewline reason numbers = formatNumbers numTests numShrinks colonNewline = ":\n" GaveUp {..} -> case stripSuffix outputWithoutVerbose output of Just info -> otherFailure info ("Gave up after " ++ numbers ++ "!") Nothing -> couldNotParse output where numbers = showTestCount numTests numDiscarded outputWithoutVerbose = "*** Gave up! Passed only " ++ numbers ++ " tests.\n" NoExpectedFailure {..} -> case splitBy "*** Failed! " output of Just (info, err) -> otherFailure info err Nothing -> couldNotParse output where result = QuickCheckResult (numTests r) . strip otherFailure info err = result info (QuickCheckOtherFailure $ strip err) couldNotParse = result "" . QuickCheckOtherFailure showTestCount :: Int -> Int -> String showTestCount success discarded = QC.showTestCount state where state = MkState { terminal = undefined , maxSuccessTests = undefined , maxDiscardedRatio = undefined , coverageConfidence = undefined , computeSize = undefined , numTotMaxShrinks = 0 , numSuccessTests = success , numDiscardedTests = discarded , numRecentlyDiscardedTests = 0 , labels = mempty , classes = mempty , tables = mempty , requiredCoverage = mempty , expected = True , randomSeed = mkGen 0 , numSuccessShrinks = 0 , numTryShrinks = 0 , numTotTryShrinks = 0 } ensureTrailingNewline :: String -> String ensureTrailingNewline = unlines . lines maybeStripPrefix :: String -> String -> String maybeStripPrefix prefix m = fromMaybe m (stripPrefix prefix m) maybeStripSuffix :: String -> String -> String maybeStripSuffix suffix = reverse . maybeStripPrefix (reverse suffix) . reverse stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse splitBy :: String -> String -> Maybe (String, String) splitBy sep xs = listToMaybe [ (x, y) | (x, Just y) <- zip (inits xs) (map stripSep $ tails xs) ] where stripSep = stripPrefix sep hspec-core-2.10.10/src/Test/Hspec/Core/Runner.hs0000644000000000000000000004216507346545000017351 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Stability: provisional module Test.Hspec.Core.Runner ( -- * Running a spec {- | To run a spec `hspec` performs a sequence of steps: 1. Evaluate a `Spec` to a forest of `SpecTree`s 1. Read config values from the command-line, config files and the process environment 1. Execute each spec item of the forest and report results to `stdout` 1. Exit with `exitFailure` if at least on spec item fails The four primitives `evalSpec`, `readConfig`, `runSpecForest` and `evaluateResult` each perform one of these steps respectively. `hspec` is defined in terms of these primitives: @ hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) -> `getArgs` >>= `readConfig` config >>= `withArgs` [] . `runSpecForest` spec >>= `evaluateResult` @ If you need more control over how a spec is run use these primitives individually. -} hspec , evalSpec , runSpecForest , evaluateResult -- * Config , Config (..) , ColorMode (..) , UnicodeMode(..) , Path , defaultConfig , registerFormatter , registerDefaultFormatter , configAddFilter , readConfig -- * Result -- ** Spec Result , Test.Hspec.Core.Runner.Result.SpecResult , Test.Hspec.Core.Runner.Result.specResultItems , Test.Hspec.Core.Runner.Result.specResultSuccess -- ** Result Item , Test.Hspec.Core.Runner.Result.ResultItem , Test.Hspec.Core.Runner.Result.resultItemPath , Test.Hspec.Core.Runner.Result.resultItemStatus , Test.Hspec.Core.Runner.Result.resultItemIsFailure -- ** Result Item Status , Test.Hspec.Core.Runner.Result.ResultItemStatus(..) -- * Legacy -- | The following primitives are deprecated. Use `runSpecForest` instead. , hspecWith , hspecResult , hspecWithResult , runSpec -- ** Summary , Summary (..) , toSummary , isSuccess , evaluateSummary -- * Re-exports , Spec , SpecWith #ifdef TEST , UseColor(..) , ProgressReporting(..) , rerunAll , specToEvalForest , colorOutputSupported , unicodeOutputSupported #endif ) where import Prelude () import Test.Hspec.Core.Compat import NonEmpty (nonEmpty) import System.IO import System.Environment (getArgs, withArgs) import System.Exit (exitFailure) import System.Random import Control.Monad.ST import Data.STRef import System.Console.ANSI (hSupportsANSI, hHideCursor, hShowCursor) import qualified Test.QuickCheck as QC import Test.Hspec.Core.Util (Path) import Test.Hspec.Core.Clock import Test.Hspec.Core.Spec hiding (pruneTree, pruneForest) import Test.Hspec.Core.Config import Test.Hspec.Core.Format (Format, FormatConfig(..)) import qualified Test.Hspec.Core.Formatters.V1 as V1 import qualified Test.Hspec.Core.Formatters.V2 as V2 import Test.Hspec.Core.FailureReport import Test.Hspec.Core.QuickCheckUtil import Test.Hspec.Core.Shuffle import Test.Hspec.Core.Runner.PrintSlowSpecItems import Test.Hspec.Core.Runner.Eval hiding (Tree(..)) import qualified Test.Hspec.Core.Runner.Eval as Eval import Test.Hspec.Core.Runner.Result -- | -- Make a formatter available for use with @--format@. -- -- @since 2.10.5 registerFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config registerFormatter formatter config = config { configAvailableFormatters = formatter : configAvailableFormatters config } -- | -- Make a formatter available for use with @--format@ and use it by default. -- -- @since 2.10.5 registerDefaultFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config registerDefaultFormatter formatter@(_, format) config = (registerFormatter formatter config) { configFormat = Just format } applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem] applyFilterPredicates c = filterForestWithLabels p where include :: Path -> Bool include = fromMaybe (const True) (configFilterPredicate c) skip :: Path -> Bool skip = fromMaybe (const False) (configSkipPredicate c) p :: [String] -> EvalItem -> Bool p groups item = include path && not (skip path) where path = (groups, evalItemDescription item) applyDryRun :: Config -> [EvalItemTree] -> [EvalItemTree] applyDryRun c | configDryRun c = bimapForest removeCleanup markSuccess | otherwise = id where removeCleanup :: IO () -> IO () removeCleanup _ = pass markSuccess :: EvalItem -> EvalItem markSuccess item = item {evalItemAction = \ _ -> return (0, Result "" Success)} -- | Run a given spec and write a report to `stdout`. -- Exit with `exitFailure` if at least one spec item fails. -- -- /Note/: `hspec` handles command-line options and reads config files. This -- is not always desirable. Use `evalSpec` and `runSpecForest` if you need -- more control over these aspects. hspec :: Spec -> IO () hspec = hspecWith defaultConfig -- | -- Evaluate a `Spec` to a forest of `SpecTree`s. This does not execute any -- spec items, but it does run any IO that is used during spec construction -- time (see `runIO`). -- -- A `Spec` may modify a `Config` through `modifyConfig`. These modifications -- are applied to the given config (the first argument). -- -- @since 2.10.0 evalSpec :: Config -> SpecWith a -> IO (Config, [SpecTree a]) evalSpec config spec = do (Endo f, forest) <- runSpecM spec return (f config, forest) -- 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 defaults = hspecWithSpecResult defaults >=> evaluateResult -- | Exit with `exitFailure` if the given `Summary` indicates that there was at -- least one failure. evaluateSummary :: Summary -> IO () evaluateSummary summary = unless (isSuccess summary) exitFailure evaluateResult :: SpecResult -> IO () evaluateResult result = unless (specResultSuccess result) exitFailure -- | Run given spec and returns a summary of the test run. -- -- /Note/: `hspecResult` does not exit with `exitFailure` on failing spec -- items. If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecResult :: Spec -> IO Summary hspecResult = hspecWithResult defaultConfig -- | Run given spec with custom options and returns a summary of the test run. -- -- /Note/: `hspecWithResult` does not exit with `exitFailure` on failing spec -- items. If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary hspecWithResult config = fmap toSummary . hspecWithSpecResult config hspecWithSpecResult :: Config -> Spec -> IO SpecResult hspecWithSpecResult defaults spec = do (c, forest) <- evalSpec defaults spec config <- getArgs >>= readConfig c oldFailureReport <- readFailureReportOnRerun config let normalMode :: IO SpecResult normalMode = doNotLeakCommandLineArgumentsToExamples $ runSpecForest_ oldFailureReport forest config rerunAllMode :: IO SpecResult rerunAllMode = do result <- normalMode if rerunAll config oldFailureReport result then hspecWithSpecResult defaults spec else return result -- 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 if configRerunAllOnSuccess config then do rerunAllMode else do normalMode -- | -- /Note/: `runSpec` is deprecated. It ignores any modifications applied -- through `modifyConfig`. Use `evalSpec` and `runSpecForest` instead. runSpec :: Spec -> Config -> IO Summary runSpec spec config = evalSpec defaultConfig spec >>= fmap toSummary . flip runSpecForest config . snd -- | -- `runSpecForest` is the most basic primitive to run a spec. `hspec` is -- defined in terms of @runSpecForest@: -- -- @ -- hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) -> -- `getArgs` -- >>= `readConfig` config -- >>= `withArgs` [] . runSpecForest spec -- >>= `evaluateResult` -- @ -- -- @since 2.10.0 runSpecForest :: [SpecTree ()] -> Config -> IO SpecResult runSpecForest spec config = do oldFailureReport <- readFailureReportOnRerun config runSpecForest_ oldFailureReport spec config mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b] mapItem f = map (fmap f) failFocusedItems :: Config -> [SpecTree a] -> [SpecTree a] failFocusedItems config | configFailOnFocused config = mapItem failFocused | otherwise = id failFocused :: forall a. Item a -> Item a failFocused item = item {itemExample = example} where failure :: ResultStatus failure = Failure Nothing (Reason "item is focused; failing due to --fail-on=focused") example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result example | itemIsFocused item = \ params hook p -> do Result info status <- itemExample item params hook p return $ Result info $ case status of Success -> failure Pending _ _ -> failure Failure{} -> status | otherwise = itemExample item failPendingItems :: Config -> [SpecTree a] -> [SpecTree a] failPendingItems config | configFailOnPending config = mapItem failPending | otherwise = id failPending :: forall a. Item a -> Item a failPending item = item {itemExample = example} where example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result example params hook p = do Result info status <- itemExample item params hook p return $ Result info $ case status of Pending loc _ -> Failure loc (Reason "item is pending; failing due to --fail-on=pending") _ -> status focusSpec :: Config -> [SpecTree a] -> [SpecTree a] focusSpec config spec | configFocusedOnly config = spec | otherwise = focusForest spec runSpecForest_ :: Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult runSpecForest_ oldFailureReport spec c_ = do config <- ensureSeed (applyFailureReport oldFailureReport c_) colorMode <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout) outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout let filteredSpec = specToEvalForest config spec seed = (fromJust . configQuickCheckSeed) config qcArgs = configQuickCheckArgs config !numberOfItems = countEvalItems filteredSpec when (configFailOnEmpty config && numberOfItems == 0) $ do when (countSpecItems spec /= 0) $ do die "all spec items have been filtered; failing due to --fail-on=empty" concurrentJobs <- maybe getDefaultConcurrentJobs return $ configConcurrentJobs config results <- fmap toSpecResult . withHiddenCursor (progressReporting colorMode) stdout $ do let formatConfig = FormatConfig { formatConfigUseColor = shouldUseColor colorMode , formatConfigReportProgress = progressReporting colorMode == ProgressReportingEnabled , formatConfigOutputUnicode = outputUnicode , formatConfigUseDiff = configDiff config , formatConfigDiffContext = configDiffContext config , formatConfigExternalDiff = if configDiff config then ($ configDiffContext config) <$> configExternalDiff config else Nothing , formatConfigPrettyPrint = configPrettyPrint config , formatConfigPrettyPrintFunction = if configPrettyPrint config then Just (configPrettyPrintFunction config outputUnicode) else Nothing , formatConfigPrintTimes = configTimes config , formatConfigHtmlOutput = configHtmlOutput config , formatConfigPrintCpuTime = configPrintCpuTime config , formatConfigUsedSeed = seed , formatConfigExpectedTotalCount = numberOfItems } formatter = fromMaybe (V2.formatterToFormat V2.checks) (configFormat config <|> V1.formatterToFormat <$> configFormatter config) format <- maybe id printSlowSpecItems (configPrintSlowItems config) <$> formatter formatConfig let evalConfig = EvalConfig { evalConfigFormat = format , evalConfigConcurrentJobs = concurrentJobs , evalConfigFailFast = configFailFast config } runFormatter evalConfig filteredSpec let failures :: [Path] failures = map resultItemPath $ filter resultItemIsFailure $ specResultItems results dumpFailureReport config seed qcArgs failures return results specToEvalForest :: Config -> [SpecTree ()] -> [EvalTree] specToEvalForest config = failFocusedItems config >>> failPendingItems config >>> focusSpec config >>> toEvalItemForest params >>> applyDryRun config >>> applyFilterPredicates config >>> randomize >>> pruneForest where seed :: Integer seed = (fromJust . configQuickCheckSeed) config params :: Params params = Params (configQuickCheckArgs config) (configSmallCheckDepth config) randomize :: [Tree c a] -> [Tree c a] randomize | configRandomize config = randomizeForest seed | otherwise = id pruneForest :: [Tree c a] -> [Eval.Tree c a] pruneForest = mapMaybe pruneTree pruneTree :: Tree c a -> Maybe (Eval.Tree c a) pruneTree node = case node of Node group xs -> Eval.Node group <$> prune xs NodeWithCleanup loc action xs -> Eval.NodeWithCleanup loc action <$> prune xs Leaf item -> Just (Eval.Leaf item) where prune = nonEmpty . pruneForest type EvalItemTree = Tree (IO ()) EvalItem toEvalItemForest :: Params -> [SpecTree ()] -> [EvalItemTree] toEvalItemForest params = bimapForest id toEvalItem . filterForest itemIsFocused where toEvalItem :: Item () -> EvalItem toEvalItem (Item requirement loc isParallelizable _isFocused e) = EvalItem { evalItemDescription = requirement , evalItemLocation = loc , evalItemConcurrency = if isParallelizable == Just True then Concurrent else Sequential , evalItemAction = \ progress -> measure $ e params withUnit progress } withUnit :: ActionWith () -> IO () withUnit action = action () 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 :: ProgressReporting -> Handle -> IO a -> IO a withHiddenCursor progress h = case progress of ProgressReportingDisabled -> id ProgressReportingEnabled -> bracket_ (hHideCursor h) (hShowCursor h) data UseColor = ColorDisabled | ColorEnabled ProgressReporting deriving (Eq, Show) data ProgressReporting = ProgressReportingDisabled | ProgressReportingEnabled deriving (Eq, Show) shouldUseColor :: UseColor -> Bool shouldUseColor c = case c of ColorDisabled -> False ColorEnabled _ -> True progressReporting :: UseColor -> ProgressReporting progressReporting c = case c of ColorDisabled -> ProgressReportingDisabled ColorEnabled r -> r colorOutputSupported :: ColorMode -> IO Bool -> IO UseColor colorOutputSupported mode isTerminalDevice = do github <- githubActions buildkite <- lookupEnv "BUILDKITE" <&> (== Just "true") let progress :: ProgressReporting progress | github || buildkite = ProgressReportingDisabled | otherwise = ProgressReportingEnabled colorEnabled :: UseColor colorEnabled = ColorEnabled progress case mode of ColorAuto -> bool ColorDisabled colorEnabled . (github ||) <$> colorTerminal ColorNever -> return ColorDisabled ColorAlways -> return colorEnabled where githubActions :: IO Bool githubActions = lookupEnv "GITHUB_ACTIONS" <&> (== Just "true") colorTerminal :: IO Bool colorTerminal = (&&) <$> (not <$> noColor) <*> isTerminalDevice noColor :: IO Bool noColor = lookupEnv "NO_COLOR" <&> (/= Nothing) unicodeOutputSupported :: UnicodeMode -> Handle -> IO Bool unicodeOutputSupported mode h = case mode of UnicodeAuto -> (== Just "UTF-8") . fmap show <$> hGetEncoding h UnicodeNever -> return False UnicodeAlways -> return True rerunAll :: Config -> Maybe FailureReport -> SpecResult -> Bool rerunAll config mOldFailureReport result = case mOldFailureReport of Nothing -> False Just oldFailureReport -> configRerunAllOnSuccess config && configRerun config && specResultSuccess result && (not . null) (failureReportPaths oldFailureReport) randomizeForest :: Integer -> [Tree c a] -> [Tree c a] randomizeForest seed t = runST $ do ref <- newSTRef (mkStdGen $ fromIntegral seed) shuffleForest ref t countEvalItems :: [Eval.Tree c a] -> Int countEvalItems = getSum . foldMap (foldMap . const $ Sum 1) countSpecItems :: [Tree c a] -> Int countSpecItems = getSum . foldMap (foldMap . const $ Sum 1) hspec-core-2.10.10/src/Test/Hspec/Core/Runner/0000755000000000000000000000000007346545000017005 5ustar0000000000000000hspec-core-2.10.10/src/Test/Hspec/Core/Runner/Eval.hs0000644000000000000000000002210107346545000020224 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-} module Test.Hspec.Core.Runner.Eval ( EvalConfig(..) , EvalTree , Tree(..) , EvalItem(..) , Concurrency(..) , runFormatter #ifdef TEST , mergeResults #endif ) where import Prelude () import Test.Hspec.Core.Compat hiding (Monad) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader import Control.Monad.Trans.Class import Test.Hspec.Core.Util import Test.Hspec.Core.Spec (Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback) import Test.Hspec.Core.Timer import Test.Hspec.Core.Format (Format) import qualified Test.Hspec.Core.Format as Format import Test.Hspec.Core.Clock import Test.Hspec.Core.Example.Location import Test.Hspec.Core.Example (safeEvaluateResultStatus, exceptionToResultStatus) import qualified NonEmpty import NonEmpty (NonEmpty(..)) import Test.Hspec.Core.Runner.JobQueue data Tree c a = Node String (NonEmpty (Tree c a)) | NodeWithCleanup (Maybe (String, Location)) c (NonEmpty (Tree c a)) | Leaf a deriving (Eq, Show, Functor, Foldable, Traversable) data EvalConfig = EvalConfig { evalConfigFormat :: Format , evalConfigConcurrentJobs :: Int , evalConfigFailFast :: Bool } data Env = Env { envConfig :: EvalConfig , envFailed :: IORef Bool , envResults :: IORef [(Path, Format.Item)] } formatEvent :: Format.Event -> EvalM () formatEvent event = do format <- asks $ evalConfigFormat . envConfig liftIO $ format event type EvalM = ReaderT Env IO setFailed :: EvalM () setFailed = do ref <- asks envFailed liftIO $ writeIORef ref True hasFailed :: EvalM Bool hasFailed = do ref <- asks envFailed liftIO $ readIORef ref addResult :: Path -> Format.Item -> EvalM () addResult path item = do ref <- asks envResults liftIO $ modifyIORef ref ((path, item) :) reportItem :: Path -> Maybe Location -> EvalM (Seconds, Result) -> EvalM () reportItem path loc action = do reportItemStarted path action >>= reportResult path loc reportItemStarted :: Path -> EvalM () reportItemStarted = formatEvent . Format.ItemStarted reportItemDone :: Path -> Format.Item -> EvalM () reportItemDone path item = do let isFailure = case Format.itemResult item of Format.Success{} -> False Format.Pending{} -> False Format.Failure{} -> True when isFailure setFailed addResult path item formatEvent $ Format.ItemDone path item reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM () reportResult path loc (duration, result) = do case result of Result info status -> reportItemDone path $ Format.Item loc duration info $ case status of Success -> Format.Success Pending loc_ reason -> Format.Pending loc_ reason Failure loc_ err@(Error _ e) -> Format.Failure (loc_ <|> extractLocation e) err Failure loc_ err -> Format.Failure loc_ err groupStarted :: Path -> EvalM () groupStarted = formatEvent . Format.GroupStarted groupDone :: Path -> EvalM () groupDone = formatEvent . Format.GroupDone data EvalItem = EvalItem { evalItemDescription :: String , evalItemLocation :: Maybe Location , evalItemConcurrency :: Concurrency , evalItemAction :: ProgressCallback -> IO (Seconds, Result) } type EvalTree = Tree (IO ()) EvalItem -- | Evaluate all examples of a given spec and produce a report. runFormatter :: EvalConfig -> [EvalTree] -> IO ([(Path, Format.Item)]) runFormatter config specs = do withJobQueue (evalConfigConcurrentJobs config) $ \ queue -> do withTimer 0.05 $ \ timer -> do env <- mkEnv runningSpecs_ <- enqueueItems queue specs let applyReportProgress :: RunningItem_ IO -> RunningItem applyReportProgress item = fmap (. reportProgress timer) item runningSpecs :: [RunningTree ()] runningSpecs = applyCleanup $ map (fmap applyReportProgress) runningSpecs_ getResults :: IO [(Path, Format.Item)] getResults = reverse <$> readIORef (envResults env) formatItems :: IO () formatItems = runReaderT (eval runningSpecs) env formatDone :: IO () formatDone = getResults >>= format . Format.Done format Format.Started formatItems `finally` formatDone getResults where mkEnv :: IO Env mkEnv = Env config <$> newIORef False <*> newIORef [] format :: Format format = evalConfigFormat config reportProgress :: IO Bool -> Path -> Progress -> IO () reportProgress timer path progress = do r <- timer when r $ do format (Format.Progress path progress) data Item a = Item { itemDescription :: String , itemLocation :: Maybe Location , itemAction :: a } deriving Functor type RunningItem = Item (Path -> IO (Seconds, Result)) type RunningTree c = Tree c RunningItem type RunningItem_ m = Item (Job m Progress (Seconds, Result)) type RunningTree_ m = Tree (IO ()) (RunningItem_ m) applyCleanup :: [RunningTree (IO ())] -> [RunningTree ()] applyCleanup = map go where go t = case t of Node label xs -> Node label (go <$> xs) NodeWithCleanup loc cleanup xs -> NodeWithCleanup loc () (addCleanupToLastLeaf loc cleanup $ go <$> xs) Leaf a -> Leaf a addCleanupToLastLeaf :: Maybe (String, Location) -> IO () -> NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ()) addCleanupToLastLeaf loc cleanup = go where go = NonEmpty.reverse . mapHead goNode . NonEmpty.reverse goNode node = case node of Node description xs -> Node description (go xs) NodeWithCleanup loc_ () xs -> NodeWithCleanup loc_ () (go xs) Leaf item -> Leaf (addCleanupToItem loc cleanup item) mapHead :: (a -> a) -> NonEmpty a -> NonEmpty a mapHead f xs = case xs of y :| ys -> f y :| ys addCleanupToItem :: Maybe (String, Location) -> IO () -> RunningItem -> RunningItem addCleanupToItem loc cleanup item = item { itemAction = \ path -> do (t1, r1) <- itemAction item path (t2, r2) <- measure $ safeEvaluateResultStatus (cleanup >> return Success) let t = t1 + t2 return (t, mergeResults loc r1 r2) } mergeResults :: Maybe (String, Location) -> Result -> ResultStatus -> Result mergeResults mCallSite (Result info r1) r2 = Result info $ case (r1, r2) of (_, Success) -> r1 (Failure{}, _) -> r1 (Pending{}, Pending{}) -> r1 (Success, Pending{}) -> r2 (_, Failure mLoc err) -> Failure (mLoc <|> hookLoc) $ case err of Error message e -> Error (message <|> hookFailed) e _ -> err where hookLoc = snd <$> mCallSite hookFailed = case mCallSite of Just (name, _) -> Just $ "in " ++ name ++ "-hook:" Nothing -> Nothing enqueueItems :: MonadIO m => JobQueue -> [EvalTree] -> IO [RunningTree_ m] enqueueItems queue = mapM (traverse $ enqueueItem queue) enqueueItem :: MonadIO m => JobQueue -> EvalItem -> IO (RunningItem_ m) enqueueItem queue EvalItem{..} = do job <- enqueueJob queue evalItemConcurrency evalItemAction return Item { itemDescription = evalItemDescription , itemLocation = evalItemLocation , itemAction = job >=> liftIO . either exceptionToResult return } where exceptionToResult :: SomeException -> IO (Seconds, Result) exceptionToResult err = (,) 0 . Result "" <$> exceptionToResultStatus err eval :: [RunningTree ()] -> EvalM () eval specs = do failFast <- asks (evalConfigFailFast . envConfig) sequenceActions failFast (concatMap foldSpec specs) where foldSpec :: RunningTree () -> [EvalM ()] foldSpec = foldTree FoldTree { onGroupStarted = groupStarted , onGroupDone = groupDone , onCleanup = runCleanup , onLeafe = evalItem } runCleanup :: Maybe (String, Location) -> [String] -> () -> EvalM () runCleanup _loc _groups = return evalItem :: [String] -> RunningItem -> EvalM () evalItem groups (Item requirement loc action) = do reportItem path loc $ lift (action path) where path :: Path path = (groups, requirement) data FoldTree c a r = FoldTree { onGroupStarted :: Path -> r , onGroupDone :: Path -> r , onCleanup :: Maybe (String, Location) -> [String] -> c -> r , onLeafe :: [String] -> a -> r } foldTree :: FoldTree c a r -> Tree c a -> [r] foldTree FoldTree{..} = go [] where go rGroups (Node group xs) = start : children ++ [done] where path = (reverse rGroups, group) start = onGroupStarted path children = concatMap (go (group : rGroups)) xs done = onGroupDone path go rGroups (NodeWithCleanup loc action xs) = children ++ [cleanup] where children = concatMap (go rGroups) xs cleanup = onCleanup loc (reverse rGroups) action go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] sequenceActions :: Bool -> [EvalM ()] -> EvalM () sequenceActions failFast = go where go :: [EvalM ()] -> EvalM () go [] = pass go (action : actions) = do action stopNow <- case failFast of False -> return False True -> hasFailed unless stopNow (go actions) hspec-core-2.10.10/src/Test/Hspec/Core/Runner/JobQueue.hs0000644000000000000000000000722707346545000021070 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} #if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0) -- Control.Concurrent.QSem is deprecated in base-4.6.0.* {-# OPTIONS_GHC -fno-warn-deprecations #-} #endif module Test.Hspec.Core.Runner.JobQueue ( MonadIO , Job , Concurrency(..) , JobQueue , withJobQueue , enqueueJob ) where import Prelude () import Test.Hspec.Core.Compat hiding (Monad) import qualified Test.Hspec.Core.Compat as M import Control.Concurrent import Control.Concurrent.Async (Async, AsyncCancelled(..), async, waitCatch, asyncThreadId) import Control.Monad.IO.Class (liftIO) import qualified Control.Monad.IO.Class as M -- for compatibility with GHC < 7.10.1 type Monad m = (Functor m, Applicative m, M.Monad m) type MonadIO m = (Monad m, M.MonadIO m) type Job m progress a = (progress -> m ()) -> m a data Concurrency = Sequential | Concurrent data JobQueue = JobQueue { _semaphore :: Semaphore , _cancelQueue :: CancelQueue } data Semaphore = Semaphore { _wait :: IO () , _signal :: IO () } type CancelQueue = IORef [Async ()] withJobQueue :: Int -> (JobQueue -> IO a) -> IO a withJobQueue concurrency = bracket new cancelAll where new :: IO JobQueue new = JobQueue <$> newSemaphore concurrency <*> newIORef [] cancelAll :: JobQueue -> IO () cancelAll (JobQueue _ cancelQueue) = readIORef cancelQueue >>= cancelMany cancelMany :: [Async a] -> IO () cancelMany jobs = do mapM_ notifyCancel jobs mapM_ waitCatch jobs notifyCancel :: Async a -> IO () notifyCancel = flip throwTo AsyncCancelled . asyncThreadId newSemaphore :: Int -> IO Semaphore newSemaphore capacity = do sem <- newQSem capacity return $ Semaphore (waitQSem sem) (signalQSem sem) enqueueJob :: MonadIO m => JobQueue -> Concurrency -> Job IO progress a -> IO (Job m progress (Either SomeException a)) enqueueJob (JobQueue sem cancelQueue) concurrency = case concurrency of Sequential -> runSequentially cancelQueue Concurrent -> runConcurrently sem cancelQueue runSequentially :: forall m progress a. MonadIO m => CancelQueue -> Job IO progress a -> IO (Job m progress (Either SomeException a)) runSequentially cancelQueue action = do barrier <- newEmptyMVar let wait :: IO () wait = takeMVar barrier signal :: m () signal = liftIO $ putMVar barrier () job <- runConcurrently (Semaphore wait pass) cancelQueue action return $ \ notifyPartial -> signal >> job notifyPartial data Partial progress a = Partial progress | Done runConcurrently :: forall m progress a. MonadIO m => Semaphore -> CancelQueue -> Job IO progress a -> IO (Job m progress (Either SomeException a)) runConcurrently (Semaphore wait signal) cancelQueue action = do result :: MVar (Partial progress a) <- newEmptyMVar let worker :: IO a worker = bracket_ wait signal $ do interruptible (action partialResult) `finally` done where partialResult :: progress -> IO () partialResult = replaceMVar result . Partial done :: IO () done = replaceMVar result Done pushOnCancelQueue :: Async a -> IO () pushOnCancelQueue = (modifyIORef cancelQueue . (:) . void) job <- bracket (async worker) pushOnCancelQueue return let waitForResult :: (progress -> m ()) -> m (Either SomeException a) waitForResult notifyPartial = do r <- liftIO (takeMVar result) case r of Partial progress -> notifyPartial progress >> waitForResult notifyPartial Done -> liftIO $ waitCatch job return waitForResult replaceMVar :: MVar a -> a -> IO () replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p hspec-core-2.10.10/src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs0000644000000000000000000000231707346545000023122 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Test.Hspec.Core.Runner.PrintSlowSpecItems ( printSlowSpecItems ) where import Prelude () import Test.Hspec.Core.Compat import Test.Hspec.Core.Util import Test.Hspec.Core.Format import Test.Hspec.Core.Clock import Test.Hspec.Core.Formatters.V2 (formatLocation) data SlowItem = SlowItem { location :: Maybe Location , path :: Path , duration :: Int } printSlowSpecItems :: Int -> Format -> Format printSlowSpecItems n format event = do format event case event of Done items -> do let xs = slowItems n $ map toSlowItem items unless (null xs) $ do putStrLn "\nSlow spec items:" mapM_ printSlowSpecItem xs _ -> pass toSlowItem :: (Path, Item) -> SlowItem toSlowItem (path, item) = SlowItem (itemLocation item) path (toMilliseconds $ itemDuration item) slowItems :: Int -> [SlowItem] -> [SlowItem] slowItems n = take n . reverse . sortOn duration . filter ((/= 0) . duration) printSlowSpecItem :: SlowItem -> IO () printSlowSpecItem SlowItem{..} = do putStrLn $ " " ++ maybe "" formatLocation location ++ joinPath path ++ " (" ++ show duration ++ "ms)" hspec-core-2.10.10/src/Test/Hspec/Core/Runner/Result.hs0000644000000000000000000000472207346545000020624 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.Runner.Result ( -- RE-EXPORTED from Test.Hspec.Core.Runner SpecResult(SpecResult) , specResultItems , specResultSuccess , ResultItem(ResultItem) , resultItemPath , resultItemStatus , resultItemIsFailure , ResultItemStatus(..) , Summary(..) , toSummary , isSuccess -- END RE-EXPORTED from Test.Hspec.Core.Runner , toSpecResult ) where import Prelude () import Test.Hspec.Core.Compat import Test.Hspec.Core.Util import qualified Test.Hspec.Core.Format as Format -- | -- @since 2.10.0 data SpecResult = SpecResult { -- | -- @since 2.10.0 specResultItems :: [ResultItem] -- | -- @since 2.10.0 , specResultSuccess :: !Bool } deriving (Eq, Show) -- | -- @since 2.10.0 data ResultItem = ResultItem { -- | -- @since 2.10.0 resultItemPath :: Path -- | -- @since 2.10.0 , resultItemStatus :: ResultItemStatus } deriving (Eq, Show) -- | -- @since 2.10.0 resultItemIsFailure :: ResultItem -> Bool resultItemIsFailure item = case resultItemStatus item of ResultItemSuccess -> False ResultItemPending -> False ResultItemFailure -> True data ResultItemStatus = ResultItemSuccess | ResultItemPending | ResultItemFailure deriving (Eq, Show) toSpecResult :: [(Path, Format.Item)] -> SpecResult toSpecResult results = SpecResult items success where items = map toResultItem results success = all (not . resultItemIsFailure) items toResultItem :: (Path, Format.Item) -> ResultItem toResultItem (path, item) = ResultItem path status where status = case Format.itemResult item of Format.Success{} -> ResultItemSuccess Format.Pending{} -> ResultItemPending Format.Failure{} -> ResultItemFailure -- | Summary of a test run. data Summary = Summary { summaryExamples :: !Int , summaryFailures :: !Int } deriving (Eq, Show) instance Monoid Summary where mempty = Summary 0 0 #if MIN_VERSION_base(4,11,0) instance Semigroup Summary where #endif (Summary x1 x2) #if MIN_VERSION_base(4,11,0) <> #else `mappend` #endif (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) toSummary :: SpecResult -> Summary toSummary result = Summary { summaryExamples = length items , summaryFailures = length failures } where items = specResultItems result failures = filter resultItemIsFailure items -- | `True` if the given `Summary` indicates that there were no -- failures, `False` otherwise. isSuccess :: Summary -> Bool isSuccess summary = summaryFailures summary == 0 hspec-core-2.10.10/src/Test/Hspec/Core/Shuffle.hs0000644000000000000000000000227407346545000017471 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.Shuffle ( shuffleForest #ifdef TEST , shuffle , mkArray #endif ) where import Prelude () import Test.Hspec.Core.Compat import Test.Hspec.Core.Tree import System.Random import Control.Monad.ST import Data.STRef import Data.Array.ST shuffleForest :: STRef st StdGen -> [Tree c a] -> ST st [Tree c a] shuffleForest ref xs = (shuffle ref xs >>= mapM (shuffleTree ref)) shuffleTree :: STRef st StdGen -> Tree c a -> ST st (Tree c a) shuffleTree ref t = case t of Node d xs -> Node d <$> shuffleForest ref xs NodeWithCleanup loc c xs -> NodeWithCleanup loc c <$> shuffleForest ref xs Leaf {} -> return t shuffle :: STRef st StdGen -> [a] -> ST st [a] shuffle ref xs = do arr <- mkArray xs bounds@(_, n) <- getBounds arr forM (range bounds) $ \ i -> do j <- randomIndex (i, n) vi <- readArray arr i vj <- readArray arr j writeArray arr j vi return vj where randomIndex bounds = do (a, gen) <- randomR bounds <$> readSTRef ref writeSTRef ref gen return a mkArray :: [a] -> ST st (STArray st Int a) mkArray xs = newListArray (1, length xs) xs hspec-core-2.10.10/src/Test/Hspec/Core/Spec.hs0000644000000000000000000001517407346545000016772 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 , focus , fit , fspecify , fdescribe , fcontext , parallel , sequential -- * The @SpecM@ monad , Test.Hspec.Core.Spec.Monad.Spec , Test.Hspec.Core.Spec.Monad.SpecWith , Test.Hspec.Core.Spec.Monad.SpecM(..) , Test.Hspec.Core.Spec.Monad.runSpecM , Test.Hspec.Core.Spec.Monad.fromSpecList , Test.Hspec.Core.Spec.Monad.runIO , Test.Hspec.Core.Spec.Monad.mapSpecForest , Test.Hspec.Core.Spec.Monad.mapSpecItem , Test.Hspec.Core.Spec.Monad.mapSpecItem_ , Test.Hspec.Core.Spec.Monad.modifyParams , Test.Hspec.Core.Spec.Monad.modifyConfig , getSpecDescriptionPath -- * A type class for examples , Test.Hspec.Core.Example.Example (..) , Test.Hspec.Core.Example.Params (..) , Test.Hspec.Core.Example.defaultParams , Test.Hspec.Core.Example.ActionWith , Test.Hspec.Core.Example.Progress , Test.Hspec.Core.Example.ProgressCallback , Test.Hspec.Core.Example.Result(..) , Test.Hspec.Core.Example.ResultStatus (..) , Test.Hspec.Core.Example.Location (..) , Test.Hspec.Core.Example.FailureReason (..) , Test.Hspec.Core.Example.safeEvaluate , Test.Hspec.Core.Example.safeEvaluateExample -- * Internal representation of a spec tree , Test.Hspec.Core.Tree.SpecTree , Test.Hspec.Core.Tree.Tree (..) , Test.Hspec.Core.Tree.Item (..) , Test.Hspec.Core.Tree.specGroup , Test.Hspec.Core.Tree.specItem , Test.Hspec.Core.Tree.bimapTree , Test.Hspec.Core.Tree.bimapForest , Test.Hspec.Core.Tree.filterTree , Test.Hspec.Core.Tree.filterForest , Test.Hspec.Core.Tree.filterTreeWithLabels , Test.Hspec.Core.Tree.filterForestWithLabels , Test.Hspec.Core.Tree.pruneTree -- unused , Test.Hspec.Core.Tree.pruneForest -- unused , Test.Hspec.Core.Tree.location , focusForest -- * Re-exports , HasCallStack , Expectation ) where import Prelude () import Test.Hspec.Core.Compat import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (asks) 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 :: HasCallStack => String -> SpecWith a -> SpecWith a describe label = withEnv pushLabel . mapSpecForest (return . specGroup label) where pushLabel (Env labels) = Env $ label : labels -- | @context@ is an alias for `describe`. context :: HasCallStack => 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 :: HasCallStack => String -> SpecWith a -> SpecWith a xdescribe label spec = before_ pending_ $ describe label spec -- | @xcontext@ is an alias for `xdescribe`. xcontext :: HasCallStack => 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 -- | `focus` focuses all spec items of the given spec. -- -- Applying `focus` to a spec with focused spec items has no effect. focus :: SpecWith a -> SpecWith a focus = mapSpecForest focusForest focusForest :: [SpecTree a] -> [SpecTree a] focusForest xs | any (any itemIsFocused) xs = xs | otherwise = bimapForest id (\ item -> item {itemIsFocused = True}) xs -- | @fit@ is an alias for @fmap focus . it@ fit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) fit = fmap focus . it -- | @fspecify@ is an alias for `fit`. fspecify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) fspecify = fit -- | @fdescribe@ is an alias for @fmap focus . describe@ fdescribe :: HasCallStack => String -> SpecWith a -> SpecWith a fdescribe = fmap focus . describe -- | @fcontext@ is an alias for `fdescribe`. fcontext :: HasCallStack => String -> SpecWith a -> SpecWith a fcontext = fdescribe -- | `parallel` marks all spec items of the given spec to be safe for parallel -- evaluation. parallel :: SpecWith a -> SpecWith a parallel = mapSpecItem_ (setParallelizable True) -- | `sequential` marks all spec items of the given spec to be evaluated sequentially. sequential :: SpecWith a -> SpecWith a sequential = mapSpecItem_ (setParallelizable False) setParallelizable :: Bool -> Item a -> Item a setParallelizable value item = item {itemIsParallelizable = itemIsParallelizable item <|> Just value} -- | `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 :: HasCallStack => Expectation pending = throwIO (Pending location Nothing) pending_ :: Expectation pending_ = (throwIO (Pending Nothing 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 :: HasCallStack => String -> Expectation pendingWith = throwIO . Pending location . Just -- | Get the path of `describe` labels, from the root all the way in to the -- call-site of this function. -- -- ==== __Example__ -- >>> :{ -- runSpecM $ do -- describe "foo" $ do -- describe "bar" $ do -- getSpecDescriptionPath >>= runIO . print -- :} -- ["foo","bar"] -- -- @since 2.10.0 getSpecDescriptionPath :: SpecM a [String] getSpecDescriptionPath = SpecM $ lift $ reverse <$> asks envSpecDescriptionPath hspec-core-2.10.10/src/Test/Hspec/Core/Spec/0000755000000000000000000000000007346545000016426 5ustar0000000000000000hspec-core-2.10.10/src/Test/Hspec/Core/Spec/Monad.hs0000644000000000000000000000544507346545000020030 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Spec.Monad ( -- RE-EXPORTED from Test.Hspec.Core.Spec Spec , SpecWith , SpecM (SpecM) , runSpecM , fromSpecList , runIO , mapSpecForest , mapSpecItem , mapSpecItem_ , modifyParams , modifyConfig -- END RE-EXPORTED from Test.Hspec.Core.Spec , Env(..) , withEnv ) where import Prelude () import Test.Hspec.Core.Compat import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer import Test.Hspec.Core.Example import Test.Hspec.Core.Tree import Test.Hspec.Core.Config.Definition (Config) type Spec = SpecWith () type SpecWith a = SpecM a () -- | -- @since 2.10.0 modifyConfig :: (Config -> Config) -> SpecWith a modifyConfig f = SpecM $ tell (Endo f, mempty) -- | A writer monad for `SpecTree` forests newtype SpecM a r = SpecM { unSpecM :: WriterT (Endo Config, [SpecTree a]) (ReaderT Env IO) r } deriving (Functor, Applicative, Monad) -- | Convert a `Spec` to a forest of `SpecTree`s. runSpecM :: SpecWith a -> IO (Endo Config, [SpecTree a]) runSpecM = flip runReaderT (Env []) . execWriterT . unSpecM -- | Create a `Spec` from a forest of `SpecTree`s. fromSpecForest :: (Endo Config, [SpecTree a]) -> SpecWith a fromSpecForest = SpecM . tell -- | Create a `Spec` from a forest of `SpecTree`s. fromSpecList :: [SpecTree a] -> SpecWith a fromSpecList = fromSpecForest . (,) mempty -- | 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 mapSpecForest :: ([SpecTree a] -> [SpecTree b]) -> SpecM a r -> SpecM b r mapSpecForest f (SpecM specs) = SpecM (mapWriterT (fmap (fmap (second f))) specs) -- {-# DEPRECATED mapSpecItem "Use `mapSpecItem_` instead." #-} -- | Deprecated: Use `mapSpecItem_` instead. mapSpecItem :: (ActionWith a -> ActionWith b) -> (Item a -> Item b) -> SpecWith a -> SpecWith b mapSpecItem _ = mapSpecItem_ mapSpecItem_ :: (Item a -> Item b) -> SpecWith a -> SpecWith b mapSpecItem_ = mapSpecForest . bimapForest id modifyParams :: (Params -> Params) -> SpecWith a -> SpecWith a modifyParams f = mapSpecItem_ $ \item -> item {itemExample = \p -> (itemExample item) (f p)} newtype Env = Env { envSpecDescriptionPath :: [String] } withEnv :: (Env -> Env) -> SpecM a r -> SpecM a r withEnv f = SpecM . WriterT . local f . runWriterT . unSpecM hspec-core-2.10.10/src/Test/Hspec/Core/Timer.hs0000644000000000000000000000103007346545000017142 0ustar0000000000000000module Test.Hspec.Core.Timer (withTimer) where import Prelude () import Test.Hspec.Core.Compat import Control.Concurrent.Async import Test.Hspec.Core.Clock withTimer :: Seconds -> (IO Bool -> IO a) -> IO a withTimer delay action = do ref <- newIORef False bracket (async $ worker delay ref) cancel $ \_ -> do action $ atomicModifyIORef ref (\a -> (False, a)) worker :: Seconds -> IORef Bool -> IO () worker delay ref = do forever $ do sleep delay atomicWriteIORef ref True hspec-core-2.10.10/src/Test/Hspec/Core/Tree.hs0000644000000000000000000001137107346545000016772 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} module Test.Hspec.Core.Tree ( -- RE-EXPORTED from Test.Hspec.Core.Spec SpecTree , Tree (..) , Item (..) , specGroup , specItem , bimapTree , bimapForest , filterTree , filterForest , filterTreeWithLabels , filterForestWithLabels , pruneTree -- unused , pruneForest -- unused , location -- END RE-EXPORTED from Test.Hspec.Core.Spec , callSite ) where import Prelude () import Test.Hspec.Core.Compat import Data.CallStack (SrcLoc(..)) import qualified Data.CallStack as CallStack import Test.Hspec.Core.Example -- | Internal tree data structure data Tree c a = Node String [Tree c a] | NodeWithCleanup (Maybe (String, Location)) c [Tree c a] | Leaf a deriving (Eq, Show, Functor, Foldable, Traversable) -- | A tree is used to represent a spec internally. The tree is parameterized -- over the type of cleanup actions and the type of the actual spec items. type SpecTree a = Tree (IO ()) (Item a) bimapForest :: (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d] bimapForest g f = map (bimapTree g f) bimapTree :: (a -> b) -> (c -> d) -> Tree a c -> Tree b d bimapTree g f = go where go spec = case spec of Node d xs -> Node d (map go xs) NodeWithCleanup loc action xs -> NodeWithCleanup loc (g action) (map go xs) Leaf item -> Leaf (f item) filterTree :: (a -> Bool) -> Tree c a -> Maybe (Tree c a) filterTree = filterTreeWithLabels . const filterForest :: (a -> Bool) -> [Tree c a] -> [Tree c a] filterForest = filterForestWithLabels . const filterTreeWithLabels :: ([String] -> a -> Bool) -> Tree c a -> Maybe (Tree c a) filterTreeWithLabels = filterTree_ [] filterForestWithLabels :: ([String] -> a -> Bool) -> [Tree c a] -> [Tree c a] filterForestWithLabels = filterForest_ [] filterForest_ :: [String] -> ([String] -> a -> Bool) -> [Tree c a] -> [Tree c a] filterForest_ groups = mapMaybe . filterTree_ groups filterTree_ :: [String] -> ([String] -> a -> Bool) -> Tree c a -> Maybe (Tree c a) filterTree_ groups p tree = case tree of Node group xs -> Just $ Node group $ filterForest_ (groups ++ [group]) p xs NodeWithCleanup loc action xs -> Just $ NodeWithCleanup loc action $ filterForest_ groups p xs Leaf item -> Leaf <$> guarded (p groups) item pruneForest :: [Tree c a] -> [Tree c a] pruneForest = mapMaybe pruneTree pruneTree :: Tree c a -> Maybe (Tree c a) pruneTree node = case node of Node group xs -> Node group <$> prune xs NodeWithCleanup loc action xs -> NodeWithCleanup loc action <$> prune xs Leaf{} -> Just node where prune = guarded (not . null) . pruneForest -- | -- @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 :: Maybe Bool -- | A flag that indicates whether this spec item is focused. , itemIsFocused :: Bool -- | Example for behavior , itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result } -- | The @specGroup@ function combines a list of specs into a larger spec. specGroup :: HasCallStack => String -> [SpecTree a] -> SpecTree a specGroup s = Node msg where msg :: HasCallStack => String msg | null s = fromMaybe "(no description given)" defaultDescription | otherwise = s -- | The @specItem@ function creates a spec item. specItem :: (HasCallStack, Example e) => String -> e -> SpecTree (Arg e) specItem s e = Leaf Item { itemRequirement = requirement , itemLocation = location , itemIsParallelizable = Nothing , itemIsFocused = False , itemExample = safeEvaluateExample e } where requirement :: HasCallStack => String requirement | null s = fromMaybe "(unspecified behavior)" defaultDescription | otherwise = s location :: HasCallStack => Maybe Location location = snd <$> callSite callSite :: HasCallStack => Maybe (String, Location) callSite = fmap toLocation <$> CallStack.callSite defaultDescription :: HasCallStack => Maybe String defaultDescription = case CallStack.callSite of Just (_, loc) -> Just (srcLocModule loc ++ "[" ++ show (srcLocStartLine loc) ++ ":" ++ show (srcLocStartCol loc) ++ "]") Nothing -> Nothing hspec-core-2.10.10/src/Test/Hspec/Core/Util.hs0000644000000000000000000001043207346545000017005 0ustar0000000000000000-- | Stability: unstable module Test.Hspec.Core.Util ( -- * String functions pluralize , strip , lineBreaksAt -- * Working with paths , Path , joinPath , formatRequirement , filterPredicate -- * Working with exceptions , safeTry , formatException ) where import Prelude () import Test.Hspec.Core.Compat hiding (join) import Data.Char (isSpace) import GHC.IO.Exception import Control.Concurrent.Async -- | -- @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" -- -- @since 2.0.0 pluralize :: Int -> String -> String pluralize 1 s = "1 " ++ s pluralize n s = show n ++ " " ++ s ++ "s" -- | Strip leading and trailing whitespace -- -- @since 2.0.0 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 -- -- @since 2.0.0 lineBreaksAt :: Int -> String -> [String] lineBreaksAt n = concatMap f . lines where f input = case words input of [] -> [] x:xs -> go (x, xs) 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` describes the location of a spec item within a spec tree. -- -- It consists of a list of group descriptions and a requirement description. -- -- @since 2.0.0 type Path = ([String], String) -- | -- Join a `Path` with slashes. The result will have a leading and a trailing -- slash. -- -- @since 2.5.4 joinPath :: Path -> String joinPath (groups, requirement) = "/" ++ intercalate "/" (groups ++ [requirement]) ++ "/" -- | -- Try to create a proper English sentence from a path by applying some -- heuristics. -- -- @since 2.0.0 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. -- -- @since 2.0.0 filterPredicate :: String -> Path -> Bool filterPredicate pattern path = pattern `isInfixOf` plain || pattern `isInfixOf` formatted where plain = joinPath path 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\ndivide by zero" -- -- For `IOException`s the `IOErrorType` is included, as well. -- -- @since 2.0.0 formatException :: SomeException -> String formatException err@(SomeException e) = case fromException err of Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ "\n" ++ show ioe Nothing -> showType e ++ "\n" ++ 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. -- -- @since 2.0.0 safeTry :: IO a -> IO (Either SomeException a) safeTry action = withAsync (action >>= evaluate) waitCatch hspec-core-2.10.10/test/GetOpt/Declarative/0000755000000000000000000000000007346545000016500 5ustar0000000000000000hspec-core-2.10.10/test/GetOpt/Declarative/EnvironmentSpec.hs0000644000000000000000000000477307346545000022166 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-missing-fields #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module GetOpt.Declarative.EnvironmentSpec (spec) where import Prelude () import Helper import GetOpt.Declarative.Types import GetOpt.Declarative.Environment spec :: Spec spec = do describe "parseEnvironmentOption" $ do context "with NoArg" $ do let option :: Option Bool option = Option { optionName = "some-flag" , optionSetter = NoArg $ const True } it "accepts 'yes'" $ do parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] False option `shouldBe` Right True it "rejects other values" $ do parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] False option `shouldBe` invalidValue "FOO_SOME_FLAG" "no" context "with Flag" $ do let option :: Option Bool option = Option { optionName = "some-flag" , optionSetter = Flag $ \ value _ -> value } it "accepts 'yes'" $ do parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] False option `shouldBe` Right True it "accepts 'no'" $ do parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] True option `shouldBe` Right False it "rejects other values" $ do parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "nay")] True option `shouldBe` invalidValue "FOO_SOME_FLAG" "nay" context "with OptArg" $ do let option :: Option String option = Option { optionName = "some-flag" , optionSetter = OptArg undefined $ \ (Just arg) _ -> guard (arg == "yes") >> Just arg } it "accepts valid values" $ do parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] "" option `shouldBe` Right "yes" it "rejects invalid values" $ do parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] "" option `shouldBe` invalidValue "FOO_SOME_FLAG" "no" context "with Arg" $ do let option :: Option String option = Option { optionName = "some-flag" , optionSetter = Arg undefined $ \ arg _ -> guard (arg == "yes") >> Just arg } it "accepts valid values" $ do parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] "" option `shouldBe` Right "yes" it "rejects invalid values" $ do parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] "" option `shouldBe` invalidValue "FOO_SOME_FLAG" "no" where invalidValue name = Left . InvalidValue name hspec-core-2.10.10/test/GetOpt/Declarative/UtilSpec.hs0000644000000000000000000000173307346545000020570 0ustar0000000000000000module GetOpt.Declarative.UtilSpec (spec) where import Prelude () import Helper import System.Console.GetOpt import GetOpt.Declarative.Util spec :: Spec spec = do describe "mkUsageInfo" $ do it "restricts output size to 80 characters" $ do let options = [ Option "" ["color"] (NoArg ()) (unwords $ replicate 3 "some very long and verbose help text") ] mkUsageInfo "" options `shouldBe` unlines [ "" , " --color some very long and verbose help text some very long and verbose" , " help text some very long and verbose help text" ] it "condenses help for --no-options" $ do let options = [ Option "" ["color"] (NoArg ()) "some help" , Option "" ["no-color"] (NoArg ()) "some other help" ] mkUsageInfo "" options `shouldBe` unlines [ "" , " --[no-]color some help" ] hspec-core-2.10.10/test/0000755000000000000000000000000007346545000013053 5ustar0000000000000000hspec-core-2.10.10/test/Helper.hs0000644000000000000000000001344207346545000014632 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Helper ( module Test.Hspec.Meta , module Test.Hspec.Core.Compat , module Test.QuickCheck , module System.IO.Silently , Seconds(..) , sleep , timeout , defaultParams , noOpProgressCallback , captureLines , normalizeSummary , normalizeTimes , ignoreExitCode , ignoreUserInterrupt , throwException , throwException_ , withEnvironment , inTempDirectory , hspecSilent , hspecResultSilent , shouldUseArgs , removeLocations , () , mkLocation , workaroundForIssue19236 , replace ) where import Prelude () import Test.Hspec.Core.Compat import Data.Char import System.Environment (withArgs, getEnvironment) import System.Exit import System.IO.Silently import System.SetEnv import System.FilePath import System.Directory import System.IO.Temp import Test.Hspec.Meta hiding (hspec, hspecResult, pending, pendingWith) import Test.QuickCheck hiding (Result(..)) import qualified Test.HUnit.Lang as HUnit import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import Test.Hspec.Core.QuickCheckUtil (mkGen) import Test.Hspec.Core.Clock import Test.Hspec.Core.Example (Result(..), ResultStatus(..), FailureReason(..), Location(..)) import Test.Hspec.Core.Example.Location (workaroundForIssue19236) import Test.Hspec.Core.Util import qualified Test.Hspec.Core.Format as Format import Test.Hspec.Core.Formatters.V2 (formatterToFormat, silent) import Data.Orphans() exceptionEq :: SomeException -> SomeException -> Bool exceptionEq a b | Just ea <- fromException a, Just eb <- fromException b = ea == (eb :: ErrorCall) | Just ea <- fromException a, Just eb <- fromException b = ea == (eb :: ArithException) | otherwise = throw (HUnit.HUnitFailure Nothing $ HUnit.ExpectedButGot Nothing (formatException b) (formatException a)) deriving instance Eq FailureReason deriving instance Eq ResultStatus deriving instance Eq Result deriving instance Eq Format.Result deriving instance Eq Format.Item instance Eq SomeException where (==) = exceptionEq throwException :: IO a throwException = throwIO DivideByZero throwException_ :: IO () throwException_ = throwException ignoreExitCode :: IO () -> IO () ignoreExitCode action = action `catch` \e -> let _ = e :: ExitCode in pass ignoreUserInterrupt :: IO () -> IO () ignoreUserInterrupt action = catchJust (guard . (== 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 normalizeTimes :: [String] -> [String] normalizeTimes = map go where go xs = case xs of [] -> [] '(' : y : ys | isNumber y, Just zs <- stripPrefix "ms)" $ dropWhile isNumber ys -> "(2ms)" ++ go zs y : ys -> y : go ys defaultParams :: H.Params defaultParams = H.defaultParams {H.paramsQuickCheckArgs = stdArgs {replay = Just (mkGen 23, 0), maxSuccess = 1000}} noOpProgressCallback :: H.ProgressCallback noOpProgressCallback _ = pass silentConfig :: H.Config silentConfig = H.defaultConfig {H.configFormat = Just $ formatterToFormat silent} hspecSilent :: H.Spec -> IO () hspecSilent = H.hspecWith silentConfig hspecResultSilent :: H.Spec -> IO H.Summary hspecResultSilent = H.hspecWithResult silentConfig shouldUseArgs :: HasCallStack => (Eq n, Show n) => [String] -> (Args -> n, n) -> Expectation shouldUseArgs args (accessor, expected) = do spy <- newIORef stdArgs let interceptArgs :: H.Item a -> H.Item a interceptArgs item = item { H.itemExample = \ params action progressCallback -> do writeIORef spy (H.paramsQuickCheckArgs params) H.itemExample item params action progressCallback } spec :: H.Spec spec = H.mapSpecItem_ interceptArgs $ H.it "" True withArgs args $ hspecSilent spec accessor <$> readIORef spy `shouldReturn` expected removeLocations :: H.SpecWith a -> H.SpecWith a removeLocations = H.mapSpecItem_ $ \ item -> item { H.itemLocation = Nothing , H.itemExample = \ params action progressCallback -> removeResultLocation <$> H.itemExample item params action progressCallback } removeResultLocation :: Result -> Result removeResultLocation (Result info status) = case status of Success -> Result info status Pending _loc reason -> Result info (Pending Nothing reason) Failure _loc reason -> Result info (Failure Nothing reason) 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 mkLocation :: FilePath -> Int -> Int -> Maybe Location #if MIN_VERSION_base(4,8,1) mkLocation file line column = Just (Location (workaroundForIssue19236 file) line column) #else mkLocation _ _ _ = Nothing #endif replace :: Eq a => a -> a -> [a] -> [a] replace x y xs = case break (== x) xs of (ys, _: zs) -> ys ++ y : zs _ -> xs hspec-core-2.10.10/test/Mock.hs0000644000000000000000000000047407346545000014305 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.10.10/test/Spec.hs0000644000000000000000000000010007346545000014270 0ustar0000000000000000{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-meta-discover #-} hspec-core-2.10.10/test/SpecHook.hs0000644000000000000000000000070207346545000015121 0ustar0000000000000000module SpecHook (hook) where import Prelude () import Helper import System.Environment (getEnvironment) ignoreHspecConfig :: IO a -> IO a ignoreHspecConfig action = do env <- getEnvironment let filteredEnv = ("IGNORE_DOT_HSPEC", "yes") : filter p env withEnvironment filteredEnv action where p (name, _value) = name == "COMSPEC" || name == "PATH" hook :: Spec -> Spec hook = aroundAll_ ignoreHspecConfig hspec-core-2.10.10/test/Test/Hspec/Core/0000755000000000000000000000000007346545000015724 5ustar0000000000000000hspec-core-2.10.10/test/Test/Hspec/Core/ClockSpec.hs0000644000000000000000000000063007346545000020125 0ustar0000000000000000module Test.Hspec.Core.ClockSpec (spec) where import Prelude () import Helper import Test.Hspec.Core.Clock spec :: Spec spec = do describe "toMilliseconds" $ do it "converts Seconds to milliseconds" $ do toMilliseconds 0.1 `shouldBe` 100 describe "toMicroseconds" $ do it "converts Seconds to microseconds" $ do toMicroseconds 2.5 `shouldBe` 2500000 hspec-core-2.10.10/test/Test/Hspec/Core/CompatSpec.hs0000644000000000000000000000154607346545000020324 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Test.Hspec.Core.CompatSpec (spec) where import Prelude () import Helper import System.SetEnv import Data.Typeable data SomeType = SomeType deriving Typeable 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.10.10/test/Test/Hspec/Core/Config/0000755000000000000000000000000007346545000017131 5ustar0000000000000000hspec-core-2.10.10/test/Test/Hspec/Core/Config/DefinitionSpec.hs0000644000000000000000000000113507346545000022370 0ustar0000000000000000module Test.Hspec.Core.Config.DefinitionSpec (spec) where import Prelude () import Helper import Test.Hspec.Core.Config.Definition spec :: Spec spec = do describe "splitOn" $ do it "splits a string" $ do splitOn ',' "foo,bar,baz" `shouldBe` ["foo", "bar", "baz"] it "splits *arbitrary* strings" $ property $ do let string :: Gen String string = arbitrary `suchThat` p p :: String -> Bool p = (&&) <$> not . null <*> all (/= ',') forAll (listOf string) $ \ xs -> splitOn ',' (intercalate "," xs) `shouldBe` xs hspec-core-2.10.10/test/Test/Hspec/Core/Config/OptionsSpec.hs0000644000000000000000000002621207346545000021736 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Test.Hspec.Core.Config.OptionsSpec (spec) where import Prelude () import Helper import System.Exit import Test.Hspec.Core.Config import Test.Hspec.Core.Config.Options hiding (parseOptions) import qualified Test.Hspec.Core.Config.Options as Options fromLeft :: Either a b -> a fromLeft (Left a) = a fromLeft _ = error "fromLeft: No left value!" spec :: Spec spec = do describe "parseOptions" $ do let parseOptions configFiles envVar env args = snd <$> Options.parseOptions defaultConfig "my-spec" configFiles envVar env args 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 "when the same option is specified multiple times" $ do it "gives later occurrences precedence" $ do configColorMode <$> parseOptions [] Nothing [] ["--color", "--no-color"] `shouldBe` Right ColorNever context "with --help" $ do let Left (code, help) = Options.parseOptions defaultConfig "spec" [] Nothing [] ["--help"] it "returns ExitSuccess" $ do code `shouldBe` ExitSuccess it "prints help" $ do expected <- readFile "help.txt" help `shouldBe` expected describe "RUNNER OPTIONS" $ do let parseOptions_ args = snd <$> Options.parseOptions defaultConfig "my-spec" [] Nothing [] args it "gives HSPEC_FAIL_ON precedence over HSPEC_STRICT" $ do (configFailOnFocused &&& configFailOnPending) <$> parseOptions [] Nothing [("HSPEC_STRICT", "no"), ("HSPEC_FAIL_ON", "focused")] [] `shouldBe` Right (True, False) it "gives HSPEC_NO_FAIL_ON precedence over HSPEC_STRICT" $ do (configFailOnFocused &&& configFailOnPending) <$> parseOptions [] Nothing [("HSPEC_STRICT", "yes"), ("HSPEC_NO_FAIL_ON", "focused")] [] `shouldBe` Right (False, True) context "with --fail-on-focused" $ do it "sets configFailOnFocused to True" $ do configFailOnFocused <$> parseOptions_ ["--fail-on-focused"] `shouldBe` Right True context "with --fail-on-pending" $ do it "sets configFailOnPending to True" $ do configFailOnPending <$> parseOptions_ ["--fail-on-pending"] `shouldBe` Right True context "with --fail-on" $ do it "accepts a list of values" $ do let config = parseOptions_ ["--fail-on=focused,pending"] configFailOnFocused <$> config `shouldBe` Right True configFailOnPending <$> config `shouldBe` Right True context "with focused" $ do it "sets configFailOnFocused to True" $ do configFailOnFocused <$> parseOptions_ ["--fail-on=focused"] `shouldBe` Right True context "with pending" $ do it "sets configFailOnPending to True" $ do configFailOnPending <$> parseOptions_ ["--fail-on=pending"] `shouldBe` Right True context "with --no-fail-on" $ do it "inverts --fail-on" $ do let config = parseOptions_ ["--fail-on=focused,pending", "--no-fail-on=focused,pending"] configFailOnFocused <$> config `shouldBe` Right False configFailOnPending <$> config `shouldBe` Right False context "with --color" $ do it "sets configColorMode to ColorAlways" $ do configColorMode <$> parseOptions [] Nothing [] ["--color"] `shouldBe` Right ColorAlways context "with --no-color" $ do it "sets configColorMode to ColorNever" $ do configColorMode <$> parseOptions [] Nothing [] ["--no-color"] `shouldBe` Right ColorNever context "with --diff" $ do it "sets configDiff to True" $ do configDiff <$> parseOptions [] Nothing [] ["--diff"] `shouldBe` Right True context "with --no-diff" $ do it "sets configDiff to False" $ do configDiff <$> parseOptions [] Nothing [] ["--no-diff"] `shouldBe` Right False context "with --diff-context" $ do it "accepts 0" $ do configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=0"] `shouldBe` Right (Just 0) it "accepts positive values" $ do configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=5"] `shouldBe` Right (Just 5) it "rejects invalid values" $ do let msg = "my-spec: invalid argument `foo' for `--diff-context'\nTry `my-spec --help' for more information.\n" void (parseOptions [] Nothing [] ["--diff-context=foo"]) `shouldBe` Left (ExitFailure 1, msg) context "with negative values" $ do it "disables the option" $ do configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=-1"] `shouldBe` Right Nothing context "with 'full'" $ do it "disables the option" $ do configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=full"] `shouldBe` Right Nothing context "with --diff-command=" $ do it "sets configExternalDiff to Nothing" $ do fmap (const ()) . configExternalDiff <$> parseOptions [] Nothing [] ["--diff-command="] `shouldBe` Right Nothing context "with --print-slow-items" $ do it "sets configPrintSlowItems to N" $ do configPrintSlowItems <$> parseOptions [] Nothing [] ["--print-slow-items=5"] `shouldBe` Right (Just 5) it "defaults N to 10" $ do configPrintSlowItems <$> parseOptions [] Nothing [] ["--print-slow-items"] `shouldBe` Right (Just 10) it "rejects invalid values" $ do let msg = "my-spec: invalid argument `foo' for `--print-slow-items'\nTry `my-spec --help' for more information.\n" void (parseOptions [] Nothing [] ["--print-slow-items=foo"]) `shouldBe` Left (ExitFailure 1, msg) context "when N is 0" $ do it "disables the option" $ do configPrintSlowItems <$> parseOptions [] Nothing [] ["-p0"] `shouldBe` Right Nothing context "when N is negative" $ do it "disables the option" $ do configPrintSlowItems <$> parseOptions [] Nothing [] ["--print-slow-items=-23"] `shouldBe` Right Nothing context "with --qc-max-success" $ do it "sets QuickCheck maxSuccess" $ do maxSuccess . configQuickCheckArgs <$> (parseOptions [] Nothing [] ["--qc-max-success", "23"]) `shouldBe` Right 23 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 --qc-max-shrinks" $ do it "sets QuickCheck maxShrinks" $ do maxShrinks . configQuickCheckArgs <$> (parseOptions [] Nothing [] ["--qc-max-shrinks", "23"]) `shouldBe` Right 23 context "with --depth" $ do it "sets depth parameter for SmallCheck" $ do configSmallCheckDepth <$> parseOptions [] Nothing [] ["--depth", "23"] `shouldBe` Right (Just 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", ["--print"])] Nothing [] []) `shouldBe` (ExitFailure 1, unlines [ "my-spec: option `--print' is ambiguous; could be one of:" , " --print-cpu-time include used CPU time in summary" , " -p[N] --print-slow-items[=N] print the N slowest spec items (default: 10)" , "in config file ~/.hspec" ] ) context "when the same option is specified multiple times" $ do it "gives later occurrences precedence" $ do configColorMode <$> parseOptions [("~/.hspec", ["--color", "--no-color"])] Nothing [] [] `shouldBe` Right ColorNever 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 HSPEC_OPTIONS (deprecated)" $ do it "uses options from HSPEC_OPTIONS" $ 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") context "when given an option as an environment variable" $ do it "sets config value from environment variable" $ do configColorMode <$> parseOptions [] Nothing [("HSPEC_COLOR", "no")] [] `shouldBe` Right ColorNever it "gives command-line options precedence" $ do configColorMode <$> parseOptions [] Nothing [("HSPEC_COLOR", "no")] ["--color"] `shouldBe` Right ColorAlways it "warns on unrecognized option values" $ do fmap configColorMode <$> Options.parseOptions defaultConfig "my-spec" [] Nothing [("HSPEC_COLOR", "foo")] [] `shouldBe` Right (["invalid value `foo' for environment variable HSPEC_COLOR"], ColorAuto) 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.10.10/test/Test/Hspec/Core/ConfigSpec.hs0000644000000000000000000000270507346545000020304 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.ConfigSpec (spec) where import Prelude () import Helper import System.Directory import Test.Hspec.Core.Config spec :: Spec spec = around_ inTempDirectory $ around_ (withEnvironment [("HOME", "foo")]) $ do describe "readConfig" $ do it "recognizes options from HSPEC_OPTIONS" $ do withEnvironment [("HSPEC_OPTIONS", "--color")] $ do configColorMode <$> readConfig defaultConfig [] `shouldReturn` ColorAlways it "recognizes options from HSPEC_*" $ do withEnvironment [("HSPEC_COLOR", "yes")] $ do configColorMode <$> readConfig defaultConfig [] `shouldReturn` ColorAlways describe "readConfigFiles" $ do it "reads .hspec" $ do dir <- getCurrentDirectory let name = dir ".hspec" writeFile name "--diff" readConfigFiles `shouldReturn` [(name, ["--diff"])] #ifndef mingw32_HOST_OS 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` [] #endif hspec-core-2.10.10/test/Test/Hspec/Core/Example/0000755000000000000000000000000007346545000017317 5ustar0000000000000000hspec-core-2.10.10/test/Test/Hspec/Core/Example/LocationSpec.hs0000644000000000000000000001031107346545000022232 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# OPTIONS_GHC -O0 #-} module Test.Hspec.Core.Example.LocationSpec (spec) where import Prelude () import Helper import Test.Hspec.Core.Example import Test.Hspec.Core.Example.Location class SomeClass a where someMethod :: a -> IO () instance SomeClass () where data Person = Person { name :: String , age :: Int } deriving (Eq, Show) spec :: Spec spec = do describe "parseAssertionFailed" $ do context "with pre-GHC-8.* error message" $ do it "extracts source location" $ do parseAssertionFailed "Foo.hs:4:7-12: Assertion failed\n" `shouldBe` Just (Location "Foo.hs" 4 7) describe "extractLocation" $ do context "with pattern match failure in do expression" $ do context "in IO" $ do it "extracts Location" $ do let location = Just $ Location file (__LINE__ + 2) 13 Left e <- try $ do Just n <- return Nothing return (n :: Int) extractLocation e `shouldBe` location #if !MIN_VERSION_base(4,12,0) context "in Either" $ do it "extracts Location" $ do let location = Just $ Location file (__LINE__ + 4) 15 let foo :: Either () () foo = do 23 <- Right (42 :: Int) pass Left e <- try (evaluate foo) extractLocation e `shouldBe` location #endif context "with ErrorCall" $ do it "extracts Location" $ do let location = #if MIN_VERSION_base(4,9,0) Just $ Location file (__LINE__ + 4) 34 #else Nothing #endif Left e <- try (evaluate (undefined :: ())) extractLocation e `shouldBe` location context "with PatternMatchFail" $ do context "with single-line source span" $ do it "extracts Location" $ do let location = Just $ Location file (__LINE__ + 1) 40 Left e <- try (evaluate (let Just n = Nothing in (n :: Int))) extractLocation e `shouldBe` location context "with multi-line source span" $ do it "extracts Location" $ do let location = Just $ Location file (__LINE__ + 1) 36 Left e <- try (evaluate (case Nothing of Just n -> n :: Int )) extractLocation e `shouldBe` location context "with RecConError" $ do it "extracts Location" $ do let location = Just $ Location file (__LINE__ + 1) 39 Left e <- try $ evaluate (age Person {name = "foo"}) extractLocation e `shouldBe` location context "with NoMethodError" $ do it "extracts Location" $ do Left e <- try $ someMethod () extractLocation e `shouldBe` Just (Location file 19 10) context "with AssertionFailed" $ do it "extracts Location" $ do let location = Just $ Location file (__LINE__ + 1) 36 Left e <- try . evaluate $ assert False () extractLocation e `shouldBe` location describe "parseCallStack" $ do it "parses Location from call stack" $ do let input = unlines [ "CallStack (from HasCallStack):" , " error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err" , " undefined, called at test/Test/Hspec.hs:13:32 in main:Test.Hspec" ] parseCallStack input `shouldBe` Just (Location ("test" "Test" "Hspec.hs") 13 32) describe "parseLocation" $ do it "parses Location" $ do parseLocation "test/Test/Hspec.hs:13:32" `shouldBe` Just (Location ("test" "Test" "Hspec.hs") 13 32) describe "parseSourceSpan" $ do it "parses single-line source span" $ do parseSourceSpan "test/Test/Hspec.hs:25:36-51:" `shouldBe` Just (Location ("test" "Test" "Hspec.hs") 25 36) it "parses multi-line source span" $ do parseSourceSpan "test/Test/Hspec.hs:(15,7)-(17,26):" `shouldBe` Just (Location ("test" "Test" "Hspec.hs") 15 7) file :: FilePath file = workaroundForIssue19236 __FILE__ hspec-core-2.10.10/test/Test/Hspec/Core/ExampleSpec.hs0000644000000000000000000002427307346545000020476 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Test.Hspec.Core.ExampleSpec (spec) where import Prelude () import Helper import Mock import Test.HUnit (assertFailure, assertEqual) import Test.Hspec.Core.Example (Result(..), ResultStatus(..), FailureReason(..)) import qualified Test.Hspec.Expectations as H import qualified Test.Hspec.Core.Example as H import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H safeEvaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO Result safeEvaluateExample e = H.safeEvaluateExample e defaultParams ($ ()) noOpProgressCallback evaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO Result evaluateExample e = H.evaluateExample e defaultParams ($ ()) noOpProgressCallback evaluateExampleWith :: (H.Example e, H.Arg e ~ ()) => (IO () -> IO ()) -> e -> IO Result evaluateExampleWith action e = H.evaluateExample e defaultParams (action . ($ ())) noOpProgressCallback evaluateExampleWithArgument :: H.Example e => (ActionWith (H.Arg e) -> IO ()) -> e -> IO Result evaluateExampleWithArgument action e = H.evaluateExample e defaultParams action noOpProgressCallback bottom :: a bottom = throw DivideByZero spec :: Spec spec = do describe "safeEvaluate" $ do let status :: ResultStatus status = Failure Nothing (Error Nothing $ toException DivideByZero) err :: Result err = Result "" status it "forces Result" $ do H.safeEvaluate (return $ Result "" bottom) `shouldReturn` err it "handles ResultStatus exceptions" $ do H.safeEvaluate (throwIO status) `shouldReturn` err it "forces ResultStatus exceptions" $ do H.safeEvaluate (throwIO $ Failure Nothing bottom) `shouldReturn` err it "handles other exceptions" $ do H.safeEvaluate (throwIO DivideByZero) `shouldReturn` err it "forces other exceptions" $ do H.safeEvaluate (throwIO $ ErrorCall bottom) `shouldReturn` err describe "safeEvaluateResultStatus" $ do let err :: ResultStatus err = Failure Nothing (Error Nothing $ toException DivideByZero) it "forces ResultStatus" $ do H.safeEvaluateResultStatus (return $ Failure Nothing bottom) `shouldReturn` err it "handles ResultStatus exceptions" $ do H.safeEvaluateResultStatus (throwIO err) `shouldReturn` err it "forces ResultStatus exceptions" $ do H.safeEvaluateResultStatus (throwIO $ Failure Nothing bottom) `shouldReturn` err it "handles other exceptions" $ do H.safeEvaluateResultStatus (throwIO DivideByZero) `shouldReturn` err it "forces other exceptions" $ do H.safeEvaluateResultStatus (throwIO $ ErrorCall bottom) `shouldReturn` err describe "safeEvaluateExample" $ do context "for Expectation" $ do it "returns Failure if an expectation does not hold" $ do Result "" (Failure _ msg) <- safeEvaluateExample (23 `H.shouldBe` (42 :: Int)) msg `shouldBe` ExpectedButGot Nothing "42" "23" context "when used with `pending`" $ do it "returns Pending" $ do result <- safeEvaluateExample (H.pending) let location = mkLocation __FILE__ (pred __LINE__) 42 result `shouldBe` Result "" (Pending location Nothing) context "when used with `pendingWith`" $ do it "includes the optional reason" $ do result <- safeEvaluateExample (H.pendingWith "foo") let location = mkLocation __FILE__ (pred __LINE__) 42 result `shouldBe` Result "" (Pending location $ Just "foo") describe "evaluateExample" $ do context "for Result" $ do it "propagates exceptions" $ do evaluateExample (error "foobar" :: Result) `shouldThrow` errorCall "foobar" it "runs around-action" $ do ref <- newIORef (0 :: Int) let action :: IO () -> IO () action e = do e modifyIORef ref succ result = Result "" (Failure Nothing NoReason) evaluateExampleWith action result `shouldReturn` result 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 (Result "" . Failure Nothing . Reason . show) `shouldReturn` Result "" (Failure Nothing $ Reason "42") readIORef ref `shouldReturn` 1 context "for Bool" $ do it "returns Success on True" $ do evaluateExample True `shouldReturn` Result "" Success it "returns Failure on False" $ do evaluateExample False `shouldReturn` Result "" (Failure Nothing 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` Result "" (Failure Nothing 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` Result "" (Failure Nothing NoReason) readIORef ref `shouldReturn` 1 context "for Expectation" $ do it "returns Success if all expectations hold" $ do evaluateExample (23 `shouldBe` (23 :: Int)) `shouldReturn` Result "" 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` Result "" Success readIORef ref `shouldReturn` 2 context "for Property" $ do it "returns Success if property holds" $ do evaluateExample (property $ \n -> n == (n :: Int)) `shouldReturn` Result "+++ OK, passed 1000 tests." Success it "shows the collected labels" $ do Result info Success <- evaluateExample $ property $ \ () -> label "unit" True info `shouldBe` "+++ OK, passed 1000 tests (100.0% unit)." it "returns Failure if property does not hold" $ do Result "" (Failure _ _) <- evaluateExample $ property $ \n -> n /= (n :: Int) pass it "shows what falsified it" $ do Result "" (Failure _ r) <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False r `shouldBe` (Reason . intercalate "\n") [ "Falsified (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 Result _ Success <- evaluateExampleWith action (property $ \(_ :: Int) -> modifyIORef ref succ) readIORef ref `shouldReturn` 2000 it "pretty-prints exceptions" $ do Result "" (Failure _ r) <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (throw (ErrorCall "foobar") :: Bool)) r `shouldBe` (Reason . intercalate "\n") [ "uncaught exception: ErrorCall" , "foobar" , "(after 1 test)" , " 0" ] context "when used with Expectation" $ do let prop p = property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> p context "when used with shouldBe" $ do it "shows what falsified it" $ do Result "" (Failure _ err) <- evaluateExample $ prop $ 23 `H.shouldBe` (42 :: Int) err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n 0\n 1") "42" "23" context "when used with assertEqual" $ do it "includes prefix" $ do Result "" (Failure _ err) <- evaluateExample $ prop $ assertEqual "foobar" (42 :: Int) 23 err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n 0\n 1\nfoobar") "42" "23" context "when used with assertFailure" $ do it "includes reason" $ do Result "" (Failure _ err) <- evaluateExample $ prop (assertFailure "foobar" :: IO ()) err `shouldBe` Reason "Falsifiable (after 1 test):\n 0\n 1\nfoobar" context "when used with verbose" $ do it "includes verbose output" $ do Result info (Failure _ err) <- evaluateExample $ verbose $ (`H.shouldBe` (23 :: Int)) info `shouldBe` "Failed:\n0" err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n 0") "23" "0" context "when used with `pending`" $ do it "returns Pending" $ do let location = mkLocation __FILE__ (succ __LINE__) 37 evaluateExample (property H.pending) `shouldReturn` Result "" (Pending location Nothing) context "when used with `pendingWith`" $ do it "includes the optional reason" $ do let location = mkLocation __FILE__ (succ __LINE__) 39 evaluateExample (property $ H.pendingWith "foo") `shouldReturn` Result "" (Pending location $ Just "foo") describe "Expectation" $ do context "as a QuickCheck property" $ do it "can be quantified" $ do e <- newMock hspecSilent $ 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 hspecResultSilent $ 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.10.10/test/Test/Hspec/Core/FailureReportSpec.hs0000644000000000000000000000342207346545000021657 0ustar0000000000000000module Test.Hspec.Core.FailureReportSpec (spec) where import Prelude () import Helper import System.IO import Test.Hspec.Core.FailureReport import Test.Hspec.Core.Config spec :: Spec spec = do describe "writeFailureReport" $ do it "prints a warning on unexpected exceptions" $ do r <- hCapture_ [stderr] $ writeFailureReport defaultConfig (throw (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.10.10/test/Test/Hspec/Core/FormatSpec.hs0000644000000000000000000000103207346545000020317 0ustar0000000000000000module Test.Hspec.Core.FormatSpec (spec) where import Prelude () import Helper import Test.Hspec.Core.Format spec :: Spec spec = do describe "monadic" $ do context "on exception" $ do it "propagates" $ do format <- monadic id (\ _ -> throwIO DivideByZero) format (Done []) `shouldThrow` (== DivideByZero) it "does not hang" $ do format <- monadic id (\ _ -> throwIO DivideByZero) format (Done []) `shouldThrow` (== DivideByZero) format (Done []) hspec-core-2.10.10/test/Test/Hspec/Core/Formatters/0000755000000000000000000000000007346545000020052 5ustar0000000000000000hspec-core-2.10.10/test/Test/Hspec/Core/Formatters/DiffSpec.hs0000644000000000000000000000773607346545000022106 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Test.Hspec.Core.Formatters.DiffSpec (spec) where import Prelude () import Helper hiding (First) import Data.Char import Test.Hspec.Core.Formatters.Diff as Diff dropQuotes :: String -> String dropQuotes = init . tail spec :: Spec spec = do describe "diff" $ do let enumerate name n = map ((name ++) . show) [1 .. n :: Int] diff_ expected actual = diff (Just 2) (unlines expected) (unlines actual) it "suppresses excessive diff output" $ do let expected = enumerate "foo" 99 actual = replace "foo50" "bar50" expected diff_ expected actual `shouldBe` [ Omitted 47 , Both $ unlines [ "foo48" , "foo49" ] , First "foo50" , Second "bar50" , Both $ unlines [ "" , "foo51" , "foo52" ] , Omitted 47 ] it "ensures that omitted sections are at least three lines in size" $ do forAll (elements [1..20]) $ \ size -> do let expected = enumerate "" size forAll (elements expected) $ \ i -> do let actual = replace i "bar" expected [n | Omitted n <- diff_ expected actual] `shouldSatisfy` all (>= 3) context "with modifications within a line" $ do it "suppresses excessive diff output" $ do let expected = enumerate "foo " 99 actual = replace "foo 42" "foo 23" expected diff_ expected actual `shouldBe` [ Omitted 39 , Both $ concat [ "foo 40\n" , "foo 41\n" , "foo " ] , First "42" , Second "23" , Both $ concat [ "\n" , "foo 43\n" , "foo 44\n" ] , Omitted 55 ] context "with modifications at start / end" $ do it "suppresses excessive diff output" $ do let expected = enumerate "foo" 9 actual = replace "foo9" "bar9" $ replace "foo1" "bar1" expected diff_ expected actual `shouldBe` [ First "foo1" , Second "bar1" , Both $ unlines [ "" , "foo2" , "foo3" ] , Omitted 3 , Both $ unlines [ "foo7" , "foo8" ] , First "foo9" , Second "bar9" , Both "\n" ] describe "partition" $ do context "with a single shown Char" $ do it "never partitions a character escape" $ do property $ \ (c :: Char) -> partition (show c) `shouldBe` ["'", dropQuotes (show c), "'"] context "with a shown String" $ do it "puts backslash-escaped characters into separate chunks" $ do partition (show "foo\nbar") `shouldBe` ["\"", "foo", "\\n", "bar", "\""] it "puts *arbitrary* backslash-escaped characters into separate chunks" $ do property $ \ xs c ys -> let char = dropQuotes (show [c]) isEscaped = length char > 1 escape = tail char sep = case ys of x : _ | all isDigit escape && isDigit x || escape == "SO" && x == 'H' -> ["\\&"] _ -> [] actual = partition (show (xs ++ c : ys)) expected = partition (init $ show xs) ++ [char] ++ sep ++ partition (tail $ show ys) in isEscaped ==> actual `shouldBe` expected 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.10.10/test/Test/Hspec/Core/Formatters/InternalSpec.hs0000644000000000000000000000474607346545000023010 0ustar0000000000000000module Test.Hspec.Core.Formatters.InternalSpec (spec) where import Prelude () import Helper import System.Console.ANSI import Test.Hspec.Core.Format import Test.Hspec.Core.Formatters.Internal formatConfig :: FormatConfig formatConfig = FormatConfig { formatConfigUseColor = True , formatConfigReportProgress = False , formatConfigOutputUnicode = False , formatConfigUseDiff = True , formatConfigDiffContext = Just 3 , formatConfigExternalDiff = Nothing , formatConfigPrettyPrint = False , formatConfigPrettyPrintFunction = Nothing , formatConfigPrintTimes = False , formatConfigHtmlOutput = False , formatConfigPrintCpuTime = False , formatConfigUsedSeed = 0 , formatConfigExpectedTotalCount = 0 } green :: String -> String green text = setSGRCode [SetColor Foreground Dull Green] <> text <> setSGRCode [Reset] spec :: Spec spec = do forM_ [ ("extraChunk", extraChunk, Red) , ("missingChunk", missingChunk, Green) ] $ \ (name, chunk, color) -> do let colorize layer text = setSGRCode [SetColor layer Dull color] <> text <> setSGRCode [Reset] describe name $ do it "colorizes chunks" $ do capture_ $ runFormatM formatConfig $ do chunk "foo" `shouldReturn` colorize Foreground "foo" context "with an all-spaces chunk" $ do it "colorizes background" $ do capture_ $ runFormatM formatConfig $ do chunk " " `shouldReturn` colorize Background " " context "with an all-newlines chunk" $ do it "colorizes background" $ do capture_ $ runFormatM formatConfig $ do chunk "\n\n\n" `shouldReturn` colorize Background "\n\n\n" describe "write" $ do it "does not span colored output over multiple lines" $ do -- This helps with output on Jenkins and Buildkite: -- https://github.com/hspec/hspec/issues/346 capture_ $ runFormatM formatConfig $ do withSuccessColor $ write "foo\nbar\nbaz\n" `shouldReturn` unlines [green "foo", green "bar", green "baz"] describe "splitLines" $ do it "splits a string into chunks" $ do splitLines "foo\nbar\nbaz" `shouldBe` ["foo", "\n", "bar", "\n", "baz"] it "splits *arbitrary* strings into chunks" $ do property $ \ xs -> do mconcat (splitLines xs) `shouldBe` xs it "puts newlines into separate chunks" $ do property $ \ xs -> do filter (notElem '\n') (splitLines xs) `shouldBe` filter (not . null) (lines xs) hspec-core-2.10.10/test/Test/Hspec/Core/Formatters/Pretty/0000755000000000000000000000000007346545000021341 5ustar0000000000000000hspec-core-2.10.10/test/Test/Hspec/Core/Formatters/Pretty/ParserSpec.hs0000644000000000000000000000433307346545000023747 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} module Test.Hspec.Core.Formatters.Pretty.ParserSpec (spec, Person(..)) where import Prelude () import Helper import Test.Hspec.Core.Formatters.Pretty.Parser data Person = Person { personName :: String , personAge :: Int } deriving (Eq, Show) infix 1 `shouldParseAs` shouldParseAs :: HasCallStack => String -> Value -> Expectation shouldParseAs input expected = parseValue input `shouldBe` Just expected unit :: Value unit = Tuple [] parentheses :: Value -> Value parentheses value = Tuple [value] spec :: Spec spec = do describe "parseValue" $ do it "parses unit" $ do show () `shouldParseAs` unit it "parses characters" $ do show 'c' `shouldParseAs` Char 'c' it "parses strings" $ do show "foo" `shouldParseAs` String "foo" it "accepts rationals" $ do show (0.5 :: Rational) `shouldParseAs` Rational (Number "1") (Number "2") it "accepts negative rationals" $ do show (-0.5 :: Rational) `shouldParseAs` Rational (parentheses $ Number "-1") (Number "2") it "accepts integers" $ do "23" `shouldParseAs` Number "23" it "accepts negative integers" $ do "-23" `shouldParseAs` Number "-23" it "accepts floats" $ do show (23.0 :: Float) `shouldParseAs` Number "23.0" it "accepts negative floats" $ do show (-23.0 :: Float) `shouldParseAs` Number "-23.0" it "parses lists" $ do show ["foo", "bar", "baz"] `shouldParseAs` List [String "foo", String "bar", String "baz"] it "parses tuples" $ do show ("foo", "bar", "baz") `shouldParseAs` Tuple [String "foo", String "bar", String "baz"] it "parses Nothing" $ do show (Nothing :: Maybe Int) `shouldParseAs` Constructor "Nothing" [] it "parses Just" $ do show (Just "foo") `shouldParseAs` Constructor "Just" [String "foo"] it "parses nested Just" $ do show (Just $ Just "foo") `shouldParseAs` Constructor "Just" [parentheses (Constructor "Just" [String "foo"])] it "parses records" $ do let person = Person "Joe" 23 show person `shouldParseAs` Record "Person" [ ("personName", String "Joe") , ("personAge", Number "23") ] hspec-core-2.10.10/test/Test/Hspec/Core/Formatters/Pretty/UnicodeSpec.hs0000644000000000000000000000064707346545000024105 0ustar0000000000000000module Test.Hspec.Core.Formatters.Pretty.UnicodeSpec (spec) where import Prelude () import Helper import Test.Hspec.Core.Formatters.Pretty.Unicode spec :: Spec spec = do describe "ushow" $ do it "retains unicode characters" $ do ushow "foo-\955-bar" `shouldBe` "\"foo-\955-bar\"" it "is inverted by read" $ do property $ \ xs -> read (ushow xs) `shouldBe` xs hspec-core-2.10.10/test/Test/Hspec/Core/Formatters/PrettySpec.hs0000644000000000000000000001174607346545000022521 0ustar0000000000000000module Test.Hspec.Core.Formatters.PrettySpec (spec) where import Prelude () import Helper import Test.Hspec.Core.Formatters.Pretty.ParserSpec (Person(..)) import Test.Hspec.Core.Formatters.Pretty spec :: Spec spec = do describe "pretty2" $ do context "with single-line string literals" $ do context "with --unicode" $ do it "recovers unicode" $ do pretty2 True (show "foo\955bar") (show "foo-bar") `shouldBe` ("\"foo\955bar\"", "\"foo-bar\"") context "with --no-unicode" $ do it "does not recover unicode" $ do pretty2 False (show "foo\955bar") (show "foo-bar") `shouldBe` ("\"foo\\955bar\"", "\"foo-bar\"") context "when expected and actual would be equal after pretty-printing" $ do it "returns the original values unmodified" $ do pretty2 True (show "foo") (show "foo" <> " ") `shouldBe` (show "foo", show "foo" <> " ") describe "recoverString" $ do it "recovers a string" $ do recoverString (show "foo") `shouldBe` Just "foo" it "recovers the empty string" $ do recoverString (show "") `shouldBe` Just "" it "does not recover a string with leading space" $ do recoverString (" " <> show "foo") `shouldBe` Nothing it "does not recover a string with trailing space" $ do recoverString (show "foo" <> " ") `shouldBe` Nothing it "does not recover an empty list" $ do recoverString "[]" `shouldBe` Nothing describe "recoverMultiLineString" $ do let multiLineString :: String multiLineString = "foo\nbar\nbaz\n" it "recovers multi-line string literals" $ do recoverMultiLineString True (show multiLineString) `shouldBe` Just multiLineString it "does not recover string literals that contain control characters" $ do recoverMultiLineString True (show "foo\n\tbar\nbaz\n") `shouldBe` Nothing it "does not recover string literals that span a single line" $ do recoverMultiLineString True (show "foo\n") `shouldBe` Nothing it "does not recover a string with trailing space" $ do recoverMultiLineString True (" " <> show multiLineString) `shouldBe` Nothing it "does not recover a string with trailing space" $ do recoverMultiLineString True (show multiLineString <> " ") `shouldBe` Nothing context "when unicode is True" $ do it "recovers string literals that contain unicode" $ do recoverMultiLineString True (show "foo\n\955\nbaz\n") `shouldBe` Just "foo\n\955\nbaz\n" context "when unicode is False" $ do it "does not recover string literals that contain unicode" $ do recoverMultiLineString False (show "foo\n\955\nbaz\n") `shouldBe` Nothing describe "pretty" $ do let person = Person "Joe" 23 it "pretty-prints records" $ do pretty True (show person) `shouldBe` just [ "Person {" , " personName = \"Joe\"," , " personAge = 23" , "}" ] it "pretty-prints Just-values" $ do pretty True (show $ Just person) `shouldBe` just [ "Just Person {" , " personName = \"Joe\"," , " personAge = 23" , "}" ] it "pretty-prints tuples" $ do pretty True (show (person, -0.5 :: Rational)) `shouldBe` just [ "(Person {" , " personName = \"Joe\"," , " personAge = 23" , "}, (-1) % 2)" ] it "pretty-prints lists" $ do pretty True (show [Just person, Nothing]) `shouldBe` just [ "[Just Person {" , " personName = \"Joe\"," , " personAge = 23" , "}, Nothing]" ] context "with --unicode" $ do it "retains unicode characters in record fields" $ do pretty True (show $ Person "λ-Joe" 23) `shouldBe` just [ "Person {" , " personName = \"λ-Joe\"," , " personAge = 23" , "}" ] it "retains unicode characters in list elements" $ do pretty True (show ["foo", "λ", "bar"]) `shouldBe` just ["[\"foo\", \"λ\", \"bar\"]"] context "with --no-unicode" $ do it "does not retain unicode characters in record fields" $ do pretty False (show $ Person "λ-Joe" 23) `shouldBe` just [ "Person {" , " personName = \"\\955-Joe\"," , " personAge = 23" , "}" ] it "does not retain unicode characters in list elements" $ do pretty False (show ["foo", "λ", "bar"]) `shouldBe` just ["[\"foo\", \"\\955\", \"bar\"]"] context "with input that looks like a list" $ do it "it returns Nothing" $ do pretty True "[23,42]" `shouldBe` Nothing context "with input that looks like a tuple" $ do it "it returns Nothing" $ do pretty True "(23,42)" `shouldBe` Nothing context "with input that looks like function applications" $ do it "it returns Nothing" $ do let input = unlines ["foo", "bar", "baz"] pretty True input `shouldBe` Nothing where just = Just . intercalate "\n" hspec-core-2.10.10/test/Test/Hspec/Core/Formatters/V1Spec.hs0000644000000000000000000002470407346545000021516 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Test.Hspec.Core.Formatters.V1Spec (spec) where import Prelude () import Helper import Data.String import Control.Monad.IO.Class import Control.Monad.Trans.Writer hiding (pass) import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Formatters.V1 as H import qualified Test.Hspec.Core.Formatters.V1.Monad as H (interpretWith) import Test.Hspec.Core.Formatters.V1.Monad (FormatM, Environment(..), FailureRecord(..), FailureReason(..)) data ColorizedText = Plain String | Transient 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 Transient _ : xs -> 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 -> IO [ColorizedText] interpret = interpretWith environment interpretWith :: Environment (WriterT [ColorizedText] IO) -> FormatM a -> IO [ColorizedText] interpretWith env = fmap simplify . execWriterT . H.interpretWith env environment :: Environment (WriterT [ColorizedText] IO) environment = Environment { environmentGetSuccessCount = return 0 , environmentGetPendingCount = return 0 , environmentGetFailMessages = return [] , environmentUsedSeed = return 0 , environmentGetCPUTime = return Nothing , environmentGetRealTime = return 0 , environmentWrite = tell . return . Plain , environmentWriteTransient = tell . return . Transient , environmentWithFailColor = \ action -> do (a, r) <- liftIO $ runWriterT action tell (colorize Failed r) >> return a , environmentWithSuccessColor = \ action -> do (a, r) <- liftIO $ runWriterT action tell (colorize Succeeded r) >> return a , environmentWithPendingColor = \ action -> do (a, r) <- liftIO $ runWriterT action tell (colorize Pending r) >> return a , environmentWithInfoColor = \ action -> do (a, r) <- liftIO $ runWriterT action tell (colorize Info r) >> return a , environmentUseDiff = return True , environmentPrintTimes = return False , environmentExtraChunk = tell . return . Extra , environmentMissingChunk = tell . return . Missing , environmentLiftIO = liftIO } testSpec :: H.Spec testSpec = do H.describe "Example" $ do H.it "success" (H.Result "" H.Success) H.it "fail 1" (H.Result "" $ H.Failure Nothing $ H.Reason "fail message") H.it "pending" (H.pendingWith "pending message") H.it "fail 2" (H.Result "" $ H.Failure Nothing H.NoReason) H.it "exceptions" (undefined :: H.Result) H.it "fail 3" (H.Result "" $ 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 undefined) `shouldReturn` [ Succeeded "." ] describe "exampleFailed" $ do it "marks failing examples with F" $ do interpret (H.exampleFailed formatter undefined undefined undefined) `shouldReturn` [ Failed "F" ] describe "examplePending" $ do it "marks pending examples with ." $ do interpret (H.examplePending formatter undefined undefined undefined) `shouldReturn` [ 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 successful, 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 pass 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 ([], "") (ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")] } it "adds indentation" $ do (removeColors <$> interpretWith env action) `shouldReturn` unlines [ "" , "Failures:" , "" , " 1) " , " expected: first" , " second" , " third" , " but got: first" , " two" , " third" , "" , " To rerun use: --match \"//\"" , "" , "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 `shouldReturn` [ "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 `shouldReturn` [ "Finished in 0.0000 seconds\n" , Pending "1 example, 0 failures, 1 pending\n" ] context "with failures" $ do let env = environment {environmentGetFailMessages = return [undefined]} it "shows summary in red" $ do interpretWith env action `shouldReturn` [ "Finished in 0.0000 seconds\n" , Failed "1 example, 1 failure\n" ] context "with both failures and pending examples" $ do let env = environment {environmentGetFailMessages = return [undefined], environmentGetPendingCount = return 1} it "shows summary in red" $ do interpretWith env action `shouldReturn` [ "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" (throw (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 it "includes that source location above the error message" $ do let loc = H.Location "test/FooSpec.hs" 23 4 addLoc e = e {H.itemLocation = Just loc} r <- runSpec $ H.mapSpecItem_ addLoc $ do H.it "foo" False r `shouldContain` [" test/FooSpec.hs:23:4: ", " 1) foo"] hspec-core-2.10.10/test/Test/Hspec/Core/Formatters/V2Spec.hs0000644000000000000000000002655707346545000021527 0ustar0000000000000000module Test.Hspec.Core.Formatters.V2Spec (spec) where import Prelude () import Helper import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Spec as Spec import qualified Test.Hspec.Core.Runner as H import Test.Hspec.Core.Format import Test.Hspec.Core.Formatters.V2 testSpec :: H.Spec testSpec = do H.describe "Example" $ do H.it "success" (H.Result "" Spec.Success) H.it "fail 1" (H.Result "" $ Spec.Failure Nothing $ H.Reason "fail message") H.it "pending" (H.pendingWith "pending message") H.it "fail 2" (H.Result "" $ Spec.Failure Nothing H.NoReason) H.it "exceptions" (undefined :: Spec.Result) H.it "fail 3" (H.Result "" $ Spec.Failure Nothing H.NoReason) formatConfig :: FormatConfig formatConfig = FormatConfig { formatConfigUseColor = False , formatConfigReportProgress = False , formatConfigOutputUnicode = unicode , formatConfigUseDiff = True , formatConfigDiffContext = Just 3 , formatConfigExternalDiff = Nothing , formatConfigPrettyPrint = True , formatConfigPrettyPrintFunction = Just (H.configPrettyPrintFunction H.defaultConfig unicode) , formatConfigPrintTimes = False , formatConfigHtmlOutput = False , formatConfigPrintCpuTime = False , formatConfigUsedSeed = 0 , formatConfigExpectedTotalCount = 0 } where unicode = True runSpecWith :: Formatter -> H.Spec -> IO [String] runSpecWith formatter = captureLines . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ formatterToFormat formatter} spec :: Spec spec = do describe "indentChunks" $ do context "with Original" $ do it "does not indent single-line input" $ do indentChunks " " [Original "foo"] `shouldBe` [PlainChunk "foo"] it "indents multi-line input" $ do indentChunks " " [Original "foo\nbar\nbaz\n"] `shouldBe` [PlainChunk "foo\n bar\n baz\n "] context "with Modified" $ do it "returns the empty list on empty input" $ do indentChunks " " [Modified ""] `shouldBe` [] it "does not indent single-line input" $ do indentChunks " " [Modified "foo"] `shouldBe` [ColorChunk "foo"] it "indents multi-line input" $ do indentChunks " " [Modified "foo\nbar\nbaz\n"] `shouldBe` [ColorChunk "foo", PlainChunk "\n ", ColorChunk "bar", PlainChunk "\n ", ColorChunk "baz", PlainChunk "\n "] it "colorizes whitespace-only input" $ do indentChunks " " [Modified " "] `shouldBe` [ColorChunk " "] it "colorizes whitespace-only lines" $ do indentChunks " " [Modified "foo\n \n"] `shouldBe` [ColorChunk "foo", PlainChunk "\n ", ColorChunk " ", PlainChunk "\n "] it "colorizes whitespace at the end of the input" $ do indentChunks " " [Modified "foo\n "] `shouldBe` [ColorChunk "foo", PlainChunk "\n ", ColorChunk " "] it "splits off whitespace-only segments at the end of a line so that they get colorized" $ do indentChunks " " [Modified "foo \n"] `shouldBe` [ColorChunk "foo", ColorChunk " ", PlainChunk "\n "] context "with empty lines" $ do it "colorizes indentation" $ do indentChunks " " [Original "foo", Modified "\n\n", Original "bar"] `shouldBe` [PlainChunk "foo", PlainChunk "\n", ColorChunk " ", PlainChunk "\n", ColorChunk " ", PlainChunk "bar"] describe "progress" $ do let item = ItemDone ([], "") . Item Nothing 0 "" describe "formatterItemDone" $ do it "marks succeeding examples with ." $ do formatter <- formatterToFormat progress formatConfig captureLines (formatter $ item Success) `shouldReturn` ["."] it "marks failing examples with F" $ do formatter <- formatterToFormat progress formatConfig captureLines (formatter . item $ Failure Nothing NoReason) `shouldReturn` ["F"] it "marks pending examples with ." $ do formatter <- formatterToFormat progress formatConfig captureLines (formatter . item $ Pending Nothing Nothing) `shouldReturn` ["."] describe "checks" $ do let formatter = checks config = H.defaultConfig { H.configFormat = Just $ formatterToFormat formatter } it "prints unicode check marks" $ do r <- captureLines . H.hspecWithResult config $ do H.it "foo" True normalizeSummary r `shouldBe` [ "" , "foo [✔]" , "" , "Finished in 0.0000 seconds" , "1 example, 0 failures" ] it "uses ASCII as a fallback" $ do r <- captureLines . H.hspecWithResult config { H.configUnicodeMode = H.UnicodeNever } $ do H.it "foo" True normalizeSummary r `shouldBe` [ "" , "foo [v]" , "" , "Finished in 0.0000 seconds" , "1 example, 0 failures" ] describe "specdoc" $ do let runSpec = runSpecWith specdoc it "displays a header for each thing being described" $ do _:x:_ <- runSpec testSpec x `shouldBe` "Example" it "displays one row for each behavior" $ do r <- runSpec $ do H.describe "List as a Monoid" $ do H.describe "mappend" $ do H.it "is associative" True H.describe "mempty" $ do H.it "is a left identity" True H.it "is a right identity" True H.describe "Maybe as a Monoid" $ do H.describe "mappend" $ do H.it "is associative" True H.describe "mempty" $ do H.it "is a left identity" True H.it "is a right identity" True normalizeSummary r `shouldBe` [ "" , "List as a Monoid" , " mappend" , " is associative" , " mempty" , " is a left identity" , " is a right identity" , "Maybe as a Monoid" , " mappend" , " is associative" , " mempty" , " is a left identity" , " is a right identity" , "" , "Finished in 0.0000 seconds" , "6 examples, 0 failures" ] it "outputs an empty line at the beginning (even for non-nested specs)" $ do r <- runSpec $ do H.it "example 1" True H.it "example 2" True normalizeSummary r `shouldBe` [ "" , "example 1" , "example 2" , "" , "Finished in 0.0000 seconds" , "2 examples, 0 failures" ] it "displays a row for each successful, 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 pass 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 "formatterDone" $ do it "recovers unicode from ExpectedButGot" $ do formatter <- formatterToFormat failed_examples formatConfig { formatConfigOutputUnicode = True } _ <- formatter . ItemDone ([], "") . Item Nothing 0 "" $ Failure Nothing $ ExpectedButGot Nothing (show "\955") (show "\956") (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [ "" , "Failures:" , "" , " 1) " , " expected: \"λ\"" , " but got: \"μ\"" , "" , " To rerun use: --match \"//\"" , "" , "Randomized with seed 0" , "" , "Finished in 0.0000 seconds" , "1 example, 1 failure" ] context "when actual/expected contain newlines" $ do it "adds indentation" $ do formatter <- formatterToFormat failed_examples formatConfig _ <- formatter . ItemDone ([], "") . Item Nothing 0 "" $ Failure Nothing $ ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird" (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [ "" , "Failures:" , "" , " 1) " , " expected: first" , " second" , " third" , " but got: first" , " two" , " third" , "" , " To rerun use: --match \"//\"" , "" , "Randomized with seed 0" , "" , "Finished in 0.0000 seconds" , "1 example, 1 failure" ] context "without failures" $ do it "shows summary in green if there are no failures" $ do formatter <- formatterToFormat failed_examples formatConfig _ <- formatter . ItemDone ([], "") . Item Nothing 0 "" $ Success (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [ "" , "Finished in 0.0000 seconds" , "1 example, 0 failures" ] context "with pending examples" $ do it "shows summary in yellow if there are pending examples" $ do formatter <- formatterToFormat failed_examples formatConfig _ <- formatter . ItemDone ([], "") . Item Nothing 0 "" $ Pending Nothing Nothing (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [ "" , "Finished in 0.0000 seconds" , "1 example, 0 failures, 1 pending" ] context "same as failed_examples" $ do failed_examplesSpec specdoc describe "getExpectedTotalCount" $ do let formatter = silent { formatterStarted = fmap show getExpectedTotalCount >>= writeLine } runSpec = runSpecWith formatter it "returns the total number of spec items" $ do result:_ <- runSpec testSpec result `shouldBe` "6" failed_examplesSpec :: Formatter -> Spec failed_examplesSpec formatter = do let runSpec = runSpecWith 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" (throw (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 it "includes that source location above the error message" $ do let loc = H.Location "test/FooSpec.hs" 23 4 addLoc e = e {Spec.itemLocation = Just loc} r <- runSpec $ H.mapSpecItem_ addLoc $ do H.it "foo" False r `shouldContain` [" test/FooSpec.hs:23:4: ", " 1) foo"] hspec-core-2.10.10/test/Test/Hspec/Core/HooksSpec.hs0000644000000000000000000005212507346545000020163 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Hspec.Core.HooksSpec (spec) where import Prelude () import Helper import Mock import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Spec as H import Test.Hspec.Core.Format import Test.Hspec.Core.Runner.Eval import qualified Test.Hspec.Core.Hooks as H evalSpec_ :: H.Spec -> IO () evalSpec_ = void . evalSpec evalSpec :: H.Spec -> IO [([String], Item)] evalSpec = fmap normalize . (toEvalForest >=> runFormatter config) where config = EvalConfig { evalConfigFormat = \ _ -> pass , evalConfigConcurrentJobs = 1 , evalConfigFailFast = False } normalize = map $ \ (path, item) -> (pathToList path, normalizeItem item) normalizeItem item = item { itemLocation = Nothing , itemDuration = 0 , itemResult = case itemResult item of Success -> Success Pending _ reason -> Pending Nothing reason Failure _ reason -> Failure Nothing reason } pathToList (xs, x) = xs ++ [x] toEvalForest :: H.SpecWith () -> IO [EvalTree] toEvalForest = fmap (uncurry H.specToEvalForest . first (($ H.defaultConfig) . appEndo)) . H.runSpecM 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 evalSpec_ $ 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 with a QuickCheck property" $ do it "runs action before every check of the property" $ do (rec, retrieve) <- mkAppend evalSpec_ $ H.before (rec "before" >> return "value") $ do H.it "foo" $ \value -> property $ \(_ :: Int) -> rec value retrieve `shouldReturn` (take 200 . cycle) ["before", "value"] describe "before_" $ do it "runs an action before every spec item" $ do (rec, retrieve) <- mkAppend evalSpec_ $ 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 evalSpec_ $ 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 evalSpec_ $ 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 evalSpec_ $ 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 evalSpec_ $ 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 evalSpec_ $ 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 evalSpec_ $ 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 evalSpec $ H.beforeAll throwException $ do H.it "foo" $ \n -> do n `shouldBe` (23 :: Int) H.it "bar" $ \n -> do n `shouldBe` 23 `shouldReturn` [ item ["foo"] divideByZero , item ["bar"] (Pending Nothing $ exceptionIn "beforeAll") ] context "when used with an empty list of examples" $ do it "does not run specified action" $ do (rec, retrieve) <- mkAppend evalSpec_ $ H.beforeAll (rec "beforeAll" >> return "value") $ do pass retrieve `shouldReturn` [] describe "beforeAll_" $ do it "runs an action before the first spec item" $ do (rec, retrieve) <- mkAppend evalSpec_ $ 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 evalSpec_ $ 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 "beforeAllWith" $ do it "transforms the spec argument" $ do (rec, retrieve) <- mkAppend let action :: Int -> IO String action = return . show evalSpec_ $ H.beforeAll (return 23) $ H.beforeAllWith 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 evalSpec_ $ H.beforeAll (return 23) $ H.beforeAllWith action1 $ H.beforeAllWith action2 $ H.beforeAllWith action3 $ do H.it "foo" $ \value -> rec value retrieve `shouldReturn` ["foo 24"] it "runs an action before the first spec item" $ do (rec, retrieve) <- mkAppend evalSpec_ $ H.beforeAll (return (23 :: Int)) $ H.beforeAllWith (\value -> rec "beforeAllWith" >> return (show value)) $ do H.it "foo" $ \value -> do rec $ "foo " ++ value H.it "bar" $ \value -> do rec $ "bar " ++ value retrieve `shouldReturn` [ "beforeAllWith" , "foo 23" , "bar 23" ] context "when specified action throws an exception" $ do it "sets subsequent spec items to pending" $ do evalSpec $ do H.beforeAll (return (23 :: Int)) $ do H.beforeAllWith (\ _ -> throwException) $ do H.it "foo" $ \n -> do n `shouldBe` (23 :: Int) H.it "bar" $ \n -> do n `shouldBe` 23 `shouldReturn` [ item ["foo"] divideByZero , item ["bar"] (Pending Nothing $ exceptionIn "beforeAllWith") ] context "when used with an empty list of examples" $ do it "does not run specified action" $ do (rec, retrieve) <- mkAppend evalSpec_ $ H.beforeAll (return (23 :: Int)) $ H.beforeAllWith (\_ -> rec "beforeAllWith" >> return "value") $ do pass retrieve `shouldReturn` [] describe "after" $ do it "runs an action after every spec item" $ do (rec, retrieve) <- mkAppend evalSpec_ $ 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 evalSpec_ $ H.before (rec "before" >> return "from before") $ H.after rec $ do H.it "foo" $ \_ -> do throwException_ rec "foo" retrieve `shouldReturn` ["before", "from before"] describe "after_" $ do it "runs an action after every spec item" $ do (rec, retrieve) <- mkAppend evalSpec_ $ 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 evalSpec_ $ H.after_ (rec "after") $ do H.it "foo" $ do throwException_ rec "foo" retrieve `shouldReturn` ["after"] context "when used multiple times" $ do it "is evaluated inside out" $ do (rec, retrieve) <- mkAppend evalSpec_ $ 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 evalSpec_ $ 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" , "from before" ] context "when used with an empty list of examples" $ do it "does not run specified action" $ do evalSpec $ H.before undefined $ H.afterAll undefined $ do pass `shouldReturn` [] context "when action throws an exception" $ do it "reports a failure" $ do evalSpec $ H.before (return "from before") $ H.afterAll (\_ -> throwException) $ do H.it "foo" $ \a -> a `shouldBe` "from before" H.it "bar" $ \a -> a `shouldBe` "from before" `shouldReturn` [ item ["foo"] Success , item ["bar"] $ divideByZeroIn "afterAll" ] describe "afterAll_" $ do it "runs an action after the last spec item" $ do (rec, retrieve) <- mkAppend evalSpec_ $ 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" , "afterAll_" ] context "when used multiple times" $ do it "is evaluated inside out" $ do (rec, retrieve) <- mkAppend evalSpec_ $ 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 evalSpec_ $ H.afterAll_ (rec "afterAll_") $ do pass retrieve `shouldReturn` [] context "when action is pending" $ do it "reports pending" $ do evalSpec $ do H.afterAll_ H.pending $ do H.it "foo" True H.it "bar" True `shouldReturn` [ item ["foo"] Success , item ["bar"] (Pending Nothing Nothing) ] context "when action throws an exception" $ do it "reports a failure" $ do evalSpec $ do H.afterAll_ throwException $ do H.it "foo" True H.it "bar" True `shouldReturn` [ item ["foo"] Success , item ["bar"] $ divideByZeroIn "afterAll_" ] context "when action is successful" $ do it "does not report anything" $ do evalSpec $ do H.afterAll_ pass $ do H.it "foo" True `shouldReturn` [ item ["foo"] Success ] 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" evalSpec_ $ 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" ] describe "around_" $ do it "wraps every spec item with an action" $ do (rec, retrieve) <- mkAppend let action e = rec "before" >> e >> rec "after" evalSpec_ $ 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" evalSpec_ $ 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 mock <- newMock (rec, retrieve) <- mkAppend let action = (. show) evalSpec_ $ H.before (mockAction mock >> mockCounter mock) $ H.aroundWith action $ do H.it "foo" rec H.it "bar" rec H.it "baz" rec retrieve `shouldReturn` [ "1" , "2" , "3" ] mockCounter mock `shouldReturn` 3 describe "aroundAll" $ do it "wraps an action around a spec" $ do (rec, retrieve) <- mkAppend let action e = rec "before" *> e "from around" <* rec "after" evalSpec_ $ H.aroundAll action $ do H.it "foo" $ rec . ("foo " ++) H.it "bar" $ rec . ("bar " ++) H.it "baz" $ rec . ("baz " ++) retrieve `shouldReturn` [ "before" , "foo from around" , "bar from around" , "baz from around" , "after" ] describe "aroundAll_" $ do it "wraps an action around a spec" $ do (rec, retrieve) <- mkAppend let action inner = rec "before" *> inner <* rec "after" evalSpec_ $ H.aroundAll_ action $ do H.it "foo" $ rec "foo" H.it "bar" $ rec "bar" retrieve `shouldReturn` [ "before" , "foo" , "bar" , "after" ] it "wrap actions around a spec in order" $ do (rec, retrieve) <- mkAppend let action i inner = rec ("before " <> i) *> inner <* rec ("after " <> i) evalSpec_ $ H.aroundAll_ (action "1") $ H.aroundAll_ (action "2") $ do H.it "foo" $ rec "foo" H.it "bar" $ rec "bar" retrieve `shouldReturn` [ "before 1" , "before 2" , "foo" , "bar" , "after 2" , "after 1" ] it "does not call actions wrapped around a failing action" $ do (rec, retrieve) <- mkAppend let action i inner = rec ("before " <> i) *> inner <* rec ("after " <> i) evalSpec_ $ H.aroundAll_ (action "1") $ H.aroundAll_ (action "2 failing" . const throwException) $ H.aroundAll_ (action "3") $ do H.it "foo" $ rec "foo" H.it "bar" $ rec "bar" retrieve `shouldReturn` [ "before 1" , "before 2 failing" , "after 1" ] it "does not memoize subject" $ do mock <- newMock let action :: IO Int action = mockAction mock >> mockCounter mock (rec, retrieve) <- mkAppend evalSpec_ $ H.before action $ H.aroundAll_ id $ do H.it "foo" $ rec . show H.it "bar" $ rec . show H.it "baz" $ rec . show retrieve `shouldReturn` [ "1" , "2" , "3" ] mockCounter mock `shouldReturn` 3 it "reports exceptions on acquire" $ do evalSpec $ do H.aroundAll_ (throwException <*) $ do H.it "foo" True H.it "bar" True `shouldReturn` [ item ["foo"] divideByZero , item ["bar"] (Pending Nothing $ exceptionIn "aroundAll_") ] it "reports exceptions on release" $ do evalSpec $ do H.aroundAll_ (<* throwException) $ do H.it "foo" True H.it "bar" True `shouldReturn` [ item ["foo"] Success , item ["bar"] $ divideByZeroIn "aroundAll_" ] describe "aroundAllWith" $ do it "wraps an action around a spec" $ do mock <- newMock (rec, retrieve) <- mkAppend let action = (. show) evalSpec_ $ H.before (mockAction mock >> mockCounter mock) $ H.aroundAllWith action $ do H.it "foo" rec H.it "bar" rec H.it "baz" rec retrieve `shouldReturn` [ "1" , "1" , "1" ] mockCounter mock `shouldReturn` 3 it "wrap actions around a spec in order" $ do (rec, retrieve) <- mkAppend let action i inner a = rec ("before " <> i) *> inner a <* rec ("after " <> i) evalSpec_ $ H.aroundAllWith (action "1") $ H.aroundAllWith (action "2") $ do H.it "foo" $ rec "foo" H.it "bar" $ rec "bar" retrieve `shouldReturn` [ "before 1" , "before 2" , "foo" , "bar" , "after 2" , "after 1" ] it "does not call actions wrapped around a failing action" $ do (rec, retrieve) <- mkAppend let action i inner a = rec ("before " <> i) *> inner a <* rec ("after " <> i) evalSpec_ $ H.aroundAllWith (action "1") $ H.aroundAllWith (action "2 failing" . const . const throwException) $ H.aroundAllWith (action "3") $ do H.it "foo" $ rec "foo" H.it "bar" $ rec "bar" retrieve `shouldReturn` [ "before 1" , "before 2 failing" , "after 1" ] it "reports exceptions on acquire" $ do evalSpec $ do H.aroundAllWith (\ action () -> throwException >>= action) $ do H.it "foo" H.pending `shouldReturn` [ item ["foo"] divideByZero ] it "reports exceptions on release" $ do evalSpec $ do H.aroundAllWith (\ action () -> action () <* throwException) $ do H.it "foo" True H.it "bar" True `shouldReturn` [ item ["foo"] Success , item ["bar"] $ divideByZeroIn "aroundAllWith" ] describe "decompose" $ do it "decomposes a with-style action into acquire / release" $ do (acquire, release) <- H.decompose $ \ action x -> do action (x + 42 :: Int) acquire 23 `shouldReturn` 65 release context "when release is called before acquire" $ do it "does nothing" $ do (_, release) <- H.decompose $ \ action x -> do action (x + 42 :: Int) release context "with an exception during resource acquisition" $ do it "propagates that exception" $ do (acquire, release) <- H.decompose $ \ action () -> do throwException_ action () acquire () `shouldThrow` (== DivideByZero) release context "with an exception during resource deallocation" $ do it "propagates that exception" $ do (acquire, release) <- H.decompose $ \ action () -> do action () throwException_ acquire () release `shouldThrow` (== DivideByZero) where divideByZero :: Result divideByZero = Failure Nothing (Error Nothing $ toException DivideByZero) divideByZeroIn :: String -> Result #if MIN_VERSION_base(4,8,1) divideByZeroIn hook = Failure Nothing (Error (Just $ "in " <> hook <> "-hook:") $ toException DivideByZero) #else divideByZeroIn _ = Failure Nothing (Error Nothing $ toException DivideByZero) #endif item :: [String] -> Result -> ([String], Item) item path result = (path, Item Nothing 0 "" result) #if MIN_VERSION_base(4,8,1) exceptionIn name = Just ("exception in " <> name <> "-hook (see previous failure)") #else exceptionIn _ = Just "exception in beforeAll-hook (see previous failure)" #endif hspec-core-2.10.10/test/Test/Hspec/Core/QuickCheckUtilSpec.hs0000644000000000000000000001711007346545000021743 0ustar0000000000000000{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Test.Hspec.Core.QuickCheckUtilSpec (spec) where import Prelude () import Helper import qualified Test.QuickCheck.Property as QCP import Test.Hspec.Core.QuickCheckUtil deriving instance Eq QuickCheckResult deriving instance Eq Status deriving instance Eq QuickCheckFailure spec :: Spec spec = do describe "formatNumbers" $ do it "includes number of tests" $ do formatNumbers 1 0 `shouldBe` "(after 1 test)" it "pluralizes number of tests" $ do formatNumbers 3 0 `shouldBe` "(after 3 tests)" it "includes number of shrinks" $ do formatNumbers 3 1 `shouldBe` "(after 3 tests and 1 shrink)" it "pluralizes number of shrinks" $ do formatNumbers 3 3 `shouldBe` "(after 3 tests and 3 shrinks)" describe "stripSuffix" $ do it "drops the given suffix from a list" $ do stripSuffix "bar" "foobar" `shouldBe` Just "foo" describe "splitBy" $ do it "splits a string by a given infix" $ do splitBy "bar" "foo bar baz" `shouldBe` Just ("foo ", " baz") describe "parseQuickCheckResult" $ do let args = stdArgs {chatty = False, replay = Just (mkGen 0, 0)} qc = quickCheckWithResult args context "with Success" $ do let p :: Int -> Bool p n = n == n it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` QuickCheckResult 100 "+++ OK, passed 100 tests." QuickCheckSuccess it "includes labels" $ do parseQuickCheckResult <$> qc (label "unit" p) `shouldReturn` QuickCheckResult 100 "+++ OK, passed 100 tests (100% unit)." QuickCheckSuccess context "with GaveUp" $ do let p :: Int -> Property p n = (n == 1234) ==> True qc = quickCheckWithResult args {maxSuccess = 2, maxDiscardRatio = 1} result = QuickCheckResult 0 "" (QuickCheckOtherFailure "Gave up after 0 tests; 2 discarded!") it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` result it "includes verbose output" $ do let info = intercalate "\n" [ "Skipped (precondition false):" , "0" , "" , "Skipped (precondition false):" , "0" ] parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} context "with NoExpectedFailure" $ do let p :: Int -> Property p _ = expectFailure True it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` QuickCheckResult 100 "" (QuickCheckOtherFailure "Passed 100 tests (expected failure).") it "includes verbose output" $ do let info = intercalate "\n" [ "Passed:" , "0" , "" , "Passed:" , "23" ] parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` QuickCheckResult 2 info (QuickCheckOtherFailure "Passed 2 tests (expected failure).") context "with cover" $ do context "without checkCoverage" $ do let p :: Int -> Property p n = cover 10 (n == 5) "is 5" True it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` QuickCheckResult 100 "+++ OK, passed 100 tests (1% is 5).\n\nOnly 1% is 5, but expected 10%" QuickCheckSuccess it "includes verbose output" $ do let info = intercalate "\n" [ "Passed:" , "0" , "" , "Passed:" , "23" , "" , "+++ OK, passed 2 tests." , "" , "Only 0% is 5, but expected 10%" ] parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` QuickCheckResult 2 info QuickCheckSuccess context "with checkCoverage" $ do let p :: Int -> Property p n = checkCoverage $ cover 10 (n == 23) "is 23" True failure :: QuickCheckFailure failure = QCFailure { quickCheckFailureNumShrinks = 0 , quickCheckFailureException = Nothing , quickCheckFailureReason = "Insufficient coverage" , quickCheckFailureCounterexample = [ " 0.9% is 23" , "" , "Only 0.9% is 23, but expected 10.0%" ] } it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` QuickCheckResult 800 "" (QuickCheckFailure failure) it "includes verbose output" $ do let info = intercalate "\n\n" (replicate 799 "Passed:") parseQuickCheckResult <$> qc (verbose . p) `shouldReturn` QuickCheckResult 800 info (QuickCheckFailure failure) context "with Failure" $ do context "with single-line failure reason" $ do let p :: Int -> Bool p = (< 1) err = "Falsified" result = QuickCheckResult 4 "" (QuickCheckFailure $ QCFailure 2 Nothing err ["1"]) it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` result it "includes verbose output" $ do let info = intercalate "\n" [ "Passed:" , "0" , "" , "Passed:" , "0" , "" , "Passed:" , "-2" , "" , "Failed:" , "3" , "" , "Passed:" , "0" , "" , "Failed:" , "2" , "" , "Passed:" , "0" , "" , "Failed:" , "1" , "" , "Passed:" , "0" ] parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} context "with multi-line failure reason" $ do let p :: Int -> QCP.Result p n = if n /= 2 then QCP.succeeded else QCP.failed {QCP.reason = err} err = "foo\nbar" result = QuickCheckResult 5 "" (QuickCheckFailure $ QCFailure 0 Nothing err ["2"]) it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` result it "includes verbose output" $ do let info = intercalate "\n" [ "Passed:" , "0" , "" , "Passed:" , "0" , "" , "Passed:" , "-2" , "" , "Passed:" , "3" , "" , "Failed:" , "2" , "" , "Passed:" , "0" , "" , "Passed:" , "1" ] parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} context "with HUnit assertion" $ do let p :: Int -> Int -> Expectation p m n = do m `shouldBe` n it "includes counterexample" $ do result <- qc p let QuickCheckResult _ _ (QuickCheckFailure r) = parseQuickCheckResult result quickCheckFailureCounterexample r `shouldBe` ["0", "1"] hspec-core-2.10.10/test/Test/Hspec/Core/Runner/0000755000000000000000000000000007346545000017175 5ustar0000000000000000hspec-core-2.10.10/test/Test/Hspec/Core/Runner/EvalSpec.hs0000644000000000000000000000476407346545000021246 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Hspec.Core.Runner.EvalSpec (spec) where import Prelude () import Helper import NonEmpty (fromList) import Test.Hspec.Core.Spec (FailureReason(..), Result(..), ResultStatus(..), Location(..)) import Test.Hspec.Core.Runner.Eval instance Arbitrary ResultStatus where arbitrary = oneof [ pure Success , Pending <$> arbitrary <*> arbitrary , failure ] instance Arbitrary FailureReason where arbitrary = oneof [ pure NoReason , ExpectedButGot <$> arbitrary <*> (show <$> positive) <*> (show <$> positive) , Error <$> arbitrary <*> pure (toException DivideByZero) ] instance Arbitrary Location where arbitrary = Location <$> elements ["src/Foo.hs", "src/Bar.hs", "src/Baz.hs"] <*> positive <*> positive positive :: Gen Int positive = getPositive <$> arbitrary failureResult :: Gen Result failureResult = Result <$> arbitrary <*> failure pendingResult :: Gen Result pendingResult = Result <$> arbitrary <*> pending successResult :: Gen Result successResult = Result <$> arbitrary <*> pure Success pending :: Gen ResultStatus pending = Pending <$> arbitrary <*> arbitrary failure :: Gen ResultStatus failure = Failure <$> arbitrary <*> arbitrary spec :: Spec spec = do describe "mergeResults" $ do it "gives failures from items precedence" $ do forAll failureResult $ \ item -> \ hook -> do mergeResults Nothing item hook `shouldBe` item it "gives failures from hooks precedence over succeeding items" $ do forAll successResult $ \ item@(Result info _) -> forAll failure $ \ hook -> do mergeResults Nothing item hook `shouldBe` Result info hook it "gives failures from hooks precedence over pending items" $ do forAll pendingResult $ \ item@(Result info _) -> forAll failure $ \ hook -> do mergeResults Nothing item hook `shouldBe` Result info hook it "gives pending items precedence over pending hooks" $ do forAll pendingResult $ \ item -> forAll pending $ \ hook -> do mergeResults Nothing item hook `shouldBe` item describe "traverse" $ do context "when used with Tree" $ do let tree :: Tree () Int tree = Node "" $ fromList [Node "" $ fromList [Leaf 1, Node "" $ fromList [Leaf 2, Leaf 3]], Leaf 4] it "walks the tree left-to-right, depth-first" $ do ref <- newIORef [] traverse_ (modifyIORef ref . (:) ) tree reverse <$> readIORef ref `shouldReturn` [1 .. 4] hspec-core-2.10.10/test/Test/Hspec/Core/Runner/JobQueueSpec.hs0000644000000000000000000000245307346545000022067 0ustar0000000000000000module Test.Hspec.Core.Runner.JobQueueSpec (spec) where import Prelude () import Helper import Control.Concurrent import Test.Hspec.Core.Runner.JobQueue spec :: Spec spec = do describe "enqueueJob" $ do let waitFor job = job (\ _ -> pass) >>= either throwIO return context "with Sequential" $ do it "runs actions sequentially" $ do withJobQueue 10 $ \ queue -> do ref <- newIORef [] jobA <- enqueueJob queue Sequential $ \ _ -> modifyIORef ref (23 :) jobB <- enqueueJob queue Sequential $ \ _ -> modifyIORef ref (42 :) waitFor jobB readIORef ref `shouldReturn` [42 :: Int] waitFor jobA readIORef ref `shouldReturn` [23, 42] context "with Concurrent" $ do it "runs actions concurrently" $ do withJobQueue 10 $ \ queue -> do barrierA <- newEmptyMVar barrierB <- newEmptyMVar jobA <- enqueueJob queue Concurrent $ \ _ -> do putMVar barrierB () takeMVar barrierA jobB <- enqueueJob queue Concurrent $ \ _ -> do putMVar barrierA () takeMVar barrierB timeout (0.1 :: Seconds) $ do waitFor jobA waitFor jobB `shouldReturn` Just () hspec-core-2.10.10/test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs0000644000000000000000000000234707346545000024130 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Test.Hspec.Core.Runner.PrintSlowSpecItemsSpec (spec) where import Prelude () import Helper import Test.Hspec.Core.Format import Test.Hspec.Core.Runner.PrintSlowSpecItems location :: Location location = Location { locationFile = "Foo.hs" , locationLine = 23 , locationColumn = 42 } item :: Item item = Item { itemLocation = Just location , itemDuration = 0 , itemInfo = undefined , itemResult = undefined } spec :: Spec spec = do describe "printSlowSpecItems" $ do let format = printSlowSpecItems 2 $ \ _ -> pass it "prints slow spec items" $ do capture_ $ format $ Done [ ((["foo", "bar"], "one"), item {itemDuration = 0.100}) , ((["foo", "bar"], "two"), item {itemDuration = 0.500}) , ((["foo", "bar"], "thr"), item {itemDuration = 0.050}) ] `shouldReturn` unlines [ "" , "Slow spec items:" , " Foo.hs:23:42: /foo/bar/two/ (500ms)" , " Foo.hs:23:42: /foo/bar/one/ (100ms)" ] context "when there are no slow items" $ do it "prints nothing" $ do capture_ $ format $ Done [((["foo", "bar"], "one"), item {itemDuration = 0})] `shouldReturn` "" hspec-core-2.10.10/test/Test/Hspec/Core/Runner/ResultSpec.hs0000644000000000000000000000255407346545000021630 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Test.Hspec.Core.Runner.ResultSpec (spec) where import Prelude () import Helper import Test.Hspec.Core.Format import Test.Hspec.Core.Runner.Result spec :: Spec spec = do describe "Summary" $ do let summary :: Summary summary = toSummary $ toSpecResult [item Success, item failure] it "can be deconstructed via accessor functions" $ do (summaryExamples &&& summaryFailures) summary `shouldBe` (2, 1) it "can be deconstructed via pattern matching" $ do let Summary examples failures = summary (examples, failures) `shouldBe` (2, 1) it "can be deconstructed via RecordWildCards" $ do let Summary{..} = summary (summaryExamples, summaryFailures) `shouldBe` (2, 1) describe "specResultSuccess" $ do context "when all spec items passed" $ do it "returns True" $ do specResultSuccess (toSpecResult [item Success]) `shouldBe` True context "with a failed spec item" $ do it "returns False" $ do specResultSuccess (toSpecResult [item Success, item failure]) `shouldBe` False context "with an empty result list" $ do it "returns True" $ do specResultSuccess (toSpecResult []) `shouldBe` True where failure = Failure Nothing NoReason item result = (([], ""), Item Nothing 0 "" result) hspec-core-2.10.10/test/Test/Hspec/Core/RunnerSpec.hs0000644000000000000000000007432207346545000020354 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} #if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0) -- Control.Concurrent.QSem is deprecated in base-4.6.0.* {-# OPTIONS_GHC -fno-warn-deprecations #-} #endif module Test.Hspec.Core.RunnerSpec (spec) where import Prelude () import Helper import System.IO import System.Environment (withArgs, withProgName, getArgs) import System.Exit import Control.Concurrent import Control.Concurrent.Async import Mock import System.SetEnv import System.Console.ANSI import Test.Hspec.Core.FailureReport (FailureReport(..)) import qualified Test.Hspec.Expectations as H import qualified Test.Hspec.Core.Spec as H import Test.Hspec.Core.Runner (UseColor(..), ProgressReporting(..)) import qualified Test.Hspec.Core.Runner as H import Test.Hspec.Core.Runner.Result import qualified Test.Hspec.Core.QuickCheck as H import qualified Test.QuickCheck as QC import qualified Test.Hspec.Core.Hooks as H import Test.Hspec.Core.Formatters.Pretty.ParserSpec (Person(..)) 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)) person :: Int -> Person person = Person "Joe" spec :: Spec spec = do describe "hspec" $ do let hspec args = withArgs args . hspecSilent hspec_ = hspecSilent it "evaluates examples Unmasked" $ do mvar <- newEmptyMVar hspec_ $ do H.it "foo" $ do getMaskingState >>= putMVar mvar takeMVar mvar `shouldReturn` Unmasked it "runs finalizers" $ do mvar <- newEmptyMVar ref <- newIORef "did not run finalizer" a <- async $ hspec_ $ do H.it "foo" $ do (putMVar mvar () >> threadDelay 10000000) `finally` writeIORef ref "ran finalizer" takeMVar mvar cancel a readIORef ref `shouldReturn` "ran finalizer" it "runs a spec" $ do hspec_ $ do H.it "foobar" True `shouldReturn` () it "exits with exitFailure if not all examples pass" $ do 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 ignoreExitCode . hspec ["--seed", "23"] $ 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") ] } context "with --rerun" $ do let failingSpec = 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 succeedingSpec = do H.it "example 1" True H.it "example 2" True H.it "example 3" True H.it "example 4" True H.it "example 5" True run = captureLines . H.hspecResult rerun = withArgs ["--rerun"] . run it "reuses same --seed" $ do r <- runPropFoo ["--seed", "42"] runPropFoo ["--rerun"] `shouldReturn` r it "reuses same --qc-max-success" $ do n <- generate arbitrary ["--qc-max-success", show n] `shouldUseArgs` (QC.maxSuccess, n) ["--rerun"] `shouldUseArgs` (QC.maxSuccess, n) it "reuses same --qc-max-discard" $ do n <- generate arbitrary ["--qc-max-discard", show n] `shouldUseArgs` (QC.maxDiscardRatio, n) ["--rerun"] `shouldUseArgs` (QC.maxDiscardRatio, n) it "reuses same --qc-max-size" $ do n <- generate arbitrary ["--qc-max-size", show n] `shouldUseArgs` (QC.maxSize, n) ["--rerun"] `shouldUseArgs` (QC.maxSize, n) context "with failing examples" $ do it "only reruns failing examples" $ do r0 <- run failingSpec last r0 `shouldBe` "5 examples, 3 failures" r1 <- rerun failingSpec last r1 `shouldBe` "3 examples, 3 failures" context "without failing examples" $ do it "runs all examples" $ do r0 <- run succeedingSpec last r0 `shouldBe` "5 examples, 0 failures" r1 <- rerun succeedingSpec last r1 `shouldBe` "5 examples, 0 failures" context "when there is no failure report in the environment" $ do it "runs all examples" $ do unsetEnv "HSPEC_FAILURES" r <- hSilence [stderr] $ rerun failingSpec r `shouldSatisfy` elem "5 examples, 3 failures" it "prints a warning to stderr" $ do unsetEnv "HSPEC_FAILURES" r <- hCapture_ [stderr] $ rerun failingSpec r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n" context "when parsing of failure report fails" $ do it "runs all examples" $ do setEnv "HSPEC_FAILURES" "some invalid report" r <- hSilence [stderr] $ rerun failingSpec r `shouldSatisfy` elem "5 examples, 3 failures" it "prints a warning to stderr" $ do setEnv "HSPEC_FAILURES" "some invalid report" r <- hCapture_ [stderr] $ rerun failingSpec r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n" context "with --rerun-all-on-success" $ do let rerunAllOnSuccess = withArgs ["--rerun", "--rerun-all-on-success"] . run context "after a previously failing rerun succeeds for the first time" $ do it "runs the whole test suite" $ do _ <- run failingSpec output <- rerunAllOnSuccess succeedingSpec output `shouldSatisfy` elem "3 examples, 0 failures" last output `shouldBe` "5 examples, 0 failures" it "reruns runIO-actions" $ do ref <- newIORef (0 :: Int) let succeedingSpecWithRunIO = H.runIO (modifyIORef ref succ) >> succeedingSpec _ <- run failingSpec _ <- rerunAllOnSuccess succeedingSpecWithRunIO readIORef ref `shouldReturn` 2 it "does not leak command-line options to examples" $ do hspec ["--diff"] $ 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 UserInterrupt r <- takeMVar mvar normalizeSummary r `shouldBe` [ "" , "foo [✘]" , "" , "Failures:" , "" , " 1) foo" , "" , " To rerun use: --match \"/foo/\"" , "" , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds" , "1 example, 1 failure" ] it "throws UserInterrupt" $ do mvar <- newEmptyMVar sync <- newEmptyMVar threadId <- forkIO $ do hspec_ $ do H.it "foo" $ do putMVar sync () threadDelay 1000000 `catch` putMVar mvar takeMVar sync throwTo threadId UserInterrupt takeMVar mvar `shouldReturn` UserInterrupt 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 --focused-only" $ do let run = captureLines . withArgs ["--focused-only"] . H.hspec context "when there aren't any focused spec items" $ do it "does not run anything" $ do r <- run $ do H.it "foo" True H.it "bar" True normalizeSummary r `shouldBe` [ "" , "" , "Finished in 0.0000 seconds" , "0 examples, 0 failures" ] context "with --fail-on=empty" $ do it "fails if no spec items have been run" $ do (out, r) <- hCapture [stdout, stderr] . try . withProgName "spec" . withArgs ["--skip=", "--fail-on=empty"] . H.hspec $ do H.it "foo" True H.it "bar" True H.it "baz" True unlines (normalizeSummary (lines out)) `shouldBe` unlines [ "spec: all spec items have been filtered; failing due to --fail-on=empty" ] r `shouldBe` Left (ExitFailure 1) context "with --fail-on=focused" $ do let run = captureLines . ignoreExitCode . withArgs ["--fail-on=focused", "--seed", "23"] . H.hspec . removeLocations it "fails on focused spec items" $ do r <- run $ do H.it "foo" True H.fit "bar" True normalizeSummary r `shouldBe` [ "" , "bar [✘]" , "" , "Failures:" , "" , " 1) bar" , " item is focused; failing due to --fail-on=focused" , "" , " To rerun use: --match \"/bar/\"" , "" , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds" , "1 example, 1 failure" ] context "with --fail-on=pending" $ do let run = captureLines . ignoreExitCode . withArgs ["--fail-on=pending", "--seed", "23"] . H.hspec . removeLocations it "fails on pending spec items" $ do r <- run $ do H.it "foo" True H.it "bar" $ do void $ throwIO (H.Pending Nothing Nothing) normalizeSummary r `shouldBe` [ "" , "foo [✔]" , "bar [✘]" , "" , "Failures:" , "" , " 1) bar" , " item is pending; failing due to --fail-on=pending" , "" , " To rerun use: --match \"/bar/\"" , "" , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds" , "2 examples, 1 failure" ] 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 [✘]" , "" , "Failures:" , "" , " 1) bar" , "" , " To rerun use: --match \"/bar/\"" , "" , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds" , "2 examples, 1 failure" ] it "cancels running parallel spec items on failure" $ do child1 <- newQSem 0 child2 <- newQSem 0 parent <- newQSem 0 ref <- newIORef "" ignoreExitCode . hspec ["--fail-fast", "-j", "2"] $ do H.parallel $ do H.it "foo" $ do waitQSem child1 "foo" `shouldBe` "bar" H.it "bar" $ do -- NOTE: waitQSem should never return here, as we want to -- guarantee that the thread is killed before hspec returns (signalQSem child1 >> waitQSem child2 >> writeIORef ref "foo") `finally` signalQSem parent signalQSem child2 waitQSem parent readIORef ref `shouldReturn` "" 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 [✘]" , "" , "Failures:" , "" , " 1) foo bar" , "" , " To rerun use: --match \"/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 hspec ["-m", "/bar/example"] $ 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 hspec ["-m", "/bar/example", "--skip", "example 3"] $ 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 hspec ["-m", "foo", "-m", "baz"] $ 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) #if __GLASGOW_HASKELL__ >= 802 context "with --pretty" $ do it "pretty-prints Haskell values" $ do let args = ["--pretty", "--seed=0", "--format=failed-examples"] r <- fmap (unlines . normalizeSummary . lines) . capture_ . ignoreExitCode . withArgs args . H.hspec . removeLocations $ do H.it "foo" $ do person 23 `H.shouldBe` person 42 r `shouldBe` unlines [ "" , "Failures:" , "" , " 1) foo" , " expected: Person {" , " personName = \"Joe\"," , " personAge = 42" , " }" , " but got: Person {" , " personName = \"Joe\"," , " personAge = 23" , " }" , "" , " To rerun use: --match \"/foo/\"" , "" , "Randomized with seed 0" , "" , "Finished in 0.0000 seconds" , "1 example, 1 failure" ] #endif it "uses custom pretty-print functions" $ do let pretty _ _ _ = ("foo", "bar") r <- capture_ . ignoreExitCode . withArgs ["--pretty"] . H.hspec $ do H.modifyConfig $ \ c -> c { H.configPrettyPrintFunction = pretty } H.it "foo" $ do 23 `H.shouldBe` (42 :: Int) r `shouldContain` unlines [ " expected: foo" , " but got: bar" ] context "with --no-pretty" $ do it "does not pretty-prints Haskell values" $ do r <- capture_ . ignoreExitCode . withArgs ["--no-pretty"] . H.hspec $ do H.it "foo" $ do person 23 `H.shouldBe` person 42 r `shouldContain` unlines [ " expected: Person {personName = \"Joe\", personAge = 42}" , " but got: Person {personName = \"Joe\", personAge = 23}" ] context "with --diff" $ do it "shows colorized diffs" $ do r <- capture_ . ignoreExitCode . withArgs ["--diff", "--color"] . H.hspec $ do H.it "foo" $ do 23 `H.shouldBe` (42 :: Int) r `shouldContain` unlines [ red ++ " expected: " ++ reset ++ red ++ "42" ++ reset , red ++ " but got: " ++ reset ++ green ++ "23" ++ reset ] context "with --no-diff" $ do it "it does not show colorized diffs" $ do r <- capture_ . ignoreExitCode . withArgs ["--no-diff", "--color"] . H.hspec $ do H.it "foo" $ do 23 `H.shouldBe` (42 :: Int) r `shouldContain` unlines [ red ++ " expected: " ++ reset ++ "42" , red ++ " but got: " ++ reset ++ "23" ] context "with --diff-context" $ do it "suppresses excessive diff output" $ do let args = ["--seed=0", "--format=failed-examples", "--diff-context=1"] expected = map show [1 .. 99 :: Int] actual = replace "50" "foo" expected r <- fmap (unlines . normalizeSummary . lines) . capture_ . ignoreExitCode . withArgs args . H.hspec . removeLocations $ do H.it "foo" $ do unlines actual `H.shouldBe` unlines expected r `shouldBe` unlines [ "" , "Failures:" , "" , " 1) foo" , " expected: @@ 48 lines omitted @@" , " 49" , " 50" , " 51" , " @@ 48 lines omitted @@" , " " , " but got: @@ 48 lines omitted @@" , " 49" , " foo" , " 51" , " @@ 48 lines omitted @@" , " " , "" , " To rerun use: --match \"/foo/\"" , "" , "Randomized with seed 0" , "" , "Finished in 0.0000 seconds" , "1 example, 1 failure" ] context "with --diff-command" $ do it "uses an external diff command" $ do let args = ["--seed=0", "--format=failed-examples", "--diff-command", "diff -u -L expected -L actual"] expected = map show [1 .. 99 :: Int] actual = replace "50" "foo" expected r <- fmap (unlines . normalizeSummary . lines) . capture_ . ignoreExitCode . withArgs args . H.hspec . removeLocations $ do H.it "foo" $ do unlines actual `H.shouldBe` unlines expected r `shouldBe` unlines [ "" , "Failures:" , "" , " 1) foo" , "--- expected" , "+++ actual" , "@@ -47,7 +47,7 @@" , " 47" , " 48" , " 49" , "-50" , "+foo" , " 51" , " 52" , " 53" , "" , " To rerun use: --match \"/foo/\"" , "" , "Randomized with seed 0" , "" , "Finished in 0.0000 seconds" , "1 example, 1 failure" ] context "with --print-slow-items" $ do it "prints slow items" $ do r <- captureLines . ignoreExitCode . withArgs ["--print-slow-items"] . H.hspec $ do H.it "foo" $ threadDelay 2000 normalizeTimes (normalizeSummary r) `shouldBe` [ "" , "foo [✔]" , "" , "Finished in 0.0000 seconds" , "1 example, 0 failures" , "" , "Slow spec items:" #if MIN_VERSION_base(4,8,1) , " test" "Test" "Hspec" "Core" "RunnerSpec.hs:" <> show (__LINE__ - 10 :: Int) <> ":11: /foo/ (2ms)" #else , " /foo/ (2ms)" #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 hspec ["--qc-max-success", "23"] $ 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` (QC.maxSuccess, 23) ["--rerun", "--qc-max-success", "42"] `shouldUseArgs` (QC.maxSuccess, 42) context "with --qc-max-size" $ do it "passes specified size to QuickCheck properties" $ do ["--qc-max-size", "23"] `shouldUseArgs` (QC.maxSize, 23) context "with --qc-max-discard" $ do it "uses specified discard ratio to QuickCheck properties" $ do ["--qc-max-discard", "23"] `shouldUseArgs` (QC.maxDiscardRatio, 23) 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 [‐]\n" 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 [✘]\n" describe "hspecResult" $ do let hspecResult args = withArgs args . hspecResultSilent hspecResult_ = hspecResultSilent it "returns a summary of the test run" $ do 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 hspecResult_ $ do H.it "foobar" throwException_ `shouldReturn` H.Summary 1 1 it "handles unguarded exceptions in runner" $ do let throwExceptionThatIsNotGuardedBy_safeTry :: H.Item () -> H.Item () throwExceptionThatIsNotGuardedBy_safeTry item = item { H.itemExample = \ _params _hook _progress -> throwIO DivideByZero } hspecResult_ $ H.mapSpecItem_ throwExceptionThatIsNotGuardedBy_safeTry $ do H.it "foo" True `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 "does not let escape error thunks from failure messages" $ do r <- hspecResult_ $ do H.it "some example" (H.Result "" $ H.Failure Nothing . H.Reason $ "foobar" ++ undefined) r `shouldBe` H.Summary 1 1 it "runs specs in parallel" $ do let n = 100 t = 0.01 dt = t * (fromIntegral n / 2) r <- timeout dt . hspecResult ["-j", show n] . 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 <- hspecResult ["-j", show j] . H.parallel $ do replicateM_ n $ H.it "foo" $ bracket_ start stop $ sleep t r `shouldBe` H.Summary n 0 high <- readIORef highRef high `shouldBe` j describe "colorOutputSupported" $ do context "without a terminal device" $ do let isTerminalDevice = return False it "disables color output" $ do H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorDisabled context "with GITHUB_ACTIONS=true" $ do it "enable color output" $ do withEnvironment [("GITHUB_ACTIONS", "true")] $ do H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorEnabled ProgressReportingDisabled context "with a terminal device" $ do let isTerminalDevice = return True it "enable color output" $ do H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorEnabled ProgressReportingEnabled context "with BUILDKITE=true" $ do it "disables progress reporting" $ do withEnvironment [("BUILDKITE", "true")] $ do H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorEnabled ProgressReportingDisabled context "when NO_COLOR is set" $ do it "disables color output" $ do withEnvironment [("NO_COLOR", "yes")] $ do H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorDisabled describe "unicodeOutputSupported" $ do context "with UnicodeAlways" $ do it "returns True" $ do H.unicodeOutputSupported H.UnicodeAlways undefined `shouldReturn` True context "with UnicodeNever" $ do it "returns False" $ do H.unicodeOutputSupported H.UnicodeNever undefined `shouldReturn` False context "with UnicodeAuto" $ do context "when file encoding is UTF-8" $ do it "returns True" $ do inTempDirectory $ do withFile "foo" WriteMode $ \ h -> do hSetEncoding h utf8 H.unicodeOutputSupported H.UnicodeAuto h `shouldReturn` True context "when file encoding is not UTF-8" $ do it "returns False" $ do inTempDirectory $ do withFile "foo" WriteMode $ \ h -> do hSetEncoding h latin1 H.unicodeOutputSupported H.UnicodeAuto h `shouldReturn` False describe "rerunAll" $ do let report = FailureReport 0 0 0 0 [([], "foo")] config = H.defaultConfig {H.configRerun = True, H.configRerunAllOnSuccess = True} result = SpecResult [] True context "with --rerun, --rerun-all-on-success, previous failures, on success" $ do it "returns True" $ do H.rerunAll config (Just report) result `shouldBe` True context "without --rerun" $ do it "returns False" $ do H.rerunAll config {H.configRerun = False} (Just report) result `shouldBe` False context "without --rerun-all-on-success" $ do it "returns False" $ do H.rerunAll config {H.configRerunAllOnSuccess = False} (Just report) result `shouldBe` False context "without previous failures" $ do it "returns False" $ do H.rerunAll config (Just report {failureReportPaths = []}) result `shouldBe` False context "without failure report" $ do it "returns False" $ do H.rerunAll config Nothing result `shouldBe` False context "on failure" $ do it "returns False" $ do H.rerunAll config (Just report) result { specResultSuccess = False } `shouldBe` False where green = setSGRCode [SetColor Foreground Dull Green] red = setSGRCode [SetColor Foreground Dull Red] reset = setSGRCode [Reset] hspec-core-2.10.10/test/Test/Hspec/Core/ShuffleSpec.hs0000644000000000000000000000265107346545000020473 0ustar0000000000000000module Test.Hspec.Core.ShuffleSpec (spec) where import Prelude () import Helper import qualified Test.Hspec.Core.Shuffle as H import Test.Hspec.Core.Tree import Data.Array.ST import Control.Monad.ST import Data.STRef import System.Random spec :: Spec spec = do describe "shuffleForest" $ do let shuffleForest :: Int -> [Tree () Int] -> [Tree () Int] shuffleForest seed xs = runST $ do gen <- newSTRef (mkStdGen seed) H.shuffleForest gen xs it "shuffles a forest" $ do shuffleForest 2 [Leaf 1, Leaf 2, Leaf 3] `shouldBe` [Leaf 3, Leaf 1, Leaf 2] it "recurses into Node" $ do shuffleForest 1 [Node "foo" [Node "bar" [Leaf 1, Leaf 2, Leaf 3]]] `shouldBe` [Node "foo" [Node "bar" [Leaf 2, Leaf 3, Leaf 1]]] it "recurses into NodeWithCleanup" $ do shuffleForest 1 [NodeWithCleanup Nothing () [NodeWithCleanup Nothing () [Leaf 1, Leaf 2, Leaf 3]]] `shouldBe` [NodeWithCleanup Nothing () [NodeWithCleanup Nothing () [Leaf 2, Leaf 3, Leaf 1]]] describe "shuffle" $ do it "shuffles a list" $ do runST $ do gen <- newSTRef (mkStdGen 2) H.shuffle gen [1, 2, 3 :: Int] `shouldBe` [3, 1, 2] describe "mkArray" $ do it "creates an STArray from a list" $ do runST (H.mkArray [1, 2, 3 :: Int] >>= getElems) `shouldBe` [1, 2, 3] hspec-core-2.10.10/test/Test/Hspec/Core/SpecSpec.hs0000644000000000000000000001145707346545000017775 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.SpecSpec (spec) where import Prelude () import Helper import Test.Hspec.Core.Spec (Item(..), Result(..), ResultStatus(..)) import qualified Test.Hspec.Core.Runner as H import Test.Hspec.Core.Spec (Tree(..)) import qualified Test.Hspec.Core.Spec as H extract :: (Item () -> a) -> H.Spec -> IO [Tree () a] extract f = fmap (H.bimapForest (const ()) f) . fmap snd . H.runSpecM runSpec :: H.Spec -> IO [String] runSpec = captureLines . H.hspecResult spec :: Spec spec = do let runSpecM :: H.SpecWith a -> IO [H.SpecTree a] runSpecM = fmap snd . H.runSpecM runItem :: Item () -> IO Result runItem item = itemExample item defaultParams ($ ()) noOpProgressCallback describe "getSpecDescriptionPath" $ do it "returns the spec path" $ do let descriptionPathShouldBe xs = H.getSpecDescriptionPath >>= H.runIO . (`shouldBe` xs) void . runSpecM $ do descriptionPathShouldBe [] H.describe "foo" $ do H.describe "bar" $ do descriptionPathShouldBe ["foo", "bar"] H.it "baz" True 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 ())) #if MIN_VERSION_base(4,8,1) d `shouldBe` "Test.Hspec.Core.SpecSpec[" ++ show (__LINE__ - 2 :: Int) ++ ":33]" #else d `shouldBe` "(no description given)" #endif describe "xdescribe" $ do it "creates a tree of pending spec items" $ do [Node _ [Leaf item]] <- runSpecM (H.xdescribe "" $ H.it "whatever" True) runItem item `shouldReturn` Result "" (Pending Nothing 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) runItem item `shouldReturn` Result "" Success it "adds source locations" $ do [Leaf item] <- runSpecM (H.it "foo" True) let location = mkLocation __FILE__ (pred __LINE__) 32 itemLocation item `shouldBe` location context "when no description is given" $ do it "uses a default description" $ do [Leaf item] <- runSpecM (H.it "" True) #if MIN_VERSION_base(4,8,1) itemRequirement item `shouldBe` "Test.Hspec.Core.SpecSpec[" ++ show (__LINE__ - 2 :: Int) ++ ":34]" #else itemRequirement item `shouldBe` "(unspecified behavior)" #endif describe "xit" $ do it "creates a pending spec item" $ do [Leaf item] <- runSpecM (H.xit "whatever" True) runItem item `shouldReturn` Result "" (Pending Nothing 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 "focus" $ do it "focuses spec items" $ do items <- extract itemIsFocused $ H.focus $ do H.it "is focused and will run" True H.it "is also focused and will also run" True items `shouldBe` [Leaf True, Leaf True] context "when applied to a spec with focused spec items" $ do it "has no effect" $ do items <- extract itemIsFocused $ H.focus $ do H.focus $ H.it "is focused and will run" True H.it "is not focused and will not run" True items `shouldBe` [Leaf True, Leaf False] describe "parallel" $ do it "marks examples for parallel execution" $ do items <- extract itemIsParallelizable . H.parallel $ H.it "whatever" H.pending items `shouldBe` [Leaf $ Just True] it "is applied recursively" $ do items <- extract itemIsParallelizable . H.parallel $ do H.describe "foo" $ do H.describe "bar" $ do H.it "baz" H.pending items `shouldBe` [Node "foo" [Node "bar" [Leaf $ Just True]]] describe "sequential" $ do it "marks examples for sequential execution" $ do items <- extract itemIsParallelizable . H.sequential $ H.it "whatever" H.pending items `shouldBe` [Leaf $ Just False] it "takes precedence over a later `parallel`" $ do items <- extract itemIsParallelizable . H.parallel . H.sequential $ H.it "whatever" H.pending items `shouldBe` [Leaf $ Just False] hspec-core-2.10.10/test/Test/Hspec/Core/TimerSpec.hs0000644000000000000000000000140207346545000020150 0ustar0000000000000000module Test.Hspec.Core.TimerSpec (spec) where import Prelude () import Helper -- import Test.Hspec.Core.Timer spec :: Spec spec = do describe "timer action provided by withTimer" $ do pass -- this test is fragile, see e.g. https://github.com/hspec/hspec/issues/352 {- let dt = 0.01 wait = sleep (dt * 1.1) it "returns False" $ do withTimer dt $ \timer -> do timer `shouldReturn` False context "after specified time" $ do it "returns True" $ do withTimer dt $ \timer -> do wait timer `shouldReturn` True timer `shouldReturn` False wait wait timer `shouldReturn` True timer `shouldReturn` False -} hspec-core-2.10.10/test/Test/Hspec/Core/UtilSpec.hs0000644000000000000000000001066707346545000020022 0ustar0000000000000000module Test.Hspec.Core.UtilSpec (spec) where import Prelude () import Helper import Control.Concurrent import Test.Hspec.Core.Util 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 (toException DivideByZero) `shouldBe` "ArithException\ndivide by zero" context "when used with an IOException" $ do it "includes the IOErrorType" $ do inTempDirectory $ do Left e <- try (readFile "foo") formatException e `shouldBe` intercalate "\n" [ "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" ] it "preserves existing line breaks" $ do lineBreaksAt 10 "foo bar baz\none two three" `shouldBe` [ "foo bar" , "baz" , "one two" , "three" ] 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 fromException e `shouldBe` Just DivideByZero it "evaluates result to weak head normal form" $ do Left e <- safeTry (return $ throw $ 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) >> pass `catch` putMVar mvar takeMVar sync throwTo threadId UserInterrupt readMVar mvar `shouldReturn` 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 given in the failure list" $ do let p = filterPredicate "ModuleA.ModuleB.foo does something" p (["ModuleA", "ModuleB", "foo"], "does something") `shouldBe` True context "with an absolute path that begins or ends with a slash" $ do it "succeeds" $ do let p = filterPredicate "/foo/bar/baz/example 1/" p (["foo", "bar", "baz"], "example 1") `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 consists 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.10.10/vendor/Control/Concurrent/0000755000000000000000000000000007346545000017133 5ustar0000000000000000hspec-core-2.10.10/vendor/Control/Concurrent/Async.hs0000644000000000000000000010110607346545000020543 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes, ExistentialQuantification #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE DeriveDataTypeable #-} #endif {-# OPTIONS -Wall -fno-warn-implicit-prelude -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.Async -- Copyright : (c) Simon Marlow 2012 -- License : BSD3 (see the file LICENSE) -- -- Maintainer : Simon Marlow -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- This module provides a set of operations for running IO operations -- asynchronously and waiting for their results. It is a thin layer -- over the basic concurrency operations provided by -- "Control.Concurrent". The main additional functionality it -- provides is the ability to wait for the return value of a thread, -- but the interface also provides some additional safety and -- robustness over using 'forkIO' threads and @MVar@ directly. -- -- == High-level API -- -- @async@'s high-level API spawns /lexically scoped/ threads, -- ensuring the following key poperties that make it safer to use -- than using plain 'forkIO': -- -- 1. No exception is swallowed (waiting for results propagates exceptions). -- 2. No thread is leaked (left running unintentionally). -- -- (This is done using the 'Control.Exception.bracket' pattern to work in presence -- of synchornous and asynchronous exceptions.) -- -- __Most practical/production code should only use the high-level API__. -- -- The basic type is @'Async' a@, which represents an asynchronous -- @IO@ action that will return a value of type @a@, or die with an -- exception. An 'Async' is a wrapper around a low-level 'forkIO' thread. -- -- The fundamental function to spawn threads with the high-level API is -- 'withAsync'. -- -- For example, to fetch two web pages at the same time, we could do -- this (assuming a suitable @getURL@ function): -- -- > withAsync (getURL url1) $ \a1 -> do -- > withAsync (getURL url2) $ \a2 -> do -- > page1 <- wait a1 -- > page2 <- wait a2 -- > ... -- -- where 'withAsync' starts the operation in a separate thread, and -- 'wait' waits for and returns the result. -- -- * If the operation throws an exception, then that exception is re-thrown -- by 'wait'. This ensures property (1): No exception is swallowed. -- * If an exception bubbles up through a 'withAsync', then the 'Async' -- it spawned is 'cancel'ed. This ensures property (2): No thread is leaked. -- -- Often we do not care to work manually with 'Async' handles like -- @a1@ and @a2@. Instead, we want to express high-level objectives like -- performing two or more tasks concurrently, and waiting for one or all -- of them to finish. -- -- For example, the pattern of performing two IO actions concurrently and -- waiting for both their results is packaged up in a combinator 'concurrently', -- so we can further shorten the above example to: -- -- > (page1, page2) <- concurrently (getURL url1) (getURL url2) -- > ... -- -- The section __/High-level utilities/__ covers the most -- common high-level objectives, including: -- -- * Waiting for 2 results ('concurrently'). -- * Waiting for many results ('mapConcurrently' / 'forConcurrently'). -- * Waiting for the first of 2 results ('race'). -- * Waiting for arbitrary nestings of "all of /N/" and "the first of /N/" -- results with the 'Concurrently' newtype and its 'Applicative' and -- 'Alternative' instances. -- -- Click here to scroll to that section: -- "Control.Concurrent.Async#high-level-utilities". -- -- == Low-level API -- -- Some use cases require parallelism that is not lexically scoped. -- -- For those, the low-level function 'async' can be used as a direct -- equivalent of 'forkIO': -- -- > -- Do NOT use this code in production, it has a flaw (explained below). -- > do -- > a1 <- async (getURL url1) -- > a2 <- async (getURL url2) -- > page1 <- wait a1 -- > page2 <- wait a2 -- > ... -- -- In contrast to 'withAsync', this code has a problem. -- -- It still fulfills property (1) in that an exception arising from -- @getUrl@ will be re-thrown by 'wait', but it does not fulfill -- property (2). -- Consider the case when the first 'wait' throws an exception; then the -- second 'wait' will not happen, and the second 'async' may be left -- running in the background, possibly indefinitely. -- -- 'withAsync' is like 'async', except that the 'Async' is -- automatically killed (using 'uninterruptibleCancel') if the -- enclosing IO operation returns before it has completed. -- Furthermore, 'withAsync' allows a tree of threads to be built, such -- that children are automatically killed if their parents die for any -- reason. -- -- If you need to use the low-level API, ensure that you gurantee -- property (2) by other means, such as 'link'ing asyncs that need -- to die together, and protecting against asynchronous exceptions -- using 'Control.Exception.bracket', 'Control.Exception.mask', -- or other functions from "Control.Exception". -- -- == Miscellaneous -- -- The 'Functor' instance can be used to change the result of an -- 'Async'. For example: -- -- > ghci> withAsync (return 3) (\a -> wait (fmap (+1) a)) -- > 4 -- -- === Resource exhaustion -- -- As with all concurrent programming, keep in mind that while -- Haskell's cooperative ("green") multithreading carries low overhead, -- spawning too many of them at the same time may lead to resource exhaustion -- (of memory, file descriptors, or other limited resources), given that the -- actions running in the threads consume these resources. ----------------------------------------------------------------------------- module Control.Concurrent.Async ( -- * Asynchronous actions Async, -- * High-level API -- ** Spawning with automatic 'cancel'ation withAsync, withAsyncBound, withAsyncOn, withAsyncWithUnmask, withAsyncOnWithUnmask, -- ** Querying 'Async's wait, poll, waitCatch, asyncThreadId, cancel, uninterruptibleCancel, cancelWith, AsyncCancelled(..), -- ** #high-level-utilities# High-level utilities race, race_, concurrently, concurrently_, mapConcurrently, forConcurrently, mapConcurrently_, forConcurrently_, replicateConcurrently, replicateConcurrently_, Concurrently(..), compareAsyncs, -- ** Specialised operations -- *** STM operations waitSTM, pollSTM, waitCatchSTM, -- *** Waiting for multiple 'Async's waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel, waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel, waitEither_, waitBoth, -- *** Waiting for multiple 'Async's in STM waitAnySTM, waitAnyCatchSTM, waitEitherSTM, waitEitherCatchSTM, waitEitherSTM_, waitBothSTM, -- * Low-level API -- ** Spawning (low-level API) async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask, -- ** Linking link, linkOnly, link2, link2Only, ExceptionInLinkedThread(..), ) where import Control.Concurrent.STM.TMVar import Control.Exception import Control.Concurrent import qualified Data.Foldable as F #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif import Control.Monad import Control.Applicative #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(mempty,mappend)) import Data.Traversable #endif #if __GLASGOW_HASKELL__ < 710 import Data.Typeable #endif #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup((<>))) #endif import Data.IORef import GHC.Exts import GHC.IO hiding (finally, onException) import GHC.Conc -- ----------------------------------------------------------------------------- -- STM Async API -- | An asynchronous action spawned by 'async' or 'withAsync'. -- Asynchronous actions are executed in a separate thread, and -- operations are provided for waiting for asynchronous actions to -- complete and obtaining their results (see e.g. 'wait'). -- data Async a = Async { asyncThreadId :: {-# UNPACK #-} !ThreadId -- ^ Returns the 'ThreadId' of the thread running -- the given 'Async'. , _asyncWait :: STM (Either SomeException a) } instance Eq (Async a) where Async a _ == Async b _ = a == b instance Ord (Async a) where Async a _ `compare` Async b _ = a `compare` b instance Functor Async where fmap f (Async a w) = Async a (fmap (fmap f) w) -- | Compare two Asyncs that may have different types by their 'ThreadId'. compareAsyncs :: Async a -> Async b -> Ordering compareAsyncs (Async t1 _) (Async t2 _) = compare t1 t2 -- | Spawn an asynchronous action in a separate thread. -- -- Like for 'forkIO', the action may be left running unintentinally -- (see module-level documentation for details). -- -- __Use 'withAsync' style functions wherever you can instead!__ async :: IO a -> IO (Async a) async = inline asyncUsing rawForkIO -- | Like 'async' but using 'forkOS' internally. asyncBound :: IO a -> IO (Async a) asyncBound = asyncUsing forkOS -- | Like 'async' but using 'forkOn' internally. asyncOn :: Int -> IO a -> IO (Async a) asyncOn = asyncUsing . rawForkOn -- | Like 'async' but using 'forkIOWithUnmask' internally. The child -- thread is passed a function that can be used to unmask asynchronous -- exceptions. asyncWithUnmask :: ((forall b . IO b -> IO b) -> IO a) -> IO (Async a) asyncWithUnmask actionWith = asyncUsing rawForkIO (actionWith unsafeUnmask) -- | Like 'asyncOn' but using 'forkOnWithUnmask' internally. The -- child thread is passed a function that can be used to unmask -- asynchronous exceptions. asyncOnWithUnmask :: Int -> ((forall b . IO b -> IO b) -> IO a) -> IO (Async a) asyncOnWithUnmask cpu actionWith = asyncUsing (rawForkOn cpu) (actionWith unsafeUnmask) asyncUsing :: (IO () -> IO ThreadId) -> IO a -> IO (Async a) asyncUsing doFork = \action -> do var <- newEmptyTMVarIO -- t <- forkFinally action (\r -> atomically $ putTMVar var r) -- slightly faster: t <- mask $ \restore -> doFork $ try (restore action) >>= atomically . putTMVar var return (Async t (readTMVar var)) -- | Spawn an asynchronous action in a separate thread, and pass its -- @Async@ handle to the supplied function. When the function returns -- or throws an exception, 'uninterruptibleCancel' is called on the @Async@. -- -- > withAsync action inner = mask $ \restore -> do -- > a <- async (restore action) -- > restore (inner a) `finally` uninterruptibleCancel a -- -- This is a useful variant of 'async' that ensures an @Async@ is -- never left running unintentionally. -- -- Note: a reference to the child thread is kept alive until the call -- to `withAsync` returns, so nesting many `withAsync` calls requires -- linear memory. -- withAsync :: IO a -> (Async a -> IO b) -> IO b withAsync = inline withAsyncUsing rawForkIO -- | Like 'withAsync' but uses 'forkOS' internally. withAsyncBound :: IO a -> (Async a -> IO b) -> IO b withAsyncBound = withAsyncUsing forkOS -- | Like 'withAsync' but uses 'forkOn' internally. withAsyncOn :: Int -> IO a -> (Async a -> IO b) -> IO b withAsyncOn = withAsyncUsing . rawForkOn -- | Like 'withAsync' but uses 'forkIOWithUnmask' internally. The -- child thread is passed a function that can be used to unmask -- asynchronous exceptions. withAsyncWithUnmask :: ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b withAsyncWithUnmask actionWith = withAsyncUsing rawForkIO (actionWith unsafeUnmask) -- | Like 'withAsyncOn' but uses 'forkOnWithUnmask' internally. The -- child thread is passed a function that can be used to unmask -- asynchronous exceptions withAsyncOnWithUnmask :: Int -> ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b withAsyncOnWithUnmask cpu actionWith = withAsyncUsing (rawForkOn cpu) (actionWith unsafeUnmask) withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (Async a -> IO b) -> IO b -- The bracket version works, but is slow. We can do better by -- hand-coding it: withAsyncUsing doFork = \action inner -> do var <- newEmptyTMVarIO mask $ \restore -> do t <- doFork $ try (restore action) >>= atomically . putTMVar var let a = Async t (readTMVar var) r <- restore (inner a) `catchAll` \e -> do uninterruptibleCancel a throwIO e uninterruptibleCancel a return r -- | Wait for an asynchronous action to complete, and return its -- value. If the asynchronous action threw an exception, then the -- exception is re-thrown by 'wait'. -- -- > wait = atomically . waitSTM -- {-# INLINE wait #-} wait :: Async a -> IO a wait = tryAgain . atomically . waitSTM where -- See: https://github.com/simonmar/async/issues/14 tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f -- | Wait for an asynchronous action to complete, and return either -- @Left e@ if the action raised an exception @e@, or @Right a@ if it -- returned a value @a@. -- -- > waitCatch = atomically . waitCatchSTM -- {-# INLINE waitCatch #-} waitCatch :: Async a -> IO (Either SomeException a) waitCatch = tryAgain . atomically . waitCatchSTM where -- See: https://github.com/simonmar/async/issues/14 tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f -- | Check whether an 'Async' has completed yet. If it has not -- completed yet, then the result is @Nothing@, otherwise the result -- is @Just e@ where @e@ is @Left x@ if the @Async@ raised an -- exception @x@, or @Right a@ if it returned a value @a@. -- -- > poll = atomically . pollSTM -- {-# INLINE poll #-} poll :: Async a -> IO (Maybe (Either SomeException a)) poll = atomically . pollSTM -- | A version of 'wait' that can be used inside an STM transaction. -- waitSTM :: Async a -> STM a waitSTM a = do r <- waitCatchSTM a either throwSTM return r -- | A version of 'waitCatch' that can be used inside an STM transaction. -- {-# INLINE waitCatchSTM #-} waitCatchSTM :: Async a -> STM (Either SomeException a) waitCatchSTM (Async _ w) = w -- | A version of 'poll' that can be used inside an STM transaction. -- {-# INLINE pollSTM #-} pollSTM :: Async a -> STM (Maybe (Either SomeException a)) pollSTM (Async _ w) = (Just <$> w) `orElse` return Nothing -- | Cancel an asynchronous action by throwing the @AsyncCancelled@ -- exception to it, and waiting for the `Async` thread to quit. -- Has no effect if the 'Async' has already completed. -- -- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a -- -- Note that 'cancel' will not terminate until the thread the 'Async' -- refers to has terminated. This means that 'cancel' will block for -- as long said thread blocks when receiving an asynchronous exception. -- -- For example, it could block if: -- -- * It's executing a foreign call, and thus cannot receive the asynchronous -- exception; -- * It's executing some cleanup handler after having received the exception, -- and the handler is blocking. {-# INLINE cancel #-} cancel :: Async a -> IO () cancel a@(Async t _) = throwTo t AsyncCancelled <* waitCatch a -- | The exception thrown by `cancel` to terminate a thread. data AsyncCancelled = AsyncCancelled deriving (Show, Eq #if __GLASGOW_HASKELL__ < 710 ,Typeable #endif ) instance Exception AsyncCancelled where #if __GLASGOW_HASKELL__ >= 708 fromException = asyncExceptionFromException toException = asyncExceptionToException #endif -- | Cancel an asynchronous action -- -- This is a variant of `cancel`, but it is not interruptible. {-# INLINE uninterruptibleCancel #-} uninterruptibleCancel :: Async a -> IO () uninterruptibleCancel = uninterruptibleMask_ . cancel -- | Cancel an asynchronous action by throwing the supplied exception -- to it. -- -- > cancelWith a x = throwTo (asyncThreadId a) x -- -- The notes about the synchronous nature of 'cancel' also apply to -- 'cancelWith'. cancelWith :: Exception e => Async a -> e -> IO () cancelWith a@(Async t _) e = throwTo t e <* waitCatch a -- | Wait for any of the supplied asynchronous operations to complete. -- The value returned is a pair of the 'Async' that completed, and the -- result that would be returned by 'wait' on that 'Async'. -- -- If multiple 'Async's complete or have completed, then the value -- returned corresponds to the first completed 'Async' in the list. -- {-# INLINE waitAnyCatch #-} waitAnyCatch :: [Async a] -> IO (Async a, Either SomeException a) waitAnyCatch = atomically . waitAnyCatchSTM -- | A version of 'waitAnyCatch' that can be used inside an STM transaction. -- -- @since 2.1.0 waitAnyCatchSTM :: [Async a] -> STM (Async a, Either SomeException a) waitAnyCatchSTM asyncs = foldr orElse retry $ map (\a -> do r <- waitCatchSTM a; return (a, r)) asyncs -- | Like 'waitAnyCatch', but also cancels the other asynchronous -- operations as soon as one has completed. -- waitAnyCatchCancel :: [Async a] -> IO (Async a, Either SomeException a) waitAnyCatchCancel asyncs = waitAnyCatch asyncs `finally` mapM_ cancel asyncs -- | Wait for any of the supplied @Async@s to complete. If the first -- to complete throws an exception, then that exception is re-thrown -- by 'waitAny'. -- -- If multiple 'Async's complete or have completed, then the value -- returned corresponds to the first completed 'Async' in the list. -- {-# INLINE waitAny #-} waitAny :: [Async a] -> IO (Async a, a) waitAny = atomically . waitAnySTM -- | A version of 'waitAny' that can be used inside an STM transaction. -- -- @since 2.1.0 waitAnySTM :: [Async a] -> STM (Async a, a) waitAnySTM asyncs = foldr orElse retry $ map (\a -> do r <- waitSTM a; return (a, r)) asyncs -- | Like 'waitAny', but also cancels the other asynchronous -- operations as soon as one has completed. -- waitAnyCancel :: [Async a] -> IO (Async a, a) waitAnyCancel asyncs = waitAny asyncs `finally` mapM_ cancel asyncs -- | Wait for the first of two @Async@s to finish. {-# INLINE waitEitherCatch #-} waitEitherCatch :: Async a -> Async b -> IO (Either (Either SomeException a) (Either SomeException b)) waitEitherCatch left right = tryAgain $ atomically (waitEitherCatchSTM left right) where -- See: https://github.com/simonmar/async/issues/14 tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f -- | A version of 'waitEitherCatch' that can be used inside an STM transaction. -- -- @since 2.1.0 waitEitherCatchSTM :: Async a -> Async b -> STM (Either (Either SomeException a) (Either SomeException b)) waitEitherCatchSTM left right = (Left <$> waitCatchSTM left) `orElse` (Right <$> waitCatchSTM right) -- | Like 'waitEitherCatch', but also 'cancel's both @Async@s before -- returning. -- waitEitherCatchCancel :: Async a -> Async b -> IO (Either (Either SomeException a) (Either SomeException b)) waitEitherCatchCancel left right = waitEitherCatch left right `finally` (cancel left >> cancel right) -- | Wait for the first of two @Async@s to finish. If the @Async@ -- that finished first raised an exception, then the exception is -- re-thrown by 'waitEither'. -- {-# INLINE waitEither #-} waitEither :: Async a -> Async b -> IO (Either a b) waitEither left right = atomically (waitEitherSTM left right) -- | A version of 'waitEither' that can be used inside an STM transaction. -- -- @since 2.1.0 waitEitherSTM :: Async a -> Async b -> STM (Either a b) waitEitherSTM left right = (Left <$> waitSTM left) `orElse` (Right <$> waitSTM right) -- | Like 'waitEither', but the result is ignored. -- {-# INLINE waitEither_ #-} waitEither_ :: Async a -> Async b -> IO () waitEither_ left right = atomically (waitEitherSTM_ left right) -- | A version of 'waitEither_' that can be used inside an STM transaction. -- -- @since 2.1.0 waitEitherSTM_:: Async a -> Async b -> STM () waitEitherSTM_ left right = (void $ waitSTM left) `orElse` (void $ waitSTM right) -- | Like 'waitEither', but also 'cancel's both @Async@s before -- returning. -- waitEitherCancel :: Async a -> Async b -> IO (Either a b) waitEitherCancel left right = waitEither left right `finally` (cancel left >> cancel right) -- | Waits for both @Async@s to finish, but if either of them throws -- an exception before they have both finished, then the exception is -- re-thrown by 'waitBoth'. -- {-# INLINE waitBoth #-} waitBoth :: Async a -> Async b -> IO (a,b) waitBoth left right = tryAgain $ atomically (waitBothSTM left right) where -- See: https://github.com/simonmar/async/issues/14 tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f -- | A version of 'waitBoth' that can be used inside an STM transaction. -- -- @since 2.1.0 waitBothSTM :: Async a -> Async b -> STM (a,b) waitBothSTM left right = do a <- waitSTM left `orElse` (waitSTM right >> retry) b <- waitSTM right return (a,b) -- ----------------------------------------------------------------------------- -- Linking threads data ExceptionInLinkedThread = forall a . ExceptionInLinkedThread (Async a) SomeException #if __GLASGOW_HASKELL__ < 710 deriving Typeable #endif instance Show ExceptionInLinkedThread where showsPrec p (ExceptionInLinkedThread (Async t _) e) = showParen (p >= 11) $ showString "ExceptionInLinkedThread " . showsPrec 11 t . showString " " . showsPrec 11 e instance Exception ExceptionInLinkedThread where #if __GLASGOW_HASKELL__ >= 708 fromException = asyncExceptionFromException toException = asyncExceptionToException #endif -- | Link the given @Async@ to the current thread, such that if the -- @Async@ raises an exception, that exception will be re-thrown in -- the current thread, wrapped in 'ExceptionInLinkedThread'. -- -- 'link' ignores 'AsyncCancelled' exceptions thrown in the other thread, -- so that it's safe to 'cancel' a thread you're linked to. If you want -- different behaviour, use 'linkOnly'. -- link :: Async a -> IO () link = linkOnly (not . isCancel) -- | Link the given @Async@ to the current thread, such that if the -- @Async@ raises an exception, that exception will be re-thrown in -- the current thread, wrapped in 'ExceptionInLinkedThread'. -- -- The supplied predicate determines which exceptions in the target -- thread should be propagated to the source thread. -- linkOnly :: (SomeException -> Bool) -- ^ return 'True' if the exception -- should be propagated, 'False' -- otherwise. -> Async a -> IO () linkOnly shouldThrow a = do me <- myThreadId void $ forkRepeat $ do r <- waitCatch a case r of Left e | shouldThrow e -> throwTo me (ExceptionInLinkedThread a e) _otherwise -> return () -- | Link two @Async@s together, such that if either raises an -- exception, the same exception is re-thrown in the other @Async@, -- wrapped in 'ExceptionInLinkedThread'. -- -- 'link2' ignores 'AsyncCancelled' exceptions, so that it's possible -- to 'cancel' either thread without cancelling the other. If you -- want different behaviour, use 'link2Only'. -- link2 :: Async a -> Async b -> IO () link2 = link2Only (not . isCancel) -- | Link two @Async@s together, such that if either raises an -- exception, the same exception is re-thrown in the other @Async@, -- wrapped in 'ExceptionInLinkedThread'. -- -- The supplied predicate determines which exceptions in the target -- thread should be propagated to the source thread. -- link2Only :: (SomeException -> Bool) -> Async a -> Async b -> IO () link2Only shouldThrow left@(Async tl _) right@(Async tr _) = void $ forkRepeat $ do r <- waitEitherCatch left right case r of Left (Left e) | shouldThrow e -> throwTo tr (ExceptionInLinkedThread left e) Right (Left e) | shouldThrow e -> throwTo tl (ExceptionInLinkedThread right e) _ -> return () isCancel :: SomeException -> Bool isCancel e | Just AsyncCancelled <- fromException e = True | otherwise = False -- ----------------------------------------------------------------------------- -- | Run two @IO@ actions concurrently, and return the first to -- finish. The loser of the race is 'cancel'led. -- -- > race left right = -- > withAsync left $ \a -> -- > withAsync right $ \b -> -- > waitEither a b -- race :: IO a -> IO b -> IO (Either a b) -- | Like 'race', but the result is ignored. -- race_ :: IO a -> IO b -> IO () -- | Run two @IO@ actions concurrently, and return both results. If -- either action throws an exception at any time, then the other -- action is 'cancel'led, and the exception is re-thrown by -- 'concurrently'. -- -- > concurrently left right = -- > withAsync left $ \a -> -- > withAsync right $ \b -> -- > waitBoth a b concurrently :: IO a -> IO b -> IO (a,b) -- | 'concurrently', but ignore the result values -- -- @since 2.1.1 concurrently_ :: IO a -> IO b -> IO () #define USE_ASYNC_VERSIONS 0 #if USE_ASYNC_VERSIONS race left right = withAsync left $ \a -> withAsync right $ \b -> waitEither a b race_ left right = void $ race left right concurrently left right = withAsync left $ \a -> withAsync right $ \b -> waitBoth a b concurrently_ left right = void $ concurrently left right #else -- MVar versions of race/concurrently -- More ugly than the Async versions, but quite a bit faster. -- race :: IO a -> IO b -> IO (Either a b) race left right = concurrently' left right collect where collect m = do e <- m case e of Left ex -> throwIO ex Right r -> return r -- race_ :: IO a -> IO b -> IO () race_ left right = void $ race left right -- concurrently :: IO a -> IO b -> IO (a,b) concurrently left right = concurrently' left right (collect []) where collect [Left a, Right b] _ = return (a,b) collect [Right b, Left a] _ = return (a,b) collect xs m = do e <- m case e of Left ex -> throwIO ex Right r -> collect (r:xs) m concurrently' :: IO a -> IO b -> (IO (Either SomeException (Either a b)) -> IO r) -> IO r concurrently' left right collect = do done <- newEmptyMVar mask $ \restore -> do -- Note: uninterruptibleMask here is because we must not allow -- the putMVar in the exception handler to be interrupted, -- otherwise the parent thread will deadlock when it waits for -- the thread to terminate. lid <- forkIO $ uninterruptibleMask_ $ restore (left >>= putMVar done . Right . Left) `catchAll` (putMVar done . Left) rid <- forkIO $ uninterruptibleMask_ $ restore (right >>= putMVar done . Right . Right) `catchAll` (putMVar done . Left) count <- newIORef (2 :: Int) let takeDone = do r <- takeMVar done -- interruptible -- Decrement the counter so we know how many takes are left. -- Since only the parent thread is calling this, we can -- use non-atomic modifications. -- NB. do this *after* takeMVar, because takeMVar might be -- interrupted. modifyIORef count (subtract 1) return r let tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f stop = do -- kill right before left, to match the semantics of -- the version using withAsync. (#27) uninterruptibleMask_ $ do count' <- readIORef count -- we only need to use killThread if there are still -- children alive. Note: forkIO here is because the -- child thread could be in an uninterruptible -- putMVar. when (count' > 0) $ void $ forkIO $ do throwTo rid AsyncCancelled throwTo lid AsyncCancelled -- ensure the children are really dead replicateM_ count' (tryAgain $ takeMVar done) r <- collect (tryAgain $ takeDone) `onException` stop stop return r concurrently_ left right = concurrently' left right (collect 0) where collect 2 _ = return () collect i m = do e <- m case e of Left ex -> throwIO ex Right _ -> collect (i + 1 :: Int) m #endif -- | Maps an 'IO'-performing function over any 'Traversable' data -- type, performing all the @IO@ actions concurrently, and returning -- the original data structure with the arguments replaced by the -- results. -- -- If any of the actions throw an exception, then all other actions are -- cancelled and the exception is re-thrown. -- -- For example, @mapConcurrently@ works with lists: -- -- > pages <- mapConcurrently getURL ["url1", "url2", "url3"] -- -- Take into account that @async@ will try to immediately spawn a thread -- for each element of the @Traversable@, so running this on large -- inputs without care may lead to resource exhaustion (of memory, -- file descriptors, or other limited resources). mapConcurrently :: Traversable t => (a -> IO b) -> t a -> IO (t b) mapConcurrently f = runConcurrently . traverse (Concurrently . f) -- | `forConcurrently` is `mapConcurrently` with its arguments flipped -- -- > pages <- forConcurrently ["url1", "url2", "url3"] $ \url -> getURL url -- -- @since 2.1.0 forConcurrently :: Traversable t => t a -> (a -> IO b) -> IO (t b) forConcurrently = flip mapConcurrently -- | `mapConcurrently_` is `mapConcurrently` with the return value discarded; -- a concurrent equivalent of 'mapM_'. mapConcurrently_ :: F.Foldable f => (a -> IO b) -> f a -> IO () mapConcurrently_ f = runConcurrently . F.foldMap (Concurrently . void . f) -- | `forConcurrently_` is `forConcurrently` with the return value discarded; -- a concurrent equivalent of 'forM_'. forConcurrently_ :: F.Foldable f => f a -> (a -> IO b) -> IO () forConcurrently_ = flip mapConcurrently_ -- | Perform the action in the given number of threads. -- -- @since 2.1.1 replicateConcurrently :: Int -> IO a -> IO [a] replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently -- | Same as 'replicateConcurrently', but ignore the results. -- -- @since 2.1.1 replicateConcurrently_ :: Int -> IO a -> IO () replicateConcurrently_ cnt = runConcurrently . F.fold . replicate cnt . Concurrently . void -- ----------------------------------------------------------------------------- -- | A value of type @Concurrently a@ is an @IO@ operation that can be -- composed with other @Concurrently@ values, using the @Applicative@ -- and @Alternative@ instances. -- -- Calling @runConcurrently@ on a value of type @Concurrently a@ will -- execute the @IO@ operations it contains concurrently, before -- delivering the result of type @a@. -- -- For example -- -- > (page1, page2, page3) -- > <- runConcurrently $ (,,) -- > <$> Concurrently (getURL "url1") -- > <*> Concurrently (getURL "url2") -- > <*> Concurrently (getURL "url3") -- newtype Concurrently a = Concurrently { runConcurrently :: IO a } instance Functor Concurrently where fmap f (Concurrently a) = Concurrently $ f <$> a instance Applicative Concurrently where pure = Concurrently . return Concurrently fs <*> Concurrently as = Concurrently $ (\(f, a) -> f a) <$> concurrently fs as instance Alternative Concurrently where empty = Concurrently $ forever (threadDelay maxBound) Concurrently as <|> Concurrently bs = Concurrently $ either id id <$> race as bs #if MIN_VERSION_base(4,9,0) -- | Only defined by @async@ for @base >= 4.9@ -- -- @since 2.1.0 instance Semigroup a => Semigroup (Concurrently a) where (<>) = liftA2 (<>) -- | @since 2.1.0 instance (Semigroup a, Monoid a) => Monoid (Concurrently a) where mempty = pure mempty mappend = (<>) #else -- | @since 2.1.0 instance Monoid a => Monoid (Concurrently a) where mempty = pure mempty mappend = liftA2 mappend #endif -- ---------------------------------------------------------------------------- -- | Fork a thread that runs the supplied action, and if it raises an -- exception, re-runs the action. The thread terminates only when the -- action runs to completion without raising an exception. forkRepeat :: IO a -> IO ThreadId forkRepeat action = mask $ \restore -> let go = do r <- tryAll (restore action) case r of Left _ -> go _ -> return () in forkIO go catchAll :: IO a -> (SomeException -> IO a) -> IO a catchAll = catch tryAll :: IO a -> IO (Either SomeException a) tryAll = try -- A version of forkIO that does not include the outer exception -- handler: saves a bit of time when we will be installing our own -- exception handler. {-# INLINE rawForkIO #-} rawForkIO :: IO () -> IO ThreadId rawForkIO (IO action) = IO $ \ s -> case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #) {-# INLINE rawForkOn #-} rawForkOn :: Int -> IO () -> IO ThreadId rawForkOn (I# cpu) (IO action) = IO $ \ s -> case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #) hspec-core-2.10.10/vendor/Data/Algorithm/0000755000000000000000000000000007346545000016170 5ustar0000000000000000hspec-core-2.10.10/vendor/Data/Algorithm/Diff.hs0000644000000000000000000001110307346545000017370 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- 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.10.10/vendor/stm-2.5.0.1/Control/Concurrent/STM/0000755000000000000000000000000007346545000021200 5ustar0000000000000000hspec-core-2.10.10/vendor/stm-2.5.0.1/Control/Concurrent/STM/TMVar.hs0000644000000000000000000001153207346545000022527 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif {-# OPTIONS -fno-warn-implicit-prelude #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.STM.TMVar -- Copyright : (c) The University of Glasgow 2004 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM) -- -- TMVar: Transactional MVars, for use in the STM monad -- (GHC only) -- ----------------------------------------------------------------------------- module Control.Concurrent.STM.TMVar ( #ifdef __GLASGOW_HASKELL__ -- * TMVars TMVar, newTMVar, newEmptyTMVar, newTMVarIO, newEmptyTMVarIO, takeTMVar, putTMVar, readTMVar, tryReadTMVar, swapTMVar, tryTakeTMVar, tryPutTMVar, isEmptyTMVar, mkWeakTMVar #endif ) where #ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.Conc import GHC.Weak import Data.Typeable (Typeable) newtype TMVar a = TMVar (TVar (Maybe a)) deriving (Eq, Typeable) {- ^ A 'TMVar' is a synchronising variable, used for communication between concurrent threads. It can be thought of as a box, which may be empty or full. -} -- |Create a 'TMVar' which contains the supplied value. newTMVar :: a -> STM (TMVar a) newTMVar a = do t <- newTVar (Just a) return (TMVar t) -- |@IO@ version of 'newTMVar'. This is useful for creating top-level -- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible. newTMVarIO :: a -> IO (TMVar a) newTMVarIO a = do t <- newTVarIO (Just a) return (TMVar t) -- |Create a 'TMVar' which is initially empty. newEmptyTMVar :: STM (TMVar a) newEmptyTMVar = do t <- newTVar Nothing return (TMVar t) -- |@IO@ version of 'newEmptyTMVar'. This is useful for creating top-level -- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible. newEmptyTMVarIO :: IO (TMVar a) newEmptyTMVarIO = do t <- newTVarIO Nothing return (TMVar t) -- |Return the contents of the 'TMVar'. If the 'TMVar' is currently -- empty, the transaction will 'retry'. After a 'takeTMVar', -- the 'TMVar' is left empty. takeTMVar :: TMVar a -> STM a takeTMVar (TMVar t) = do m <- readTVar t case m of Nothing -> retry Just a -> do writeTVar t Nothing; return a -- | A version of 'takeTMVar' that does not 'retry'. The 'tryTakeTMVar' -- function returns 'Nothing' if the 'TMVar' was empty, or @'Just' a@ if -- the 'TMVar' was full with contents @a@. After 'tryTakeTMVar', the -- 'TMVar' is left empty. tryTakeTMVar :: TMVar a -> STM (Maybe a) tryTakeTMVar (TMVar t) = do m <- readTVar t case m of Nothing -> return Nothing Just a -> do writeTVar t Nothing; return (Just a) -- |Put a value into a 'TMVar'. If the 'TMVar' is currently full, -- 'putTMVar' will 'retry'. putTMVar :: TMVar a -> a -> STM () putTMVar (TMVar t) a = do m <- readTVar t case m of Nothing -> do writeTVar t (Just a); return () Just _ -> retry -- | A version of 'putTMVar' that does not 'retry'. The 'tryPutTMVar' -- function attempts to put the value @a@ into the 'TMVar', returning -- 'True' if it was successful, or 'False' otherwise. tryPutTMVar :: TMVar a -> a -> STM Bool tryPutTMVar (TMVar t) a = do m <- readTVar t case m of Nothing -> do writeTVar t (Just a); return True Just _ -> return False -- | This is a combination of 'takeTMVar' and 'putTMVar'; ie. it -- takes the value from the 'TMVar', puts it back, and also returns -- it. readTMVar :: TMVar a -> STM a readTMVar (TMVar t) = do m <- readTVar t case m of Nothing -> retry Just a -> return a -- | A version of 'readTMVar' which does not retry. Instead it -- returns @Nothing@ if no value is available. -- -- @since 2.3 tryReadTMVar :: TMVar a -> STM (Maybe a) tryReadTMVar (TMVar t) = readTVar t -- |Swap the contents of a 'TMVar' for a new value. swapTMVar :: TMVar a -> a -> STM a swapTMVar (TMVar t) new = do m <- readTVar t case m of Nothing -> retry Just old -> do writeTVar t (Just new); return old -- |Check whether a given 'TMVar' is empty. isEmptyTMVar :: TMVar a -> STM Bool isEmptyTMVar (TMVar t) = do m <- readTVar t case m of Nothing -> return True Just _ -> return False -- | Make a 'Weak' pointer to a 'TMVar', using the second argument as -- a finalizer to run when the 'TMVar' is garbage-collected. -- -- @since 2.4.4 mkWeakTMVar :: TMVar a -> IO () -> IO (Weak (TMVar a)) mkWeakTMVar tmv@(TMVar (TVar t#)) (IO finalizer) = IO $ \s -> case mkWeak# t# tmv finalizer s of (# s1, w #) -> (# s1, Weak w #) #endif hspec-core-2.10.10/version.yaml0000644000000000000000000000002107346545000014436 0ustar0000000000000000&version 2.10.10