hspec-core-2.6.1/0000755000000000000000000000000013412542117011736 5ustar0000000000000000hspec-core-2.6.1/LICENSE0000644000000000000000000000226113412542117012744 0ustar0000000000000000Copyright (c) 2011-2019 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.6.1/hspec-core.cabal0000644000000000000000000001063213412542117014754 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.31.0. -- -- see: https://github.com/sol/hpack -- -- hash: 7cca186c021b61bad5f4aa3748a723fbe2ec81a918644d575eaa8d7fbba6f3a0 name: hspec-core version: 2.6.1 license: MIT license-file: LICENSE copyright: (c) 2011-2019 Simon Hengel, (c) 2011-2012 Trystan Spangler, (c) 2011 Greg Weber maintainer: Simon Hengel build-type: Simple category: Testing stability: experimental bug-reports: https://github.com/hspec/hspec/issues homepage: http://hspec.github.io/ synopsis: A Testing Framework for Haskell description: This package exposes internal types and functions that can be used to extend Hspec's functionality. source-repository head type: git location: https://github.com/hspec/hspec subdir: hspec-core library hs-source-dirs: src vendor ghc-options: -Wall build-depends: HUnit ==1.6.* , QuickCheck ==2.12.* , ansi-terminal >=0.5 , array , base >=4.5.0.0 && <5 , call-stack , clock , deepseq , directory , filepath , hspec-expectations ==0.8.2.* , quickcheck-io >=0.2.0 , random , setenv , stm >=2.2 , tf-random , transformers >=0.2.2.0 exposed-modules: Test.Hspec.Core.Spec Test.Hspec.Core.Hooks Test.Hspec.Core.Runner Test.Hspec.Core.Formatters Test.Hspec.Core.QuickCheck Test.Hspec.Core.Util other-modules: Test.Hspec.Core.Clock Test.Hspec.Core.Compat Test.Hspec.Core.Config Test.Hspec.Core.Config.Options Test.Hspec.Core.Config.Util Test.Hspec.Core.Example Test.Hspec.Core.Example.Location Test.Hspec.Core.FailureReport Test.Hspec.Core.Format Test.Hspec.Core.Formatters.Diff Test.Hspec.Core.Formatters.Free Test.Hspec.Core.Formatters.Internal Test.Hspec.Core.Formatters.Monad Test.Hspec.Core.QuickCheckUtil Test.Hspec.Core.Runner.Eval 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 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: src vendor test ghc-options: -Wall cpp-options: -DTEST build-depends: HUnit ==1.6.* , QuickCheck ==2.12.* , ansi-terminal >=0.5 , array , base >=4.5.0.0 && <5 , call-stack , clock , deepseq , directory , filepath , hspec-expectations ==0.8.2.* , hspec-meta >=2.3.2 , process , quickcheck-io >=0.2.0 , random , setenv , silently >=1.2.4 , stm >=2.2 , temporary , tf-random , transformers >=0.2.2.0 build-tool-depends: hspec-meta:hspec-meta-discover other-modules: Test.Hspec.Core.Clock Test.Hspec.Core.Compat Test.Hspec.Core.Config Test.Hspec.Core.Config.Options Test.Hspec.Core.Config.Util 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.Free Test.Hspec.Core.Formatters.Internal Test.Hspec.Core.Formatters.Monad Test.Hspec.Core.Hooks Test.Hspec.Core.QuickCheck Test.Hspec.Core.QuickCheckUtil Test.Hspec.Core.Runner Test.Hspec.Core.Runner.Eval Test.Hspec.Core.Spec Test.Hspec.Core.Spec.Monad Test.Hspec.Core.Timer Test.Hspec.Core.Tree Test.Hspec.Core.Util Control.Concurrent.Async Data.Algorithm.Diff All Helper Mock Test.Hspec.Core.ClockSpec Test.Hspec.Core.CompatSpec Test.Hspec.Core.Config.OptionsSpec Test.Hspec.Core.Config.UtilSpec Test.Hspec.Core.ConfigSpec Test.Hspec.Core.Example.LocationSpec Test.Hspec.Core.ExampleSpec Test.Hspec.Core.FailureReportSpec Test.Hspec.Core.Formatters.DiffSpec Test.Hspec.Core.FormattersSpec Test.Hspec.Core.HooksSpec Test.Hspec.Core.QuickCheckUtilSpec Test.Hspec.Core.Runner.EvalSpec Test.Hspec.Core.RunnerSpec Test.Hspec.Core.SpecSpec Test.Hspec.Core.TimerSpec Test.Hspec.Core.UtilSpec Paths_hspec_core default-language: Haskell2010 hspec-core-2.6.1/Setup.lhs0000644000000000000000000000011413412542117013542 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain hspec-core-2.6.1/vendor/0000755000000000000000000000000013412542116013232 5ustar0000000000000000hspec-core-2.6.1/vendor/Data/0000755000000000000000000000000013412542116014103 5ustar0000000000000000hspec-core-2.6.1/vendor/Data/Algorithm/0000755000000000000000000000000013412542117016032 5ustar0000000000000000hspec-core-2.6.1/vendor/Data/Algorithm/Diff.hs0000644000000000000000000001101513412542117017234 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Algorithm.Diff -- Copyright : (c) Sterling Clover 2008-2011, Kevin Charter 2011 -- License : BSD 3 Clause -- Maintainer : s.clover@gmail.com -- Stability : experimental -- Portability : portable -- -- This is an implementation of the O(ND) diff algorithm as described in -- \"An O(ND) Difference Algorithm and Its Variations (1986)\" -- . It is O(mn) in space. -- The algorithm is the same one used by standared Unix diff. ----------------------------------------------------------------------------- module Data.Algorithm.Diff ( Diff(..) -- * Comparing lists for differences , getDiff , getDiffBy -- * Finding chunks of differences , getGroupedDiff , getGroupedDiffBy ) where import Prelude hiding (pi) import Data.Array data DI = F | S | B deriving (Show, Eq) -- | A value is either from the 'First' list, the 'Second' or from 'Both'. -- 'Both' contains both the left and right values, in case you are using a form -- of equality that doesn't check all data (for example, if you are using a -- newtype to only perform equality on side of a tuple). data Diff a = First a | Second a | Both a a deriving (Show, Eq, Functor) data DL = DL {poi :: !Int, poj :: !Int, path::[DI]} deriving (Show, Eq) instance Ord DL where x <= y = if poi x == poi y then poj x > poj y else poi x <= poi y canDiag :: (a -> a -> Bool) -> [a] -> [a] -> Int -> Int -> Int -> Int -> Bool canDiag eq as bs lena lenb = \ i j -> if i < lena && j < lenb then (arAs ! i) `eq` (arBs ! j) else False where arAs = listArray (0,lena - 1) as arBs = listArray (0,lenb - 1) bs dstep :: (Int -> Int -> Bool) -> [DL] -> [DL] dstep cd dls = hd:pairMaxes rst where (hd:rst) = nextDLs dls nextDLs [] = [] nextDLs (dl:rest) = dl':dl'':nextDLs rest where dl' = addsnake cd $ dl {poi=poi dl + 1, path=(F : pdl)} dl'' = addsnake cd $ dl {poj=poj dl + 1, path=(S : pdl)} pdl = path dl pairMaxes [] = [] pairMaxes [x] = [x] pairMaxes (x:y:rest) = max x y:pairMaxes rest addsnake :: (Int -> Int -> Bool) -> DL -> DL addsnake cd dl | cd pi pj = addsnake cd $ dl {poi = pi + 1, poj = pj + 1, path=(B : path dl)} | otherwise = dl where pi = poi dl; pj = poj dl lcs :: (a -> a -> Bool) -> [a] -> [a] -> [DI] lcs eq as bs = path . head . dropWhile (\dl -> poi dl /= lena || poj dl /= lenb) . concat . iterate (dstep cd) . (:[]) . addsnake cd $ DL {poi=0,poj=0,path=[]} where cd = canDiag eq as bs lena lenb lena = length as; lenb = length bs -- | Takes two lists and returns a list of differences between them. This is -- 'getDiffBy' with '==' used as predicate. getDiff :: (Eq t) => [t] -> [t] -> [Diff t] getDiff = getDiffBy (==) -- | Takes two lists and returns a list of differences between them, grouped -- into chunks. This is 'getGroupedDiffBy' with '==' used as predicate. getGroupedDiff :: (Eq t) => [t] -> [t] -> [Diff [t]] getGroupedDiff = getGroupedDiffBy (==) -- | A form of 'getDiff' with no 'Eq' constraint. Instead, an equality predicate -- is taken as the first argument. getDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff t] getDiffBy eq a b = markup a b . reverse $ lcs eq a b where markup (x:xs) ys (F:ds) = First x : markup xs ys ds markup xs (y:ys) (S:ds) = Second y : markup xs ys ds markup (x:xs) (y:ys) (B:ds) = Both x y : markup xs ys ds markup _ _ _ = [] getGroupedDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff [t]] getGroupedDiffBy eq a b = go $ getDiffBy eq a b where go (First x : xs) = let (fs, rest) = goFirsts xs in First (x:fs) : go rest go (Second x : xs) = let (fs, rest) = goSeconds xs in Second (x:fs) : go rest go (Both x y : xs) = let (fs, rest) = goBoth xs (fxs, fys) = unzip fs in Both (x:fxs) (y:fys) : go rest go [] = [] goFirsts (First x : xs) = let (fs, rest) = goFirsts xs in (x:fs, rest) goFirsts xs = ([],xs) goSeconds (Second x : xs) = let (fs, rest) = goSeconds xs in (x:fs, rest) goSeconds xs = ([],xs) goBoth (Both x y : xs) = let (fs, rest) = goBoth xs in ((x,y):fs, rest) goBoth xs = ([],xs) hspec-core-2.6.1/vendor/Control/0000755000000000000000000000000013412542116014652 5ustar0000000000000000hspec-core-2.6.1/vendor/Control/Concurrent/0000755000000000000000000000000013412542117016775 5ustar0000000000000000hspec-core-2.6.1/vendor/Control/Concurrent/Async.hs0000644000000000000000000007163113412542117020416 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes, ExistentialQuantification #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE DeriveDataTypeable #-} #endif {-# OPTIONS -Wall #-} ----------------------------------------------------------------------------- -- | -- 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 threads and @MVar@ directly. -- -- 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@ corresponds to a thread, and its 'ThreadId' -- can be obtained with 'asyncThreadId', although that should rarely -- be necessary. -- -- For example, to fetch two web pages at the same time, we could do -- this (assuming a suitable @getURL@ function): -- -- > do a1 <- async (getURL url1) -- > a2 <- async (getURL url2) -- > page1 <- wait a1 -- > page2 <- wait a2 -- > ... -- -- where 'async' 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 is one of the ways in which this library -- provides some additional safety: it is harder to accidentally -- forget about exceptions thrown in child threads. -- -- A slight improvement over the previous example is this: -- -- > withAsync (getURL url1) $ \a1 -> do -- > withAsync (getURL url2) $ \a2 -> do -- > page1 <- wait a1 -- > page2 <- wait a2 -- > ... -- -- 'withAsync' is like 'async', except that the 'Async' is -- automatically killed (using 'uninterruptibleCancel') if the -- enclosing IO operation returns before it has completed. Consider -- the case when the first 'wait' throws an exception; then the second -- 'Async' will be automatically killed rather than being left to run -- in the background, possibly indefinitely. This is the second way -- that the library provides additional safety: using 'withAsync' -- means we can avoid accidentally leaving threads running. -- Furthermore, 'withAsync' allows a tree of threads to be built, such -- that children are automatically killed if their parents die for any -- reason. -- -- The pattern of performing two IO actions concurrently and waiting -- for 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 'Functor' instance can be used to change the result of an -- 'Async'. For example: -- -- > ghci> a <- async (return 3) -- > ghci> wait a -- > 3 -- > ghci> wait (fmap (+1) a) -- > 4 ----------------------------------------------------------------------------- module Control.Concurrent.Async ( -- * Asynchronous actions Async, -- ** Spawning async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask, -- ** Spawning with automatic 'cancel'ation withAsync, withAsyncBound, withAsyncOn, withAsyncWithUnmask, withAsyncOnWithUnmask, -- ** Querying 'Async's wait, poll, waitCatch, asyncThreadId, cancel, uninterruptibleCancel, cancelWith, AsyncCancelled(..), -- ** 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, -- ** Linking link, link2, ExceptionInLinkedThread(..), -- * Convenient utilities race, race_, concurrently, concurrently_, mapConcurrently, forConcurrently, mapConcurrently_, forConcurrently_, replicateConcurrently, replicateConcurrently_, Concurrently(..), compareAsyncs, ) where import Control.Concurrent.STM 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 'Async's that may have different types compareAsyncs :: Async a -> Async b -> Ordering compareAsyncs (Async t1 _) (Async t2 _) = compare t1 t2 -- | Spawn an asynchronous action in a separate thread. 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 `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 = atomically . waitSTM -- | 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 = atomically (waitBothSTM left right) -- | 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 show (ExceptionInLinkedThread (Async t _) e) = "ExceptionInLinkedThread " ++ show t ++ " " ++ show 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. 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) 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) #define USE_ASYNC_VERSIONS 0 #if USE_ASYNC_VERSIONS race left right = withAsync left $ \a -> withAsync right $ \b -> waitEither a b race_ left right = withAsync left $ \a -> withAsync right $ \b -> waitEither_ a b concurrently left right = withAsync left $ \a -> withAsync right $ \b -> waitBoth a b #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 #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"] -- 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, -- just like @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, -- just like @forM_ forConcurrently_ :: F.Foldable f => f a -> (a -> IO b) -> IO () forConcurrently_ = flip mapConcurrently_ -- | 'concurrently', but ignore the result values -- -- @since 2.1.1 concurrently_ :: IO a -> IO b -> IO () 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 -- | 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 action = IO $ \ s -> case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #) {-# INLINE rawForkOn #-} rawForkOn :: Int -> IO () -> IO ThreadId rawForkOn (I# cpu) action = IO $ \ s -> case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #) hspec-core-2.6.1/test/0000755000000000000000000000000013412542117012715 5ustar0000000000000000hspec-core-2.6.1/test/All.hs0000644000000000000000000000013013412542117013753 0ustar0000000000000000{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-meta-discover -optF --module-name=All #-} hspec-core-2.6.1/test/Spec.hs0000644000000000000000000000037613412542117014151 0ustar0000000000000000module Main where import Test.Hspec.Meta import System.SetEnv import qualified All spec :: Spec spec = beforeAll_ (setEnv "IGNORE_DOT_HSPEC" "yes") $ afterAll_ (unsetEnv "IGNORE_DOT_HSPEC") All.spec main :: IO () main = hspec spec hspec-core-2.6.1/test/Helper.hs0000644000000000000000000001014413412542117014470 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 , sleep , timeout , defaultParams , noOpProgressCallback , captureLines , normalizeSummary , ignoreExitCode , ignoreUserInterrupt , throwException , withEnvironment , inTempDirectory , shouldUseArgs , removeLocations ) where import Prelude () import Test.Hspec.Core.Compat import Data.List import Data.Char import System.Environment (withArgs, getEnvironment) import System.Exit import qualified Control.Exception as E import Control.Exception import qualified System.Timeout as System import System.IO.Silently import System.SetEnv import System.Directory import System.IO.Temp import Test.Hspec.Meta hiding (hspec, hspecResult) import Test.QuickCheck hiding (Result(..)) import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import Test.Hspec.Core.QuickCheckUtil (mkGen) import Test.Hspec.Core.Clock import Test.Hspec.Core.Example(Result(..), ResultStatus(..), FailureReason(..)) #if !MIN_VERSION_base(4,7,0) deriving instance Eq ErrorCall #endif exceptionEq :: E.SomeException -> E.SomeException -> Bool exceptionEq a b | Just ea <- E.fromException a, Just eb <- E.fromException b = ea == (eb :: E.ErrorCall) | Just ea <- E.fromException a, Just eb <- E.fromException b = ea == (eb :: E.ArithException) | otherwise = undefined deriving instance Eq FailureReason deriving instance Eq ResultStatus deriving instance Eq Result instance Eq SomeException where (==) = exceptionEq throwException :: IO () throwException = E.throwIO (E.ErrorCall "foobar") ignoreExitCode :: IO () -> IO () ignoreExitCode action = action `E.catch` \e -> let _ = e :: ExitCode in return () ignoreUserInterrupt :: IO () -> IO () ignoreUserInterrupt action = E.catchJust (guard . (== E.UserInterrupt)) action return captureLines :: IO a -> IO [String] captureLines = fmap lines . capture_ -- replace times in summary with zeroes normalizeSummary :: [String] -> [String] normalizeSummary = map f where f x | "Finished in " `isPrefixOf` x = map g x | otherwise = x g x | isNumber x = '0' | otherwise = x defaultParams :: H.Params defaultParams = H.defaultParams {H.paramsQuickCheckArgs = stdArgs {replay = Just (mkGen 23, 0), maxSuccess = 1000}} noOpProgressCallback :: H.ProgressCallback noOpProgressCallback _ = return () timeout :: Seconds -> IO a -> IO (Maybe a) timeout = System.timeout . toMicroseconds shouldUseArgs :: HasCallStack => [String] -> (Args -> Bool) -> Expectation shouldUseArgs args p = do spy <- newIORef (H.paramsQuickCheckArgs defaultParams) let interceptArgs item = item {H.itemExample = \params action progressCallback -> writeIORef spy (H.paramsQuickCheckArgs params) >> H.itemExample item params action progressCallback} spec = H.mapSpecItem_ interceptArgs $ H.it "foo" False (silence . ignoreExitCode . withArgs args . H.hspec) spec readIORef spy >>= (`shouldSatisfy` p) removeLocations :: H.SpecWith a -> H.SpecWith a removeLocations = H.mapSpecItem_ (\item -> item{H.itemLocation = Nothing}) withEnvironment :: [(String, String)] -> IO a -> IO a withEnvironment environment action = bracket saveEnv restoreEnv $ const action where saveEnv :: IO [(String, String)] saveEnv = do env <- clearEnv forM_ environment $ uncurry setEnv return env restoreEnv :: [(String, String)] -> IO () restoreEnv env = do _ <- clearEnv forM_ env $ uncurry setEnv clearEnv :: IO [(String, String)] clearEnv = do env <- getEnvironment forM_ env (unsetEnv . fst) return env inTempDirectory :: IO a -> IO a inTempDirectory action = withSystemTempDirectory "mockery" $ \path -> do bracket getCurrentDirectory setCurrentDirectory $ \_ -> do setCurrentDirectory path action hspec-core-2.6.1/test/Mock.hs0000644000000000000000000000047413412542117014147 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.6.1/test/Test/0000755000000000000000000000000013412542117013634 5ustar0000000000000000hspec-core-2.6.1/test/Test/Hspec/0000755000000000000000000000000013412542117014676 5ustar0000000000000000hspec-core-2.6.1/test/Test/Hspec/Core/0000755000000000000000000000000013412542117015566 5ustar0000000000000000hspec-core-2.6.1/test/Test/Hspec/Core/CompatSpec.hs0000644000000000000000000000151113412542117020156 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Test.Hspec.Core.CompatSpec (spec) where 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.6.1/test/Test/Hspec/Core/QuickCheckUtilSpec.hs0000644000000000000000000001545513412542117021617 0ustar0000000000000000{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Test.Hspec.Core.QuickCheckUtilSpec (spec) where 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:" , "-39" ] 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 == 23) "is 23" True it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` QuickCheckResult 100 "+++ OK, passed 100 tests.\n\nOnly 0% is 23, but expected 10%" QuickCheckSuccess it "includes verbose output" $ do let info = intercalate "\n" [ "Passed:" , "0" , "" , "Passed:" , "-39" , "" , "+++ OK, passed 2 tests." , "" , "Only 0% is 23, 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 = [ " 1.0% is 23" , "" , "Only 1.0% 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 = "Falsifiable" result = QuickCheckResult 2 "" (QuickCheckFailure $ QCFailure 0 Nothing err ["1"]) it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` result it "includes verbose output" $ do let info = intercalate "\n" [ "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 /= 1 then QCP.succeeded else QCP.failed {QCP.reason = err} err = "foo\nbar" result = QuickCheckResult 2 "" (QuickCheckFailure $ QCFailure 0 Nothing err ["1"]) it "parses result" $ do parseQuickCheckResult <$> qc p `shouldReturn` result it "includes verbose output" $ do let info = intercalate "\n" [ "Passed:" , "0" , "" , "Failed:" , "1" , "" , "Passed:" , "0" ] 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.6.1/test/Test/Hspec/Core/ExampleSpec.hs0000644000000000000000000002203513412542117020332 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Test.Hspec.Core.ExampleSpec (spec) where import Helper import Mock import Control.Exception import Test.HUnit (assertFailure, assertEqual) import Test.Hspec.Core.Example (Result(..), ResultStatus(..) #if MIN_VERSION_base(4,8,1) , Location(..) #endif , FailureReason(..)) 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 spec :: Spec spec = do describe "safeEvaluateExample" $ do context "for Expectation" $ do it "returns Failure if an expectation does not hold" $ do Result "" (Failure _ msg) <- safeEvaluateExample (23 `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 = #if MIN_VERSION_base(4,8,1) Just $ Location __FILE__ (__LINE__ - 3) 42 #else Nothing #endif 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 = #if MIN_VERSION_base(4,8,1) Just $ Location __FILE__ (__LINE__ - 3) 42 #else Nothing #endif 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) return () 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") [ "Falsifiable (after 1 test):" , " 0" , " 1" ] it "runs around-action for each single check of the property" $ do ref <- newIORef (0 :: Int) let action :: IO () -> IO () action e = do n <- readIORef ref e readIORef ref `shouldReturn` succ n modifyIORef ref succ 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 `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 $ (`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 = #if MIN_VERSION_base(4,8,1) Just $ Location __FILE__ (__LINE__ + 4) 37 #else Nothing #endif evaluateExample (property H.pending) `shouldReturn` Result "" (Pending location Nothing) context "when used with `pendingWith`" $ do it "includes the optional reason" $ do let location = #if MIN_VERSION_base(4,8,1) Just $ Location __FILE__ (__LINE__ + 4) 39 #else Nothing #endif 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 silence . H.hspec $ do H.it "some behavior" $ property $ \xs -> do mockAction e (reverse . reverse) xs `shouldBe` (xs :: [Int]) mockCounter e `shouldReturn` 100 it "can be used with expectations/HUnit assertions" $ do silence . H.hspecResult $ do H.describe "readIO" $ do H.it "is inverse to show" $ property $ \x -> do (readIO . show) x `shouldReturn` (x :: Int) `shouldReturn` H.Summary 1 0 hspec-core-2.6.1/test/Test/Hspec/Core/FailureReportSpec.hs0000644000000000000000000000344213412542117021523 0ustar0000000000000000module Test.Hspec.Core.FailureReportSpec (spec) where import Helper import System.IO import qualified Control.Exception as E 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 (E.throw (E.ErrorCall "some error")) r `shouldBe` "WARNING: Could not write environment variable HSPEC_FAILURES (some error)\n" describe "readFailureReport" $ do context "when configFailureReport is specified" $ do let file = "report" config = defaultConfig {configFailureReport = Just file} report = FailureReport { failureReportSeed = 23 , failureReportMaxSuccess = 42 , failureReportMaxSize = 65 , failureReportMaxDiscardRatio = 123 , failureReportPaths = [(["foo", "bar"], "baz")] } it "reads a failure report from a file" $ do inTempDirectory $ do writeFailureReport config report readFailureReport config `shouldReturn` Just report context "when file does not exist" $ do it "returns Nothing" $ do inTempDirectory $ do readFailureReport config `shouldReturn` Nothing context "when file is malformed" $ do it "returns Nothing" $ do hSilence [stderr] $ inTempDirectory $ do writeFile file "foo" readFailureReport config `shouldReturn` Nothing it "prints a warning" $ do inTempDirectory $ do writeFile file "foo" hCapture_ [stderr] (readFailureReport config) `shouldReturn` "WARNING: Could not read failure report from file \"report\"!\n" hspec-core-2.6.1/test/Test/Hspec/Core/HooksSpec.hs0000644000000000000000000002613013412542117020022 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Test.Hspec.Core.HooksSpec (spec) where import Control.Exception import Helper import Prelude () import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Hooks as H runSilent :: H.Spec -> IO () runSilent = silence . H.hspec mkAppend :: IO (String -> IO (), IO [String]) mkAppend = do ref <- newIORef ([] :: [String]) let rec n = modifyIORef ref (++ [n]) return (rec, readIORef ref) spec :: Spec spec = do describe "before" $ do it "runs an action before every spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.before (rec "before" >> return "value") $ do H.it "foo" $ \value -> do rec (value ++ " foo") H.it "bar" $ \value -> do rec (value ++ " bar") retrieve `shouldReturn` ["before", "value foo", "before", "value bar"] context "when used with a QuickCheck property" $ do it "runs action before every check of the property" $ do (rec, retrieve) <- mkAppend runSilent $ H.before (rec "before" >> return "value") $ do H.it "foo" $ \value -> property $ \(_ :: Int) -> rec value retrieve `shouldReturn` (take 200 . cycle) ["before", "value"] describe "before_" $ do it "runs an action before every spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.before_ (rec "before") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` ["before", "foo", "before", "bar"] context "when used multiple times" $ do it "is evaluated outside in" $ do (rec, retrieve) <- mkAppend runSilent $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` ["outer", "inner", "foo"] context "when used with a QuickCheck property" $ do it "runs action before every check of the property" $ do (rec, retrieve) <- mkAppend runSilent $ H.before_ (rec "before") $ do H.it "foo" $ property $ \(_ :: Int) -> rec "foo" retrieve `shouldReturn` (take 200 . cycle) ["before", "foo"] context "when used multiple times" $ do it "is evaluated outside in" $ do (rec, retrieve) <- mkAppend runSilent $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do H.it "foo" $ property $ \(_ :: Int) -> rec "foo" retrieve `shouldReturn` (take 300 . cycle) ["outer", "inner", "foo"] describe "beforeWith" $ do it "transforms spec argument" $ do (rec, retrieve) <- mkAppend let action :: Int -> IO String action = return . show runSilent $ H.before (return 23) $ H.beforeWith action $ do H.it "foo" $ \value -> rec value retrieve `shouldReturn` ["23"] it "can be used multiple times" $ do let action1 :: Int -> IO Int action1 = return . succ action2 :: Int -> IO String action2 = return . show action3 :: String -> IO String action3 = return . ("foo " ++) (rec, retrieve) <- mkAppend runSilent $ H.before (return 23) $ H.beforeWith action1 $ H.beforeWith action2 $ H.beforeWith action3 $ do H.it "foo" $ \value -> rec value retrieve `shouldReturn` ["foo 24"] describe "beforeAll" $ do it "runs an action before the first spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.beforeAll (rec "beforeAll" >> return "value") $ do H.it "foo" $ \value -> do rec $ "foo " ++ value H.it "bar" $ \value -> do rec $ "bar " ++ value retrieve `shouldReturn` [ "beforeAll" , "foo value" , "bar value" ] context "when specified action throws an exception" $ do it "sets subsequent spec items to pending" $ do result <- silence . H.hspecResult $ H.beforeAll (throwIO (ErrorCall "foo")) $ do H.it "foo" $ \n -> do n `shouldBe` (23 :: Int) H.it "bar" $ \n -> do n `shouldBe` 23 result `shouldBe` H.Summary {H.summaryExamples = 2, H.summaryFailures = 1} context "when used with an empty list of examples" $ do it "does not run specified action" $ do (rec, retrieve) <- mkAppend runSilent $ H.beforeAll (rec "beforeAll" >> return "value") $ do return () retrieve `shouldReturn` [] describe "beforeAll_" $ do it "runs an action before the first spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.beforeAll_ (rec "beforeAll_") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` [ "beforeAll_" , "foo" , "bar" ] context "when used multiple times" $ do it "is evaluated outside in" $ do (rec, retrieve) <- mkAppend runSilent $ H.beforeAll_ (rec "outer") $ H.beforeAll_ (rec "inner") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` [ "outer" , "inner" , "foo" , "bar" ] describe "after" $ do it "runs an action after every spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.before (rec "before" >> return "from before") $ H.after rec $ do H.it "foo" $ \_ -> do rec "foo" H.it "bar" $ \_ -> do rec "bar" retrieve `shouldReturn` [ "before" , "foo" , "from before" , "before" , "bar" , "from before" ] it "guarantees that action is run" $ do (rec, retrieve) <- mkAppend silence . ignoreExitCode . H.hspec $ H.before (rec "before" >> return "from before") $ H.after rec $ do H.it "foo" $ \_ -> do ioError $ userError "foo" :: IO () rec "foo" retrieve `shouldReturn` ["before", "from before"] describe "after_" $ do it "runs an action after every spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.after_ (rec "after") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` [ "foo" , "after" , "bar" , "after" ] it "guarantees that action is run" $ do (rec, retrieve) <- mkAppend silence . ignoreExitCode $ H.hspec $ H.after_ (rec "after") $ do H.it "foo" $ do ioError $ userError "foo" :: IO () rec "foo" retrieve `shouldReturn` ["after"] context "when used multiple times" $ do it "is evaluated inside out" $ do (rec, retrieve) <- mkAppend runSilent $ H.after_ (rec "after outer") $ H.after_ (rec "after inner") $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` [ "foo" , "after inner" , "after outer" ] describe "afterAll" $ do it "runs an action after the last spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do H.it "foo" $ \_ -> do rec "foo" H.it "bar" $ \_ -> do rec "bar" retrieve `shouldReturn` [ "before" , "foo" , "before" , "bar" , "before" , "from before" ] context "when used with an empty list of examples" $ do it "does not run specified action" $ do (rec, retrieve) <- mkAppend runSilent $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do return () retrieve `shouldReturn` [] context "when action throws an exception" $ do it "reports a failure" $ do r <- runSpec $ H.before (return "from before") $ H.afterAll (\_ -> throwException) $ do H.it "foo" $ \a -> a `shouldBe` "from before" r `shouldSatisfy` any (== "afterAll-hook FAILED [1]") describe "afterAll_" $ do it "runs an action after the last spec item" $ do (rec, retrieve) <- mkAppend runSilent $ H.before_ (rec "before") $ H.afterAll_ (rec "afterAll_") $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` [ "before" , "foo" , "before" , "bar" , "before" , "afterAll_" ] context "when used multiple times" $ do it "is evaluated inside out" $ do (rec, retrieve) <- mkAppend runSilent $ H.afterAll_ (rec "after outer") $ H.afterAll_ (rec "after inner") $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` [ "foo" , "after inner" , "after outer" ] context "when used with an empty list of examples" $ do it "does not run specified action" $ do (rec, retrieve) <- mkAppend runSilent $ H.afterAll_ (rec "afterAll_") $ do return () retrieve `shouldReturn` [] context "when action throws an exception" $ do it "reports a failure" $ do r <- runSpec $ do H.afterAll_ throwException $ do H.it "foo" True r `shouldSatisfy` any (== "afterAll-hook FAILED [1]") describe "around" $ do it "wraps every spec item with an action" $ do (rec, retrieve) <- mkAppend let action e = rec "before" >> e "from around" >> rec "after" runSilent $ H.around action $ do H.it "foo" $ rec . ("foo " ++) H.it "bar" $ rec . ("bar " ++) retrieve `shouldReturn` [ "before" , "foo from around" , "after" , "before" , "bar from around" , "after" ] describe "around_" $ do it "wraps every spec item with an action" $ do (rec, retrieve) <- mkAppend let action e = rec "before" >> e >> rec "after" runSilent $ H.around_ action $ do H.it "foo" $ do rec "foo" H.it "bar" $ do rec "bar" retrieve `shouldReturn` [ "before" , "foo" , "after" , "before" , "bar" , "after" ] context "when used multiple times" $ do it "is evaluated outside in" $ do (rec, retrieve) <- mkAppend let actionOuter e = rec "before outer" >> e >> rec "after outer" actionInner e = rec "before inner" >> e >> rec "after inner" runSilent $ H.around_ actionOuter $ H.around_ actionInner $ do H.it "foo" $ do rec "foo" retrieve `shouldReturn` [ "before outer" , "before inner" , "foo" , "after inner" , "after outer" ] describe "aroundWith" $ do it "wraps every spec item with an action" $ do (rec, retrieve) <- mkAppend let action :: H.ActionWith String -> H.ActionWith Int action e = e . show runSilent $ H.before (return 23) $ H.aroundWith action $ do H.it "foo" rec retrieve `shouldReturn` ["23"] where runSpec :: H.Spec -> IO [String] runSpec = captureLines . H.hspecResult hspec-core-2.6.1/test/Test/Hspec/Core/ConfigSpec.hs0000644000000000000000000000176113412542117020147 0ustar0000000000000000module Test.Hspec.Core.ConfigSpec (spec) where import Helper import System.Directory import System.FilePath import Test.Hspec.Core.Config spec :: Spec spec = do describe "readConfigFiles" $ around_ (withEnvironment []) $ around_ inTempDirectory $ do it "reads .hspec" $ do dir <- getCurrentDirectory let name = dir ".hspec" writeFile name "--diff" readConfigFiles `shouldReturn` [(name, ["--diff"])] it "reads ~/.hspec" $ do let name = "my-home/.hspec" createDirectory "my-home" writeFile name "--diff" withEnvironment [("HOME", "my-home")] $ do readConfigFiles `shouldReturn` [(name, ["--diff"])] context "without $HOME" $ do it "returns empty list" $ do readConfigFiles `shouldReturn` [] context "without current directory" $ do it "returns empty list" $ do dir <- getCurrentDirectory removeDirectory dir readConfigFiles `shouldReturn` [] hspec-core-2.6.1/test/Test/Hspec/Core/FormattersSpec.hs0000644000000000000000000002502113412542117021063 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Test.Hspec.Core.FormattersSpec (spec) where import Prelude () import Helper import Data.String import Control.Monad.Trans.Writer import qualified Control.Exception as E import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Formatters as H import qualified Test.Hspec.Core.Formatters.Monad as H import Test.Hspec.Core.Formatters.Monad hiding (interpretWith) data ColorizedText = Plain String | 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 -> [ColorizedText] interpret = interpretWith environment interpretWith :: Environment (Writer [ColorizedText]) -> FormatM a -> [ColorizedText] interpretWith env = simplify . execWriter . H.interpretWith env environment :: Environment (Writer [ColorizedText]) environment = Environment { environmentGetSuccessCount = return 0 , environmentGetPendingCount = return 0 , environmentGetFailMessages = return [] , environmentUsedSeed = return 0 , environmentGetCPUTime = return Nothing , environmentGetRealTime = return 0 , environmentWrite = tell . return . Plain , environmentWriteTransient = tell . return . Transient , environmentWithFailColor = \action -> let (a, r) = runWriter action in tell (colorize Failed r) >> return a , environmentWithSuccessColor = \action -> let (a, r) = runWriter action in tell (colorize Succeeded r) >> return a , environmentWithPendingColor = \action -> let (a, r) = runWriter action in tell (colorize Pending r) >> return a , environmentWithInfoColor = \action -> let (a, r) = runWriter action in tell (colorize Info r) >> return a , environmentUseDiff = return True , environmentExtraChunk = tell . return . Extra , environmentMissingChunk = tell . return . Missing , environmentLiftIO = undefined } 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) `shouldBe` [ Succeeded "." ] describe "exampleFailed" $ do it "marks failing examples with F" $ do interpret (H.exampleFailed formatter undefined undefined undefined) `shouldBe` [ Failed "F" ] describe "examplePending" $ do it "marks pending examples with ." $ do interpret (H.examplePending formatter undefined undefined undefined) `shouldBe` [ Pending "." ] describe "specdoc" $ do let formatter = H.specdoc runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter} it "displays a header for each thing being described" $ do _:x:_ <- runSpec testSpec x `shouldBe` "Example" it "displays one row for each behavior" $ do r <- runSpec $ do H.describe "List as a Monoid" $ do H.describe "mappend" $ do H.it "is associative" True H.describe "mempty" $ do H.it "is a left identity" True H.it "is a right identity" True H.describe "Maybe as a Monoid" $ do H.describe "mappend" $ do H.it "is associative" True H.describe "mempty" $ do H.it "is a left identity" True H.it "is a right identity" True normalizeSummary r `shouldBe` [ "" , "List as a Monoid" , " mappend" , " is associative" , " mempty" , " is a left identity" , " is a right identity" , "Maybe as a Monoid" , " mappend" , " is associative" , " mempty" , " is a left identity" , " is a right identity" , "" , "Finished in 0.0000 seconds" , "6 examples, 0 failures" ] it "outputs an empty line at the beginning (even for non-nested specs)" $ do r <- runSpec $ do H.it "example 1" True H.it "example 2" True normalizeSummary r `shouldBe` [ "" , "example 1" , "example 2" , "" , "Finished in 0.0000 seconds" , "2 examples, 0 failures" ] it "displays a row for each successfull, failed, or pending example" $ do r <- runSpec testSpec r `shouldSatisfy` any (== " fail 1 FAILED [1]") r `shouldSatisfy` any (== " success") it "displays a '#' with an additional message for pending examples" $ do r <- runSpec testSpec r `shouldSatisfy` any (== " # PENDING: pending message") context "with an empty group" $ do it "omits that group from the report" $ do r <- runSpec $ do H.describe "foo" $ do H.it "example 1" True H.describe "bar" $ do return () H.describe "baz" $ do H.it "example 2" True normalizeSummary r `shouldBe` [ "" , "foo" , " example 1" , "baz" , " example 2" , "" , "Finished in 0.0000 seconds" , "2 examples, 0 failures" ] describe "failedFormatter" $ do let action = H.failedFormatter formatter context "when actual/expected contain newlines" $ do let env = environment { environmentGetFailMessages = return [FailureRecord Nothing ([], "") (ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")] } it "adds indentation" $ do removeColors (interpretWith env action) `shouldBe` unlines [ "" , "Failures:" , "" , " 1) " , " expected: first" , " second" , " third" , " but got: first" , " two" , " third" , "" , " To rerun use: --match \"//\"" , "" #if __GLASGOW_HASKELL__ == 800 , "WARNING:" , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285." , " Source locations may not work as expected." , "" , " Please consider upgrading GHC!" , "" #endif , "Randomized with seed 0" , "" ] describe "footerFormatter" $ do let action = H.footerFormatter formatter context "without failures" $ do let env = environment {environmentGetSuccessCount = return 1} it "shows summary in green if there are no failures" $ do interpretWith env action `shouldBe` [ "Finished in 0.0000 seconds\n" , Succeeded "1 example, 0 failures\n" ] context "with pending examples" $ do let env = environment {environmentGetPendingCount = return 1} it "shows summary in yellow if there are pending examples" $ do interpretWith env action `shouldBe` [ "Finished in 0.0000 seconds\n" , Pending "1 example, 0 failures, 1 pending\n" ] context "with failures" $ do let env = environment {environmentGetFailMessages = return [undefined]} it "shows summary in red" $ do interpretWith env action `shouldBe` [ "Finished in 0.0000 seconds\n" , Failed "1 example, 1 failure\n" ] context "with both failures and pending examples" $ do let env = environment {environmentGetFailMessages = return [undefined], environmentGetPendingCount = return 1} it "shows summary in red" $ do interpretWith env action `shouldBe` [ "Finished in 0.0000 seconds\n" , Failed "2 examples, 1 failure, 1 pending\n" ] context "same as failed_examples" $ do failed_examplesSpec formatter failed_examplesSpec :: H.Formatter -> Spec failed_examplesSpec formatter = do let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter} context "displays a detailed list of failures" $ do it "prints all requirements that are not met" $ do r <- runSpec testSpec r `shouldSatisfy` any (== " 1) Example fail 1") it "prints the exception type for requirements that fail due to an uncaught exception" $ do r <- runSpec $ do H.it "foobar" (E.throw (E.ErrorCall "baz") :: Bool) r `shouldContain` [ " 1) foobar" , " uncaught exception: ErrorCall" , " baz" ] it "prints all descriptions when a nested requirement fails" $ do r <- runSpec $ H.describe "foo" $ do H.describe "bar" $ do H.it "baz" False r `shouldSatisfy` any (== " 1) foo.bar baz") context "when a failed example has a source location" $ do 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.6.1/test/Test/Hspec/Core/SpecSpec.hs0000644000000000000000000001074413412542117017635 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(..), runSpecM) import qualified Test.Hspec.Core.Spec as H ignoreCleanup :: Tree c a -> Tree () a ignoreCleanup = H.bimapTree (const ()) id runSpec :: H.Spec -> IO [String] runSpec = captureLines . H.hspecResult spec :: Spec spec = do describe "describe" $ do it "can be nested" $ do [Node foo [Node bar [Leaf _]]] <- runSpecM $ do H.describe "foo" $ do H.describe "bar" $ do H.it "baz" True (foo, bar) `shouldBe` ("foo", "bar") context "when no description is given" $ do it "uses a default description" $ do [Node d _] <- runSpecM (H.describe "" (pure ())) #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) r <- itemExample item defaultParams ($ ()) noOpProgressCallback r `shouldBe` 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) r <- itemExample item defaultParams ($ ()) noOpProgressCallback r `shouldBe` Result "" Success it "adds source locations" $ do [Leaf item] <- runSpecM (H.it "foo" True) let location = #if MIN_VERSION_base(4,8,1) Just $ H.Location __FILE__ (__LINE__ - 3) 32 #else Nothing #endif itemLocation item `shouldBe` location context "when no description is given" $ do it "uses a default description" $ do [Leaf item] <- runSpecM (H.it "" True) #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) r <- itemExample item defaultParams ($ ()) noOpProgressCallback r `shouldBe` 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 <- runSpecM $ H.focus $ do H.it "is focused and will run" True H.it "is also focused and will also run" True map (ignoreCleanup . fmap itemIsFocused) items `shouldBe` [Leaf True, Leaf True] context "when applied to a spec with focused spec items" $ do it "has no effect" $ do items <- runSpecM $ H.focus $ do H.focus $ H.it "is focused and will run" True H.it "is not focused and will not run" True map (ignoreCleanup . fmap itemIsFocused) items `shouldBe` [Leaf True, Leaf False] describe "parallel" $ do it "marks examples for parallel execution" $ do [Leaf item] <- runSpecM . H.parallel $ H.it "whatever" H.pending itemIsParallelizable item `shouldBe` Just True it "is applied recursively" $ do [Node _ [Node _ [Leaf item]]] <- runSpecM . H.parallel $ do H.describe "foo" $ do H.describe "bar" $ do H.it "baz" H.pending itemIsParallelizable item `shouldBe` Just True describe "sequential" $ do it "marks examples for sequential execution" $ do [Leaf item] <- runSpecM . H.sequential $ H.it "whatever" H.pending itemIsParallelizable item `shouldBe` Just False it "takes precedence over a later `parallel`" $ do [Leaf item] <- runSpecM . H.parallel . H.sequential $ H.it "whatever" H.pending itemIsParallelizable item `shouldBe` Just False hspec-core-2.6.1/test/Test/Hspec/Core/RunnerSpec.hs0000644000000000000000000005026213412542117020213 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 (stderr) import System.Environment (withArgs, withProgName, getArgs) import System.Exit import Control.Concurrent import qualified Control.Exception as E import Control.Concurrent.Async import Mock import System.SetEnv import System.Console.ANSI import Test.Hspec.Core.FailureReport (FailureReport(..)) import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Formatters as H (silent) import qualified Test.Hspec.Core.QuickCheck as H import qualified Test.QuickCheck as QC import qualified Test.Hspec.Core.Hooks as H quickCheckOptions :: [([Char], Args -> Int)] quickCheckOptions = [("--qc-max-success", QC.maxSuccess), ("--qc-max-size", QC.maxSize), ("--qc-max-discard", QC.maxDiscardRatio)] runPropFoo :: [String] -> IO String runPropFoo args = unlines . normalizeSummary . lines <$> do capture_ . ignoreExitCode . withArgs args . H.hspec . H.modifyMaxSuccess (const 1000000) $ do H.it "foo" $ do property (/= (23 :: Int)) spec :: Spec spec = do describe "hspec" $ do let hspec args = withArgs ("--format=silent" : args) . H.hspec hspec_ = hspec [] it "evaluates examples Unmasked" $ do mvar <- newEmptyMVar hspec_ $ do H.it "foo" $ do E.getMaskingState >>= putMVar mvar takeMVar mvar `shouldReturn` E.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) `E.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") ] } describe "with --rerun" $ do let runSpec = (captureLines . ignoreExitCode . H.hspec) $ do H.it "example 1" True H.it "example 2" False H.it "example 3" False H.it "example 4" True H.it "example 5" False it "reruns examples that previously failed" $ do r0 <- runSpec r0 `shouldSatisfy` elem "5 examples, 3 failures" r1 <- withArgs ["--rerun"] runSpec r1 `shouldSatisfy` elem "3 examples, 3 failures" it "reuses the same seed" $ do r <- runPropFoo ["--seed", "42"] runPropFoo ["--rerun"] `shouldReturn` r forM_ quickCheckOptions $ \(name, accessor) -> do it ("reuses same " ++ name) $ do [name, "23"] `shouldUseArgs` ((== 23) . accessor) ["--rerun"] `shouldUseArgs` ((== 23) . accessor) context "when no examples failed previously" $ do it "runs all examples" $ do let run = capture_ . H.hspec $ do H.it "example 1" True H.it "example 2" True H.it "example 3" True r0 <- run r0 `shouldContain` "3 examples, 0 failures" r1 <- withArgs ["--rerun"] run r1 `shouldContain` "3 examples, 0 failures" context "when there is no failure report in the environment" $ do it "runs everything" $ do unsetEnv "HSPEC_FAILURES" r <- hSilence [stderr] $ withArgs ["--rerun"] runSpec r `shouldSatisfy` elem "5 examples, 3 failures" it "prints a warning to stderr" $ do unsetEnv "HSPEC_FAILURES" r <- hCapture_ [stderr] $ withArgs ["--rerun"] runSpec r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n" context "when parsing of failure report fails" $ do it "runs everything" $ do setEnv "HSPEC_FAILURES" "some invalid report" r <- hSilence [stderr] $ withArgs ["--rerun"] runSpec r `shouldSatisfy` elem "5 examples, 3 failures" it "prints a warning to stderr" $ do setEnv "HSPEC_FAILURES" "some invalid report" r <- hCapture_ [stderr] $ withArgs ["--rerun"] runSpec r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n" it "does not leak command-line options to examples" $ do 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 E.UserInterrupt r <- takeMVar mvar normalizeSummary r `shouldBe` [ "" , "foo FAILED [1]" , "" , "Failures:" , "" , " 1) foo" , "" , " To rerun use: --match \"/foo/\"" , "" #if __GLASGOW_HASKELL__ == 800 , "WARNING:" , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285." , " Source locations may not work as expected." , "" , " Please consider upgrading GHC!" , "" #endif , "Randomized with seed 23" , "" ] it "throws UserInterrupt" $ do mvar <- newEmptyMVar sync <- newEmptyMVar threadId <- forkIO $ do hspec_ $ do H.it "foo" $ do putMVar sync () threadDelay 1000000 `E.catch` putMVar mvar takeMVar sync throwTo threadId E.UserInterrupt takeMVar mvar `shouldReturn` E.UserInterrupt context "with --dry-run" $ do let withDryRun = captureLines . withArgs ["--dry-run"] . H.hspec it "produces a report" $ do r <- withDryRun $ do H.it "foo" True H.it "bar" True normalizeSummary r `shouldBe` [ "" , "foo" , "bar" , "" , "Finished in 0.0000 seconds" , "2 examples, 0 failures" ] it "does not verify anything" $ do e <- newMock _ <- withDryRun $ do H.it "foo" (mockAction e) H.it "bar" False mockCounter e `shouldReturn` 0 it "ignores afterAll-hooks" $ do ref <- newIORef False _ <- withDryRun $ do H.afterAll_ (writeIORef ref True) $ do H.it "bar" True readIORef ref `shouldReturn` False context "with --fail-fast" $ do it "stops after first failure" $ do r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do H.it "foo" True H.it "bar" False H.it "baz" False normalizeSummary r `shouldBe` [ "" , "foo" , "bar FAILED [1]" , "" , "Failures:" , "" , " 1) bar" , "" , " To rerun use: --match \"/bar/\"" , "" #if __GLASGOW_HASKELL__ == 800 , "WARNING:" , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285." , " Source locations may not work as expected." , "" , " Please consider upgrading GHC!" , "" #endif , "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") `E.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 FAILED [1]" , "" , "Failures:" , "" , " 1) foo bar" , "" , " To rerun use: --match \"/foo/bar/\"" , "" #if __GLASGOW_HASKELL__ == 800 , "WARNING:" , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285." , " Source locations may not work as expected." , "" , " Please consider upgrading GHC!" , "" #endif , "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) context "with --diff" $ do it "shows colorized diffs" $ do r <- capture_ . ignoreExitCode . withArgs ["--diff", "--color"] . H.hspec $ do H.it "foo" $ do 23 `shouldBe` (42 :: Int) r `shouldContain` unlines [ red ++ " expected: " ++ reset ++ red ++ "42" ++ reset , red ++ " but got: " ++ reset ++ green ++ "23" ++ reset ] 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 `shouldBe` (42 :: Int) r `shouldContain` unlines [ red ++ " expected: " ++ reset ++ "42" , red ++ " but got: " ++ reset ++ "23" ] 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` ((== 23) . QC.maxSuccess) ["--rerun", "--qc-max-success", "42"] `shouldUseArgs` ((== 42) . QC.maxSuccess) context "with --qc-max-size" $ do it "passes specified size to QuickCheck properties" $ do ["--qc-max-size", "23"] `shouldUseArgs` ((== 23) . QC.maxSize) context "with --qc-max-discard" $ do it "uses specified discard ratio to QuickCheck properties" $ do ["--qc-max-discard", "23"] `shouldUseArgs` ((== 23) . QC.maxDiscardRatio) context "with --seed" $ do it "uses specified seed" $ do r <- runPropFoo ["--seed", "42"] runPropFoo ["--seed", "42"] `shouldReturn` r context "when run with --rerun" $ do it "takes precedence" $ do r <- runPropFoo ["--seed", "23"] _ <- runPropFoo ["--seed", "42"] runPropFoo ["--rerun", "--seed", "23"] `shouldReturn` r context "when given an invalid argument" $ do let run = withArgs ["--seed", "foo"] . H.hspec $ do H.it "foo" True it "prints an error message to stderr" $ do r <- hCapture_ [stderr] (ignoreExitCode run) r `shouldContain` "invalid argument `foo' for `--seed'" it "exits with exitFailure" $ do hSilence [stderr] run `shouldThrow` (== ExitFailure 1) context "with --print-cpu-time" $ do it "includes used CPU time in summary" $ do r <- capture_ $ withArgs ["--print-cpu-time"] (H.hspec $ pure ()) (normalizeSummary . lines) r `shouldContain` ["Finished in 0.0000 seconds, used 0.0000 seconds of CPU time"] context "with --html" $ do it "produces HTML output" $ do r <- capture_ . withArgs ["--html"] . H.hspec $ do H.it "foo" True r `shouldContain` "" it "marks successful examples with CSS class hspec-success" $ do r <- capture_ . withArgs ["--html"] . H.hspec $ do H.it "foo" True r `shouldContain` "foo\n" it "marks pending examples with CSS class hspec-pending" $ do r <- capture_ . withArgs ["--html"] . H.hspec $ do H.it "foo" H.pending r `shouldContain` "foo" it "marks failed examples with CSS class hspec-failure" $ do r <- capture_ . ignoreExitCode . withArgs ["--html"] . H.hspec $ do H.it "foo" False r `shouldContain` "foo" describe "hspecResult" $ do let hspecResult args = withArgs ("--format=silent" : args) . H.hspecResult hspecResult_ = hspecResult [] 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 "uses the specdoc formatter by default" $ do _:r:_ <- captureLines . H.hspecResult $ do H.describe "Foo.Bar" $ do H.it "some example" True r `shouldBe` "Foo.Bar" it "can use a custom formatter" $ do r <- capture_ . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.silent} $ do H.describe "Foo.Bar" $ do H.it "some example" True r `shouldBe` "" it "does not let escape error thunks from failure messages" $ do r <- 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" $ E.bracket_ start stop $ sleep t r `shouldBe` H.Summary n 0 high <- readIORef highRef high `shouldBe` j describe "rerunAll" $ do let report = FailureReport 0 0 0 0 [([], "foo")] config = H.defaultConfig {H.configRerun = True, H.configRerunAllOnSuccess = True} summary = H.Summary 1 0 context "with --rerun, --rerun-all-on-success, previous failures, on success" $ do it "returns True" $ do H.rerunAll config (Just report) summary `shouldBe` True context "without --rerun" $ do it "returns False" $ do H.rerunAll config {H.configRerun = False} (Just report) summary `shouldBe` False context "without --rerun-all-on-success" $ do it "returns False" $ do H.rerunAll config {H.configRerunAllOnSuccess = False} (Just report) summary `shouldBe` False context "without previous failures" $ do it "returns False" $ do H.rerunAll config (Just report {failureReportPaths = []}) summary `shouldBe` False context "without failure report" $ do it "returns False" $ do H.rerunAll config Nothing summary `shouldBe` False context "on failure" $ do it "returns False" $ do H.rerunAll config (Just report) summary {H.summaryFailures = 1} `shouldBe` False where green = setSGRCode [SetColor Foreground Dull Green] red = setSGRCode [SetColor Foreground Dull Red] reset = setSGRCode [Reset] hspec-core-2.6.1/test/Test/Hspec/Core/TimerSpec.hs0000644000000000000000000000135313412542117020017 0ustar0000000000000000module Test.Hspec.Core.TimerSpec (spec) where import Helper -- import Test.Hspec.Core.Timer spec :: Spec spec = do describe "timer action provided by withTimer" $ do return () -- 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.6.1/test/Test/Hspec/Core/UtilSpec.hs0000644000000000000000000001040213412542117017647 0ustar0000000000000000module Test.Hspec.Core.UtilSpec (spec) where import Helper import Control.Concurrent import qualified Control.Exception as E 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 (E.toException E.DivideByZero) `shouldBe` "ArithException\ndivide by zero" context "when used with an IOException" $ do it "includes the IOErrorType" $ do inTempDirectory $ do Left e <- 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" ] describe "safeTry" $ do it "returns Right on success" $ do Right e <- safeTry (return 23 :: IO Int) e `shouldBe` 23 it "returns Left on exception" $ do Left e <- safeTry throwException show e `shouldBe` "foobar" it "evaluates result to weak head normal form" $ do Left e <- safeTry (return $ E.throw $ E.ErrorCall "foo") show e `shouldBe` "foo" it "does not catch asynchronous exceptions" $ do mvar <- newEmptyMVar sync <- newEmptyMVar threadId <- forkIO $ do safeTry (putMVar sync () >> threadDelay 1000000) >> return () `E.catch` putMVar mvar takeMVar sync throwTo threadId E.UserInterrupt readMVar mvar `shouldReturn` E.UserInterrupt describe "filterPredicate" $ do it "tries to match a pattern against a path" $ do let p = filterPredicate "foo/bar/example 1" p (["foo", "bar"], "example 1") `shouldBe` True p (["foo", "bar"], "example 2") `shouldBe` False it "is ambiguous" $ do let p = filterPredicate "foo/bar/baz" p (["foo", "bar"], "baz") `shouldBe` True p (["foo"], "bar/baz") `shouldBe` True it "succeeds on a partial match" $ do let p = filterPredicate "bar/baz" p (["foo", "bar", "baz"], "example 1") `shouldBe` True it "succeeds with a pattern that matches the message 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 consits of multiple words" $ do formatRequirement (["The reverse function"], "reverses a list") `shouldBe` "The reverse function reverses a list" it "returns the requirement if no subject is given" $ do formatRequirement ([], "reverses a list") `shouldBe` "reverses a list" it "inserts context separated by commas" $ do formatRequirement (["reverse", "when applied twice"], "reverses a list") `shouldBe` "reverse, when applied twice, reverses a list" it "joins components of a subject with a dot" $ do formatRequirement (["Data", "List", "reverse"], "reverses a list") `shouldBe` "Data.List.reverse reverses a list" it "properly handles context after a subject that consists of several components" $ do formatRequirement (["Data", "List", "reverse", "when applied twice"], "reverses a list") `shouldBe` "Data.List.reverse, when applied twice, reverses a list" hspec-core-2.6.1/test/Test/Hspec/Core/ClockSpec.hs0000644000000000000000000000040313412542117017765 0ustar0000000000000000module Test.Hspec.Core.ClockSpec (spec) where import Helper import Test.Hspec.Core.Clock spec :: Spec spec = do describe "toMicroseconds" $ do it "converts Seconds to microseconds" $ do toMicroseconds 2.5 `shouldBe` 2500000 hspec-core-2.6.1/test/Test/Hspec/Core/Formatters/0000755000000000000000000000000013412542117017714 5ustar0000000000000000hspec-core-2.6.1/test/Test/Hspec/Core/Formatters/DiffSpec.hs0000644000000000000000000000350413412542117021735 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Test.Hspec.Core.Formatters.DiffSpec (spec) where import Prelude () import Test.Hspec.Core.Compat import Helper import Data.Char import Test.Hspec.Core.Formatters.Diff dropQuotes :: String -> String dropQuotes = init . tail spec :: Spec spec = do 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.6.1/test/Test/Hspec/Core/Runner/0000755000000000000000000000000013412542117017037 5ustar0000000000000000hspec-core-2.6.1/test/Test/Hspec/Core/Runner/EvalSpec.hs0000644000000000000000000000175113412542117021101 0ustar0000000000000000module Test.Hspec.Core.Runner.EvalSpec (spec) where import Prelude () import Helper import Test.Hspec.Core.Tree import Test.Hspec.Core.Runner.Eval spec :: Spec spec = do describe "traverse" $ do context "when used with Tree" $ do let tree :: Tree () Int tree = Node "" [Node "" [Leaf 1, Node "" [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] describe "runSequentially" $ do it "runs actions sequentially" $ do ref <- newIORef [] (_, actionA) <- runSequentially $ \ _ -> modifyIORef ref (23 :) (_, actionB) <- runSequentially $ \ _ -> modifyIORef ref (42 :) (_, ()) <- actionB (\_ -> return ()) readIORef ref `shouldReturn` [42 :: Int] (_, ()) <- actionA (\_ -> return ()) readIORef ref `shouldReturn` [23, 42] hspec-core-2.6.1/test/Test/Hspec/Core/Example/0000755000000000000000000000000013412542117017161 5ustar0000000000000000hspec-core-2.6.1/test/Test/Hspec/Core/Example/LocationSpec.hs0000644000000000000000000000635213412542117022106 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Test.Hspec.Core.Example.LocationSpec (spec) where import Helper import Control.Exception import Test.Hspec.Core.Example import Test.Hspec.Core.Example.Location data Person = Person { name :: String , age :: Int } deriving (Eq, Show) spec :: Spec spec = do 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) return () 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 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) hspec-core-2.6.1/test/Test/Hspec/Core/Config/0000755000000000000000000000000013412542117016773 5ustar0000000000000000hspec-core-2.6.1/test/Test/Hspec/Core/Config/UtilSpec.hs0000644000000000000000000000213013412542117021053 0ustar0000000000000000module Test.Hspec.Core.Config.UtilSpec (spec) where import Helper import System.Console.GetOpt import Test.Hspec.Core.Config.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" ] describe "formatOrList" $ do it "formats a list of or-options" $ do formatOrList ["foo", "bar", "baz"] `shouldBe` "foo, bar or baz" hspec-core-2.6.1/test/Test/Hspec/Core/Config/OptionsSpec.hs0000644000000000000000000001314313412542117021577 0ustar0000000000000000module Test.Hspec.Core.Config.OptionsSpec (spec) where import Prelude () import Helper import System.Exit import qualified Test.Hspec.Core.Config.Options as Options import Test.Hspec.Core.Config.Options hiding (parseOptions) fromLeft :: Either a b -> a fromLeft (Left a) = a fromLeft _ = error "fromLeft: No left value!" spec :: Spec spec = do describe "parseOptions" $ do let parseOptions = Options.parseOptions defaultConfig "my-spec" it "rejects unexpected arguments" $ do fromLeft (parseOptions [] Nothing ["foo"]) `shouldBe` (ExitFailure 1, "my-spec: unexpected argument `foo'\nTry `my-spec --help' for more information.\n") it "rejects unrecognized options" $ do fromLeft (parseOptions [] Nothing ["--foo"]) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--foo'\nTry `my-spec --help' for more information.\n") it "sets configColorMode to ColorAuto" $ do configColorMode <$> parseOptions [] Nothing [] `shouldBe` Right ColorAuto context "with --help" $ do let Left (code, output) = parseOptions [] Nothing ["--help"] help = lines output it "returns ExitSuccess" $ do code `shouldBe` ExitSuccess it "prints help" $ do help `shouldStartWith` ["Usage: my-spec [OPTION]..."] context "with --no-color" $ do it "sets configColorMode to ColorNever" $ do configColorMode <$> parseOptions [] Nothing ["--no-color"] `shouldBe` Right ColorNever context "with --color" $ do it "sets configColorMode to ColorAlways" $ do configColorMode <$> parseOptions [] Nothing ["--color"] `shouldBe` Right ColorAlways context "with --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 --out" $ do it "sets configOutputFile" $ do either (const Nothing) Just . configOutputFile <$> parseOptions [] Nothing ["--out", "foo"] `shouldBe` Right (Just "foo") context "with --qc-max-success" $ do context "when given an invalid argument" $ do it "returns an error message" $ do fromLeft (parseOptions [] Nothing ["--qc-max-success", "foo"]) `shouldBe` (ExitFailure 1, "my-spec: invalid argument `foo' for `--qc-max-success'\nTry `my-spec --help' for more information.\n") context "with --depth" $ do it "sets depth parameter for SmallCheck" $ do configSmallCheckDepth <$> parseOptions [] Nothing ["--depth", "23"] `shouldBe` Right 23 context "with --jobs" $ do it "sets number of concurrent jobs" $ do configConcurrentJobs <$> parseOptions [] Nothing ["--jobs=23"] `shouldBe` Right (Just 23) it "rejects values < 1" $ do let msg = "my-spec: invalid argument `0' for `--jobs'\nTry `my-spec --help' for more information.\n" void (parseOptions [] Nothing ["--jobs=0"]) `shouldBe` Left (ExitFailure 1, msg) context "when given a config file" $ do it "uses options from config file" $ do configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing [] `shouldBe` Right ColorNever it "gives command-line options precedence" $ do configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing ["--color"] `shouldBe` Right ColorAlways it "rejects --help" $ do fromLeft (parseOptions [("~/.hspec", ["--help"])] Nothing []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--help' in config file ~/.hspec\n") it "rejects unrecognized options" $ do fromLeft (parseOptions [("~/.hspec", ["--invalid"])] Nothing []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' in config file ~/.hspec\n") it "rejects ambiguous options" $ do fromLeft (parseOptions [("~/.hspec", ["--fail"])] Nothing []) `shouldBe` (ExitFailure 1, unlines [ "my-spec: option `--fail' is ambiguous; could be one of:" , " --fail-fast abort on first failure" , " --failure-report=FILE read/write a failure report for use with --rerun" , "in config file ~/.hspec" ] ) context "when given multiple config files" $ do it "gives later config files precedence" $ do configColorMode <$> parseOptions [("~/.hspec", ["--no-color"]), (".hspec", ["--color"])] Nothing [] `shouldBe` Right ColorAlways context "when given an environment variable" $ do it "uses options from environment variable" $ do configColorMode <$> parseOptions [] (Just ["--no-color"]) [] `shouldBe` Right ColorNever it "gives command-line options precedence" $ do configColorMode <$> parseOptions [] (Just ["--no-color"]) ["--color"] `shouldBe` Right ColorAlways it "rejects unrecognized options" $ do fromLeft (parseOptions [] (Just ["--invalid"]) []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' from environment variable HSPEC_OPTIONS\n") describe "ignoreConfigFile" $ around_ (withEnvironment []) $ do context "by default" $ do it "returns False" $ do ignoreConfigFile defaultConfig [] `shouldReturn` False context "with --ignore-dot-hspec" $ do it "returns True" $ do ignoreConfigFile defaultConfig ["--ignore-dot-hspec"] `shouldReturn` True context "with IGNORE_DOT_HSPEC" $ do it "returns True" $ do withEnvironment [("IGNORE_DOT_HSPEC", "yes")] $ do ignoreConfigFile defaultConfig [] `shouldReturn` True hspec-core-2.6.1/src/0000755000000000000000000000000013412542116012524 5ustar0000000000000000hspec-core-2.6.1/src/Test/0000755000000000000000000000000013412542116013443 5ustar0000000000000000hspec-core-2.6.1/src/Test/Hspec/0000755000000000000000000000000013412542116014505 5ustar0000000000000000hspec-core-2.6.1/src/Test/Hspec/Core/0000755000000000000000000000000013412542117015376 5ustar0000000000000000hspec-core-2.6.1/src/Test/Hspec/Core/Compat.hs0000644000000000000000000000622113412542117017156 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.Compat ( getDefaultConcurrentJobs , showType , showFullType , readMaybe , lookupEnv , module Data.IORef , module Prelude , module Control.Applicative , module Control.Monad , module Data.Foldable , module Data.Traversable , module Data.Monoid , module Data.List #if !MIN_VERSION_base(4,6,0) , modifyIORef' , atomicWriteIORef #endif , interruptible ) where import Control.Applicative import Control.Monad hiding ( mapM , mapM_ , forM , forM_ , msum , sequence , sequence_ ) import Data.Foldable import Data.Traversable import Data.Monoid import Data.List (intercalate) import Prelude hiding ( all , and , any , concat , concatMap , elem , foldl , foldl1 , foldr , foldr1 , mapM , mapM_ , maximum , minimum , notElem , or , product , sequence , sequence_ , sum ) import Data.Typeable (Typeable, typeOf, typeRepTyCon) import Text.Read import Data.IORef import System.Environment import Data.Typeable (tyConModule, tyConName) import Control.Concurrent #if MIN_VERSION_base(4,9,0) import Control.Exception (interruptible) #else import GHC.IO #endif #if !MIN_VERSION_base(4,6,0) import qualified Text.ParserCombinators.ReadP as P -- |Strict version of 'modifyIORef' modifyIORef' :: IORef a -> (a -> a) -> IO () modifyIORef' ref f = do x <- readIORef ref let x' = f x x' `seq` writeIORef ref x' atomicWriteIORef :: IORef a -> a -> IO () atomicWriteIORef ref a = do x <- atomicModifyIORef ref (\_ -> (a, ())) x `seq` return () -- | 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 hspec-core-2.6.1/src/Test/Hspec/Core/QuickCheck.hs0000644000000000000000000000301713412542117017745 0ustar0000000000000000-- | Stability: provisional module Test.Hspec.Core.QuickCheck ( modifyArgs , modifyMaxSuccess , modifyMaxDiscardRatio , modifyMaxSize , modifyMaxShrinks ) where import Test.QuickCheck import Test.Hspec.Core.Spec -- | Use a modified `maxSuccess` for given spec. modifyMaxSuccess :: (Int -> Int) -> SpecWith a -> SpecWith a modifyMaxSuccess = modifyArgs . modify where modify :: (Int -> Int) -> Args -> Args modify f args = args {maxSuccess = f (maxSuccess args)} -- | Use a modified `maxDiscardRatio` for given spec. modifyMaxDiscardRatio :: (Int -> Int) -> SpecWith a -> SpecWith a modifyMaxDiscardRatio = modifyArgs . modify where modify :: (Int -> Int) -> Args -> Args modify f args = args {maxDiscardRatio = f (maxDiscardRatio args)} -- | Use a modified `maxSize` for given spec. modifyMaxSize :: (Int -> Int) -> SpecWith a -> SpecWith a modifyMaxSize = modifyArgs . modify where modify :: (Int -> Int) -> Args -> Args modify f args = args {maxSize = f (maxSize args)} -- | 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.6.1/src/Test/Hspec/Core/Clock.hs0000644000000000000000000000137513412542117016773 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Clock ( Seconds(..) , toMicroseconds , getMonotonicTime , measure , sleep ) where import Text.Printf import System.Clock import Control.Concurrent newtype Seconds = Seconds Double deriving (Eq, Show, Num, Fractional, PrintfArg) toMicroseconds :: Seconds -> Int toMicroseconds (Seconds s) = floor (s * 1000000) getMonotonicTime :: IO Seconds getMonotonicTime = do t <- getTime Monotonic return $ Seconds ((fromIntegral . toNanoSecs $ t) / 1000000000) 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 hspec-core-2.6.1/src/Test/Hspec/Core/Example.hs0000644000000000000000000001544413412542117017335 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} module Test.Hspec.Core.Example ( Example (..) , Params (..) , defaultParams , ActionWith , Progress , ProgressCallback , Result(..) , ResultStatus (..) , Location (..) , FailureReason (..) , safeEvaluateExample ) where import qualified Test.HUnit.Lang as HUnit import Data.CallStack import Control.Exception 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.Compat 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 :: Int } deriving (Show) defaultParams :: Params defaultParams = Params { paramsQuickCheckArgs = QC.stdArgs , paramsSmallCheckDepth = 5 } type Progress = (Int, Int) type ProgressCallback = Progress -> IO () -- | An `IO` action that expects an argument of type @a@ type ActionWith a = a -> IO () -- | The result of running an example data Result = 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` e `seq` () instance Exception ResultStatus safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result safeEvaluateExample example params around progress = do r <- safeTry $ forceResult <$> evaluateExample example params around progress return $ case r of Left e | Just result <- fromException e -> Result "" result Left e | Just hunit <- fromException e -> Result "" $ hunitFailureToResult Nothing hunit Left e -> Result "" $ Failure Nothing $ Error Nothing e Right result -> result where 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 instance Example Result where type Arg Result = () evaluateExample e = evaluateExample (\() -> e) instance Example (a -> Result) where type Arg (a -> Result) = a evaluateExample example _params action _callback = do ref <- newIORef (Result "" Success) action (evaluate . example >=> writeIORef ref) readIORef ref instance Example Bool where type Arg Bool = () evaluateExample e = evaluateExample (\() -> e) instance Example (a -> Bool) where type Arg (a -> Bool) = a evaluateExample p _params action _callback = do ref <- newIORef (Result "" Success) action (evaluate . example >=> writeIORef ref) readIORef ref 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 $ Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) where addPre :: String -> String addPre xs = case pre of Just x -> x ++ "\n" ++ xs Nothing -> xs instance Example (a -> Expectation) where type Arg (a -> Expectation) = a evaluateExample e _ action _ = action 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 action progressCallback = do r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty action 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.6.1/src/Test/Hspec/Core/Util.hs0000644000000000000000000001015113412542117016645 0ustar0000000000000000-- | Stability: unstable module Test.Hspec.Core.Util ( -- * String functions pluralize , strip , lineBreaksAt -- * Working with paths , Path , joinPath , formatRequirement , filterPredicate -- * Working with exception , safeTry , formatException ) where import Data.List import Data.Char (isSpace) import GHC.IO.Exception import Control.Exception import Control.Concurrent.Async import Test.Hspec.Core.Compat (showType) -- | -- @pluralize count singular@ pluralizes the given @singular@ word unless given -- @count@ is 1. -- -- Examples: -- -- >>> pluralize 0 "example" -- "0 examples" -- -- >>> pluralize 1 "example" -- "1 example" -- -- >>> pluralize 2 "example" -- "2 examples" pluralize :: Int -> String -> String pluralize 1 s = "1 " ++ s pluralize n s = show n ++ " " ++ s ++ "s" -- | Strip leading and trailing whitespace strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse -- | -- ensure that lines are not longer than given `n`, insert line breaks at word -- boundaries lineBreaksAt :: Int -> String -> [String] lineBreaksAt n input = case words input of [] -> [] x:xs -> go (x, xs) where go :: (String, [String]) -> [String] go c = case c of (s, []) -> [s] (s, y:ys) -> let r = s ++ " " ++ y in if length r <= n then go (r, ys) else s : go (y, ys) -- | -- A `Path` describes the location of a spec item within a spec tree. -- -- It consists of a list of group descriptions and a requirement description. type Path = ([String], String) -- | -- Join a `Path` with slashes. The result will have a leading and a trailing -- slash. joinPath :: Path -> String joinPath (groups, requirement) = "/" ++ intercalate "/" (groups ++ [requirement]) ++ "/" -- | -- Try to create a proper English sentence from a path by applying some -- heuristics. formatRequirement :: Path -> String formatRequirement (groups, requirement) = groups_ ++ requirement where groups_ = case break (any isSpace) groups of ([], ys) -> join ys (xs, ys) -> join (intercalate "." xs : ys) join xs = case xs of [x] -> x ++ " " ys -> concatMap (++ ", ") ys -- | A predicate that can be used to filter a spec tree. filterPredicate :: String -> Path -> Bool filterPredicate pattern path = 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 (divide by zero)" -- -- For `IOException`s the `IOErrorType` is included, as well. formatException :: SomeException -> String formatException err@(SomeException e) = case fromException err of Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ "\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. safeTry :: IO a -> IO (Either SomeException a) safeTry action = withAsync (action >>= evaluate) waitCatch hspec-core-2.6.1/src/Test/Hspec/Core/QuickCheckUtil.hs0000644000000000000000000001210213412542117020576 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Test.Hspec.Core.QuickCheckUtil where import Prelude () import Test.Hspec.Core.Compat import Control.Exception import Data.List import Data.Maybe 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 aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a -> (unGen . unProperty $ p a) r n aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop aroundProp action p = MkProp $ aroundRose action (\a -> unProp $ p a) aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result aroundRose action r = ioRose $ do ref <- newIORef (return QCP.succeeded) action $ \a -> reduceRose (r a) >>= writeIORef ref readIORef ref 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.6.1/src/Test/Hspec/Core/Hooks.hs0000644000000000000000000000576413412542117017031 0ustar0000000000000000-- | Stability: provisional module Test.Hspec.Core.Hooks ( before , before_ , beforeWith , beforeAll , beforeAll_ , after , after_ , afterAll , afterAll_ , around , around_ , aroundWith ) where import Control.Exception (SomeException, finally, throwIO, try) import Control.Concurrent.MVar import Test.Hspec.Core.Example import Test.Hspec.Core.Tree import Test.Hspec.Core.Spec.Monad -- | Run a custom action before every spec item. before :: IO a -> SpecWith a -> Spec before action = around (action >>=) -- | Run a custom action before every spec item. before_ :: IO () -> SpecWith a -> SpecWith a before_ action = around_ (action >>) -- | Run a custom action before every spec item. beforeWith :: (b -> IO a) -> SpecWith a -> SpecWith b beforeWith action = aroundWith $ \e x -> action x >>= e -- | Run a custom action before the first spec item. beforeAll :: IO a -> SpecWith a -> Spec beforeAll action spec = do mvar <- runIO (newMVar Empty) before (memoize mvar action) spec -- | Run a custom action before the first spec item. beforeAll_ :: IO () -> SpecWith a -> SpecWith a beforeAll_ action spec = do mvar <- runIO (newMVar Empty) before_ (memoize mvar action) spec data Memoized a = Empty | Memoized a | Failed SomeException memoize :: MVar (Memoized a) -> IO a -> IO a memoize mvar action = do result <- modifyMVar mvar $ \ma -> case ma of Empty -> do a <- try action return (either Failed Memoized a, a) Memoized a -> return (ma, Right a) Failed _ -> throwIO (Pending Nothing (Just "exception in beforeAll-hook (see previous failure)")) either throwIO return result -- | Run a custom action after every spec item. after :: ActionWith a -> SpecWith a -> SpecWith a after action = aroundWith $ \e x -> e x `finally` action x -- | Run a custom action after every spec item. after_ :: IO () -> SpecWith a -> SpecWith a after_ action = after $ \_ -> action -- | Run a custom action before and/or after every spec item. around :: (ActionWith a -> IO ()) -> SpecWith a -> Spec around action = aroundWith $ \e () -> action e -- | Run a custom action after the last spec item. afterAll :: ActionWith a -> SpecWith a -> SpecWith a afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . return . NodeWithCleanup action -- | Run a custom action after the last spec item. afterAll_ :: IO () -> SpecWith a -> SpecWith a afterAll_ action = afterAll (\_ -> action) -- | Run a custom action before and/or after every spec item. around_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a around_ action = aroundWith $ \e a -> action (e a) -- | Run a custom action before and/or after every spec item. aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b aroundWith action = mapSpecItem action (modifyAroundAction action) modifyAroundAction :: (ActionWith a -> ActionWith b) -> Item a -> Item b modifyAroundAction action item@Item{itemExample = e} = item{ itemExample = \params aroundAction -> e params (aroundAction . action) } hspec-core-2.6.1/src/Test/Hspec/Core/Spec.hs0000644000000000000000000001137513412542117016633 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 , module Test.Hspec.Core.Spec.Monad -- * A type class for examples , module Test.Hspec.Core.Example -- * Internal representation of a spec tree , module Test.Hspec.Core.Tree ) where import Prelude () import Test.Hspec.Core.Compat import qualified Control.Exception as E import Data.CallStack import Test.Hspec.Expectations (Expectation) import Test.Hspec.Core.Example import Test.Hspec.Core.Hooks import Test.Hspec.Core.Tree import Test.Hspec.Core.Spec.Monad -- | The @describe@ function combines a list of specs into a larger spec. describe :: HasCallStack => String -> SpecWith a -> SpecWith a describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . specGroup label -- | @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 spec = do xs <- runIO (runSpecM spec) let ys | any (any itemIsFocused) xs = xs | otherwise = map (bimapTree id (\ item -> item {itemIsFocused = True})) xs fromSpecList ys -- | @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 = E.throwIO (Pending location Nothing) pending_ :: Expectation pending_ = (E.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 = E.throwIO . Pending location . Just hspec-core-2.6.1/src/Test/Hspec/Core/Formatters.hs0000644000000000000000000001627513412542117020073 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Stability: experimental -- -- This module contains formatters that can be used with -- `Test.Hspec.Runner.hspecWith`. module Test.Hspec.Core.Formatters ( -- * Formatters silent , specdoc , progress , failed_examples -- * Implementing a custom Formatter -- | -- A formatter is a set of actions. Each action is evaluated when a certain -- situation is encountered during a test run. -- -- Actions live in the `FormatM` monad. It provides access to the runner state -- and primitives for appending to the generated report. , Formatter (..) , FailureReason (..) , FormatM -- ** Accessing the runner state , getSuccessCount , getPendingCount , getFailCount , getTotalCount , FailureRecord (..) , getFailMessages , usedSeed , 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 Data.Maybe import Test.Hspec.Core.Util import Test.Hspec.Core.Spec (Location(..)) import Text.Printf -- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make -- sure, that we only use the public API to implement formatters. -- -- Everything imported here has to be re-exported, so that users can implement -- their own formatters. import Test.Hspec.Core.Formatters.Monad ( Formatter (..) , FailureReason (..) , FormatM , getSuccessCount , getPendingCount , getFailCount , getTotalCount , FailureRecord (..) , getFailMessages , usedSeed , getCPUTime , getRealTime , write , writeLine , writeTransient , withInfoColor , withSuccessColor , withPendingColor , withFailColor , useDiff , extraChunk , missingChunk ) import Test.Hspec.Core.Clock (Seconds(..)) import Test.Hspec.Core.Formatters.Diff silent :: Formatter silent = Formatter { headerFormatter = return () , exampleGroupStarted = \_ _ -> return () , exampleGroupDone = return () , exampleProgress = \_ _ -> return () , exampleSucceeded = \ _ _ -> return () , exampleFailed = \_ _ _ -> return () , examplePending = \_ _ _ -> return () , failedFormatter = return () , footerFormatter = return () } specdoc :: Formatter specdoc = silent { headerFormatter = do writeLine "" , exampleGroupStarted = \nesting name -> do writeLine (indentationFor nesting ++ name) , exampleProgress = \_ 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 "" #if __GLASGOW_HASKELL__ == 800 withFailColor $ do writeLine "WARNING:" writeLine " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285." writeLine " Source locations may not work as expected." writeLine "" writeLine " Please consider upgrading GHC!" writeLine "" #endif 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 -> return () Reason err -> withFailColor $ indent err ExpectedButGot preface expected actual -> do mapM_ indent preface b <- useDiff let chunks | b = diff expected actual | otherwise = [First expected, Second actual] withFailColor $ write (indentation ++ "expected: ") forM_ chunks $ \chunk -> case chunk of Both a _ -> indented write a First a -> indented extraChunk a Second _ -> return () writeLine "" withFailColor $ write (indentation ++ " but got: ") forM_ chunks $ \chunk -> case chunk of Both a _ -> indented write a First _ -> return () Second a -> indented missingChunk a writeLine "" where indented output text = case break (== '\n') text of (xs, "") -> output xs (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ " ") >> indented output ys 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.6.1/src/Test/Hspec/Core/Format.hs0000644000000000000000000000144413412542117017165 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Test.Hspec.Core.Format ( Format(..) , Progress , Path , Location(..) , Seconds(..) , Item(..) , Result(..) , FailureReason(..) ) where import Test.Hspec.Core.Spec (Progress, Location(..)) import Test.Hspec.Core.Example (FailureReason(..)) import Test.Hspec.Core.Util (Path) import Test.Hspec.Core.Clock data Item = Item { itemLocation :: Maybe Location , itemDuration :: Seconds , itemInfo :: String , itemResult :: Result } data Result = Success | Pending (Maybe String) | Failure FailureReason data Format m = Format { formatRun :: forall a. m a -> IO a , formatGroupStarted :: Path -> m () , formatGroupDone :: Path -> m () , formatProgress :: Path -> Progress -> m () , formatItem :: Path -> Item -> m () } hspec-core-2.6.1/src/Test/Hspec/Core/Timer.hs0000644000000000000000000000107313412542117017013 0ustar0000000000000000module Test.Hspec.Core.Timer (withTimer) where import Prelude () import Test.Hspec.Core.Compat import Control.Exception 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.6.1/src/Test/Hspec/Core/Config.hs0000644000000000000000000001224413412542117017142 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.Config ( Config (..) , ColorMode(..) , defaultConfig , readConfig , configAddFilter , configQuickCheckArgs , readFailureReportOnRerun , applyFailureReport #ifdef TEST , readConfigFiles #endif ) where import Prelude () import Test.Hspec.Core.Compat import Control.Exception import Data.Maybe import System.IO import System.IO.Error import System.Exit import System.FilePath import System.Directory import System.Environment (getProgName) import qualified Test.QuickCheck as QC import Test.Hspec.Core.Util import Test.Hspec.Core.Config.Options import Test.Hspec.Core.FailureReport import Test.Hspec.Core.QuickCheckUtil (mkGen) import Test.Hspec.Core.Example (Params(..), defaultParams) -- | Add a filter predicate to config. If there is already a filter predicate, -- then combine them with `||`. configAddFilter :: (Path -> Bool) -> Config -> Config configAddFilter p1 c = c { configFilterPredicate = Just p1 `filterOr` configFilterPredicate c } 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 setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c) . maybe id setMaxSize (configQuickCheckMaxSize c) . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) (paramsQuickCheckArgs defaultParams) setMaxSuccess :: Int -> QC.Args -> QC.Args setMaxSuccess n args = args {QC.maxSuccess = n} setMaxSize :: Int -> QC.Args -> QC.Args setMaxSize n args = args {QC.maxSize = n} setMaxDiscardRatio :: Int -> QC.Args -> QC.Args setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n} setSeed :: Integer -> QC.Args -> QC.Args setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)} -- | -- `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. the environment variable @HSPEC_OPTIONS@ -- 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 envVar <- fmap words <$> lookupEnv envVarName case parseOptions opts_ prog configFiles envVar args of Left (err, msg) -> exitWithMessage err msg Right opts -> 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.6.1/src/Test/Hspec/Core/FailureReport.hs0000644000000000000000000000441213412542117020516 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.FailureReport ( FailureReport (..) , writeFailureReport , readFailureReport ) where import Prelude () import Test.Hspec.Core.Compat #ifndef __GHCJS__ import System.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.Options (Config(..)) data FailureReport = FailureReport { failureReportSeed :: Integer , failureReportMaxSuccess :: Int , failureReportMaxSize :: Int , failureReportMaxDiscardRatio :: Int , failureReportPaths :: [Path] } deriving (Eq, Show, Read) writeFailureReport :: Config -> FailureReport -> IO () writeFailureReport config report = case configFailureReport config of Just file -> writeFile file (show report) Nothing -> do #ifdef __GHCJS__ -- ghcjs currently does not support setting environment variables -- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report -- into the environment is a non-essential feature we just disable this to be -- able to run hspec test-suites with ghcjs at all. Should be reverted once -- the issue is fixed. return () #else -- on Windows this can throw an exception when the input is too large, hence -- we use `safeTry` here safeTry (setEnv "HSPEC_FAILURES" $ show report) >>= either onError return where onError err = do hPutStrLn stderr ("WARNING: Could not write environment variable HSPEC_FAILURES (" ++ show err ++ ")") #endif readFailureReport :: Config -> IO (Maybe FailureReport) readFailureReport config = case configFailureReport config of Just file -> do exists <- doesFileExist file if exists then do r <- readFile file let report = readMaybe r when (report == Nothing) $ do hPutStrLn stderr ("WARNING: Could not read failure report from file " ++ show file ++ "!") return report else return Nothing Nothing -> do mx <- lookupEnv "HSPEC_FAILURES" case mx >>= readMaybe of Nothing -> do hPutStrLn stderr "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!" return Nothing report -> return report hspec-core-2.6.1/src/Test/Hspec/Core/Runner.hs0000644000000000000000000002275413412542117017215 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- Stability: provisional module Test.Hspec.Core.Runner ( -- * Running a spec hspec , runSpec -- * Config , Config (..) , ColorMode (..) , Path , defaultConfig , configAddFilter , readConfig -- * Summary , Summary (..) , isSuccess , evaluateSummary -- * Legacy -- | The following primitives are deprecated. Use `runSpec` instead. , hspecWith , hspecResult , hspecWithResult #ifdef TEST , rerunAll #endif ) where import Prelude () import Test.Hspec.Core.Compat import Data.Maybe import System.IO import System.Environment (getArgs, withArgs) import System.Exit import qualified Control.Exception as E import System.Console.ANSI (hHideCursor, hShowCursor) import qualified Test.QuickCheck as QC import Test.Hspec.Core.Util (Path) import Test.Hspec.Core.Spec import Test.Hspec.Core.Config import Test.Hspec.Core.Formatters import Test.Hspec.Core.Formatters.Internal import Test.Hspec.Core.FailureReport import Test.Hspec.Core.QuickCheckUtil import Test.Hspec.Core.Runner.Eval -- | Filter specs by given predicate. -- -- The predicate takes a list of "describe" labels and a "requirement". filterSpecs :: Config -> [EvalTree] -> [EvalTree] filterSpecs c = go [] where p :: Path -> Bool p path = (fromMaybe (const True) (configFilterPredicate c) path) && not (fromMaybe (const False) (configSkipPredicate c) path) go :: [String] -> [EvalTree] -> [EvalTree] go groups = mapMaybe (goSpec groups) goSpecs :: [String] -> [EvalTree] -> ([EvalTree] -> b) -> Maybe b goSpecs groups specs ctor = case go groups specs of [] -> Nothing xs -> Just (ctor xs) goSpec :: [String] -> EvalTree -> Maybe (EvalTree) goSpec groups spec = case spec of Leaf item -> guard (p (groups, evalItemDescription item)) >> return spec Node group specs -> goSpecs (groups ++ [group]) specs (Node group) NodeWithCleanup action specs -> goSpecs groups specs (NodeWithCleanup action) applyDryRun :: Config -> [SpecTree ()] -> [SpecTree ()] applyDryRun c | configDryRun c = map (removeCleanup . fmap markSuccess) | otherwise = id where markSuccess :: Item () -> Item () markSuccess item = item {itemExample = safeEvaluateExample (Result "" Success)} removeCleanup :: SpecTree () -> SpecTree () removeCleanup spec = case spec of Node x xs -> Node x (map removeCleanup xs) NodeWithCleanup _ xs -> NodeWithCleanup (\() -> return ()) (map removeCleanup xs) leaf@(Leaf _) -> leaf -- | Run 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 desired. Use `runSpec` if you need more control over these -- aspects. hspec :: Spec -> IO () hspec spec = getArgs >>= readConfig defaultConfig >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec >>= evaluateSummary -- 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 config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec >>= evaluateSummary -- | `True` if the given `Summary` indicates that there were no -- failures, `False` otherwise. isSuccess :: Summary -> Bool isSuccess summary = summaryFailures summary == 0 -- | Exit with `exitFailure` if the given `Summary` indicates that there was at -- least one failure. evaluateSummary :: Summary -> IO () evaluateSummary summary = unless (isSuccess summary) 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 spec = getArgs >>= readConfig defaultConfig >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec -- | Run given spec with custom options and returns a summary of the test run. -- -- /Note/: `hspecWithResult` does not exit with `exitFailure` on failing spec -- items. If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary hspecWithResult config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec -- | -- `runSpec` is the most basic primitive to run a spec. `hspec` is defined in -- terms of @runSpec@: -- -- @ -- hspec spec = -- `getArgs` -- >>= `readConfig` `defaultConfig` -- >>= `withArgs` [] . runSpec spec -- >>= `evaluateSummary` -- @ runSpec :: Spec -> Config -> IO Summary runSpec spec c_ = do oldFailureReport <- readFailureReportOnRerun c_ c <- ensureSeed (applyFailureReport oldFailureReport c_) if configRerunAllOnSuccess c -- With --rerun-all we may run the spec twice. For that reason GHC can not -- optimize away the spec tree. That means that the whole spec tree has to -- be constructed in memory and we loose constant space behavior. -- -- By separating between rerunAllMode and normalMode here, we retain -- constant space behavior in normalMode. -- -- see: https://github.com/hspec/hspec/issues/169 then rerunAllMode c oldFailureReport else normalMode c where normalMode c = runSpec_ c spec rerunAllMode c oldFailureReport = do summary <- runSpec_ c spec if rerunAll c oldFailureReport summary then runSpec spec c_ else return summary runSpec_ :: Config -> Spec -> IO Summary runSpec_ config spec = do withHandle config $ \h -> do let formatter = fromMaybe specdoc (configFormatter config) seed = (fromJust . configQuickCheckSeed) config qcArgs = configQuickCheckArgs config concurrentJobs <- case configConcurrentJobs config of Nothing -> getDefaultConcurrentJobs Just n -> return n useColor <- doesUseColor h config let params = Params (configQuickCheckArgs config) (configSmallCheckDepth config) filteredSpec <- filterSpecs config . mapMaybe (toEvalTree params) . applyDryRun config <$> runSpecM (focus spec) (total, failures) <- withHiddenCursor useColor h $ do let formatConfig = FormatConfig { formatConfigHandle = h , formatConfigUseColor = useColor , formatConfigUseDiff = configDiff config , formatConfigHtmlOutput = configHtmlOutput config , formatConfigPrintCpuTime = configPrintCpuTime config , formatConfigUsedSeed = seed } evalConfig = EvalConfig { evalConfigFormat = formatterToFormat formatter formatConfig , evalConfigConcurrentJobs = concurrentJobs , evalConfigFastFail = configFastFail config } runFormatter evalConfig filteredSpec dumpFailureReport config seed qcArgs failures return (Summary total (length failures)) toEvalTree :: Params -> SpecTree () -> Maybe EvalTree toEvalTree params = go where go :: Tree (() -> c) (Item ()) -> Maybe (Tree c EvalItem) go t = case t of Node s xs -> Just $ Node s (mapMaybe go xs) NodeWithCleanup c xs -> Just $ NodeWithCleanup (c ()) (mapMaybe go xs) Leaf (Item requirement loc isParallelizable isFocused e) -> guard isFocused >> return (Leaf (EvalItem requirement loc (fromMaybe False isParallelizable) (e params $ ($ ())))) dumpFailureReport :: Config -> Integer -> QC.Args -> [Path] -> IO () dumpFailureReport config seed qcArgs xs = do writeFailureReport config FailureReport { failureReportSeed = seed , failureReportMaxSuccess = QC.maxSuccess qcArgs , failureReportMaxSize = QC.maxSize qcArgs , failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs , failureReportPaths = xs } doNotLeakCommandLineArgumentsToExamples :: IO a -> IO a doNotLeakCommandLineArgumentsToExamples = withArgs [] withHiddenCursor :: Bool -> Handle -> IO a -> IO a withHiddenCursor useColor h | useColor = E.bracket_ (hHideCursor h) (hShowCursor h) | otherwise = id doesUseColor :: Handle -> Config -> IO Bool doesUseColor h c = case configColorMode c of ColorAuto -> (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb) ColorNever -> return False ColorAlways -> return True withHandle :: Config -> (Handle -> IO a) -> IO a withHandle c action = case configOutputFile c of Left h -> action h Right path -> withFile path WriteMode action rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool rerunAll _ Nothing _ = False rerunAll config (Just oldFailureReport) summary = configRerunAllOnSuccess config && configRerun config && isSuccess summary && (not . null) (failureReportPaths oldFailureReport) isDumb :: IO Bool isDumb = maybe False (== "dumb") <$> lookupEnv "TERM" -- | Summary of a test run. data Summary = Summary { summaryExamples :: Int , summaryFailures :: Int } deriving (Eq, Show) instance Monoid Summary where mempty = Summary 0 0 #if !MIN_VERSION_base(4,11,0) (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) #else instance Semigroup Summary where (Summary x1 x2) <> (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) #endif hspec-core-2.6.1/src/Test/Hspec/Core/Tree.hs0000644000000000000000000000606013412542117016633 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} -- | -- Stability: unstable module Test.Hspec.Core.Tree ( SpecTree , Tree (..) , Item (..) , specGroup , specItem , bimapTree , location ) where import Prelude () import Test.Hspec.Core.Compat import Data.CallStack import Data.Maybe import Test.Hspec.Core.Example -- | Internal tree data structure data Tree c a = Node String [Tree c a] | NodeWithCleanup c [Tree c a] | Leaf a deriving (Show, Eq, Functor, Foldable, Traversable) -- | A tree is used to represent a spec internally. The tree is parametrize -- over the type of cleanup actions and the type of the actual spec items. type SpecTree a = Tree (ActionWith a) (Item a) 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 cleanup xs -> NodeWithCleanup (g cleanup) (map go xs) Leaf item -> Leaf (f item) -- | -- @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 a) => String -> a -> SpecTree (Arg a) specItem s e = Leaf $ Item requirement location Nothing False (safeEvaluateExample e) where requirement :: HasCallStack => String requirement | null s = fromMaybe "(unspecified behavior)" defaultDescription | otherwise = s location :: HasCallStack => Maybe Location location = case reverse callStack of (_, loc) : _ -> Just (Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc)) _ -> Nothing defaultDescription :: HasCallStack => Maybe String defaultDescription = case reverse callStack of (_, loc) : _ -> Just (srcLocModule loc ++ "[" ++ show (srcLocStartLine loc) ++ ":" ++ show (srcLocStartCol loc) ++ "]") _ -> Nothing hspec-core-2.6.1/src/Test/Hspec/Core/Formatters/0000755000000000000000000000000013412542117017524 5ustar0000000000000000hspec-core-2.6.1/src/Test/Hspec/Core/Formatters/Free.hs0000644000000000000000000000111413412542117020736 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} module Test.Hspec.Core.Formatters.Free where import Prelude () import Test.Hspec.Core.Compat data Free f a = Free (f (Free f a)) | Pure a deriving Functor instance Functor f => Applicative (Free f) where pure = Pure Pure f <*> Pure a = Pure (f a) Pure f <*> Free m = Free (fmap f <$> m) Free m <*> b = Free (fmap (<*> b) m) instance Functor f => Monad (Free f) where return = pure Pure a >>= f = f a Free m >>= f = Free (fmap (>>= f) m) liftF :: Functor f => f a -> Free f a liftF command = Free (fmap Pure command) hspec-core-2.6.1/src/Test/Hspec/Core/Formatters/Monad.hs0000644000000000000000000002021113412542117021112 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ExistentialQuantification #-} module Test.Hspec.Core.Formatters.Monad ( Formatter (..) , FailureReason (..) , FormatM , getSuccessCount , getPendingCount , getFailCount , getTotalCount , FailureRecord (..) , getFailMessages , usedSeed , getCPUTime , getRealTime , write , writeLine , 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.Free import Test.Hspec.Core.Example (FailureReason(..)) import Test.Hspec.Core.Util (Path) import Test.Hspec.Core.Spec (Progress, Location) import Test.Hspec.Core.Clock data Formatter = Formatter { headerFormatter :: FormatM () -- | evaluated before each test group , exampleGroupStarted :: [String] -> String -> FormatM () , exampleGroupDone :: FormatM () -- | used to notify the progress of the currently evaluated example -- -- /Note/: This is only called when interactive/color mode. , exampleProgress :: 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 `failuresFormatter` , 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) | 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) 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 , 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 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) -- | 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.6.1/src/Test/Hspec/Core/Formatters/Internal.hs0000644000000000000000000002236213412542117021641 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Formatters.Internal ( FormatM , FormatConfig(..) , runFormatM , interpret , increaseSuccessCount , increasePendingCount , addFailMessage , finally_ , formatterToFormat ) where import Prelude () import Test.Hspec.Core.Compat import qualified System.IO as IO import System.IO (Handle) import Control.Exception (AsyncException(..), bracket_, try, throwIO) import System.Console.ANSI import Control.Monad.Trans.State hiding (state, gets, modify) import Control.Monad.IO.Class import Data.Char (isSpace) import qualified System.CPUTime as CPUTime import qualified Test.Hspec.Core.Formatters.Monad as M import Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..)) import Test.Hspec.Core.Format import Test.Hspec.Core.Clock formatterToFormat :: M.Formatter -> FormatConfig -> Format FormatM formatterToFormat formatter config = Format { formatRun = \action -> runFormatM config $ do interpret (M.headerFormatter formatter) a <- action `finally_` interpret (M.failedFormatter formatter) interpret (M.footerFormatter formatter) return a , formatGroupStarted = \ (nesting, name) -> interpret $ M.exampleGroupStarted formatter nesting name , formatGroupDone = \ _ -> interpret (M.exampleGroupDone formatter) , formatProgress = \ path progress -> when useColor $ do interpret $ M.exampleProgress formatter path progress , formatItem = \ path (Item loc _duration info result) -> do clearTransientOutput case result of Success -> do increaseSuccessCount interpret $ M.exampleSucceeded formatter path info Pending reason -> do increasePendingCount interpret $ M.examplePending formatter path info reason Failure err -> do addFailMessage loc path err interpret $ M.exampleFailed formatter path info err } where useColor = formatConfigUseColor config interpret :: M.FormatM a -> FormatM a interpret = interpretWith Environment { environmentGetSuccessCount = getSuccessCount , environmentGetPendingCount = getPendingCount , environmentGetFailMessages = getFailMessages , environmentUsedSeed = usedSeed , environmentGetCPUTime = getCPUTime , environmentGetRealTime = getRealTime , environmentWrite = write , environmentWriteTransient = writeTransient , environmentWithFailColor = withFailColor , environmentWithSuccessColor = withSuccessColor , environmentWithPendingColor = withPendingColor , environmentWithInfoColor = withInfoColor , environmentUseDiff = gets (formatConfigUseDiff . stateConfig) , environmentExtraChunk = extraChunk , environmentMissingChunk = missingChunk , environmentLiftIO = liftIO } -- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a gets f = FormatM $ do f <$> (get >>= liftIO . readIORef) -- | A lifted version of `Control.Monad.Trans.State.modify` modify :: (FormatterState -> FormatterState) -> FormatM () modify f = FormatM $ do get >>= liftIO . (`modifyIORef'` f) data FormatConfig = FormatConfig { formatConfigHandle :: Handle , formatConfigUseColor :: Bool , formatConfigUseDiff :: Bool , formatConfigHtmlOutput :: Bool , formatConfigPrintCpuTime :: Bool , formatConfigUsedSeed :: Integer } deriving (Eq, Show) data FormatterState = FormatterState { stateSuccessCount :: Int , statePendingCount :: Int , stateFailMessages :: [FailureRecord] , stateCpuStartTime :: Maybe Integer , stateStartTime :: Seconds , stateTransientOutput :: String , stateConfig :: FormatConfig } getConfig :: (FormatConfig -> a) -> FormatM a getConfig f = gets (f . stateConfig) getHandle :: FormatM Handle getHandle = getConfig formatConfigHandle -- | 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) = do time <- getMonotonicTime cpuTime <- if (formatConfigPrintCpuTime config) then Just <$> CPUTime.getCPUTime else pure Nothing st <- newIORef (FormatterState 0 0 [] cpuTime time "" config) evalStateT action st -- | 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 -- | Append to the list of accumulated failure messages. addFailMessage :: Maybe Location -> Path -> FailureReason -> FormatM () addFailMessage loc p m = modify $ \s -> s {stateFailMessages = FailureRecord loc p m : stateFailMessages s} -- | Get the list of accumulated failure messages. getFailMessages :: FormatM [FailureRecord] getFailMessages = reverse `fmap` gets stateFailMessages writeTransient :: String -> FormatM () writeTransient s = do write ("\r" ++ s) modify $ \ state -> state {stateTransientOutput = s} h <- getHandle liftIO $ IO.hFlush h clearTransientOutput :: FormatM () clearTransientOutput = do n <- length <$> gets stateTransientOutput unless (n == 0) $ do write ("\r" ++ replicate n ' ' ++ "\r") modify $ \ state -> state {stateTransientOutput = ""} -- | Append some output to the report. write :: String -> FormatM () write s = do h <- getHandle liftIO $ IO.hPutStr h s -- | Set output color to red, run given action, and finally restore the default -- color. withFailColor :: FormatM a -> FormatM a withFailColor = withColor (SetColor Foreground Dull Red) "hspec-failure" -- | Set output color to green, run given action, and finally restore the -- default color. withSuccessColor :: FormatM a -> FormatM a withSuccessColor = withColor (SetColor Foreground Dull Green) "hspec-success" -- | Set output color to yellow, run given action, and finally restore the -- default color. withPendingColor :: FormatM a -> FormatM a withPendingColor = withColor (SetColor Foreground Dull Yellow) "hspec-pending" -- | Set output color to cyan, run given action, and finally restore the -- default color. withInfoColor :: FormatM a -> FormatM a withInfoColor = withColor (SetColor Foreground Dull Cyan) "hspec-info" -- | Set a color, run an action, and finally reset colors. withColor :: SGR -> String -> FormatM a -> FormatM a withColor color cls action = do 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 (FormatM action) = do useColor <- getConfig formatConfigUseColor h <- getHandle FormatM . StateT $ \st -> do bracket_ -- set color (when useColor $ hSetSGR h [color]) -- reset colors (when useColor $ hSetSGR h [Reset]) -- run action (runStateT action st) -- | Output given chunk in red. extraChunk :: String -> FormatM () extraChunk s = do useDiff <- getConfig formatConfigUseDiff case useDiff 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 useDiff <- getConfig formatConfigUseDiff case useDiff 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 -- | -- @finally_ actionA actionB@ runs @actionA@ and then @actionB@. @actionB@ is -- run even when a `UserInterrupt` occurs during @actionA@. finally_ :: FormatM a -> FormatM () -> FormatM a finally_ (FormatM actionA) (FormatM actionB) = FormatM . StateT $ \st -> do r <- try (runStateT actionA st) case r of Left e -> do when (e == UserInterrupt) $ runStateT actionB st >> return () throwIO e Right (a, st_) -> do runStateT actionB st_ >>= return . replaceValue a where replaceValue a (_, st) = (a, st) -- | 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 <$> ((-) <$> pure 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.6.1/src/Test/Hspec/Core/Formatters/Diff.hs0000644000000000000000000000337013412542117020733 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 import Data.Char import Data.List (stripPrefix) import Data.Algorithm.Diff diff :: String -> String -> [Diff String] diff expected actual = map (fmap concat) $ getGroupedDiff (partition expected) (partition actual) partition :: String -> [String] partition = filter (not . null) . mergeBackslashes . breakList isAlphaNum where 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.6.1/src/Test/Hspec/Core/Runner/0000755000000000000000000000000013412542117016647 5ustar0000000000000000hspec-core-2.6.1/src/Test/Hspec/Core/Runner/Eval.hs0000644000000000000000000002222413412542117020074 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# 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.Eval ( EvalConfig(..) , EvalTree , EvalItem(..) , runFormatter #ifdef TEST , runSequentially #endif ) where import Prelude () import Test.Hspec.Core.Compat hiding (Monad) import qualified Test.Hspec.Core.Compat as M import qualified Control.Exception as E import Control.Concurrent import Control.Concurrent.Async hiding (cancel) import Control.Monad.IO.Class (liftIO) import qualified Control.Monad.IO.Class as M import Control.Monad.Trans.State hiding (State, state) import Control.Monad.Trans.Class import Test.Hspec.Core.Util import Test.Hspec.Core.Spec (Tree(..), 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 -- 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) data EvalConfig m = EvalConfig { evalConfigFormat :: Format m , evalConfigConcurrentJobs :: Int , evalConfigFastFail :: Bool } data State m = State { stateConfig :: EvalConfig m , stateSuccessCount :: Int , statePendingCount :: Int , stateFailures :: [Path] } type EvalM m = StateT (State m) m increaseSuccessCount :: Monad m => EvalM m () increaseSuccessCount = modify $ \state -> state {stateSuccessCount = stateSuccessCount state + 1} increasePendingCount :: Monad m => EvalM m () increasePendingCount = modify $ \state -> state {statePendingCount = statePendingCount state + 1} addFailure :: Monad m => Path -> EvalM m () addFailure path = modify $ \state -> state {stateFailures = path : stateFailures state} getFormat :: Monad m => (Format m -> a) -> EvalM m a getFormat format = gets (format . evalConfigFormat . stateConfig) reportItem :: Monad m => Path -> Format.Item -> EvalM m () reportItem path item = do case Format.itemResult item of Format.Success {} -> increaseSuccessCount Format.Pending {} -> increasePendingCount Format.Failure {} -> addFailure path format <- getFormat formatItem lift (format path item) failureItem :: Maybe Location -> Seconds -> String -> FailureReason -> Format.Item failureItem loc duration info err = Format.Item loc duration info (Format.Failure err) reportResult :: Monad m => Path -> Maybe Location -> (Seconds, Result) -> EvalM m () reportResult path loc (duration, result) = do case result of Result info status -> case status of Success -> reportItem path (Format.Item loc duration info Format.Success) Pending loc_ reason -> reportItem path (Format.Item (loc_ <|> loc) duration info $ Format.Pending reason) Failure loc_ err@(Error _ e) -> reportItem path (failureItem (loc_ <|> extractLocation e <|> loc) duration info err) Failure loc_ err -> reportItem path (failureItem (loc_ <|> loc) duration info err) groupStarted :: Monad m => Path -> EvalM m () groupStarted path = do format <- getFormat formatGroupStarted lift $ format path groupDone :: Monad m => Path -> EvalM m () groupDone path = do format <- getFormat formatGroupDone lift $ format path data EvalItem = EvalItem { evalItemDescription :: String , evalItemLocation :: Maybe Location , evalItemParallelize :: Bool , evalItemAction :: ProgressCallback -> IO Result } type EvalTree = Tree (IO ()) EvalItem runEvalM :: Monad m => EvalConfig m -> EvalM m () -> m (State m) runEvalM config action = execStateT action (State config 0 0 []) -- | Evaluate all examples of a given spec and produce a report. runFormatter :: forall m. MonadIO m => EvalConfig m -> [EvalTree] -> IO (Int, [Path]) runFormatter config specs = do let start = parallelizeTree (evalConfigConcurrentJobs config) specs cancel = cancelMany . concatMap toList . map (fmap fst) E.bracket start cancel $ \ runningSpecs -> do withTimer 0.05 $ \ timer -> do state <- formatRun format $ do runEvalM config $ run $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs let failures = stateFailures state total = stateSuccessCount state + statePendingCount state + length failures return (total, reverse failures) where format = evalConfigFormat config reportProgress :: IO Bool -> Path -> Progress -> m () reportProgress timer path progress = do r <- liftIO timer when r (formatProgress format path progress) cancelMany :: [Async a] -> IO () cancelMany asyncs = do mapM_ (killThread . asyncThreadId) asyncs mapM_ waitCatch asyncs data Item a = Item { _itemDescription :: String , _itemLocation :: Maybe Location , _itemAction :: a } deriving Functor type Job m p a = (p -> m ()) -> m a type RunningItem m = Item (Path -> m (Seconds, Result)) type RunningTree m = Tree (IO ()) (RunningItem m) type RunningItem_ m = (Async (), Item (Job m Progress (Seconds, Result))) type RunningTree_ m = Tree (IO ()) (RunningItem_ m) data Semaphore = Semaphore { semaphoreWait :: IO () , semaphoreSignal :: IO () } parallelizeTree :: MonadIO m => Int -> [EvalTree] -> IO [RunningTree_ m] parallelizeTree n specs = do sem <- newQSem n mapM (traverse $ parallelizeItem sem) specs parallelizeItem :: MonadIO m => QSem -> EvalItem -> IO (RunningItem_ m) parallelizeItem sem EvalItem{..} = do (asyncAction, evalAction) <- parallelize (Semaphore (waitQSem sem) (signalQSem sem)) evalItemParallelize (interruptible . evalItemAction) return (asyncAction, Item evalItemDescription evalItemLocation evalAction) parallelize :: MonadIO m => Semaphore -> Bool -> Job IO p a -> IO (Async (), Job m p (Seconds, a)) parallelize sem isParallelizable | isParallelizable = runParallel sem | otherwise = runSequentially runSequentially :: MonadIO m => Job IO p a -> IO (Async (), Job m p (Seconds, a)) runSequentially action = do mvar <- newEmptyMVar (asyncAction, evalAction) <- runParallel (Semaphore (takeMVar mvar) (return ())) action return (asyncAction, \ notifyPartial -> liftIO (putMVar mvar ()) >> evalAction notifyPartial) data Parallel p a = Partial p | Return a runParallel :: forall m p a. MonadIO m => Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a)) runParallel Semaphore{..} action = do mvar <- newEmptyMVar asyncAction <- async $ E.bracket_ semaphoreWait semaphoreSignal (worker mvar) return (asyncAction, eval mvar) where worker mvar = do let partialCallback = replaceMVar mvar . Partial result <- measure $ action partialCallback replaceMVar mvar (Return result) eval :: MVar (Parallel p (Seconds, a)) -> (p -> m ()) -> m (Seconds, a) eval mvar notifyPartial = do r <- liftIO (takeMVar mvar) case r of Partial p -> do notifyPartial p eval mvar notifyPartial Return result -> return result replaceMVar :: MVar a -> a -> IO () replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p run :: forall m. MonadIO m => [RunningTree m] -> EvalM m () run specs = do fastFail <- gets (evalConfigFastFail . stateConfig) sequenceActions fastFail (concatMap foldSpec specs) where foldSpec :: RunningTree m -> [EvalM m ()] foldSpec = foldTree FoldTree { onGroupStarted = groupStarted , onGroupDone = groupDone , onCleanup = runCleanup , onLeafe = evalItem } runCleanup :: [String] -> IO () -> EvalM m () runCleanup groups action = do (dt, r) <- liftIO $ measure $ safeTry action either (\ e -> reportItem path . failureItem (extractLocation e) dt "" . Error Nothing $ e) return r where path = (groups, "afterAll-hook") evalItem :: [String] -> RunningItem m -> EvalM m () evalItem groups (Item requirement loc action) = do lift (action path) >>= reportResult path loc where path :: Path path = (groups, requirement) data FoldTree c a r = FoldTree { onGroupStarted :: Path -> r , onGroupDone :: Path -> r , onCleanup :: [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 action xs) = children ++ [cleanup] where children = concatMap (go rGroups) xs cleanup = onCleanup (reverse rGroups) action go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] sequenceActions :: Monad m => Bool -> [EvalM m ()] -> EvalM m () sequenceActions fastFail = go where go [] = return () go (action : actions) = do () <- action hasFailures <- (not . null) <$> gets stateFailures let stopNow = fastFail && hasFailures unless stopNow (go actions) hspec-core-2.6.1/src/Test/Hspec/Core/Example/0000755000000000000000000000000013412542117016771 5ustar0000000000000000hspec-core-2.6.1/src/Test/Hspec/Core/Example/Location.hs0000644000000000000000000000602513412542117021100 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Hspec.Core.Example.Location ( Location(..) , extractLocation -- for testing , parseCallStack , parseLocation , parseSourceSpan ) where import Prelude () import Test.Hspec.Core.Compat import Control.Exception import Data.List import Data.Char import Data.Maybe import GHC.IO.Exception -- | @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 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 = stripPrefix "Pattern match failure in do expression at " input >>= parseSourceSpan 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)) -> Location file <$> readMaybe line <*> readMaybe column parseSourceSpan :: String -> Maybe Location parseSourceSpan input = case breakColon input of (file, xs) -> (uncurry $ Location 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 (== ':') hspec-core-2.6.1/src/Test/Hspec/Core/Spec/0000755000000000000000000000000013412542117016270 5ustar0000000000000000hspec-core-2.6.1/src/Test/Hspec/Core/Spec/Monad.hs0000644000000000000000000000371613412542117017671 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Spec.Monad ( Spec , SpecWith , SpecM (..) , runSpecM , fromSpecList , runIO , mapSpecItem , mapSpecItem_ , modifyParams ) where import Prelude () import Test.Hspec.Core.Compat import Control.Arrow import Control.Monad.Trans.Writer import Control.Monad.IO.Class (liftIO) import Test.Hspec.Core.Example import Test.Hspec.Core.Tree type Spec = SpecWith () type SpecWith a = SpecM a () -- | A writer monad for `SpecTree` forests newtype SpecM a r = SpecM (WriterT [SpecTree a] IO r) deriving (Functor, Applicative, Monad) -- | Convert a `Spec` to a forest of `SpecTree`s. runSpecM :: SpecWith a -> IO [SpecTree a] runSpecM (SpecM specs) = execWriterT specs -- | Create a `Spec` from a forest of `SpecTree`s. fromSpecList :: [SpecTree a] -> SpecWith a fromSpecList = SpecM . tell -- | Run an IO action while constructing the spec tree. -- -- `SpecM` is a monad to construct a spec tree, without executing any spec -- items. @runIO@ allows you to run IO actions during this construction phase. -- The IO action is always run when the spec tree is constructed (e.g. even -- when @--dry-run@ is specified). -- If you do not need the result of the IO action to construct the spec tree, -- `Test.Hspec.Core.Hooks.beforeAll` may be more suitable for your use case. runIO :: IO r -> SpecM a r runIO = SpecM . liftIO mapSpecTree :: (SpecTree a -> SpecTree b) -> SpecM a r -> SpecM b r mapSpecTree f (SpecM specs) = SpecM (mapWriterT (fmap (second (map f))) specs) mapSpecItem :: (ActionWith a -> ActionWith b) -> (Item a -> Item b) -> SpecWith a -> SpecWith b mapSpecItem g f = mapSpecTree (bimapTree g f) mapSpecItem_ :: (Item a -> Item a) -> SpecWith a -> SpecWith a mapSpecItem_ = mapSpecItem id modifyParams :: (Params -> Params) -> SpecWith a -> SpecWith a modifyParams f = mapSpecItem_ $ \item -> item {itemExample = \p -> (itemExample item) (f p)} hspec-core-2.6.1/src/Test/Hspec/Core/Config/0000755000000000000000000000000013412542117016603 5ustar0000000000000000hspec-core-2.6.1/src/Test/Hspec/Core/Config/Util.hs0000644000000000000000000000234313412542117020056 0ustar0000000000000000module Test.Hspec.Core.Config.Util where 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 [] -> [] formatOrList :: [String] -> String formatOrList xs = case xs of [] -> "" x : ys -> (case ys of [] -> x _ : [] -> x ++ " or " _ : _ : _ -> x ++ ", ") ++ formatOrList ys hspec-core-2.6.1/src/Test/Hspec/Core/Config/Options.hs0000644000000000000000000003042613412542117020577 0ustar0000000000000000module Test.Hspec.Core.Config.Options ( Config(..) , ColorMode (..) , defaultConfig , filterOr , parseOptions , ConfigFile , ignoreConfigFile , envVarName ) where import Prelude () import Test.Hspec.Core.Compat import System.IO import System.Exit import System.Console.GetOpt import Test.Hspec.Core.Formatters import Test.Hspec.Core.Config.Util import Test.Hspec.Core.Util import Test.Hspec.Core.Example (Params(..), defaultParams) import Data.Functor.Identity import Data.Maybe type ConfigFile = (FilePath, [String]) type EnvVar = [String] envVarName :: String envVarName = "HSPEC_OPTIONS" data Config = Config { configIgnoreConfigFile :: Bool , configDryRun :: Bool , configPrintCpuTime :: Bool , configFastFail :: Bool , configFailureReport :: Maybe FilePath , configRerun :: Bool , configRerunAllOnSuccess :: Bool -- | -- A predicate that is used to filter the spec before it is run. Only examples -- that satisfy the predicate are run. , configFilterPredicate :: Maybe (Path -> Bool) , configSkipPredicate :: Maybe (Path -> Bool) , configQuickCheckSeed :: Maybe Integer , configQuickCheckMaxSuccess :: Maybe Int , configQuickCheckMaxDiscardRatio :: Maybe Int , configQuickCheckMaxSize :: Maybe Int , configSmallCheckDepth :: Int , configColorMode :: ColorMode , configDiff :: Bool , configFormatter :: Maybe Formatter , configHtmlOutput :: Bool , configOutputFile :: Either Handle FilePath , configConcurrentJobs :: Maybe Int } defaultConfig :: Config defaultConfig = Config { configIgnoreConfigFile = False , configDryRun = False , configPrintCpuTime = False , configFastFail = False , configFailureReport = Nothing , configRerun = False , configRerunAllOnSuccess = False , configFilterPredicate = Nothing , configSkipPredicate = Nothing , configQuickCheckSeed = Nothing , configQuickCheckMaxSuccess = Nothing , configQuickCheckMaxDiscardRatio = Nothing , configQuickCheckMaxSize = Nothing , configSmallCheckDepth = paramsSmallCheckDepth defaultParams , configColorMode = ColorAuto , configDiff = True , configFormatter = Nothing , configHtmlOutput = False , configOutputFile = Left stdout , configConcurrentJobs = Nothing } filterOr :: Maybe (Path -> Bool) -> Maybe (Path -> Bool) -> Maybe (Path -> Bool) filterOr p1_ p2_ = case (p1_, p2_) of (Just p1, Just p2) -> Just $ \path -> p1 path || p2 path _ -> p1_ <|> p2_ addMatch :: String -> Config -> Config addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c} addSkip :: String -> Config -> Config addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c} setDepth :: Int -> Config -> Config setDepth n c = c {configSmallCheckDepth = n} setMaxSuccess :: Int -> Config -> Config setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n} setMaxSize :: Int -> Config -> Config setMaxSize n c = c {configQuickCheckMaxSize = Just n} setMaxDiscardRatio :: Int -> Config -> Config setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n} setSeed :: Integer -> Config -> Config setSeed n c = c {configQuickCheckSeed = Just n} data ColorMode = ColorAuto | ColorNever | ColorAlways deriving (Eq, Show) type Result m = Either InvalidArgument (m Config) data InvalidArgument = InvalidArgument String String data Arg a = Arg { _argumentName :: String , _argumentParser :: String -> Maybe a , _argumentSetter :: a -> Config -> Config } mkOption :: Monad m => [Char] -> String -> Arg a -> String -> OptDescr (Result m -> Result m) mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help where arg input x = x >>= \c -> case parser input of Just n -> Right (setter n `liftM` c) Nothing -> Left (InvalidArgument name input) mkFlag :: Monad m => String -> (Bool -> Config -> Config) -> String -> [OptDescr (Result m -> Result m)] mkFlag name setter help = [ Option [] [name] (NoArg $ set $ setter True) help , Option [] ["no-" ++ name] (NoArg $ set $ setter False) ("do not " ++ help) ] commandLineOptions :: [OptDescr (Result Maybe -> Result Maybe)] commandLineOptions = [ Option [] ["help"] (NoArg (const $ Right Nothing)) "display this help and exit" , Option [] ["ignore-dot-hspec"] (NoArg setIgnoreConfigFile) "do not read options from ~/.hspec and .hspec" , mkOption "m" "match" (Arg "PATTERN" return addMatch) "only run examples that match given PATTERN" , mkOption [] "skip" (Arg "PATTERN" return addSkip) "skip examples that match given PATTERN" ] where setIgnoreConfigFile = set $ \config -> config {configIgnoreConfigFile = True} formatterOptions :: Monad m => [OptDescr (Result m -> Result m)] formatterOptions = concat [ [mkOption "f" "format" (Arg "FORMATTER" readFormatter setFormatter) helpForFormat] , mkFlag "color" setColor "colorize the output" , mkFlag "diff" setDiff "show colorized diffs" , [Option [] ["print-cpu-time"] (NoArg setPrintCpuTime) "include used CPU time in summary"] ] where formatters :: [(String, Formatter)] formatters = [ ("specdoc", specdoc) , ("progress", progress) , ("failed-examples", failed_examples) , ("silent", silent) ] helpForFormat :: String helpForFormat = "use a custom formatter; this can be one of " ++ (formatOrList $ map fst formatters) readFormatter :: String -> Maybe Formatter readFormatter = (`lookup` formatters) setFormatter :: Formatter -> Config -> Config setFormatter f c = c {configFormatter = Just f} setColor :: Bool -> Config -> Config setColor v config = config {configColorMode = if v then ColorAlways else ColorNever} setDiff :: Bool -> Config -> Config setDiff v config = config {configDiff = v} setPrintCpuTime = set $ \config -> config {configPrintCpuTime = True} smallCheckOptions :: Monad m => [OptDescr (Result m -> Result m)] smallCheckOptions = [ mkOption [] "depth" (Arg "N" readMaybe setDepth) "maximum depth of generated test values for SmallCheck properties" ] quickCheckOptions :: Monad m => [OptDescr (Result m -> Result m)] quickCheckOptions = [ mkOption "a" "qc-max-success" (Arg "N" readMaybe setMaxSuccess) "maximum number of successful tests before a QuickCheck property succeeds" , mkOption "" "qc-max-size" (Arg "N" readMaybe setMaxSize) "size to use for the biggest test cases" , mkOption "" "qc-max-discard" (Arg "N" readMaybe setMaxDiscardRatio) "maximum number of discarded tests per successful test before giving up" , mkOption [] "seed" (Arg "N" readMaybe setSeed) "used seed for QuickCheck properties" ] runnerOptions :: Monad m => [OptDescr (Result m -> Result m)] runnerOptions = [ Option [] ["dry-run"] (NoArg setDryRun) "pretend that everything passed; don't verify anything" , Option [] ["fail-fast"] (NoArg setFastFail) "abort on first failure" , Option "r" ["rerun"] (NoArg setRerun) "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)" , mkOption [] "failure-report" (Arg "FILE" return setFailureReport) "read/write a failure report for use with --rerun" , Option [] ["rerun-all-on-success"] (NoArg setRerunAllOnSuccess) "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)" , mkOption "j" "jobs" (Arg "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)" ] where 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 = set $ \config -> config {configDryRun = True} setFastFail = set $ \config -> config {configFastFail = True} setRerun = set $ \config -> config {configRerun = True} setRerunAllOnSuccess = set $ \config -> config {configRerunAllOnSuccess = True} documentedConfigFileOptions :: Monad m => [(String, [OptDescr (Result m -> Result m)])] documentedConfigFileOptions = [ ("RUNNER OPTIONS", runnerOptions) , ("FORMATTER OPTIONS", formatterOptions) , ("OPTIONS FOR QUICKCHECK", quickCheckOptions) , ("OPTIONS FOR SMALLCHECK", smallCheckOptions) ] documentedOptions :: [(String, [OptDescr (Result Maybe -> Result Maybe)])] documentedOptions = ("OPTIONS", commandLineOptions) : documentedConfigFileOptions configFileOptions :: Monad m => [OptDescr (Result m -> Result m)] configFileOptions = (concat . map snd) documentedConfigFileOptions set :: Monad m => (Config -> Config) -> Either a (m Config) -> Either a (m Config) set = liftM . liftM undocumentedOptions :: Monad m => [OptDescr (Result m -> Result m)] undocumentedOptions = [ -- for compatibility with test-framework mkOption [] "maximum-generated-tests" (Arg "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default" -- undocumented for now, as we probably want to change this to produce a -- standalone HTML report in the future , Option [] ["html"] (NoArg setHtml) "produce HTML output" , mkOption "o" "out" (Arg "FILE" return setOutputFile) "write output to a file instead of STDOUT" -- now a noop , Option "v" ["verbose"] (NoArg id) "do not suppress output to stdout when evaluating examples" ] where setHtml = set $ \config -> config {configHtmlOutput = True} setOutputFile :: String -> Config -> Config setOutputFile file c = c {configOutputFile = Right file} recognizedOptions :: [OptDescr (Result Maybe -> Result Maybe)] recognizedOptions = commandLineOptions ++ configFileOptions ++ undocumentedOptions parseOptions :: Config -> String -> [ConfigFile] -> Maybe EnvVar -> [String] -> Either (ExitCode, String) Config parseOptions config prog configFiles envVar args = do foldM (parseFileOptions prog) config configFiles >>= parseEnvVarOptions prog envVar >>= parseCommandLineOptions prog args parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config parseCommandLineOptions prog args config = case parse recognizedOptions config args of Right Nothing -> Left (ExitSuccess, usage) Right (Just c) -> Right c Left err -> failure err where failure err = Left (ExitFailure 1, prog ++ ": " ++ err ++ "\nTry `" ++ prog ++ " --help' for more information.\n") usage :: String usage = "Usage: " ++ prog ++ " [OPTION]...\n\n" ++ (intercalate "\n" $ map (uncurry mkUsageInfo) documentedOptions) parseFileOptions :: String -> Config -> ConfigFile -> Either (ExitCode, String) Config parseFileOptions prog config (name, args) = parseOtherOptions prog ("in config file " ++ name) args config parseEnvVarOptions :: String -> (Maybe EnvVar) -> Config -> Either (ExitCode, String) Config parseEnvVarOptions prog args = parseOtherOptions prog ("from environment variable " ++ envVarName) (fromMaybe [] args) parseOtherOptions :: String -> String -> [String] -> Config -> Either (ExitCode, String) Config parseOtherOptions prog source args config = case parse configFileOptions config args of Right (Identity c) -> Right c Left err -> failure err where failure err = Left (ExitFailure 1, prog ++ ": " ++ message) where message = unlines $ case lines err of [x] -> [x ++ " " ++ source] xs -> xs ++ [source] parse :: Monad m => [OptDescr (Result m -> Result m)] -> Config -> [String] -> Either String (m Config) parse options config args = case getOpt Permute options args of (opts, [], []) -> case foldl' (flip id) (Right $ return config) opts of Left (InvalidArgument name value) -> Left ("invalid argument `" ++ value ++ "' for `--" ++ name ++ "'") Right x -> Right x (_, _, err:_) -> Left (init err) (_, arg:_, _) -> Left ("unexpected argument `" ++ arg ++ "'") ignoreConfigFile :: Config -> [String] -> IO Bool ignoreConfigFile config args = do ignore <- lookupEnv "IGNORE_DOT_HSPEC" case ignore of Just _ -> return True Nothing -> case parse recognizedOptions config args of Right (Just c) -> return (configIgnoreConfigFile c) _ -> return False