From ff59a9541ce8b978424a07c54476e2d2a63a40ad Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Thu, 27 Mar 2025 12:52:06 +0100 Subject: test-framework: More matchable paths (begin/end anchors) --- test-framework/Test/Framework.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/test-framework/Test/Framework.hs b/test-framework/Test/Framework.hs index 158c489..e83d0de 100644 --- a/test-framework/Test/Framework.hs +++ b/test-framework/Test/Framework.hs @@ -21,7 +21,7 @@ module Test.Framework ( import Control.Monad (forM) import Control.Monad.Trans.State.Strict import Control.Monad.IO.Class -import Data.List (isInfixOf) +import Data.List (isInfixOf, intercalate) import Data.Maybe (isJust, mapMaybe, fromJust) import Data.String (fromString) import Data.Time.Clock @@ -64,10 +64,10 @@ testProperty :: String -> H.Property -> TestTree testProperty = HP filterTree :: Options -> TestTree -> Maybe TestTree -filterTree (Options { optsPattern = pat }) = go "" +filterTree (Options { optsPattern = pat }) = go [] where go path (Group collapse name trees) = - case mapMaybe (go (path++"/"++name)) trees of + case mapMaybe (go (name:path)) trees of [] -> Nothing trees' -> Just (Group collapse name trees') go path (Resource make free fun) = @@ -75,9 +75,11 @@ filterTree (Options { optsPattern = pat }) = go "" Nothing -> Nothing Just _ -> Just $ Resource make free (fromJust . go path . fun) go path hp@(HP name _) - | pat `isInfixOf` (path++"/"++name) = Just hp + | pat `isInfixOf` renderPath (name:path) = Just hp | otherwise = Nothing + renderPath comps = "^" ++ intercalate "/" (reverse comps) ++ "$" + computeMaxLen :: TestTree -> Int computeMaxLen = go 0 where @@ -136,7 +138,7 @@ printUsage = do ,"Options:" ," -h / --help Show this help" ," -p PATTERN Only tests whose path contains PATTERN are run. The path of a" - ," test looks like: '/group1/group2/testname'." + ," test looks like: '^group1/group2/testname$'." ," --hedgehog-replay '{skip} {seed}'" ," Skip to a particular generated Hedgehog test. Should be used" ," with -p. Overrides 'propertySkip' in 'PropertyConfig' if set."] -- cgit v1.2.3-70-g09d2