tasty-sugar 1.0.1.1 → 1.1.0.0
raw patch · 13 files changed
+622/−54 lines, 13 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Test.Tasty.Sugar: paramMatchVal :: String -> ParamMatch -> Bool
- Test.Tasty.Sugar: withSugarGroups :: MonadIO m => [Sweets] -> (String -> [a] -> a) -> (Sweets -> Natural -> Expectation -> m a) -> m [a]
+ Test.Tasty.Sugar: withSugarGroups :: MonadIO m => [Sweets] -> (String -> [a] -> a) -> (Sweets -> Natural -> Expectation -> m [a]) -> m [a]
Files
- CHANGELOG.md +21/−0
- examples/example1/test-passthru-ascii.hs +5/−4
- examples/params/test-params.hs +1/−1
- src/Test/Tasty/Sugar.hs +19/−16
- src/internal/Test/Tasty/Sugar/AssocCheck.hs +2/−2
- src/internal/Test/Tasty/Sugar/ExpectCheck.hs +40/−20
- src/internal/Test/Tasty/Sugar/Types.hs +2/−0
- tasty-sugar.cabal +15/−3
- test/TestGCD.hs +149/−0
- test/TestMain.hs +13/−7
- test/TestNoAssoc.hs +20/−1
- test/TestStrlen2.hs +163/−0
- test/internals/test-internals.hs +172/−0
CHANGELOG.md view
@@ -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
examples/example1/test-passthru-ascii.hs view
@@ -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+ ]
examples/params/test-params.hs view
@@ -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
src/Test/Tasty/Sugar.hs view
@@ -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
src/internal/Test/Tasty/Sugar/AssocCheck.hs view
@@ -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
src/internal/Test/Tasty/Sugar/ExpectCheck.hs view
@@ -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
src/internal/Test/Tasty/Sugar/Types.hs view
@@ -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
tasty-sugar.cabal view
@@ -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
+ test/TestGCD.hs view
@@ -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+|]
test/TestMain.hs view
@@ -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
test/TestNoAssoc.hs view
@@ -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
+ test/TestStrlen2.hs view
@@ -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+|]
+ test/internals/test-internals.hs view
@@ -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 ---^^^---"+ ]