diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,26 @@ # Revision history for tasty-sugar +## 1.1.0.0 -- 2021-01-31 + + * Allow multiple tests to be generated for each `Expectation` via + `withSugarGroups` function. The `withSugarGroups` third argument + function (the test generator) now returns a list instead of a + single test. While roughly the same effect could have been + achieved by the test generator function using a `testGroup` to wrap + multiple tests, this change allows both (a) multiple tests to be + generated without requiring another level in the test heirarchy, + and (b) the generator can return an empty list if there should not + be any tests generated for the specified `Expectation`. + +## 1.0.2.0 -- 2021-01-31 + + * Export `paramMatchVal` utility function + + * Fix over-trimming of `Expectation` matches + + * Fix identification ranking of associated files + + ## 1.0.1.1 -- 2021-01-18 * Fix error where an expected set of matches could match multiple diff --git a/examples/example1/test-passthru-ascii.hs b/examples/example1/test-passthru-ascii.hs --- a/examples/example1/test-passthru-ascii.hs +++ b/examples/example1/test-passthru-ascii.hs @@ -17,7 +17,8 @@ test_passthru_ascii sweet cnt exp = do inp <- readFile $ rootFile sweet - return $ testCase ("checking #" <> show cnt <> ": " <> expectedFile exp) $ do - let testout = NiftyText.processText "passthru" "ascii" inp - out <- readFile $ expectedFile exp - out @=? testout + return [ testCase ("checking #" <> show cnt <> ": " <> expectedFile exp) $ do + let testout = NiftyText.processText "passthru" "ascii" inp + out <- readFile $ expectedFile exp + out @=? testout + ] diff --git a/examples/params/test-params.hs b/examples/params/test-params.hs --- a/examples/params/test-params.hs +++ b/examples/params/test-params.hs @@ -28,7 +28,7 @@ main = do testSweets <- findSugar cube elfTests <- withSugarGroups testSweets testGroup $ - \sweets expIdx expectation -> return $ + \sweets expIdx expectation -> return $ pure $ testCase (rootMatchName sweets <> " #" <> show expIdx) $ do e <- readFile $ expectedFile expectation let assoc = associated expectation 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 @@ -75,6 +75,7 @@ , Association , NamedParamMatch , ParamMatch(..) + , paramMatchVal ) where @@ -274,13 +275,13 @@ -- | The 'withSugarGroups' is the primary function used to run tests. -- Given a list of 'Sweets' returned by 'findSugar', a function to -- mark a group of tests (usually @Tasty.testGroup@), and a function --- to generate a test from a 'Sweets' and a specific 'Expectation', --- this will iterate over the supplied 'Sweets' and call the test --- generator for each valid test configuration. +-- to generate a number of tests from a 'Sweets' and a specific +-- 'Expectation', this will iterate over the supplied 'Sweets' and +-- call the test generator for each valid test configuration. -- -- Note that 'Sweets' contains all expectations (@[Expectation]@), but -- the passed 'Expectation' is the only one that should be tested for --- this generated test. +-- this set of generated tests. -- -- > withSugarGroups sweets groupFun mkTestFun -- @@ -289,23 +290,25 @@ -- * @groupFun@ is the function to group a set of tests with a -- specific name. Typically this can just be 'tasty.testGroup' -- --- * @mkTestFun@ is the function to create a specific test for the +-- * @mkTestFun@ is the function to create any specific tests for the -- specified expectation. The output type is usually a --- 'tasty.TestTree'. This is passed the general 'Sweets', the --- specific 'Expectation' for the test that should be created, and --- a numeric iteration indicating the test number within this --- group. The iteration number can be used for differentiation --- against the other tests, but there is no determinate --- relationship to elements of the 'Sweets' (such as parameters or --- associated sets). --- +-- @['Tasty.TestTree']@. This is passed the general 'Sweets', the +-- specific 'Expectation' for the tests that should be created, and +-- a numeric iteration indicating the 'Expectation' number within +-- this group. The iteration number can be used for +-- differentiation against the other tests, but there is no +-- determinate relationship to elements of the 'Sweets' (such as +-- parameters or associated sets). It is also possible to suppress +-- the generation of any tests for a particular 'Expectation' by +-- returning an empty list from the @mkTestFun@. + withSugarGroups :: MonadIO m => [Sweets] -> (String -> [a] -> a) -- Given a name and list of tests (aka -- 'TestTree'), group them (usually 'testGroup') - -> (Sweets -> Natural -> Expectation -> m a) - -- Generate a test for this 'Expectation' (usually + -> (Sweets -> Natural -> Expectation -> m [a]) + -- Generate any tests for this 'Expectation' (usually -- @a ~ TestTree@) -> m [a] withSugarGroups sweets mkGroup mkLeaf = @@ -316,7 +319,7 @@ -- mkParams iterates through the declared expected values to -- create a group for each actual value per expectation, calling -- the user-supplied mkLeaf at the leaf of each path. - mkParams sweet exp [] = mapM (uncurry $ mkLeaf sweet) $ zip [1..] exp + mkParams sweet exp [] = concat <$> (mapM (uncurry $ mkLeaf sweet) $ zip [1..] exp) mkParams sweet exp ((name,vspec):ps) = case vspec of Nothing -> do ts <- mkParams sweet exp ps diff --git a/src/internal/Test/Tasty/Sugar/AssocCheck.hs b/src/internal/Test/Tasty/Sugar/AssocCheck.hs --- a/src/internal/Test/Tasty/Sugar/AssocCheck.hs +++ b/src/internal/Test/Tasty/Sugar/AssocCheck.hs @@ -92,9 +92,9 @@ return (n+1, [s] <> v <> l, r) ((Assumed v):ps) -> do (n,l,r) <- sepParams sl ps if null sl - then return (n, v <> l, r) + then return (n+1, v <> l, r) else do s <- eachFrom sl - return (n, [s] <> v <> l, r) + return (n+1, [s] <> v <> l, r) npseq = eachFrom . ([]:) -- consider no parameters just once 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 @@ -4,6 +4,7 @@ module Test.Tasty.Sugar.ExpectCheck ( findExpectation + , removeNonExplicitMatchingExpectations ) where @@ -16,7 +17,6 @@ import Test.Tasty.Sugar.Types - -- | Finds the possible expected files matching the selected -- source. There will be either one or none. findExpectation :: CUBE @@ -37,7 +37,7 @@ expSuffix = expectedSuffix pat candidates = filter possible allNames possible f = and [ matchPrefix `L.isPrefixOf` f - , rootN /= f -- expected file cannot be the rootName file + , rootN /= f ] mkSweet e = Just $ Sweets { rootMatchName = rootN , rootBaseName = matchPrefix @@ -53,25 +53,9 @@ -- expectations. trimExpectations :: [Expectation] -> [Expectation] trimExpectations = - -- If a parameter is Explicitly matched, discard any - -- Expectation with Assumed matches. - (\l -> let removeNonExplicits lst entry = - let explParams = filter (isExplicit . snd) - (expParamsMatch entry) - removeNonExpl es explParam = - filter (noNonExplicit explParam) es - noNonExplicit (pn, Explicit pv) expl= - let chkPV (pn', pv') = - pn /= pn' || case pv' of - Explicit _ -> True - Assumed v -> v /= pv - NotSpecified -> False - in all chkPV $ expParamsMatch expl - noNonExplicit _ _ = True - in foldl removeNonExpl lst explParams - in foldl removeNonExplicits l l) - + -- Expectation with the same Assumed matches. + removeNonExplicitMatchingExpectations -- remove duplicates (uses the Eq instance for Expectation -- that ignores the order of the expParamsMatch and associated -- to ensure that different ordering with the same values @@ -158,3 +142,39 @@ else rootPrefix <> pmstr <> expSuffix guard (expFile `elem` allNames) return (expFile, pmcnt, pm) + + +removeNonExplicitMatchingExpectations :: [Expectation] -> [Expectation] +removeNonExplicitMatchingExpectations l = + let removeNonExplicits lst entry = + let (explParams, assumedParams) = + L.partition (isExplicit . snd) (expParamsMatch entry) + + -- only return False if oneExp should be + -- removed: i.e. it is an Expectation that + -- matches all non-explicit parameters and + -- has non-explicit matches for any of the + -- Explicit matches. + nonExplMatch oneExp = + or [ oneExp == entry + , not $ all nonExplParamCheck $ expParamsMatch oneExp + ] + + -- return True if this parameter check would + -- allow removal of this Explicit based on + -- _this_ parameter. + nonExplParamCheck (pn, pv) = + case lookup pn explParams of + Just (Explicit ev) -> + case pv of + Assumed av -> ev == av + NotSpecified -> True + Explicit ev' -> ev == ev' + _ -> -- generally nothing; other Just values not possible from explParams + case lookup pn assumedParams of + Nothing -> False + Just av -> av == pv + + in filter nonExplMatch lst + + in foldl removeNonExplicits l l diff --git a/src/internal/Test/Tasty/Sugar/Types.hs b/src/internal/Test/Tasty/Sugar/Types.hs --- a/src/internal/Test/Tasty/Sugar/Types.hs +++ b/src/internal/Test/Tasty/Sugar/Types.hs @@ -270,6 +270,8 @@ } deriving Show +-- | Equality comparisons of two 'Expectation' objects ignores the +-- order of the 'expParamsMatch' and 'associated' fields. instance Eq Expectation where e1 == e2 = let bagCmp a b = any (a ==) $ L.permutations b in and [ expectedFile e1 == expectedFile e2 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: 1.0.1.1 +version: 1.1.0.0 synopsis: Tests defined by Search Using Golden Answer References description: . @@ -99,13 +99,13 @@ main-is: TestMain.hs other-modules: TestMultiAssoc TestNoAssoc + TestGCD TestSingleAssoc + TestStrlen2 TestParamsAssoc TestUtils TestWildcard Sample1 - -- TestExpected - -- TestSamples build-depends: base >= 4 , filepath , hedgehog @@ -142,3 +142,15 @@ , tasty , tasty-hunit , tasty-sugar + +test-suite test-internals + type: exitcode-stdio-1.0 + hs-source-dirs: test/internals + default-language: Haskell2010 + GHC-options: -fhide-source-paths + main-is: test-internals.hs + build-depends: base + , pretty-show + , tasty + , tasty-hunit + , tasty-sugar-internal diff --git a/test/TestGCD.hs b/test/TestGCD.hs new file mode 100644 --- /dev/null +++ b/test/TestGCD.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module TestGCD ( gcdSampleTests ) where + +import Data.List +import System.FilePath ( () ) +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Test.Tasty.Sugar +import TestUtils +import Text.RawString.QQ + + +testInpPath = "test-data/samples" + +testParams = [ ("solver", Just ["z3", "yices", "boolector", "cvc4"]) + , ("loop-merging", Just ["loopmerge", "loop"]) + ] + +sugarCube = mkCUBE + { rootName = "*.c" + , expectedSuffix = "good" + , inputDir = testInpPath + , associatedNames = [ ("config", "config") + , ("stdio", "print") + , ("haskell", "hs") + ] + , validParams = testParams + } + +gcdSampleTests :: [TT.TestTree] +gcdSampleTests = + let (sugar,sdesc) = findSugarIn sugarCube gcdSamples + in [ testCase "valid sample" $ 20 @=? length gcdSamples + , sugarTestEq "correct found count" sugarCube gcdSamples 1 length + + , testCaseSteps "sweets info" $ \step -> do + step "rootMatchName" + (rootMatchName <$> sugar) @?= ["gcd-test.c"] + step "rootBaseName" + (rootBaseName <$> sugar) @?= ["gcd-test"] + step "rootFile" + (rootFile <$> sugar) @?= [ testInpPath "gcd-test.c" ] + step "cubeParams" + (cubeParams <$> sugar) @?= [ validParams sugarCube ] + + , testCase "Expectations" $ compareBags "expected" (expected $ head sugar) $ + let p = (testInpPath ) in + [ + Expectation + { expectedFile = p "gcd-test.boolector.good" + , expParamsMatch = [ ("solver", Explicit "boolector") + , ("loop-merging", Assumed "loopmerge") + ] + , associated = [ ("config", p "gcd-test.loopmerge.config") + , ("stdio", p "gcd-test.boolector.print") + ] + } + , Expectation + { expectedFile = p "gcd-test.boolector.good" + , expParamsMatch = [ ("solver", Explicit "boolector") + , ("loop-merging", Assumed "loop") + ] + , associated = [ ("config", p "gcd-test.config") + , ("stdio", p "gcd-test.boolector.print") + ] + } + + , Expectation + { expectedFile = p "gcd-test.good" + , expParamsMatch = [ ("solver", Assumed "cvc4") + , ("loop-merging", Assumed "loopmerge") + ] + , associated = [ ("config", p "gcd-test.loopmerge.config") + , ("stdio", p "gcd-test.print") + ] + } + , Expectation + { expectedFile = p "gcd-test.good" + , expParamsMatch = [ ("solver", Assumed "cvc4") + , ("loop-merging", Assumed "loop") + ] + , associated = [ ("config", p "gcd-test.config") + , ("stdio", p "gcd-test.print") + ] + } + + , Expectation + { expectedFile = p "gcd-test.good" + , expParamsMatch = [ ("solver", Assumed "yices") + , ("loop-merging", Assumed "loopmerge") + ] + , associated = [ ("config", p "gcd-test.loopmerge.config") + , ("stdio", p "gcd-test.print") + ] + } + , Expectation + { expectedFile = p "gcd-test.good" + , expParamsMatch = [ ("solver", Assumed "yices") + , ("loop-merging", Assumed "loop") + ] + , associated = [ ("config", p "gcd-test.config") + , ("stdio", p "gcd-test.print") + ] + } + + , Expectation + { expectedFile = p "gcd-test.good" + , expParamsMatch = [ ("solver", Assumed "z3") + , ("loop-merging", Assumed "loopmerge") + ] + , associated = [ ("config", p "gcd-test.loopmerge.config") + , ("stdio", p "gcd-test.print") + ] + } + , Expectation + { expectedFile = p "gcd-test.good" + , expParamsMatch = [ ("solver", Assumed "z3") + , ("loop-merging", Assumed "loop") + ] + , associated = [ ("config", p "gcd-test.config") + , ("stdio", p "gcd-test.print") + ] + } + ] + ] + +gcdSamples = lines [r| +gcd-test.boolector.boolector.out +gcd-test.boolector.boolector.print.out +gcd-test.boolector.good +gcd-test.boolector.print +gcd-test.c +gcd-test.config +gcd-test.cvc4.out +gcd-test.cvc4.print.out +gcd-test.good +gcd-test.loopmerge.config +gcd-test.print +gcd-test.stp.good +gcd-test.stp.print +gcd-test.stp.stp.out +gcd-test.stp.stp.print.out +gcd-test.yices.out +gcd-test.yices.print.out +gcd-test.z3.out +gcd-test.z3.print.out +|] diff --git a/test/TestMain.hs b/test/TestMain.hs --- a/test/TestMain.hs +++ b/test/TestMain.hs @@ -17,17 +17,24 @@ import Data.Text.Prettyprint.Doc #endif +import TestGCD import TestMultiAssoc import TestNoAssoc +import TestParamsAssoc import TestSingleAssoc +import TestStrlen2 import TestUtils -import TestParamsAssoc import TestWildcard main :: IO () -main = defaultMain $ - testGroup "tasty-sweet tests" +main = + let namedGenGroup groupName tests = + return $ testGroup (groupName <> " generated") tests + in + do generatedTests <- namedGenGroup "no association" <$> mkNoAssocTests + defaultMain $ + testGroup "tasty-sweet tests" $ [ testProperty "empty file list" $ HH.withTests 10000 $ HH.property $ do cube <- HH.forAll $ genCube @@ -104,13 +111,12 @@ , testGroup "multiple associated files" $ multiAssocTests , testGroup "params association" $ paramsAssocTests , testGroup "wildcard tests" $ wildcardAssocTests - ] + , testGroup "gcd sample tests" $ gcdSampleTests + , testGroup "strlen2 sample tests" $ strlen2SampleTests + ] <> generatedTests runTestOrErr :: CUBE -> IO (Either String String) runTestOrErr c = bimap (head . lines . show) show <$> (try (return $! findSugarIn c []) :: IO (Either SomeException ([Sweets], Doc ann))) - - -- , testGroup "samples tests" $ samplesTests - -- , testGroup "expected matching" $ expectedTests diff --git a/test/TestNoAssoc.hs b/test/TestNoAssoc.hs --- a/test/TestNoAssoc.hs +++ b/test/TestNoAssoc.hs @@ -1,11 +1,12 @@ {-# LANGUAGE ScopedTypeVariables #-} -module TestNoAssoc ( noAssocTests ) where +module TestNoAssoc ( noAssocTests, mkNoAssocTests ) where import Data.List import System.FilePath ( () ) import qualified Test.Tasty as TT import Test.Tasty.HUnit +import Test.Tasty.Runners ( testsNames ) import Test.Tasty.Sugar import TestUtils @@ -225,3 +226,21 @@ } ] ] + + +mkNoAssocTests :: IO [TT.TestTree] +mkNoAssocTests = + let (sugar1,s1desc) = findSugarIn sugarCube sample1 + in do tt <- withSugarGroups sugar1 TT.testGroup $ + \sw idx exp -> + -- Verify this will suppress the "refined" tests for + -- "looping-around.c" + if (rootMatchName sw == "looping-around.c" && + Just (Assumed "refined") == lookup "form" (expParamsMatch exp)) + then (return []) + else return [ testCase (rootMatchName sw <> "." <> show idx) $ + return () + ] + return $ + (testCase "generated count" $ 21 @=? length (concatMap (testsNames mempty) tt)) + : tt diff --git a/test/TestStrlen2.hs b/test/TestStrlen2.hs new file mode 100644 --- /dev/null +++ b/test/TestStrlen2.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module TestStrlen2 ( strlen2SampleTests ) where + +import Data.List +import System.FilePath ( () ) +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Test.Tasty.Sugar +import TestUtils +import Text.RawString.QQ + + +testInpPath = "test-data/samples" + +testParams = [ ("solver", Just ["z3", "yices", "boolector", "cvc4"]) + , ("loop-merging", Just ["loopmerge", "loop"]) + ] + +sugarCube = mkCUBE + { rootName = "*.c" + , expectedSuffix = "good" + , inputDir = testInpPath + , associatedNames = [ ("config", "config") + , ("stdio", "print") + ] + , validParams = testParams + } + +strlen2SampleTests :: [TT.TestTree] +strlen2SampleTests = + let (sugar,sdesc) = findSugarIn sugarCube strlen2Samples + in [ testCase "valid sample" $ 25 @=? length strlen2Samples + , sugarTestEq "correct found count" sugarCube strlen2Samples 1 length + + , testCaseSteps "sweets info" $ \step -> do + step "rootMatchName" + (rootMatchName <$> sugar) @?= ["strlen_test2.c"] + step "rootBaseName" + (rootBaseName <$> sugar) @?= ["strlen_test2"] + step "rootFile" + (rootFile <$> sugar) @?= [ testInpPath "strlen_test2.c" ] + step "cubeParams" + (cubeParams <$> sugar) @?= [ validParams sugarCube ] + + , testCase "Expectations" $ compareBags "expected" (expected $ head sugar) $ + let p = (testInpPath ) in + [ + Expectation + { expectedFile = p "strlen_test2.boolector.loopmerge.good" + , expParamsMatch = [ ("solver", Explicit "boolector") + , ("loop-merging", Explicit "loopmerge") + ] + , associated = [ ("config", p "strlen_test2.loopmerge.config") + , ("stdio", p "strlen_test2.print") + ] + } + , Expectation + { expectedFile = p "strlen_test2.boolector.good" + , expParamsMatch = [ ("solver", Explicit "boolector") + , ("loop-merging", Assumed "loop") + ] + , associated = [ ("stdio", p "strlen_test2.print") + ] + } + + , Expectation + { expectedFile = p "strlen_test2.loopmerge.cvc4.good" + , expParamsMatch = [ ("solver", Explicit "cvc4") + , ("loop-merging", Explicit "loopmerge") + ] + , associated = [ ("config", p "strlen_test2.loopmerge.config") + , ("stdio", p "strlen_test2.print") + ] + } + , Expectation + { expectedFile = p "strlen_test2.cvc4.loop.good" + , expParamsMatch = [ ("solver", Explicit "cvc4") + , ("loop-merging", Explicit "loop") + ] + , associated = [ ("stdio", p "strlen_test2.print") + ] + } + + , Expectation + { expectedFile = p "strlen_test2.loopmerge.good" + , expParamsMatch = [ ("loop-merging", Explicit "loopmerge") + , ("solver", Assumed "yices") + ] + , associated = [ ("config", p "strlen_test2.loopmerge.config") + , ("stdio", p "strlen_test2.print") + ] + } + , Expectation + { expectedFile = p "strlen_test2.good" + , expParamsMatch = [ ("loop-merging", Assumed "loop") + , ("solver", Assumed "yices") + ] + , associated = [ ("stdio", p "strlen_test2.print") + ] + } + + , Expectation + { expectedFile = p "strlen_test2.z3.good" + , expParamsMatch = [ ("solver", Explicit "z3") + , ("loop-merging", Assumed "loopmerge") + ] + , associated = [ ("config", p "strlen_test2.loopmerge.config") + , ("stdio", p "strlen_test2.print") + ] + } + , Expectation + { expectedFile = p "strlen_test2.z3.good" + , expParamsMatch = [ ("solver", Explicit "z3") + , ("loop-merging", Assumed "loop") + ] + , associated = [ ("stdio", p "strlen_test2.print") + ] + } + , Expectation + { expectedFile = p "strlen_test2.loopmerge.good" + , expParamsMatch = [ ("loop-merging", Explicit "loopmerge") + , ("solver", Assumed "z3") + ] + , associated = [ ("config", p "strlen_test2.loopmerge.config") + , ("stdio", p "strlen_test2.print") + ] + } + ] + ] + +-- Note that there exists strlen_test2.z3.good and +-- strlen_test2.loopmerge.good, so this will create Expectations +-- against _each_ file with different sets of Assumed and Explicit +-- parameters. + +strlen2Samples = lines [r| +strlen_test2.boolector.boolector.out +strlen_test2.boolector.boolector.print.out +strlen_test2.boolector.good +strlen_test2.boolector.loopmerge.good +strlen_test2.c +strlen_test2.cvc4.cvc4.out +strlen_test2.cvc4.cvc4.print.out +strlen_test2.cvc4.loop.good +strlen_test2.loopmerge.cvc4.good +strlen_test2.good +strlen_test2.loopmerge.config +strlen_test2.loopmerge.good +strlen_test2.loopmerge.stp.out +strlen_test2.loopmerge.stp.print.out +strlen_test2.loopmerge.yices.out +strlen_test2.loopmerge.yices.print.out +strlen_test2.print +strlen_test2.stp.out +strlen_test2.stp.print.out +strlen_test2.yices.out +strlen_test2.yices.print.out +strlen_test2.z3.good +strlen_test2.z3.z3.out +strlen_test2.z3.z3.print.out +|] diff --git a/test/internals/test-internals.hs b/test/internals/test-internals.hs new file mode 100644 --- /dev/null +++ b/test/internals/test-internals.hs @@ -0,0 +1,172 @@ +module Main where + +import Control.Monad ( unless ) +import qualified Data.List as L +import Test.Tasty +import Test.Tasty.HUnit +import Text.Show.Pretty + +import Test.Tasty.Sugar.Types +import Test.Tasty.Sugar.ExpectCheck + + +main = defaultMain $ + let sample = + [ + Expectation + { + expectedFile = "test.file" + , expParamsMatch = + [ ("foo", Explicit "a") + , ("bar", Explicit "b") + , ("cow", Assumed "moo") + ] + , associated = [] + } + + , Expectation + { + expectedFile = "test.file" + , expParamsMatch = + [ ("foo", Explicit "a") + , ("bar", Explicit "b") + , ("cow", Assumed "milk") + ] + , associated = [] + } + + -- KWQ: inverse here, more specific 0th entry supercedes this one + -- , Expectation + -- { + -- expectedFile = "test.file" + -- , expParamsMatch = + -- [ ("foo", Explicit "a") + -- , ("cow", Assumed "moo") + -- ] + -- , associated = [] + -- } + + , Expectation + { + expectedFile = "test.file" + , expParamsMatch = + [ ("foo", Explicit "other") + , ("bar", Explicit "b") + , ("cow", Assumed "moo") + ] + , associated = [] + } + + , Expectation + { + expectedFile = "test.file" + , expParamsMatch = + [ ("foo", Assumed "a") + , ("bar", Explicit "b") + , ("cow", Assumed "moo") + ] + , associated = [] + } + + -- -- KWQ: more specific than the 0th entry, so this supercedes that entry (separate test) + -- , Expectation + -- { expectedFile = "test.file" + -- , expParamsMatch = + -- [ ("foo", Explicit "a") + -- , ("bar", Explicit "b") + -- , ("cow", Assumed "moo") + -- , ("frog", Explicit "croak") + -- ] + -- , associated = [] + -- } + + ] + in testGroup "Expected trimming" + [ testCase "non-explicit removals" $ + pCmpExp (init sample) + (removeNonExplicitMatchingExpectations sample) + + , testCase "supermatch supercedes" $ + -- Normally the trimming occurs on Expectations which all have + -- a matching named set of expParamsMatch even though the + -- values may be different. If, however, and Expectation + -- exists which has _more_ params than the rest, it will + -- supercede any Expectation that has the same set but fewer, + -- as this test checks. This test is not critical to overall + -- functionality, but serves to capture behavior. + let adding = Expectation + { expectedFile = "test.file" + , expParamsMatch = + [ ("foo", Explicit "a") + , ("bar", Explicit "b") + , ("cow", Assumed "moo") + , ("frog", Explicit "croak") + ] + , associated = [] + } + test l = pCmpExp (adding : (tail $ init sample)) + (removeNonExplicitMatchingExpectations l) + in mapM test (L.permutations $ adding : sample) + >> return () + + , testCase "submatch removed" $ + -- This is the inverse of the supermatch: an entry is added + -- that has fewer params, and it is elided in favor of an entry + -- that has matching params plus additional params. + let adding = Expectation + { + expectedFile = "test.file" + , expParamsMatch = + [ ("foo", Explicit "a") + , ("cow", Assumed "moo") + ] + , associated = [] + } + test l = pCmpExp (init sample) + (removeNonExplicitMatchingExpectations l) + in mapM test (L.permutations $ adding : sample) + >> return () + + , testCase "superset and subset distinct" $ + -- As a variation of the supermatch and submatch tests, if an + -- Expectation exists that has a different number of params but + -- the params that are present are not a strict subset, then + -- that is simply treated as a different Expectation than the + -- others and doesn't affect matching removal. + let adding = [ Expectation + { expectedFile = "test.file" + , expParamsMatch = + [ ("foo", Explicit "a") + , ("bar", Explicit "bell") + , ("cow", Assumed "moo") + , ("frog", Explicit "croak") + ] + , associated = [] + } + , Expectation + { expectedFile = "test.file" + , expParamsMatch = + [ ("foo", Explicit "a") + , ("cow", Explicit "moo") + ] + , associated = [] + } + ] + test l = pCmpExp (adding <> init sample) + (removeNonExplicitMatchingExpectations l) + in mapM test (L.permutations $ adding <> sample) + >> return () + + ] + + +pCmpExp expected actual = + unless (expected `elem` L.permutations actual) $ + assertFailure $ unlines + ["MISMATCH ---vvv---" + ,"----- Expected [" <> show (length expected) <> "]:" + , ppShow expected + ,"----- Actual [" <> show (length actual) <> "]:" + , ppShow actual + ,"MISMATCH ---^^^---" + ]