summaryrefslogtreecommitdiff
path: root/test-framework
diff options
context:
space:
mode:
authorTom Smeding <tom@tomsmeding.com>2025-03-27 12:52:06 +0100
committerTom Smeding <tom@tomsmeding.com>2025-03-27 12:52:06 +0100
commitff59a9541ce8b978424a07c54476e2d2a63a40ad (patch)
treeaa326aaee15a4f3038c24b35d3e8769c43ffbed3 /test-framework
parenta994883ef5b08c16e6331f5f4dbde6a650856bc1 (diff)
test-framework: More matchable paths (begin/end anchors)
Diffstat (limited to 'test-framework')
-rw-r--r--test-framework/Test/Framework.hs12
1 files 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."]