diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ ## Unreleased changes +## 0.1.1.2 + +* Improve semantics of multiple `--filter/-f` arguments. Now they get applied to the test tree sequentially. + ## 0.1.1.1 * Fix error symlink creation on Windows (don't allow invalid characters). diff --git a/sandwich.cabal b/sandwich.cabal --- a/sandwich.cabal +++ b/sandwich.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: sandwich -version: 0.1.1.1 +version: 0.1.1.2 synopsis: Yet another test framework for Haskell description: Please see the . category: Testing @@ -125,6 +125,7 @@ , transformers-base , unliftio-core , vector + default-language: Haskell2010 if !os(windows) build-depends: brick @@ -147,7 +148,6 @@ Test.Sandwich.Formatters.TerminalUI.Types hs-source-dirs: unix-src - default-language: Haskell2010 executable sandwich-demo main-is: Main.hs @@ -200,12 +200,12 @@ , transformers-base , unliftio-core , vector + default-language: Haskell2010 if !os(windows) build-depends: brick , unix , vty - default-language: Haskell2010 executable sandwich-discover main-is: Main.hs @@ -258,12 +258,12 @@ , transformers-base , unliftio-core , vector + default-language: Haskell2010 if !os(windows) build-depends: brick , unix , vty - default-language: Haskell2010 executable sandwich-test main-is: Main.hs @@ -321,12 +321,12 @@ , transformers-base , unliftio-core , vector + default-language: Haskell2010 if !os(windows) build-depends: brick , unix , vty - default-language: Haskell2010 test-suite sandwich-test-suite type: exitcode-stdio-1.0 @@ -385,9 +385,9 @@ , transformers-base , unliftio-core , vector + default-language: Haskell2010 if !os(windows) build-depends: brick , unix , vty - default-language: Haskell2010 diff --git a/src/Test/Sandwich.hs b/src/Test/Sandwich.hs --- a/src/Test/Sandwich.hs +++ b/src/Test/Sandwich.hs @@ -190,12 +190,17 @@ exitReasonRef <- newIORef NormalExit - let shutdown info = do - putStrLn [i|Shutting down due to #{info}...|] - writeIORef exitReasonRef InterruptExit + let shutdown sig = do + let signalName :: T.Text = + if | sig == sigINT -> "sigINT" + | sig == sigTERM -> "sigTERM" + | otherwise -> [i|signal #{sig}|] + putStrLn [i|Shutting down due to #{signalName}...|] + writeIORef exitReasonRef SignalExit forM_ rts cancelNode _ <- installHandler sigINT shutdown + _ <- installHandler sigTERM shutdown -- Wait for the tree to finish mapM_ waitForTree rts diff --git a/src/Test/Sandwich/Internal/Running.hs b/src/Test/Sandwich/Internal/Running.hs --- a/src/Test/Sandwich/Internal/Running.hs +++ b/src/Test/Sandwich/Internal/Running.hs @@ -37,9 +37,7 @@ startSandwichTree' :: BaseContext -> Options -> CoreSpec -> IO [RunNode BaseContext] startSandwichTree' baseContext (Options {..}) spec' = do - let spec = case optionsFilterTree of - Nothing -> spec' - Just (TreeFilter matches) -> filterTree matches spec' + let spec = maybe spec' (L.foldl' filterTree spec' . unTreeFilter) optionsFilterTree runTree <- atomically $ specToRunTreeVariable baseContext spec @@ -67,7 +65,7 @@ modify $ \(successes, total) -> (successes + (if numFailures == 0 then 1 else 0), total + 1) - if | exitReason == InterruptExit -> return () + if | exitReason == SignalExit -> return () | n > 0 -> loop (n - 1) | otherwise -> return () diff --git a/src/Test/Sandwich/Interpreters/FilterTree.hs b/src/Test/Sandwich/Interpreters/FilterTree.hs --- a/src/Test/Sandwich/Interpreters/FilterTree.hs +++ b/src/Test/Sandwich/Interpreters/FilterTree.hs @@ -7,28 +7,32 @@ import qualified Data.List as L import Test.Sandwich.Types.Spec -filterTree :: [String] -> Free (SpecCommand context m) () -> Free (SpecCommand context m) () -filterTree matches (Free (It'' loc no l ex next)) - | all (`L.isInfixOf` l) matches = Free (It'' loc no l ex (filterTree matches next)) - | otherwise = filterTree matches (filterTree matches next) -filterTree matches (Free (Introduce'' loc no l cl alloc cleanup subspec next)) - | all (`L.isInfixOf` l) matches = Free (Introduce'' loc no l cl alloc cleanup subspec (filterTree matches next)) - | otherwise = case filterTree matches subspec of - (Pure _) -> filterTree matches next - x -> Free (Introduce'' loc no l cl alloc cleanup x (filterTree matches next)) -filterTree matches (Free (IntroduceWith'' loc no l cl action subspec next)) - | all (`L.isInfixOf` l) matches = Free (IntroduceWith'' loc no l cl action subspec (filterTree matches next)) - | otherwise = case filterTree matches subspec of - (Pure _) -> filterTree matches next - x -> Free (IntroduceWith'' loc no l cl action x (filterTree matches next)) -filterTree matches (Free (Parallel'' loc no subspec next)) = - case filterTree matches subspec of - (Pure _) -> filterTree matches next - x -> Free (Parallel'' loc no x (filterTree matches next)) -filterTree matches (Free x) - | all (`L.isInfixOf` label x) matches = Free (x { next = (filterTree matches (next x)) }) - | otherwise = case filterTree matches (subspec x) of - (Pure _) -> filterTree matches (next x) +filterTree :: Free (SpecCommand context m) () -> String -> Free (SpecCommand context m) () +filterTree (Free (It'' loc no l ex next)) match + | l `matches` match = Free (It'' loc no l ex (filterTree next match)) + | otherwise = filterTree (filterTree next match) match +filterTree (Free (Introduce'' loc no l cl alloc cleanup subspec next)) match + | l `matches` match = Free (Introduce'' loc no l cl alloc cleanup subspec (filterTree next match)) + | otherwise = case filterTree subspec match of + (Pure _) -> filterTree next match + x -> Free (Introduce'' loc no l cl alloc cleanup x (filterTree next match)) +filterTree (Free (IntroduceWith'' loc no l cl action subspec next)) match + | l `matches` match = Free (IntroduceWith'' loc no l cl action subspec (filterTree next match)) + | otherwise = case filterTree subspec match of + (Pure _) -> filterTree next match + x -> Free (IntroduceWith'' loc no l cl action x (filterTree next match)) +filterTree (Free (Parallel'' loc no subspec next)) match + = case filterTree subspec match of + (Pure _) -> filterTree next match + x -> Free (Parallel'' loc no x (filterTree next match)) +filterTree (Free x) match + | label x `matches` match = Free (x { next = (filterTree (next x) match) }) + | otherwise = case filterTree (subspec x) match of + (Pure _) -> filterTree (next x) match subspec' -> Free (x { subspec = subspec' - , next = (filterTree matches (next x)) }) -filterTree _ (Pure x) = Pure x + , next = (filterTree (next x) match) }) +filterTree (Pure x) _ = Pure x + + +matches :: String -> String -> Bool +matches l match = match `L.isInfixOf` l diff --git a/src/Test/Sandwich/Types/General.hs b/src/Test/Sandwich/Types/General.hs --- a/src/Test/Sandwich/Types/General.hs +++ b/src/Test/Sandwich/Types/General.hs @@ -1,5 +1,5 @@ module Test.Sandwich.Types.General where -data ExitReason = NormalExit | InterruptExit +data ExitReason = NormalExit | SignalExit deriving (Show, Eq) diff --git a/src/Test/Sandwich/Types/RunTree.hs b/src/Test/Sandwich/Types/RunTree.hs --- a/src/Test/Sandwich/Types/RunTree.hs +++ b/src/Test/Sandwich/Types/RunTree.hs @@ -205,7 +205,7 @@ } -- ^ Create a new test artifacts directory under '' test artifacts directory at the given path. -newtype TreeFilter = TreeFilter [String] +newtype TreeFilter = TreeFilter { unTreeFilter :: [String] } type LogFn = Loc -> LogSource -> LogLevel -> LogStr -> IO ()