diff --git a/hspec-core.cabal b/hspec-core.cabal --- a/hspec-core.cabal +++ b/hspec-core.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.5. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: hspec-core -version: 2.11.5 +version: 2.11.6 license: MIT license-file: LICENSE copyright: (c) 2011-2023 Simon Hengel, @@ -130,7 +130,7 @@ , filepath , haskell-lexer , hspec-expectations ==0.8.4.* - , hspec-meta ==2.11.5 + , hspec-meta ==2.11.6 , process , quickcheck-io >=0.2.0 , random diff --git a/src/Test/Hspec/Core/Runner/Eval.hs b/src/Test/Hspec/Core/Runner/Eval.hs --- a/src/Test/Hspec/Core/Runner/Eval.hs +++ b/src/Test/Hspec/Core/Runner/Eval.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE LambdaCase #-} module Test.Hspec.Core.Runner.Eval ( EvalConfig(..) , ColorMode(..) @@ -53,7 +54,7 @@ data Env = Env { envConfig :: EvalConfig -, envFailed :: IORef Bool +, envAbort :: IORef Bool , envResults :: IORef [(Path, Format.Item)] } @@ -64,14 +65,14 @@ type EvalM = ReaderT Env IO -setFailed :: EvalM () -setFailed = do - ref <- asks envFailed +abort :: EvalM () +abort = do + ref <- asks envAbort liftIO $ writeIORef ref True -hasFailed :: EvalM Bool -hasFailed = do - ref <- asks envFailed +shouldAbort :: EvalM Bool +shouldAbort = do + ref <- asks envAbort liftIO $ readIORef ref addResult :: Path -> Format.Item -> EvalM () @@ -89,15 +90,15 @@ reportItemDone :: Path -> Format.Item -> EvalM () reportItemDone path item = do - let - isFailure = case Format.itemResult item of - Format.Success{} -> False - Format.Pending{} -> False - Format.Failure{} -> True - when isFailure setFailed addResult path item formatEvent $ Format.ItemDone path item +isFailure :: Result -> Bool +isFailure r = case resultStatus r of + Success{} -> False + Pending{} -> False + Failure{} -> True + reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM () reportResult path loc (duration, result) = do mode <- asks (evalConfigColorMode . envConfig) @@ -141,12 +142,15 @@ runningSpecs_ <- enqueueItems queue specs let - applyReportProgress :: RunningItem_ IO -> RunningItem + applyReportProgress :: RunningItem_ IO -> RunningItem IO applyReportProgress item = fmap (. reportProgress timer) item - runningSpecs :: [RunningTree ()] - runningSpecs = applyCleanup $ map (fmap applyReportProgress) runningSpecs_ + runningSpecs :: [RunningTree () EvalM] + runningSpecs = applyCleanup abortEarly $ map (fmap applyReportProgress) runningSpecs_ + abortEarly :: Result -> Bool + abortEarly result = evalConfigFailFast config && isFailure result + getResults :: IO [(Path, Format.Item)] getResults = reverse <$> readIORef (envResults env) @@ -178,41 +182,61 @@ , itemAction :: a } deriving Functor -type RunningItem = Item (Path -> IO (Seconds, Result)) -type RunningTree c = Tree c RunningItem +type RunningItem m = Item (Path -> m (Seconds, Result)) +type RunningTree c m = Tree c (RunningItem m) type RunningItem_ m = Item (Job m Progress (Seconds, Result)) type RunningTree_ m = Tree (IO ()) (RunningItem_ m) -applyCleanup :: [RunningTree (IO ())] -> [RunningTree ()] -applyCleanup = map go +applyFailFast :: (Result -> Bool) -> RunningTree () IO -> RunningTree () EvalM +applyFailFast = fmap . fmap . fmap . applyToItem where + applyToItem abortEarly action = do + result@(_, r) <- lift action + when (abortEarly r) abort + return result + +applyCleanup :: (Result -> Bool) -> [RunningTree (IO ()) IO] -> [RunningTree () EvalM] +applyCleanup abortEarly = map (applyFailFast abortEarly . go) + where + go :: RunningTree (IO ()) IO -> RunningTree () IO go t = case t of Node label xs -> Node label (go <$> xs) - NodeWithCleanup loc cleanup xs -> NodeWithCleanup loc () (addCleanupToLastLeaf loc cleanup $ go <$> xs) + NodeWithCleanup loc cleanup xs -> NodeWithCleanup loc () (applyCleanupAction abortEarly loc cleanup $ go <$> xs) Leaf a -> Leaf a -addCleanupToLastLeaf :: Maybe (String, Location) -> IO () -> NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ()) -addCleanupToLastLeaf loc cleanup = go +applyCleanupAction :: (Result -> Bool) -> Maybe (String, Location) -> IO () -> NonEmpty (RunningTree () IO) -> NonEmpty (RunningTree () IO) +applyCleanupAction abortEarly loc cleanup = forLastLeaf (addCleanupOn (not . abortEarly)) . forEachLeaf (addCleanupOn abortEarly) where + addCleanupOn p = addCleanupToItem p loc cleanup + +forEachLeaf :: (a -> b) -> NonEmpty (Tree () a) -> NonEmpty (Tree () b) +forEachLeaf f = fmap (fmap f) + +forLastLeaf :: (a -> a) -> NonEmpty (Tree () a) -> NonEmpty (Tree () a) +forLastLeaf p = go + where go = NonEmpty.reverse . mapHead goNode . NonEmpty.reverse goNode node = case node of Node description xs -> Node description (go xs) NodeWithCleanup loc_ () xs -> NodeWithCleanup loc_ () (go xs) - Leaf item -> Leaf (addCleanupToItem loc cleanup item) + Leaf item -> Leaf (p item) mapHead :: (a -> a) -> NonEmpty a -> NonEmpty a mapHead f xs = case xs of y :| ys -> f y :| ys -addCleanupToItem :: Maybe (String, Location) -> IO () -> RunningItem -> RunningItem -addCleanupToItem loc cleanup item = item { +addCleanupToItem :: (Result -> Bool) -> Maybe (String, Location) -> IO () -> RunningItem IO -> RunningItem IO +addCleanupToItem shouldRunCleanup loc cleanup item = item { itemAction = \ path -> do - (t1, r1) <- itemAction item path - (t2, r2) <- measure $ safeEvaluateResultStatus (cleanup >> return Success) - let t = t1 + t2 - return (t, mergeResults loc r1 r2) + result@(t1, r1) <- itemAction item path + if shouldRunCleanup r1 then do + (t2, r2) <- measure $ safeEvaluateResultStatus (cleanup >> return Success) + let t = t1 + t2 + return (t, mergeResults loc r1 r2) + else do + return result } mergeResults :: Maybe (String, Location) -> Result -> ResultStatus -> Result @@ -245,12 +269,11 @@ exceptionToResult :: SomeException -> IO (Seconds, Result) exceptionToResult err = (,) 0 . Result "" <$> exceptionToResultStatus err -eval :: [RunningTree ()] -> EvalM () +eval :: [RunningTree () EvalM] -> EvalM () eval specs = do - failFast <- asks (evalConfigFailFast . envConfig) - sequenceActions failFast (concatMap foldSpec specs) + sequenceActions (concatMap foldSpec specs) where - foldSpec :: RunningTree () -> [EvalM ()] + foldSpec :: RunningTree () EvalM -> [EvalM ()] foldSpec = foldTree FoldTree { onGroupStarted = groupStarted , onGroupDone = groupDone @@ -261,9 +284,9 @@ runCleanup :: Maybe (String, Location) -> [String] -> () -> EvalM () runCleanup _loc _groups = return - evalItem :: [String] -> RunningItem -> EvalM () + evalItem :: [String] -> RunningItem EvalM -> EvalM () evalItem groups (Item requirement loc action) = do - reportItem path loc $ lift (action path) + reportItem path loc $ action path where path :: Path path = (groups, requirement) @@ -290,14 +313,13 @@ cleanup = onCleanup loc (reverse rGroups) action go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] -sequenceActions :: Bool -> [EvalM ()] -> EvalM () -sequenceActions failFast = go +sequenceActions :: [EvalM ()] -> EvalM () +sequenceActions = go where go :: [EvalM ()] -> EvalM () go [] = pass go (action : actions) = do action - stopNow <- case failFast of - False -> return False - True -> hasFailed - unless stopNow (go actions) + shouldAbort >>= \ case + False -> go actions + True -> pass diff --git a/test/Test/Hspec/Core/Formatters/DiffSpec.hs b/test/Test/Hspec/Core/Formatters/DiffSpec.hs --- a/test/Test/Hspec/Core/Formatters/DiffSpec.hs +++ b/test/Test/Hspec/Core/Formatters/DiffSpec.hs @@ -8,7 +8,7 @@ import Test.Hspec.Core.Formatters.Diff as Diff dropQuotes :: String -> String -dropQuotes = init . tail +dropQuotes = init . drop 1 spec :: Spec spec = do @@ -106,12 +106,12 @@ let char = dropQuotes (show [c]) isEscaped = length char > 1 - escape = tail char + escape = drop 1 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) + expected = partition (init $ show xs) ++ [char] ++ sep ++ partition (drop 1 $ show ys) in isEscaped ==> actual `shouldBe` expected describe "breakList" $ do diff --git a/test/Test/Hspec/Core/RunnerSpec.hs b/test/Test/Hspec/Core/RunnerSpec.hs --- a/test/Test/Hspec/Core/RunnerSpec.hs +++ b/test/Test/Hspec/Core/RunnerSpec.hs @@ -448,6 +448,26 @@ , "1 example, 1 failure" ] + context "with a cleanup action" $ do + it "runs cleanup action" $ do + ref <- newIORef 0 + ignoreExitCode $ hspec ["--fail-fast"] $ do + H.afterAll_ (modifyIORef ref succ) $ do + H.it "foo" True + H.it "bar" False + H.it "baz" True + readIORef ref `shouldReturn` (1 :: Int) + + context "when last leaf fails" $ do + it "runs cleanup action exactly once" $ do + ref <- newIORef 0 + ignoreExitCode $ hspec ["--fail-fast"] $ do + H.afterAll_ (modifyIORef ref succ) $ do + H.it "foo" True + H.it "bar" True + H.it "baz" False + readIORef ref `shouldReturn` (1 :: Int) + context "with --match" $ do it "only runs examples that match a given pattern" $ do e1 <- newMock diff --git a/vendor/Data/Algorithm/Diff.hs b/vendor/Data/Algorithm/Diff.hs --- a/vendor/Data/Algorithm/Diff.hs +++ b/vendor/Data/Algorithm/Diff.hs @@ -1,5 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -fno-warn-x-partial #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Algorithm.Diff diff --git a/version.yaml b/version.yaml --- a/version.yaml +++ b/version.yaml @@ -1,4 +1,4 @@ -version: &version 2.11.5 +version: &version 2.11.6 synopsis: A Testing Framework for Haskell author: Simon Hengel maintainer: Simon Hengel