tasty-sugar 1.0.0.0 → 1.0.1.0
raw patch · 8 files changed
+89/−28 lines, 8 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +11/−0
- src/internal/Test/Tasty/Sugar/AssocCheck.hs +39/−22
- src/internal/Test/Tasty/Sugar/Types.hs +1/−1
- tasty-sugar.cabal +1/−1
- test/Sample1.hs +3/−0
- test/TestMultiAssoc.hs +18/−2
- test/TestNoAssoc.hs +8/−1
- test/TestSingleAssoc.hs +8/−1
CHANGELOG.md view
@@ -1,5 +1,16 @@ # Revision history for tasty-sugar +## 1.0.1.0 -- 2021-01-18++ * Associated files are now ranked based on the number of parameter+ components in the name and only the highest number of matches are+ provided. Previously all possible matches were supplied, which+ meant that "more generic" associations caused an Expectation in+ addition to the "more specific" associations. Now only the "more+ specific" assocations cause an Expectation.++ * Better indentation on Expectation information for --showsearch.+ ## 1.0.0.0 -- 2021-01-14 * Allow multiple CUBE inputs for a single test session; Sweets are a semigroup.
src/internal/Test/Tasty/Sugar/AssocCheck.hs view
@@ -29,22 +29,36 @@ -> Logic [(String, FilePath)] getAssoc rootPrefix seps pmatch assocNames allNames = assocSet where- assocSet = catMaybes <$> mapM fndAnAssoc assocNames+ assocSet = concat <$> mapM fndBestAssoc assocNames + fndBestAssoc :: (String, FileSuffix)+ -> Logic [(String, FilePath)] -- usually just one+ fndBestAssoc assoc =+ do let candidates = L.nub $ catMaybes $+ observeAll (fndAnAssoc assoc)+ let highestRank = maximum (fst <$> candidates)+ c = filter ((== highestRank) . fst) candidates+ if null candidates+ then return []+ else return (snd <$> c)++ fndAnAssoc :: (String, FileSuffix)+ -> Logic (Maybe (Int, (String, FilePath))) fndAnAssoc assoc = ifte (fndAssoc assoc) (return . Just) (return Nothing) + fndAssoc :: (String, FileSuffix) -> Logic (Int, (String, FilePath)) fndAssoc assoc = do pseq <- npseq pmatch- (assocPfx, assocSfx) <- sepParams seps (fmap snd pseq)+ (rank, assocPfx, assocSfx) <- sepParams seps (fmap snd pseq) if null assocSfx then do let assocNm = if null (snd assoc) && length assocPfx == 1 -- just a separator then rootPrefix else rootPrefix <> assocPfx <> (snd assoc) guard (assocNm `elem` allNames)- return (fst assoc, assocNm)+ return (rank, (fst assoc, assocNm)) else let assocStart = rootPrefix <> assocPfx assocEnd = assocSfx <> snd assoc aSL = length assocStart@@ -58,26 +72,29 @@ ] fnd = filter possible allNames in do f <- eachFrom fnd- return (fst assoc, f)+ return (rank, (fst assoc, f)) - sepParams :: Separators -> [ParamMatch] -> Logic (String, String)- sepParams sl = \case- [] -> if null sl- then return ([], [])- else do s <- eachFrom sl- return ([s], [])- (NotSpecified:ps) -> do r <- sepParams sl ps- return ([], fst r)- ((Explicit v):ps) -> do (l,r) <- sepParams sl ps- if null sl- then return (v <> l, r)- else do s <- eachFrom sl- return ([s] <> v <> l, r)- ((Assumed v):ps) -> do (l,r) <- sepParams sl ps- if null sl- then return (v <> l, r)- else do s <- eachFrom sl- return ([s] <> v <> l, r)+ sepParams :: Separators -> [ParamMatch] -> Logic (Int, String, String)+ sepParams sl =+ let rank (n,_,_) = n+ pfx (_,l,_) = l+ in \case+ [] -> if null sl+ then return (0, [], [])+ else do s <- eachFrom sl+ return (0, [s], [])+ (NotSpecified:ps) -> do r <- sepParams sl ps+ return (rank r, [], pfx r)+ ((Explicit v):ps) -> do (n,l,r) <- sepParams sl ps+ if null sl+ then return (n+1, v <> l, r)+ else do s <- eachFrom sl+ 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)+ else do s <- eachFrom sl+ return (n, [s] <> v <> l, r) npseq = eachFrom . ([]:) -- consider no parameters just once
src/internal/Test/Tasty/Sugar/Types.hs view
@@ -288,7 +288,7 @@ pa = if null a then Nothing else Just $ "Associated:" <+> (align $ vsep $ map pretty a)- in align $ vsep $ catMaybes+ in hang 4 $ vsep $ catMaybes [ Just $ "Expected: " <+> (align $ pretty (expectedFile exp)) , pp , pa
tasty-sugar.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 name: tasty-sugar-version: 1.0.0.0+version: 1.0.1.0 synopsis: Tests defined by Search Using Golden Answer References description: .
test/Sample1.hs view
@@ -15,6 +15,7 @@ jumpfar.c jumpfar.h jumpfar.ppc.exe+jumpfar.ppc.o jumpfar.ppc.expected jumpfar.x86.exe jumpfar.x86.expected@@ -39,6 +40,8 @@ switching_many.ppc.exe switching.ppc.base-expected switching.ppc.o+switching.ppc.base.o+switching.ppc.extra.o switching.ppc.other switching.ppc.exe switching.x86.base-expected
test/TestMultiAssoc.hs view
@@ -33,8 +33,15 @@ multiAssocTests :: [TT.TestTree] multiAssocTests = let (sugar1,_s1desc) = findSugarIn sugarCube sample1- in [ testCase "valid sample" $ 50 @=? length sample1+ in [++ -- This is simply the number of entries in sample1; if this+ -- fails in means that sample1 has been changed and the other+ -- tests here are likely to need updating.+ testCase "valid sample" $ 53 @=? length sample1+ , sugarTestEq "correct found count" sugarCube sample1 5 length+ , testCase "results" $ compareBags "results" sugar1 $ let p = (testInpPath </>) in [@@ -104,6 +111,8 @@ , ("form" , Assumed "base") ] , associated = [ ("exe", p "jumpfar.ppc.exe") , ("include", p "jumpfar.h")+ -- The x86 versions should not match this+ , ("obj", p "jumpfar.ppc.o") ] } , Expectation@@ -112,6 +121,8 @@ , ("form" , Assumed "refined") ] , associated = [ ("exe", p "jumpfar.ppc.exe") , ("include", p "jumpfar.h")+ -- The x86 versions should not match this+ , ("obj", p "jumpfar.ppc.o") ] } ]@@ -173,7 +184,12 @@ , ("arch", Explicit "ppc") ] , associated = [ ("exe", p "switching.ppc.exe")- , ("obj", p "switching.ppc.o")+ -- Note: uses switching.ppc.base.o+ -- and not switching.ppc.o--or+ -- both--because the former is a+ -- more explicit match against the+ -- expParamsMatch.+ , ("obj", p "switching.ppc.base.o") , ("include", p "switching.h") , ("c++-include", p "switching.hh") , ("plain", p "switching")
test/TestNoAssoc.hs view
@@ -26,8 +26,15 @@ noAssocTests :: [TT.TestTree] noAssocTests = let (sugar1,s1desc) = findSugarIn sugarCube sample1- in [ testCase "valid sample" $ 50 @=? length sample1+ in [++ -- This is simply the number of entries in sample1; if this+ -- fails in means that sample1 has been changed and the other+ -- tests here are likely to need updating.+ testCase "valid sample" $ 53 @=? length sample1+ , sugarTestEq "correct found count" sugarCube sample1 5 length+ , testCase "results" $ compareBags "results" sugar1 $ let p = (testInpPath </>) in [
test/TestSingleAssoc.hs view
@@ -27,8 +27,15 @@ singleAssocTests :: [TT.TestTree] singleAssocTests = let (sugar1,_s1desc) = findSugarIn sugarCube sample1- in [ testCase "valid sample" $ 50 @=? length sample1+ in [++ -- This is simply the number of entries in sample1; if this+ -- fails in means that sample1 has been changed and the other+ -- tests here are likely to need updating.+ testCase "valid sample" $ 53 @=? length sample1+ , sugarTestEq "correct found count" sugarCube sample1 5 length+ , testCase "results" $ compareBags "results" sugar1 $ let p = (testInpPath </>) in [