diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. 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 @@ -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 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 @@ -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 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.0.0 +version: 1.0.1.0 synopsis: Tests defined by Search Using Golden Answer References description: . diff --git a/test/Sample1.hs b/test/Sample1.hs --- a/test/Sample1.hs +++ b/test/Sample1.hs @@ -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 diff --git a/test/TestMultiAssoc.hs b/test/TestMultiAssoc.hs --- a/test/TestMultiAssoc.hs +++ b/test/TestMultiAssoc.hs @@ -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") diff --git a/test/TestNoAssoc.hs b/test/TestNoAssoc.hs --- a/test/TestNoAssoc.hs +++ b/test/TestNoAssoc.hs @@ -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 [ diff --git a/test/TestSingleAssoc.hs b/test/TestSingleAssoc.hs --- a/test/TestSingleAssoc.hs +++ b/test/TestSingleAssoc.hs @@ -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 [