diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for tasty-sugar +## 2.1.0.0 -- 2023-03-20 + + * Now supports the ability for the expected file to have the same name as the + root file. This is a trivial match, but still allows for capture of + parameters and associated files. Major version bump because this may result + in additional, unexpected matches; to get the original behavior use the (new) + `distinctResults` modifier on the `findSugar` results. + * Support for GHC 9.6 + ## 2.0.1.0 -- 2023-01-09 * Support for GHC 9.4. diff --git a/src/Test/Tasty/Sugar.hs b/src/Test/Tasty/Sugar.hs --- a/src/Test/Tasty/Sugar.hs +++ b/src/Test/Tasty/Sugar.hs @@ -65,6 +65,7 @@ -- * Test Generation Functions , findSugar , findSugarIn + , distinctResults , withSugarGroups -- * Types @@ -298,6 +299,22 @@ i2 <- choose [0..ll-1] guard (i1 /= i2) return (lst !! i1, lst !! i2) + + +-- | Removes any sweets results where the expected file matches the rootFile. +-- This is expected to be used as a wrapper to the 'findSugar' or 'findSugarIn' +-- functions. +-- +-- This is a convenience function for client code that wants to ensure that the +-- rootFile is distinct from the expected file, which could not happen prior to +-- release 2.1.0.0 but can happen from that release onward when a rootName allows +-- the expectedSuffix. + +distinctResults :: [Sweets] -> [Sweets] +distinctResults sweets = + let isDistinct s e = rootFile s /= expectedFile e + removeRootExp s = s { expected = filter (isDistinct s) (expected s) } + in filter (not . null . expected) $ fmap removeRootExp sweets -- | The 'withSugarGroups' is the primary function used to run tests. diff --git a/src/internal/Test/Tasty/Sugar/Analysis.hs b/src/internal/Test/Tasty/Sugar/Analysis.hs --- a/src/internal/Test/Tasty/Sugar/Analysis.hs +++ b/src/internal/Test/Tasty/Sugar/Analysis.hs @@ -60,16 +60,16 @@ let params = L.sort $ validParams pat combineExpRes (swts, expl) = bimap (swts :) (expl :) - roots = [( candidatePMatch rootF - , rootF { candidateFile = - -- truncate the candidateFile to the first separator - -- point preceeding parameter matches. - let i = fromEnum $ candidateMatchIdx rootF - l = length $ candidateFile rootF - e = l > 0 && last (candidateFile rootF) `elem` (separators pat) - t = if i == l && not e then i else i - 1 - in take t (candidateFile rootF) } - ) + roots = [ ( candidatePMatch rootF + , rootF { candidateFile = + -- truncate the candidateFile to the first separator + -- point preceeding parameter matches. + let i = fromEnum $ candidateMatchIdx rootF + l = length $ candidateFile rootF + e = l > 0 && last (candidateFile rootF) `elem` (separators pat) + t = if i == l && not e then i else i - 1 + in take t (candidateFile rootF) } + ) , (candidatePMatch rootF, rootF) ] diff --git a/src/internal/Test/Tasty/Sugar/ExpectCheck.hs b/src/internal/Test/Tasty/Sugar/ExpectCheck.hs --- a/src/internal/Test/Tasty/Sugar/ExpectCheck.hs +++ b/src/internal/Test/Tasty/Sugar/ExpectCheck.hs @@ -39,6 +39,7 @@ $ observeIAll $ do guard (not $ null candidates) expectedSearch + rootN matchPrefix rootPMatches seps params expSuffix o @@ -50,9 +51,8 @@ expSuffix = expectedSuffix pat sfxMatch = if null expSuffix then const True else (expSuffix `L.isSuffixOf`) candidates = filter possible allNames - possible f = and [ candidateFile matchPrefix `L.isPrefixOf` candidateFile f - , rootN /= f - ] + possible f = candidateFile matchPrefix `L.isPrefixOf` candidateFile f + mkSweet e = Just $ Sweets { rootMatchName = candidateFile rootN , rootBaseName = candidateFile matchPrefix @@ -96,7 +96,8 @@ -- Note that rootPVMatches may contain multiple entries for the same parameter -- value: the root file name may contain these duplications. The code here -- should be careful to check against each value instead of assuming just one. -expectedSearch :: CandidateFile +expectedSearch :: CandidateFile -- ^ actual root file + -> CandidateFile -- ^ prefix of root file to consider -> [NamedParamMatch] -> Separators -> [ParameterPattern] @@ -104,7 +105,8 @@ -> [ (String, FileSuffix) ] -> [CandidateFile] -> LogicI Expectation -expectedSearch rootPrefix rootPVMatches seps params expSuffix assocNames allNames = +expectedSearch rootN rootPrefix rootPVMatches seps params expSuffix + assocNames allNames = do let expMatch cf = and [ candidateMatchPrefix seps rootPrefix cf , candidateMatchSuffix seps expSuffix rootPrefix cf ] @@ -153,7 +155,8 @@ let pmatch = namedPMatches rAndeMatches pvals assocFiles <- getAssoc rootPrefix seps pmatch - assocNames allNames + assocNames + $ filter (rootN /=) allNames return $ Expectation { expectedFile = candidateToPath efile , associated = fmap candidateToPath <$> assocFiles , expParamsMatch = L.sort pmatch diff --git a/tasty-sugar.cabal b/tasty-sugar.cabal --- a/tasty-sugar.cabal +++ b/tasty-sugar.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: tasty-sugar -version: 2.0.1.0 +version: 2.1.0.0 synopsis: Tests defined by Search Using Golden Answer References description: . @@ -25,7 +25,13 @@ category: Testing build-type: Simple -tested-with: GHC ==8.6.5 GHC ==8.8.4 GHC ==8.10.7 GHC ==9.0.1 GHC ==9.2.3 GHC ==9.4.4 +tested-with: GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.1 + , GHC == 9.2.3 + , GHC == 9.4.4 + , GHC == 9.6.1 extra-source-files: CHANGELOG.md README.org diff --git a/test/TestMain.hs b/test/TestMain.hs --- a/test/TestMain.hs +++ b/test/TestMain.hs @@ -18,6 +18,7 @@ import Data.Text.Prettyprint.Doc #endif +import TestFileSys import TestGCD import TestMultiAssoc import TestNoAssoc @@ -26,7 +27,6 @@ import TestStrlen2 import TestUtils import TestWildcard -import TestFileSys main :: IO () diff --git a/test/TestWildcard.hs b/test/TestWildcard.hs --- a/test/TestWildcard.hs +++ b/test/TestWildcard.hs @@ -74,7 +74,7 @@ , cubeParams = [] , expected = e } - in [ sugarTestEq "correct found count" sugarCube sample1 5 length + in [ sugarTestEq "correct found count" sugarCube sample1 9 length -- foo.ex is an associated name for foo, but removing its -- extension makes it a sibling for the expected file and @@ -104,7 +104,23 @@ , sw "bar." "bar" "bar." [ expE "bar.exp" "bar-ex" ] , sw "bar-ex" "bar" "bar-ex" [ exp "bar.exp" ] , sw "dog.bark" "dog.bark" "dog.bark" [ exp "dog.bark-exp" ] + -- rootName is a wildcard, so the expected can match the root: + , sw "bar.exp" "bar" "bar.exp" [ expE "bar.exp" "bar-ex" ] + , let r = "dog.bark-exp" in sw r "dog.bark" r [ exp r ] + , sw "foo.exp" "foo" "foo.exp" [ expE "foo.exp" "foo.ex" ] + , let r = "foo.right.exp" in sw r "foo.right" r [ exp r ] ] + + , testCase "full distinct results" $ + compareBags "default result" + (distinctResults $ fst $ findSugarIn sugarCube (sample1 sugarCube)) $ + let p = (testInpPath ) in + [ sw "foo" "foo" "foo" [ expE "foo.exp" "foo.ex" ] + , sw "foo.ex" "foo" "foo.ex" [ exp "foo.exp" ] + , sw "bar." "bar" "bar." [ expE "bar.exp" "bar-ex" ] + , sw "bar-ex" "bar" "bar-ex" [ exp "bar.exp" ] + , sw "dog.bark" "dog.bark" "dog.bark" [ exp "dog.bark-exp" ] + ] ] -- The second CUBE specifies no separators: the expected suffix @@ -168,7 +184,7 @@ , cubeParams = [] , expected = e } - in [ sugarTestEq "correct found count" sugarCube sample1 4 length + in [ sugarTestEq "correct found count" sugarCube sample1 7 length -- see notes for default seps tests above @@ -195,6 +211,11 @@ , sw "foo.ex" "foo" "foo.ex" [ exp "foo.exp" ] , sw "bar." "bar" "bar." [ expE "bar.exp" "bar-ex" ] , sw "bar-ex" "bar" "bar-ex" [ exp "bar.exp" ] + + -- rootName is a wildcard, so the expected can match the root: + , sw "bar.exp" "bar" "bar.exp" [ expE "bar.exp" "bar-ex" ] + , sw "foo.exp" "foo" "foo.exp" [ expE "foo.exp" "foo.ex" ] + , let r = "foo.right.exp" in sw r "foo.right" r [ exp r ] ] ]