diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ # Revision history for tasty-sugar +## 2.2.0.0 -- 2023-05-03 + + * Added `rangedParamAdjuster` helper function. + * Added `sweetAdjuster` field to `CUBE`. + * The `findSugarIn` function is now monadic with a MonadIO constraint (ato + support sweetAdjuster functionality). + * Exports `candidateToPath`, which was added in a previous version but not made + publicly available. + * The `--showsearch` output is switched to sorted order and provides a (correct) + total count. + * Parameter names are included in the test names along with the value. + ## 2.1.0.0 -- 2023-03-20 * Now supports the ability for the expected file to have the same name as the diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -360,6 +360,38 @@ leaving the ~sample.expected~ to be used only for the ~simple.opt-clang.exe~ file. +** Parameter ranges + + In some cases, there are a large number of possible parameter values, but the + expected files change for only some of the parameter variations. While this + could normally be handled by an expected file with no corresponding parameter + value in its name to represent the default case, this is somewhat more + difficult when there are multiple "defaults". This is handled by _parameter + ranges_. + + As an example parameter range, consider a situation that might test the output + of the llvm assembler. The llvm assembler output tends to be unchanged over a + couple of versions, but then there will be a change (e.g. adding a new LLVM + assembly instruction in llvm version 14) that will change the output, but the + new format will become the default output. + + Conventionally, having a ~target.ll~ assembly file as the original default + expected file means that for every version starting at 14, there will be a + specific expected file (e.g. ~target-llvm14.ll~, ~target-llvm15.ll~, + ~target-llvm16.ll~, ...) even though all of those files are identical. + + To address this, the parameter values can specify an upper or lower range limit + and use the ~rangedParamAdjuster~ to adjust the Expectations generated. Using + this, the expected files could be something like ~target-llvm_pre12.ll~, + ~target-llvm_pre14.ll~, ~target.ll~, along with an indication that the + parameter value of ~llvm_preN~ formed an upper limit. When used this way, the + ~target-llvm_pre12.ll~ file will be chosen for versions 10 and 11 of llvm, the + ~target-llvm_pre14.ll~ file would be chosen for versions 12 and 13 of llvm, and + the ~target.ll~ file would be chosen for llvm version 14 or higher. + + For more information, see the documentation for the ~rangedParamAdjuster~ + helper function, and the corresponding tests. + # ** Multiple Inputs with different parameters producing different outputs # # KWQ... 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 @@ -52,7 +52,6 @@ -- -- See the README for more information. -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -65,7 +64,6 @@ -- * Test Generation Functions , findSugar , findSugarIn - , distinctResults , withSugarGroups -- * Types @@ -77,6 +75,7 @@ , CandidateFile(..) , makeCandidate , findCandidates + , candidateToPath -- ** Output , Sweets(..) , Expectation(..) @@ -85,7 +84,12 @@ , ParamMatch(..) , paramMatchVal , getParamVal - -- ** Reporting + + -- * Helper and Optional functions + , distinctResults + , rangedParamAdjuster + + -- * Reporting , sweetsKVITable , sweetsTextTable ) @@ -112,6 +116,7 @@ import Test.Tasty.Sugar.Analysis import Test.Tasty.Sugar.Candidates +import Test.Tasty.Sugar.Ranged ( rangedParamAdjuster ) import Test.Tasty.Sugar.Report import Test.Tasty.Sugar.Types @@ -156,13 +161,14 @@ putStrLn "" mapM_ (putStrLn . show . snd) searchinfo putStrLn "" - putStrLn ("Final set of tests [" ++ - show (sum $ fmap (length . fst) searchinfo) ++ - "]:") + let ttlNum = sum $ join + $ fmap (fmap (length . expected) . fst) searchinfo + putStrLn ("Final set of tests [" ++ show ttlNum ++ "]:") putStrLn $ show $ vsep $ concatMap (map (("•" <+>) . align . pretty) . fst) searchinfo putStrLn "" - putStrLn $ T.unpack $ sweetsTextTable pats $ + putStrLn $ T.unpack $ sweetsTextTable pats $ reverse $ F.fold (fst <$> searchinfo) + putStrLn $ "Total: " <> show ttlNum <> " tests" return True else Nothing @@ -185,7 +191,7 @@ $ L.nub $ inputDir pat : inputDirs pat)) mapM_ (liftIO . hPutStrLn stderr . ("WARNING: " <>)) $ lefts candidates - return $ findSugarIn pat $ rights candidates + findSugarIn pat $ rights candidates -- | Given a list of filepaths and a CUBE, returns the list of matching @@ -193,11 +199,17 @@ -- process (describing unmatched possibilities as well as valid test -- configurations). -- --- This is a low-level function; the findSugar and withSugarGroups are --- the recommended interface functions to use for writing tests. +-- This is a low-level function; the findSugar and withSugarGroups are the +-- recommended interface functions to use for writing tests. -findSugarIn :: CUBE -> [CandidateFile] -> ([Sweets], Doc ann) -findSugarIn pat allFiles = +findSugarIn :: MonadIO m => CUBE -> [CandidateFile] -> m ([Sweets], Doc ann) +findSugarIn pat allFiles = do + let (swts, info) = findSugarIn' pat allFiles + sweets <- sweetAdjuster pat pat swts + return (sweets, info) + +findSugarIn' :: CUBE -> [CandidateFile] -> ([Sweets], Doc ann) +findSugarIn' pat allFiles = let (nCandidates, sres, stats) = checkRoots pat allFiles inps = concat $ fst <$> sres expl = vsep $ @@ -302,8 +314,8 @@ -- | 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 expected to be registered in the 'sweetAdjuster' field of the 'CUBE' +-- if it is used. -- -- 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 @@ -364,7 +376,9 @@ -- 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 [] = concat <$> (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 -> @@ -378,7 +392,8 @@ ) in mkGroup gn <$> mkParams sweet es ps in sequence $ f <$> expGrps - Just vs -> let f v = mkGroup v <$> mkParams sweet (subExp v) ps + Just vs -> let f v = mkGroup (name <> "=" <> v) + <$> mkParams sweet (subExp v) ps subExp v = expMatching name v exp in sequence $ f <$> L.sort vs diff --git a/src/internal/Test/Tasty/Sugar/Candidates.hs b/src/internal/Test/Tasty/Sugar/Candidates.hs --- a/src/internal/Test/Tasty/Sugar/Candidates.hs +++ b/src/internal/Test/Tasty/Sugar/Candidates.hs @@ -2,6 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} +-- | This module provides management for tracking candidate files that might be a +-- root file, an expected file, or an associated file. + module Test.Tasty.Sugar.Candidates ( candidateToPath @@ -26,6 +29,10 @@ import Test.Tasty.Sugar.Types +-- | Given a CUBE and a target directory, find all files in that directory and +-- subdirectories that could be candidates for processing with tasty-sugar. Each +-- file is turned into a candidate via the 'makeCandidate' function. + findCandidates :: CUBE -> FilePath -> IO ([Either String CandidateFile]) findCandidates cube inDir = let collectDirEntries d = @@ -75,7 +82,7 @@ -- -- * All possible filename portions and sub-paths will be suggested for non-value -- * parameters (validParams with Nothing). --- + makeCandidate :: CUBE -> FilePath -> [String] -> FilePath -> CandidateFile makeCandidate cube topDir subPath fName = let fl = DL.length fName @@ -175,7 +182,9 @@ in foldr rmvKnown (first toEnum <$> r') (DL.sort p') --- | This converts a CandidatFile into a regular FilePath for access +-- | This converts a CandidateFile into a regular FilePath for access by standard +-- IO operations. + candidateToPath :: CandidateFile -> FilePath candidateToPath c = candidateDir c foldr () (candidateFile c) (candidateSubdirs c) @@ -196,6 +205,13 @@ else cl - 1 in mStart == DL.take (fromEnum pfxlen) f + +-- | Determines if the second candidate file matches the first by virtue of +-- having the same identified suffix. If a non-null suffix is specified then +-- verify the second file is the conjunction of the first file with a separator +-- and the specified suffix with appropriate considerations for any separator in +-- the supplied suffix. If no suffix is provided, then simply ensure that the +-- second file has no suffix. candidateMatchSuffix :: Separators -> FileSuffix -> CandidateFile -> CandidateFile -> Bool diff --git a/src/internal/Test/Tasty/Sugar/Ranged.hs b/src/internal/Test/Tasty/Sugar/Ranged.hs new file mode 100644 --- /dev/null +++ b/src/internal/Test/Tasty/Sugar/Ranged.hs @@ -0,0 +1,255 @@ +-- | Provides the rangedParam and rangedParamAdjuster helper functions. + +{-# LANGUAGE LambdaCase #-} + +module Test.Tasty.Sugar.Ranged + ( rangedParam + , rangedParamAdjuster + ) +where + +import Control.Applicative ( liftA2 ) +import Control.Monad.IO.Class ( MonadIO ) +import Data.Function ( on ) +import qualified Data.List as L +import Data.Maybe ( isNothing ) +import qualified Data.Set as Set + +import Test.Tasty.Sugar.Types + + +-- | Given a Parameter Name and a boolean that indicates valid/not-valid for a +-- Parameter Value, update the expectations in the Sweets to treat the parameter +-- as a ranged value. +-- +-- [This is the pure internals version; the recommended usage is via the +-- 'rangedParamAdjuster' wrapper specification in the 'sweetAdjuster' field of +-- the 'CUBE' structure.] +-- +-- Normal sweets results expect a 1:1 match between parameter value and the +-- expected file markup, but this function modifies the sweets results to +-- accomodate a parameter range with range boundaries. For example, if the test +-- might vary the output based on the version of clang used to compile the file, +-- the 'CUBE' might specify: +-- +-- > mkCUBE { rootName = "*.c" +-- > , expectedSuffix = "good" +-- > , validParams = [ ("clang-range", Just ["pre_clang11", "pre_clang13" ] ) ] +-- > ... +-- > } +-- +-- Then if the following files were present: +-- +-- > foo.c +-- > foo-pre_clang11.good +-- > foo.good +-- +-- Then a normal sweets response would include the expectations: +-- +-- > foo-pre_clang11.good ==> Explicit "pre_clang11" +-- > foo.good ==> Assumed "pre_clang13" +-- +-- The 'Test.Tasty.Sugar.withSugarGroups' callback would then be invoked with +-- these two expectations. The callback might check the actual version of clang +-- available to run in the environment. If it detected clang version 10 was +-- available, the best file would be the @foo-pre_clang11.good@, even though the +-- parameters didn't mention @clang9@ and the @foo.good@ would be the usual match +-- to pick when there was no explicit match. +-- +-- To handle this case, the 'rangedParam' function is used to filter the sweets, +-- and is also given the version of clang locally available: +-- +-- > let rangedSweets = rangedParam "clang-range" extract (<=) (Just "9") sweets +-- > extract = readMaybe . drop (length "pre-clang") +-- > withSugarGroups rangedSweets TT.testGroup $ \sweet instnum exp -> +-- > ... generate test ... +-- +-- Where the above would result in a single call to the _generate test_ code with +-- the @foo-pre_clang11.good@ expectation. The @extract@ function removes the +-- numeric value from the parameter value, and the @<=@ test checks to see if the +-- version supplied is less than or equal to the extracted parameter value. +-- +-- The @>@ comparator could be used if the validParams values specified a lower +-- limit instead of an upper limit, and the comparator and extractor can be +-- extended to handle other ways of specifying ranges. +-- +-- If the extract function returns Nothing, then the corresponding parameter +-- value is /not/ a ranged parameter value (there can be a mix of ranged values +-- and non-ranged values), and the corresponding value(s) will be used whenever +-- there is not a ranged match. As an example, if the 'validParams' above was +-- extended with a "recent-clang" value; for actual clang versions up through 12 +-- one of the pre_clang values provides the ranged match, but for clang versions +-- of 13 or later, there is no pre_clang match so recent-clang will be used. +-- Providing a non-extractable parameter value is recommended as the default to +-- select when no ranged value is applicable; the expected file does /not/ need +-- to have the same parameter value since a weak match (no parameter match) file +-- will match with the 'Assumed' value, which will be selected if no better +-- ranged match is applicable. + +rangedParam :: Enum a => Ord a + => String -> (String -> Maybe a) -> (a -> a -> Bool) + -> Maybe a + -> CUBE -> [Sweets] -> [Sweets] +rangedParam pname extractVal cmpVal targetVal cube sweets = + let adj sweet = let exps = expected sweet + in sweet { expected = adjustExp exps } + + -- extracts all parameters except the named parameter + paramsExceptPName = filter ((pname /=) . fst) . expParamsMatch + + -- Compares two assoc-lists for equality on the union of both. + assocUnionEq = \case + [] -> const True + ((an,av):as) -> \case + [] -> True + bs -> case lookup an bs of + Nothing -> assocUnionEq as bs + Just bv -> av == bv && assocUnionEq as bs + + -- This divides a list into clusters of lists, where each sub-list contains + -- members that satisfy a comparison predicate between the list members + -- (comparing against the first member of each sub-list). This is + -- effectively List.groupBy, but with global clustering instead of local + -- clustering. + -- + -- > Data.List.groupBy (==) "Mississippi" = ["M", "i", "ss", "i", "ss" ...] + -- > cluster (==) "Mississippi" = ["M", "iiii", "ssss", "pp"] + clusterBy equiv = \case + [] -> [] + (x:xs) -> let (same,diff) = L.partition (equiv x) xs + in (x:same) : clusterBy equiv diff + + adjustExp :: [Expectation] -> [Expectation] + adjustExp exps = concatMap expInRange + $ clusterBy (assocUnionEq `on` paramsExceptPName) exps + + notRange e = maybe False + (isNothing . extractVal) + (getParamVal =<< lookup pname (expParamsMatch e)) + + expInRange :: [Expectation] -> [Expectation] + expInRange = + case targetVal of + Nothing -> + -- User did not specify which target version of clang was desired. + -- Iterate through the possible parameter values, extract the version + -- associated with each, and return the expectations that would have + -- been chosen for that version. Also use a version that is the succ + -- of the highest and the pred of the lowest, to ensure + -- out-of-known-range values are also considered. + case lookup pname (validParams cube) of + Nothing -> + -- Should not happen: this means the user called rangedParam with + -- a parameter name that is not an actual parameter. In this + -- case, just return the inputs. + id + Just Nothing -> + -- Cannot support ranges on existentials (parameters whose value + -- can be *anything*). This can happen if the user specifies a + -- parameter name of this type. In this case, there is no + -- meaningful range that can be predicted, so just return the + -- inputs + id + Just (Just vals) -> \exps -> + -- Iterate through the possible values to extract the + -- corresponding parameter value. This may be a subset of the + -- actual values that could be encountered, but it at least + -- allows the proper expected file to be determined for this set + -- of values. For possible values that do not have a valid + -- extraction, just pass those Expectation entires through + -- directly. + let withPVal = \case + Nothing -> filter notRange exps + Just v -> expInRangeFor v exps + vals' = Set.fromList (extractVal <$> vals) + -- Use a Set to eliminate duplicates, especially of + -- Nothing results. + vals'' = let vs = Nothing `Set.delete` vals' + lower = pred <$> minimum vs + higher = succ <$> maximum vs + in if Set.null vs + then vs + else lower `Set.insert` (higher `Set.insert` vs) + in Set.toList $ Set.unions + -- Set operations combine/eliminate identical results + $ foldr (Set.insert . Set.fromList . withPVal) mempty vals'' + Just tv -> expInRangeFor tv + + -- expInRangeFor :: a -> [Expectation] -> [Expectation] + expInRangeFor tgtVal exps = + -- Find the expectations with the _cmpVal-est_ Explicit that is still + -- a _cmpVal_ of the input value than the target value. If none + -- exist, use the expectations that Assume the target value. There + -- can be multiple matches because of differences in other parameter + -- values; stated another way: for any set of parameter values, find + -- the expectations with the cmpVal-est Explicit ... + let explParam e = case lookup pname $ expParamsMatch e of + Just (Explicit v) -> + maybe False (cmpVal tgtVal) $ extractVal v + _ -> False + okParam e = case lookup pname $ expParamsMatch e of + Just (Assumed v) -> + maybe False (cmpVal tgtVal) $ extractVal v + _ -> False + pval e = do pm <- lookup pname $ expParamsMatch e + pv <- getParamVal pm + extractVal pv + -- bestsBy finds the testVal-est value for each set of + -- expectations whose other parameter values are the same. + bestsBy getVal testVal = \case + [] -> [] + (xp:xps) -> + let chk e bests = + -- e is an Expectation, bests is the best testVal-est + -- [Expectation] collected so-far. + let ev = getVal e + ep = paramsExceptPName e + matchE = assocUnionEq ep . paramsExceptPName + (yes,oBest) = L.partition matchE bests + -- yes is the entries in bests whose non-PName + -- parameters match e, so we can now determine if + -- yes or z is testVal-est (yes may have multiple + -- entries, but if it does they should have the + -- same value for pname, which mostly happens on + -- the Nothing case... param does not exist or + -- has NotSpecified value). + -- + -- oBest has the other entries in bests that + -- don't match e and should therefore just be + -- passed through. Note that due to adjustExp + -- this should usually be a null list. + yv = getVal $ head yes + in case () of + _ | null yes -> e:bests + _ | ev == yv -> e:bests + _ -> case liftA2 testVal yv ev of + Just True -> bests + Just False -> e:oBest + Nothing -> e:oBest + -- maybe bests (const (e:oBest)) ev + in foldr chk [xp] xps + exps' = let expl = L.filter explParam exps + assum = L.filter okParam exps + nonRanged = L.filter notRange exps + in if null expl + then if null assum + then nonRanged + else assum + else expl + in bestsBy pval cmpVal $ exps' + in adj <$> sweets + + +-- | Given a Parameter Name and a boolean that indicates valid/not-valid for a +-- Parameter Value, update the expectations in the Sweets to treat the parameter +-- as a ranged value. This provides the functionality described by the +-- 'rangedParam' function and is intended for use via the 'sweetAdjuster' field +-- of the 'CUBE' structure. + +rangedParamAdjuster :: Enum a => Ord a + => MonadIO m + => String -> (String -> Maybe a) -> (a -> a -> Bool) + -> Maybe a + -> CUBE -> [Sweets] -> m [Sweets] +rangedParamAdjuster pname extractVal cmpVal targetVal cube = + return . rangedParam pname extractVal cmpVal targetVal cube diff --git a/src/internal/Test/Tasty/Sugar/Report.hs b/src/internal/Test/Tasty/Sugar/Report.hs --- a/src/internal/Test/Tasty/Sugar/Report.hs +++ b/src/internal/Test/Tasty/Sugar/Report.hs @@ -44,7 +44,7 @@ in t & valueColName .~ "Expected File" -- | Converts a set of discovered Sweets directly into a text-based table for --- shoing to the user. +-- showing to the user. sweetsTextTable :: [CUBE] -> [Sweets] -> Text sweetsTextTable [] _ = "No CUBE provided for report" sweetsTextTable _ [] = "No Sweets provided for report" 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 @@ -4,9 +4,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Test.Tasty.Sugar.Types where +import Control.Monad.IO.Class ( MonadIO ) import Data.Function ( on ) import qualified Data.List as L import Data.Maybe ( catMaybes ) @@ -162,9 +164,32 @@ -- (the lack of a parameter is handled automatically rather than -- an explicit blank value). , validParams :: [ParameterPattern] + + -- | The 'sweetAdjuster' is used to post-process the Sweets found. This can + -- be used to provide additional filtering or handle relations between the + -- sweets. While this could be performed manually, it is much better to use + -- this entry to ensure that the results are the same as reported with the + -- --showsearch output or other handling that might not be aware of other + -- modifications of the found results. + , sweetAdjuster :: forall m . MonadIO m => CUBE -> [Sweets] -> m [Sweets] } - deriving Show +instance Show CUBE where + show c = mconcat $ catMaybes + [ Just "CUBE { " + , let i = inputDir c in if null i then Nothing + else Just $ "inputDir=" <> show i <> " {# DEPRECATED #}, " + , if not (null $ inputDir c) && null (inputDirs c) then Nothing + else Just $ "inputDirs=" <> show (inputDirs c) <> ", " + , Just $ "rootName=" <> show (rootName c) + , Just $ "expectedSuffix=" <> show (expectedSuffix c) + , Just $ "separators=" <> show (separators c) + , Just $ "associatedNames=" <> show (associatedNames c) + , Just $ "validParams=" <> show (validParams c) + , Just "}" + ] + + {-# DEPRECATED inputDir "Use inputDirs instead" #-} -- | Parameters are specified by their name and a possible list of @@ -199,6 +224,7 @@ , associatedNames = [] , expectedSuffix = "exp" , validParams = [] + , sweetAdjuster = const return } @@ -236,6 +262,8 @@ map pretty vl in indent 1 $ vsep $ map pp prms) +---------------------------------------------------------------------- + -- | Internally, this keeps the association between a possible file and the input -- directory it came from. The "file" portion is relative to the input -- directory. @@ -252,8 +280,9 @@ -- provide parameter matches. , candidateSubdirs :: [ FilePath ] -- | The 'candidateFile' is the filename portion (only) of - -- the candidate file. (Use 'candidateToPath' to get the - -- full filepath from a CandidateFile). + -- the candidate file. (Use + -- 'Test.Tasty.Sugar.candidateToPath' to get the full + -- filepath from a 'CandidateFile'). , candidateFile :: FilePath -- | Portions of the candidateFile (or candidateSubdirs) -- that match parameters @@ -267,6 +296,8 @@ deriving (Eq, Show) -- Show is for for debugging/tracing +---------------------------------------------------------------------- + -- | Each identified test input set is represented as a 'Sweets' -- object.. a Specifications With Existing Expected Testing Samples. @@ -303,6 +334,8 @@ , Just $ vsep $ map pretty $ expected inp ]) +---------------------------------------------------------------------- + -- | The 'Association' specifies the name of the associated file entry -- and the actual filepath of that associated file. @@ -316,6 +349,8 @@ type NamedParamMatch = (String, ParamMatch) +---------------------------------------------------------------------- + -- | The 'Expectation' represents a valid test configuration based on -- the set of provided files. The 'Expectation' consists of an -- expected file which matches the 'rootFile' in the containing @@ -343,6 +378,13 @@ , (bagCmp `on` associated) e1 e2 ] +-- | Ordering comparisons of two 'Expectation' objects ignores the +-- order of the 'expParamsMatch' and 'associated' fields. +instance Ord Expectation where + e1 `compare` e2 = expectedFile e1 `compare` expectedFile e2 + <> (compare `on` L.sort . expParamsMatch) e1 e2 + <> (compare `on` L.sort . associated) e1 e2 + instance Pretty Expectation where pretty exp = let p = expParamsMatch exp @@ -359,6 +401,8 @@ , pp , pa ] + +---------------------------------------------------------------------- -- | Indicates the matching parameter value for this identified -- expected test. If the parameter value is explicitly specified in 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.1.0.0 +version: 2.2.0.0 synopsis: Tests defined by Search Using Golden Answer References description: . @@ -21,7 +21,7 @@ license-file: LICENSE author: Kevin Quick maintainer: kquick@galois.com -copyright: Kevin Quick, 2019-2022 +copyright: Kevin Quick category: Testing build-type: Simple @@ -33,9 +33,10 @@ , GHC == 9.4.4 , GHC == 9.6.1 -extra-source-files: CHANGELOG.md - README.org - examples/example1/NiftyText.hs +extra-doc-files: CHANGELOG.md + README.org + +extra-source-files: examples/example1/NiftyText.hs examples/example1/README.org examples/example1/test-passthru-ascii.hs examples/example1/testdata/counting @@ -85,6 +86,8 @@ test/data/single/foo.llvm199.exp test/data/single/foo.llvm9.exe test/data/single/foo.llvm9.exp + test/data/issue3/test.c + test/data/issue3/test.42.c source-repository head type: git @@ -120,6 +123,7 @@ , Test.Tasty.Sugar.ExpectCheck , Test.Tasty.Sugar.Iterations , Test.Tasty.Sugar.ParamCheck + , Test.Tasty.Sugar.Ranged , Test.Tasty.Sugar.Report , Test.Tasty.Sugar.Types build-depends: base @@ -155,22 +159,26 @@ TestGCD TestSingleAssoc TestStrlen2 + TestParams TestParamsAssoc TestUtils TestWildcard + TestIssue3 + TestLLVMRange Sample1 build-depends: base >= 4 , filepath - , hedgehog + , hedgehog >= 1.1 && < 1.3 , logict - , pretty-show + , pretty-show >= 1.9 && < 1.11 , prettyprinter - , raw-strings-qq + , raw-strings-qq >= 1.1 && < 1.2 , tasty - , tasty-hedgehog - , tasty-hunit + , tasty-hedgehog >= 1.4 && < 1.5 + , tasty-hunit >= 0.10 && < 0.11 , tasty-sugar , text + , transformers test-suite test-passthru-ascii type: exitcode-stdio-1.0 diff --git a/test/TestGCD.hs b/test/TestGCD.hs --- a/test/TestGCD.hs +++ b/test/TestGCD.hs @@ -21,84 +21,87 @@ ] sugarCube = mkCUBE - { rootName = "*.c" - , expectedSuffix = "good" - , inputDirs = [ testInpPath ] - , associatedNames = [ ("config", "config") - , ("stdio", "print") - , ("haskell", "hs") - ] - , validParams = testParams - } + { rootName = "*.c" + , expectedSuffix = "good" + , inputDirs = [ testInpPath ] + , associatedNames = [ ("config", "config") + , ("stdio", "print") + , ("haskell", "hs") + ] + , validParams = testParams + } gcdSampleTests :: [TT.TestTree] gcdSampleTests = - let (sugar,sdesc) = findSugarIn sugarCube (gcdSamples sugarCube) - in [ testCase "valid sample" $ 19 @=? length (gcdSamples sugarCube) - , sugarTestEq "correct found count" sugarCube gcdSamples 1 length + [ testCase "valid sample" $ 19 @=? length (gcdSamples sugarCube) + , sugarTestEq "correct found count" sugarCube gcdSamples 1 length - , testCase "sweets rendering" $ - let actual = sweetsTextTable [sugarCube] sugar - in do putStrLn "Table" -- try to start table on its own line - putStrLn $ T.unpack actual - T.length actual > 0 @? "change this to see the table" + , testCase "sweets rendering" $ do + (sugar,_sdesc) <- findSugarIn sugarCube (gcdSamples sugarCube) + let actual = sweetsTextTable [sugarCube] sugar + -- putStrLn "Table" -- try to start table on its own line + -- putStrLn $ T.unpack actual + T.length actual > 0 @? "change this to see the table" - , 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 ] + , testCaseSteps "sweets info" $ \step -> do + (sugar,_sdesc) <- findSugarIn sugarCube (gcdSamples sugarCube) + 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 - let exp e s l c o = - Expectation - { expectedFile = p e - , expParamsMatch = [("solver", s), ("loop-merging", l)] - , associated = [ ("config", p c), ("stdio", p o)] - } - e = Explicit - a = Assumed - in - [ - exp "gcd-test.boolector.good" (e "boolector") (a "loopmerge") - "gcd-test.loopmerge.config" - "gcd-test.boolector.print" + , testCase "Expectations" $ do + (sugar,_sdesc) <- findSugarIn sugarCube (gcdSamples sugarCube) + compareBags "expected" (expected $ head sugar) $ + let p = (testInpPath ) + exp e s l c o = + Expectation + { expectedFile = p e + , expParamsMatch = [("solver", s), ("loop-merging", l)] + , associated = [ ("config", p c), ("stdio", p o)] + } + e = Explicit + a = Assumed + in + [ + exp "gcd-test.boolector.good" (e "boolector") (a "loopmerge") + "gcd-test.loopmerge.config" + "gcd-test.boolector.print" - , exp "gcd-test.boolector.good" (e "boolector") (a "loop") - "gcd-test.config" - "gcd-test.boolector.print" + , exp "gcd-test.boolector.good" (e "boolector") (a "loop") + "gcd-test.config" + "gcd-test.boolector.print" - , exp "gcd-test.good" (a "cvc4") (a "loopmerge") - "gcd-test.loopmerge.config" - "gcd-test.print" + , exp "gcd-test.good" (a "cvc4") (a "loopmerge") + "gcd-test.loopmerge.config" + "gcd-test.print" - , exp "gcd-test.good" (a "cvc4") (a "loop") - "gcd-test.config" - "gcd-test.print" + , exp "gcd-test.good" (a "cvc4") (a "loop") + "gcd-test.config" + "gcd-test.print" - , exp "gcd-test.good" (a "yices") (a "loopmerge") - "gcd-test.loopmerge.config" - "gcd-test.print" + , exp "gcd-test.good" (a "yices") (a "loopmerge") + "gcd-test.loopmerge.config" + "gcd-test.print" - , exp "gcd-test.good" (a "yices") (a "loop") - "gcd-test.config" - "gcd-test.print" + , exp "gcd-test.good" (a "yices") (a "loop") + "gcd-test.config" + "gcd-test.print" - , exp "gcd-test.good" (a "z3") (a "loopmerge") - "gcd-test.loopmerge.config" - "gcd-test.print" + , exp "gcd-test.good" (a "z3") (a "loopmerge") + "gcd-test.loopmerge.config" + "gcd-test.print" - , exp "gcd-test.good" (a "z3") (a "loop") - "gcd-test.config" - "gcd-test.print" + , exp "gcd-test.good" (a "z3") (a "loop") + "gcd-test.config" + "gcd-test.print" - ] - ] + ] + ] gcdSamples cube = fmap (makeCandidate cube testInpPath []) $ filter (not . null) diff --git a/test/TestIssue3.hs b/test/TestIssue3.hs new file mode 100644 --- /dev/null +++ b/test/TestIssue3.hs @@ -0,0 +1,70 @@ +module TestIssue3 ( issue3Tests ) where + +import System.FilePath ( (), takeFileName ) +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Test.Tasty.Sugar + +-- This test is in relation to https://github.com/kquick/tasty-sugar/issues/3 and +-- provides validation against that issue report. +-- +-- Note that for Issue #3, the observed behavior is the desired behavior for +-- finding expectations (which is verified below). The related need behind the +-- issue report was the ability to do ranged parameter matching and have the root +-- and expected file been the same (c.f. llvm-pretty-bc-parser:disasm-test), +-- which has been addressed in version 2.2.0.0 via the rangedParamAdjuster helper +-- function and and the Cube.sweetAdjuster field. + +issue3Tests :: IO [TT.TestTree] +issue3Tests = do tsts <- sequence [ issue3Test1 ] + return [ TT.testGroup "Issue #3" $ concat tsts ] + +issue3Test1 :: IO [TT.TestTree] +issue3Test1 = do + let testInpPath = "test/data/issue3" + let cube = mkCUBE { inputDirs = [testInpPath] + , rootName = "*.c" + , expectedSuffix = "c" + , validParams = [ ("ver", Just ["42", "43"]) ] + } + sweets <- findSugar cube + -- putStrLn $ show sweets + + let exp0 f v = Expectation + { expectedFile = testInpPath f + , expParamsMatch = [ ("ver", v) ] + , associated = [] + } + let exp f v = exp0 f v + testExp s i e f v = testCase ("Exp #" <> show i) $ e @?= exp f v + validInstNum n ns = testCase ("instnum valid: " <> show n) + (n `elem` ns @? "unexpected instnum") + + tests <- withSugarGroups sweets TT.testGroup $ \sweet instnum exp -> + return $ + case rootMatchName sweet of + "test.c" -> + validInstNum instnum [1] + : + testCase "# expectations" (length (expected sweet) @?= 2) + : + case takeFileName (expectedFile exp) of + "test.42.c" -> [testExp sweet instnum exp "test.42.c" (Explicit "42")] + "test.c" -> [testExp sweet instnum exp "test.c" (Assumed "43")] + o -> [ testCase "unexpected" $ False @? + "Unexpected exp file for " <> rootMatchName sweet + <> " sweet: " <> o + ] + + "test.42.c" -> + validInstNum instnum [1] + : testCase "# expectations" (length (expected sweet) @?= 1) + : [ testExp sweet instnum exp "test.42.c" (Explicit "42") ] + + _ -> [ testCase "unexpected" $ False @? + "Unexpected root sweet: " <> rootMatchName sweet + ] + + return $ + testCase "correct # of sweets" (length sweets @?= 2) + : tests diff --git a/test/TestLLVMRange.hs b/test/TestLLVMRange.hs new file mode 100644 --- /dev/null +++ b/test/TestLLVMRange.hs @@ -0,0 +1,708 @@ +{-# LANGUAGE LambdaCase #-} +module TestLLVMRange ( llvmRangeTests ) where + +import Control.Applicative +import Control.Monad.Trans.Writer +import Data.Function ( on ) +import qualified Data.List as L +import Data.Maybe +import System.FilePath ( (), takeFileName ) +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Test.Tasty.Sugar +import TestUtils +import Text.Read ( readMaybe ) + + +testInpPath :: FilePath +testInpPath = "test/data/llvm1" + +files :: CUBE -> [CandidateFile] +files cube = makeCandidate cube testInpPath [] + <$> [ "T847-fail2.c" + , "T847-fail2.cvc5.good" + , "T847-fail2.cvc5.pre-clang13.good" + , "T847-fail2.ll" + , "T847-fail2.pre-clang12.z3.good" + , "T847-fail2.z3.good" + , "T972-fail.c" + , "T972-fail.pre-clang12.z3.good" + , "T972-fail.pre-clang14.z3.good" + , "T972-fail.z3.good" + , "abd-test-file-32.c" + , "abd-test-file-32.config" + , "abd-test-file-32.cvc5.good" + , "abd-test-file-32.pre-clang13.cvc5.good" + , "freeze.c" + , "freeze.ll" + , "freeze.pre-clang12.z3.good" + , "freeze.z3.good" + , "shrink.c" + , "shrink.config" + , "shrink.ll" + , "shrink.z3.good" + ] + +files2 :: CUBE -> [CandidateFile] +files2 cube = makeCandidate cube testInpPath [] + <$> [ "T847-fail2.c" + , "T847-fail2.cvc5.good" + , "T847-fail2.cvc5.clang13+.good" + , "T847-fail2.ll" + , "T847-fail2.clang12+.z3.good" + , "T847-fail2.z3.good" + , "T972-fail.c" + , "T972-fail.clang12+.z3.good" + , "T972-fail.clang14+.z3.good" + , "T972-fail.z3.good" + , "abd-test-file-32.c" + , "abd-test-file-32.config" + , "abd-test-file-32.cvc5.good" + , "abd-test-file-32.clang13+.cvc5.good" + , "freeze.c" + , "freeze.ll" + , "freeze.clang12+.z3.good" + , "freeze.z3.good" + , "shrink.c" + , "shrink.config" + , "shrink.ll" + , "shrink.z3.good" + ] + + +llvmRangeTests :: IO [TT.TestTree] +llvmRangeTests = do tsts1 <- sequence [ llvmRange1 ("direct", Nothing) + , llvmRange1 ("ranged", Nothing) + , llvmRange1 ("ranged", Just 9) + , llvmRange1 ("ranged", Just 11) + , llvmRange1 ("ranged", Just 12) + , llvmRange1 ("ranged", Just 14) + , llvmRange1 ("ranged", Just 16) + ] + tsts2 <- sequence [ llvmRange2 ("direct", Nothing) + , llvmRange2 ("ranged", Just 9) + , llvmRange2 ("ranged", Just 11) + , llvmRange2 ("ranged", Just 12) + , llvmRange2 ("ranged", Just 14) + , llvmRange2 ("ranged", Just 16) + ] + tsts3 <- sequence [ llvmRange3 ("direct", Nothing) + , llvmRange3 ("ranged", Just 9) + , llvmRange3 ("ranged", Just 11) + , llvmRange3 ("ranged", Just 12) + , llvmRange3 ("ranged", Just 13) + , llvmRange3 ("ranged", Just 14) + , llvmRange3 ("ranged", Just 16) + ] + return [ TT.testGroup "LLVM Range 1" $ concat tsts1 + , TT.testGroup "LLVM Range 2" $ concat tsts2 + , TT.testGroup "LLVM Range 3" $ concat tsts3 + ] + +llvmRange1 :: (String, Maybe Int) -> IO [TT.TestTree] +llvmRange1 (mode, matchClang) = do + let cube = + let c = mkCUBE { inputDirs = [ testInpPath ] + , rootName = "*.c" + , expectedSuffix = "good" + , separators = "." + , validParams = [ ("solver", Just [ "z3", "cvc5" ]) + , ("clang-range", Just [ "recent-clang" + , "pre-clang11" + , "pre-clang12" + , "pre-clang13" + , "pre-clang14" + ]) + ] + } + in case mode of + "direct" -> c + "ranged" -> + let extract pval = + if "pre-clang" `L.isPrefixOf` pval + then readMaybe (drop (length "pre-clang") pval) + else if "recent-clang" == pval + then Nothing :: Maybe Int + else error $ "Unknown parameter value for range testing: " <> pval + in c { sweetAdjuster = + rangedParamAdjuster "clang-range" extract + (<) matchClang + } + (sweets, _) <- findSugarIn cube (files cube) + -- putStrLn $ show sweets + + (tests, calls) <- + runWriterT + $ withSugarGroups sweets TT.testGroup $ \sweet instnum exp -> + do tell [1] + let exps = mkTest1 mode matchClang sweet exp + return + [ testCase ("instnum valid: " <> show instnum) + (instnum `elem` [1] @? + ("unexpected instnum for exp " <> show exp)) + , testCase "# expectations" (length (expected sweet) @?= length exps) + , testCase "passed exp" (exp `elem` exps @? "Unexpected: " <> show exp) + ] + + + return + [ TT.testGroup (mode <> " clang " <> maybe "not-specified" show matchClang) + $ testCase "correct # of sweets" (length sweets @?= 5) + : testCase "correct # processed via withSugarGroups" + -- without ranged parameter handling, will call for every Expectation, + -- but if ranged, only calls with the appropriate Expectation for that + -- value. + (sum calls @?= + let expNothingCalls = if mode == "direct" then 5*6 else 22 + in maybe expNothingCalls (const 6) matchClang) + : tests + ] + + +-- llvmRange2 is like llvmRange1 except there is no "default" match of +-- "recent-clang" in the validParams of the CUBE, so there will be no +-- corresponding default expectations. + +llvmRange2 :: (String, Maybe Int) -> IO [TT.TestTree] +llvmRange2 (mode, matchClang) = do + let cube = mkCUBE { inputDirs = [ testInpPath ] + , rootName = "*.c" + , expectedSuffix = "good" + , separators = "." + , validParams = [ ("solver", Just [ "z3", "cvc5" ]) + , ("clang-range", Just [ "pre-clang11" + , "pre-clang12" + , "pre-clang13" + , "pre-clang14" + ]) + ] + , sweetAdjuster = + if mode == "ranged" + then + let extract paramVal = + if "pre-clang" `L.isPrefixOf` paramVal + then readMaybe (drop (length "pre-clang") paramVal) + else if "recent-clang" == paramVal + then Nothing :: Maybe Int + else error $ "Unknown parameter value for range testing: " <> paramVal + in rangedParamAdjuster "clang-range" extract (<) matchClang + else const return + } + (sweets,_) <- findSugarIn cube (files cube) + -- putStrLn $ show sweets + + (tests, calls) <- + runWriterT + $ withSugarGroups sweets TT.testGroup $ \sweet instnum exp -> + do tell [1] + let exps = + let baseExps = mkTest1 mode matchClang sweet exp + in case mode of + "direct" -> + -- Remove the first of the expected matches from the base, + -- which (by convention) is the default match. Also, for + -- T847-fail2.c there are two defaults, the second is the 5th + -- original entry. + tail $ if rootMatchName sweet == "T847-fail2.c" + then take 5 baseExps <> drop 6 baseExps + else baseExps + "ranged" -> + -- Since there's no default, there are no expectations + -- generated if the local clang version is 14 or above + -- (pre-clang14 is the highest valid parameter value) + case matchClang of + Just 14 -> [] + Just 16 -> [] + _ -> baseExps + + return + [ testCase ("instnum valid: " <> show instnum) + (instnum `elem` [1] @? "unexpected instnum") + , testCase "# expectations" (length (expected sweet) @?= length exps) + , testCase "passed exp" (exp `elem` exps @? "Unexpected: " <> show exp) + ] + + return + [ TT.testGroup (mode <> " clang " <> maybe "not-specified" show matchClang) + $ testCase "correct # of sweets" (length sweets @?= 5) + : testCase "correct # processed via withSugarGroups" + -- without ranged parameter handling, will call for every Expectation, + -- but if ranged, only calls with the appropriate Expectation for that + -- value. + (sum calls @?= + maybe (4*6) + (const $ case matchClang of + Just 14 -> 0 + Just 16 -> 0 + _ -> 6) + matchClang) + : tests + ] + + +-- The llvmRange3 tests are similar to the llvmRange1 tests, except that it +-- inverts the range limits: llvmRange1 specified exclusive upper bounds +-- (e.g. pre-clang11) whereas llvmRange3 flips to inclusive lower bounds +-- (e.g. clang11+). + +llvmRange3 :: (String, Maybe Int) -> IO [TT.TestTree] +llvmRange3 (mode, matchClang) = do + let cube0 = mkCUBE { inputDirs = [ testInpPath ] + , rootName = "*.c" + , expectedSuffix = "good" + , separators = "." + , validParams = [ ("solver", Just [ "z3", "cvc5" ]) + , ("clang-range", Just [ "older-clang" + , "clang11+" + , "clang12+" + , "clang13+" + , "clang14+" + ]) + ] + } + let cube = if mode == "ranged" + then let e = readMaybe . drop (length "clang") . init + in cube0 + { + sweetAdjuster = + rangedParamAdjuster "clang-range" e (>=) matchClang + } + else cube0 + (sweets,_) <- findSugarIn cube (files2 cube) + -- putStrLn $ show sweets + + (tests, calls) <- + runWriterT + $ withSugarGroups sweets TT.testGroup $ \sweet instnum exp -> + do tell [1] + let exps = mkTest2 mode matchClang sweet exp + return + [ testCase ("instnum valid: " <> show instnum) + (instnum `elem` [1] @? "unexpected instnum") + , testCase "# expectations" (length (expected sweet) @?= length exps) + , testCase "passed exp" (exp `elem` exps @? "Unexpected: " <> show exp) + ] + + + return + [ TT.testGroup (mode <> " clang " <> maybe "not-specified" show matchClang) + $ testCase "correct # of sweets" (length sweets @?= 5) + : testCase "correct # processed via withSugarGroups" + -- without ranged parameter handling, will call for every Expectation, + -- but if ranged, only calls with the appropriate Expectation for that + -- value. + (sum calls @?= maybe (5*6) (const 6) matchClang) + : tests + ] + + +mkTest1 mode matchClang sweet exp = + let exp0 f s c = Expectation + { expectedFile = testInpPath f + , expParamsMatch = [ ("solver", s) + , ("clang-range", c) + ] + , associated = [] + } + expA f s l = exp0 f (Explicit s) (Assumed l) + expE f s l = exp0 f (Explicit s) (Explicit l) + + exps = + case rootMatchName sweet of + "shrink.c" -> + let def = [ expA "shrink.z3.good" "z3" "recent-clang" + , expA "shrink.z3.good" "z3" "pre-clang14" + , expA "shrink.z3.good" "z3" "pre-clang13" + , expA "shrink.z3.good" "z3" "pre-clang12" + , expA "shrink.z3.good" "z3" "pre-clang11" + ] + in case mode of + "direct" -> def + "ranged" -> + -- Only run the expectation that fits the matching version + -- of clang that is present. There are no Explicit matches, + -- so this should use the best fallback (Assumed) match. + case matchClang of + Just 9 -> + [ expA "shrink.z3.good" "z3" "pre-clang11" + ] + Just 11 -> + [ expA "shrink.z3.good" "z3" "pre-clang12" + ] + Just 12 -> + [ expA "shrink.z3.good" "z3" "pre-clang13" + ] + Just 14 -> + [ expA "shrink.z3.good" "z3" "recent-clang" + ] + Just 16 -> + [ expA "shrink.z3.good" "z3" "recent-clang" + ] + Nothing -> + let e = expA "shrink.z3.good" "z3" in + [ e "recent-clang" -- presumed clang=15, clang14, nothing + , e "pre-clang14" -- presumed clang=13 + , e "pre-clang13" -- presumed clang=12 + , e "pre-clang12" -- presumed clang=11 + , e "pre-clang11" -- presumed clang=10 + ] + + "freeze.c" -> + case mode of + "direct" -> + [ expA "freeze.z3.good" "z3" "recent-clang" + , expA "freeze.z3.good" "z3" "pre-clang14" + , expA "freeze.z3.good" "z3" "pre-clang13" + , expE "freeze.pre-clang12.z3.good" "z3" "pre-clang12" + , expA "freeze.z3.good" "z3" "pre-clang11" + ] + "ranged" -> + -- Only run the expectation that fits the matching version of + -- clang that is present + case matchClang of + Just 9 -> + [ expE "freeze.pre-clang12.z3.good" "z3" "pre-clang12" ] + Just 11 -> + [ expE "freeze.pre-clang12.z3.good" "z3" "pre-clang12" ] + Just 12 -> + [ expA "freeze.z3.good" "z3" "pre-clang13" ] + Just 14 -> + [ expA "freeze.z3.good" "z3" "recent-clang" ] + Just 16 -> + [ expA "freeze.z3.good" "z3" "recent-clang" ] + Nothing -> + let e = expA "freeze.z3.good" "z3" in + [ e "recent-clang" -- presumed clang=15, clang=14, nothing + , e "pre-clang14" -- presumed clang=13 + , e "pre-clang13" -- presumed clang=12 + , expE "freeze.pre-clang12.z3.good" "z3" "pre-clang12" + -- presumed clang=10, clang=11 + ] + + "T847-fail2.c" -> + case mode of + "direct" -> + [ expA "T847-fail2.z3.good" "z3" "recent-clang" + , expA "T847-fail2.z3.good" "z3" "pre-clang14" + , expA "T847-fail2.z3.good" "z3" "pre-clang13" + , expE "T847-fail2.pre-clang12.z3.good" "z3" "pre-clang12" + , expA "T847-fail2.z3.good" "z3" "pre-clang11" + + , expA "T847-fail2.cvc5.good" "cvc5" "recent-clang" + , expA "T847-fail2.cvc5.good" "cvc5" "pre-clang14" + , expE "T847-fail2.cvc5.pre-clang13.good" "cvc5" "pre-clang13" + , expA "T847-fail2.cvc5.good" "cvc5" "pre-clang12" + , expA "T847-fail2.cvc5.good" "cvc5" "pre-clang11" + ] + "ranged" -> + -- Only run the expectation that fits the matching version of + -- clang that is present + case matchClang of + Just 9 -> + [ expE "T847-fail2.pre-clang12.z3.good" "z3" "pre-clang12" + , expE "T847-fail2.cvc5.pre-clang13.good" "cvc5" "pre-clang13" + ] + Just 11 -> + [ expE "T847-fail2.pre-clang12.z3.good" "z3" "pre-clang12" + , expE "T847-fail2.cvc5.pre-clang13.good" "cvc5" "pre-clang13" + ] + Just 12 -> + [ expA "T847-fail2.z3.good" "z3" "pre-clang13" + , expE "T847-fail2.cvc5.pre-clang13.good" "cvc5" "pre-clang13" + ] + Just 14 -> + [ expA "T847-fail2.z3.good" "z3" "recent-clang" + , expA "T847-fail2.cvc5.good" "cvc5" "recent-clang" + ] + Just 16 -> + [ expA "T847-fail2.z3.good" "z3" "recent-clang" + , expA "T847-fail2.cvc5.good" "cvc5" "recent-clang" + ] + Nothing -> + let e1 = expA "T847-fail2.z3.good" "z3" + e2 = expA "T847-fail2.cvc5.good" "cvc5" + in + [ e1 "recent-clang" -- presumed clang=15, clang=14, nothing + , e1 "pre-clang14" -- presumed clang=13 + , e1 "pre-clang13" -- presumed clang=12 + , expE "T847-fail2.pre-clang12.z3.good" "z3" "pre-clang12" + -- presumed clang=11, clang=10 + + , e2 "recent-clang" -- presumed clang=15, clang=14, nothing + , e2 "pre-clang14" -- presumed clang=13 + , expE "T847-fail2.cvc5.pre-clang13.good" "cvc5" "pre-clang13" + -- presumed clang=12, clang=11, clang=10 + ] + + "T972-fail.c" -> + case mode of + "direct" -> + [ expA "T972-fail.z3.good" "z3" "recent-clang" + , expE "T972-fail.pre-clang14.z3.good" "z3" "pre-clang14" + , expA "T972-fail.z3.good" "z3" "pre-clang13" + , expE "T972-fail.pre-clang12.z3.good" "z3" "pre-clang12" + , expA "T972-fail.z3.good" "z3" "pre-clang11" + ] + "ranged" -> + -- Only run the expectation that fits the matching version of + -- clang that is present + case matchClang of + Just 9 -> + [ expE "T972-fail.pre-clang12.z3.good" "z3" "pre-clang12" + ] + Just 11 -> + [ expE "T972-fail.pre-clang12.z3.good" "z3" "pre-clang12" + ] + Just 12 -> + [ expE "T972-fail.pre-clang14.z3.good" "z3" "pre-clang14" + ] + Just 14 -> + [ expA "T972-fail.z3.good" "z3" "recent-clang" + ] + Just 16 -> + [ expA "T972-fail.z3.good" "z3" "recent-clang" + ] + Nothing -> + let e = expA "T972-fail.z3.good" "z3" in + [ e "recent-clang" -- presumed clang=15, clang=14, nothing + , expE "T972-fail.pre-clang14.z3.good" "z3" "pre-clang14" + -- presumed clang=13, clang=12 + , expE "T972-fail.pre-clang12.z3.good" "z3" "pre-clang12" + -- presumed clang=11, clang=10 + ] + + "abd-test-file-32.c" -> + case mode of + "direct" -> + [ expA "abd-test-file-32.cvc5.good" "cvc5" "recent-clang" + , expA "abd-test-file-32.cvc5.good" "cvc5" "pre-clang14" + , expE "abd-test-file-32.pre-clang13.cvc5.good" "cvc5" "pre-clang13" + , expA "abd-test-file-32.cvc5.good" "cvc5" "pre-clang12" + , expA "abd-test-file-32.cvc5.good" "cvc5" "pre-clang11" + ] + "ranged" -> + -- Only run the expectation that fits the matching version of + -- clang that is present + case matchClang of + Just 9 -> + [ expE "abd-test-file-32.pre-clang13.cvc5.good" "cvc5" "pre-clang13" + ] + Just 11 -> + [ expE "abd-test-file-32.pre-clang13.cvc5.good" "cvc5" "pre-clang13" + ] + Just 12 -> + [ expE "abd-test-file-32.pre-clang13.cvc5.good" "cvc5" "pre-clang13" + ] + Just 14 -> + [ expA "abd-test-file-32.cvc5.good" "cvc5" "recent-clang" + ] + Just 16 -> + [ expA "abd-test-file-32.cvc5.good" "cvc5" "recent-clang" + ] + Nothing -> + let e = expA "abd-test-file-32.cvc5.good" "cvc5" in + [ e "recent-clang" -- presumed clang=15, clang=14, nothing + , e "pre-clang14" -- presumed clang=13 + , expE "abd-test-file-32.pre-clang13.cvc5.good" "cvc5" "pre-clang13" + -- presumed clang=12, clang=11, clang=10 + ] + + _ -> error $ "Unexpected root sweet: " <> rootMatchName sweet + + in exps + + +mkTest2 mode matchClang sweet exp = + let exp0 f s c = Expectation + { expectedFile = testInpPath f + , expParamsMatch = [ ("solver", s) + , ("clang-range", c) + ] + , associated = [] + } + expA f s l = exp0 f (Explicit s) (Assumed l) + expE f s l = exp0 f (Explicit s) (Explicit l) + + exps = + case rootMatchName sweet of + "shrink.c" -> + case mode of + "direct" -> + [ expA "shrink.z3.good" "z3" "older-clang" + , expA "shrink.z3.good" "z3" "clang14+" + , expA "shrink.z3.good" "z3" "clang13+" + , expA "shrink.z3.good" "z3" "clang12+" + , expA "shrink.z3.good" "z3" "clang11+" + ] + "ranged" -> + -- Only run the expectation that fits the matching version of + -- clang that is present. There are no Explicit matches, so + -- this should use the best fallback (Assumed) match. + case matchClang of + Just 9 -> + [ expA "shrink.z3.good" "z3" "older-clang" + ] + Just 11 -> + [ expA "shrink.z3.good" "z3" "clang11+" + ] + Just 12 -> + [ expA "shrink.z3.good" "z3" "clang12+" + ] + Just 13 -> + [ expA "shrink.z3.good" "z3" "clang13+" + ] + Just 14 -> + [ expA "shrink.z3.good" "z3" "clang14+" + ] + Just 16 -> + [ expA "shrink.z3.good" "z3" "clang14+" + ] + Nothing -> [] + + "freeze.c" -> + case mode of + "direct" -> + [ expA "freeze.z3.good" "z3" "older-clang" + , expA "freeze.z3.good" "z3" "clang14+" + , expA "freeze.z3.good" "z3" "clang13+" + , expE "freeze.clang12+.z3.good" "z3" "clang12+" + , expA "freeze.z3.good" "z3" "clang11+" + ] + "ranged" -> + -- Only run the expectation that fits the matching version of + -- clang that is present + case matchClang of + Just 9 -> + [ expA "freeze.z3.good" "z3" "older-clang" + ] + Just 11 -> + [ expA "freeze.z3.good" "z3" "clang11+" + ] + Just 12 -> + [ expE "freeze.clang12+.z3.good" "z3" "clang12+" + ] + Just 13 -> + [ expE "freeze.clang12+.z3.good" "z3" "clang12+" + ] + Just 14 -> + [ expE "freeze.clang12+.z3.good" "z3" "clang12+" + ] + Just 16 -> + [ expE "freeze.clang12+.z3.good" "z3" "clang12+" + ] + Nothing -> [] + + "T847-fail2.c" -> + case mode of + "direct" -> + [ expA "T847-fail2.z3.good" "z3" "older-clang" + , expA "T847-fail2.z3.good" "z3" "clang14+" + , expA "T847-fail2.z3.good" "z3" "clang13+" + , expE "T847-fail2.clang12+.z3.good" "z3" "clang12+" + , expA "T847-fail2.z3.good" "z3" "clang11+" + + , expA "T847-fail2.cvc5.good" "cvc5" "older-clang" + , expA "T847-fail2.cvc5.good" "cvc5" "clang14+" + , expE "T847-fail2.cvc5.clang13+.good" "cvc5" "clang13+" + , expA "T847-fail2.cvc5.good" "cvc5" "clang12+" + , expA "T847-fail2.cvc5.good" "cvc5" "clang11+" + ] + "ranged" -> + -- Only run the expectation that fits the matching version of + -- clang that is present + case matchClang of + Just 9 -> + [ expA "T847-fail2.z3.good" "z3" "older-clang" + , expA "T847-fail2.cvc5.good" "cvc5" "older-clang" + ] + Just 11 -> + [ expA "T847-fail2.z3.good" "z3" "clang11+" + , expA "T847-fail2.cvc5.good" "cvc5" "clang11+" + ] + Just 12 -> + [ expE "T847-fail2.clang12+.z3.good" "z3" "clang12+" + , expA "T847-fail2.cvc5.good" "cvc5" "clang12+" + ] + Just 13 -> + [ expE "T847-fail2.clang12+.z3.good" "z3" "clang12+" + , expE "T847-fail2.cvc5.clang13+.good" "cvc5" "clang13+" + ] + Just 14 -> + [ expE "T847-fail2.clang12+.z3.good" "z3" "clang12+" + , expE "T847-fail2.cvc5.clang13+.good" "cvc5" "clang13+" + ] + Just 16 -> + [ expE "T847-fail2.clang12+.z3.good" "z3" "clang12+" + , expE "T847-fail2.cvc5.clang13+.good" "cvc5" "clang13+" + ] + Nothing -> [] + + "T972-fail.c" -> + case mode of + "direct" -> + [ expA "T972-fail.z3.good" "z3" "older-clang" + , expE "T972-fail.clang14+.z3.good" "z3" "clang14+" + , expA "T972-fail.z3.good" "z3" "clang13+" + , expE "T972-fail.clang12+.z3.good" "z3" "clang12+" + , expA "T972-fail.z3.good" "z3" "clang11+" + ] + "ranged" -> + -- Only run the expectation that fits the matching version of + -- clang that is present + case matchClang of + Just 9 -> + [ expA "T972-fail.z3.good" "z3" "older-clang" + ] + Just 11 -> + [ expA "T972-fail.z3.good" "z3" "clang11+" + ] + Just 12 -> + [ expE "T972-fail.clang12+.z3.good" "z3" "clang12+" + ] + Just 13 -> + [ expE "T972-fail.clang12+.z3.good" "z3" "clang12+" + ] + Just 14 -> + [ expE "T972-fail.clang14+.z3.good" "z3" "clang14+" + ] + Just 16 -> + [ expE "T972-fail.clang14+.z3.good" "z3" "clang14+" + ] + Nothing -> [] + + "abd-test-file-32.c" -> + case mode of + "direct" -> + [ expA "abd-test-file-32.cvc5.good" "cvc5" "older-clang" + , expA "abd-test-file-32.cvc5.good" "cvc5" "clang14+" + , expE "abd-test-file-32.clang13+.cvc5.good" "cvc5" "clang13+" + , expA "abd-test-file-32.cvc5.good" "cvc5" "clang12+" + , expA "abd-test-file-32.cvc5.good" "cvc5" "clang11+" + ] + "ranged" -> + -- Only run the expectation that fits the matching version of + -- clang that is present + case matchClang of + Just 9 -> + [ expA "abd-test-file-32.cvc5.good" "cvc5" "older-clang" + ] + Just 11 -> + [ expA "abd-test-file-32.cvc5.good" "cvc5" "clang11+" + ] + Just 12 -> + [ expA "abd-test-file-32.cvc5.good" "cvc5" "clang12+" + ] + Just 13 -> + [ expE "abd-test-file-32.clang13+.cvc5.good" "cvc5" "clang13+" + ] + Just 14 -> + [ expE "abd-test-file-32.clang13+.cvc5.good" "cvc5" "clang13+" + ] + Just 16 -> + [ expE "abd-test-file-32.clang13+.cvc5.good" "cvc5" "clang13+" + ] + Nothing -> [] + + _ -> error $ "Unexpected root sweet: " <> rootMatchName sweet + + in exps diff --git a/test/TestMain.hs b/test/TestMain.hs --- a/test/TestMain.hs +++ b/test/TestMain.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -5,6 +6,7 @@ module Main where import Control.Exception ( SomeException, try ) +import Control.Monad import Data.Bifunctor ( bimap ) import qualified Hedgehog as HH import Test.Tasty @@ -20,8 +22,11 @@ import TestFileSys import TestGCD +import TestIssue3 +import TestLLVMRange import TestMultiAssoc import TestNoAssoc +import TestParams import TestParamsAssoc import TestSingleAssoc import TestStrlen2 @@ -36,6 +41,8 @@ in do generatedTests <- namedGenGroup "no association" <$> mkNoAssocTests fsTests <- fileSysTests + issueTests <- issue3Tests + llvmTests <- llvmRangeTests defaultMain $ testGroup "tasty-sweet tests" $ [ @@ -46,7 +53,8 @@ #endif HH.withTests 10000 $ HH.property $ do cube <- HH.forAll $ genCube - HH.assert $ null $ fst $ findSugarIn cube [] + (sweets, _desc) <- findSugarIn cube [] + HH.assert $ null sweets , testGroup "invalid separators" $ [ @@ -140,15 +148,25 @@ , testGroup "single associated file" $ singleAssocTests , testGroup "multiple associated files" $ multiAssocTests , testGroup "params association" $ paramsAssocTests + , testGroup "params" $ paramTests , testGroup "wildcard tests" $ wildcardAssocTests , testGroup "gcd sample tests" $ gcdSampleTests , testGroup "strlen2 sample tests" $ strlen2SampleTests ] <> generatedTests <> fsTests + <> issueTests + <> llvmTests runTestOrErr :: CUBE -> IO (Either String String) runTestOrErr c = bimap (head . lines . show) show <$> - (try (return $! findSugarIn c []) :: - IO (Either SomeException ([Sweets], Doc ann))) + (try (do !r <- findSugarIn c [] + -- the following is to force the evaluation of + -- findSugarIn within the try context. If this isn't + -- done, the tests will fail with "error" calls. + if null (fst r) + then error "never reached" + else return r + ) + :: IO (Either SomeException ([Sweets], Doc ann))) diff --git a/test/TestMultiAssoc.hs b/test/TestMultiAssoc.hs --- a/test/TestMultiAssoc.hs +++ b/test/TestMultiAssoc.hs @@ -35,180 +35,187 @@ multiAssocTests :: [TT.TestTree] multiAssocTests = - let (sugar1,_s1desc) = findSugarIn sugarCube (sample1 sugarCube testInpPath) - 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" $ 57 @=? length (sample1 sugarCube testInpPath) + [ + -- 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" $ 57 @=? length (sample1 sugarCube testInpPath) - -- KWQ: disabled 28 June 2022: encounters a pathological case in kvitable - -- rendering that causes this test to run ... forever (?) + -- KWQ: disabled 28 June 2022: encounters a pathological case in kvitable + -- rendering that causes this test to run ... forever (?) - -- , testCase "sweets rendering" $ - -- let actual = sweetsTextTable [sugarCube] sugar1 - -- in do putStrLn "Table" -- try to start table on its own line - -- putStrLn $ T.unpack actual - -- T.length actual > 0 @? "change this to see the table" + -- , testCase "sweets rendering" $ + -- let actual = sweetsTextTable [sugarCube] sugar1 + -- in do putStrLn "Table" -- try to start table on its own line + -- putStrLn $ T.unpack actual + -- T.length actual > 0 @? "change this to see the table" - , sugarTestEq "correct found count" sugarCube - (flip sample1 testInpPath) 6 length + , sugarTestEq "correct found count" sugarCube + (flip sample1 testInpPath) 6 length - , testCase "results" $ compareBags "results" sugar1 $ - let p = (testInpPath ) in - let exp0 e a f s = - Expectation { expectedFile = p e - , expParamsMatch = [("arch", a), ("form", f)] - , associated = s - } - exp1 e a f x = - let e1 = exp0 e a f [] - in e1 { associated = ("exe", p x) : associated e1 } - exp2 e a f x o = - let e1 = exp1 e a f x - in e1 { associated = ("obj", p o) : associated e1 } - exp2i e a f x i = - let e1 = exp1 e a f x - in e1 { associated = ("include", p i) : associated e1 } - exp3 e a f x o i = - let e1 = exp2 e a f x o - in e1 { associated = ("include", p i) : associated e1 } - e = Explicit - a = Assumed - in - [ - Sweets { rootMatchName = "global-max-good.c" - , rootBaseName = "global-max-good" - , rootFile = p "global-max-good.c" - , cubeParams = validParams sugarCube - , expected = - [ - exp2 "global-max-good.ppc.expected" (e "ppc") (a "refined") - "global-max-good.ppc.exe" - "global-max-good.ppc.o" + , testCase "results" $ do + (sugar1, _s1desc) <- findSugarIn sugarCube (sample1 sugarCube testInpPath) + compareBags "results" sugar1 $ + let p = (testInpPath ) + exp0 e a f s = + Expectation { expectedFile = p e + , expParamsMatch = [("arch", a), ("form", f)] + , associated = s + } + exp1 e a f x = + let e1 = exp0 e a f [] + in e1 { associated = ("exe", p x) : associated e1 } + exp2 e a f x o = + let e1 = exp1 e a f x + in e1 { associated = ("obj", p o) : associated e1 } + exp2i e a f x i = + let e1 = exp1 e a f x + in e1 { associated = ("include", p i) : associated e1 } + exp3 e a f x o i = + let e1 = exp2 e a f x o + in e1 { associated = ("include", p i) : associated e1 } + e = Explicit + a = Assumed + in + [ + Sweets + { rootMatchName = "global-max-good.c" + , rootBaseName = "global-max-good" + , rootFile = p "global-max-good.c" + , cubeParams = validParams sugarCube + , expected = + [ + exp2 "global-max-good.ppc.expected" (e "ppc") (a "refined") + "global-max-good.ppc.exe" + "global-max-good.ppc.o" - , exp2 "global-max-good.ppc.expected" (e "ppc") (a "base") - "global-max-good.ppc.exe" - "global-max-good.ppc.o" + , exp2 "global-max-good.ppc.expected" (e "ppc") (a "base") + "global-max-good.ppc.exe" + "global-max-good.ppc.o" - , exp1 "global-max-good.x86.expected" (e "x86") (a "refined") - "global-max-good.x86.exe" + , exp1 "global-max-good.x86.expected" (e "x86") (a "refined") + "global-max-good.x86.exe" - , exp1 "global-max-good.x86.expected" (e "x86") (a "base") - "global-max-good.x86.exe" - ] - } + , exp1 "global-max-good.x86.expected" (e "x86") (a "base") + "global-max-good.x86.exe" + ] + } - , Sweets { rootMatchName = "jumpfar.c" - , rootBaseName = "jumpfar" - , rootFile = p "jumpfar.c" - , cubeParams = validParams sugarCube - , expected = - [ exp3 "jumpfar.ppc.expected" (e "ppc") (a "refined") - "jumpfar.ppc.exe" - "jumpfar.ppc.o" - "jumpfar.h" + , Sweets + { rootMatchName = "jumpfar.c" + , rootBaseName = "jumpfar" + , rootFile = p "jumpfar.c" + , cubeParams = validParams sugarCube + , expected = + [ exp3 "jumpfar.ppc.expected" (e "ppc") (a "refined") + "jumpfar.ppc.exe" + "jumpfar.ppc.o" + "jumpfar.h" - , exp3 "jumpfar.ppc.expected" (e "ppc") (a "base") - "jumpfar.ppc.exe" - "jumpfar.ppc.o" - "jumpfar.h" + , exp3 "jumpfar.ppc.expected" (e "ppc") (a "base") + "jumpfar.ppc.exe" + "jumpfar.ppc.o" + "jumpfar.h" - , exp2i "jumpfar.x86.expected" (e "x86") (a "refined") - "jumpfar.x86.exe" - "jumpfar.h" + , exp2i "jumpfar.x86.expected" (e "x86") (a "refined") + "jumpfar.x86.exe" + "jumpfar.h" - , exp2i "jumpfar.x86.expected" (e "x86") (a "base") - "jumpfar.x86.exe" - "jumpfar.h" - ] - } - , Sweets { rootMatchName = "looping.c" - , rootBaseName = "looping" - , rootFile = p "looping.c" - , cubeParams = validParams sugarCube - , expected = - [ exp1 "looping.ppc.expected" (e "ppc") (a "refined") - "looping.ppc.exe" + , exp2i "jumpfar.x86.expected" (e "x86") (a "base") + "jumpfar.x86.exe" + "jumpfar.h" + ] + } + , Sweets + { rootMatchName = "looping.c" + , rootBaseName = "looping" + , rootFile = p "looping.c" + , cubeParams = validParams sugarCube + , expected = + [ exp1 "looping.ppc.expected" (e "ppc") (a "refined") + "looping.ppc.exe" - , exp1 "looping.ppc.expected" (e "ppc") (a "base") - "looping.ppc.exe" + , exp1 "looping.ppc.expected" (e "ppc") (a "base") + "looping.ppc.exe" - , exp1 "looping.x86.expected" (e "x86") (a "refined") - "looping.x86.exe" + , exp1 "looping.x86.expected" (e "x86") (a "refined") + "looping.x86.exe" - , exp1 "looping.x86.expected" (e "x86") (a "base") - "looping.x86.exe" - ] - } - , Sweets { rootMatchName = "looping-around.c" - , rootBaseName = "looping-around" - , rootFile = p "looping-around.c" - , cubeParams = validParams sugarCube - , expected = - [ exp1 "looping-around.expected" (a "x86") (a "refined") - "looping-around.x86.exe" + , exp1 "looping.x86.expected" (e "x86") (a "base") + "looping.x86.exe" + ] + } + , Sweets + { rootMatchName = "looping-around.c" + , rootBaseName = "looping-around" + , rootFile = p "looping-around.c" + , cubeParams = validParams sugarCube + , expected = + [ exp1 "looping-around.expected" (a "x86") (a "refined") + "looping-around.x86.exe" - , exp1 "looping-around.expected" (a "x86") (a "base") - "looping-around.x86.exe" + , exp1 "looping-around.expected" (a "x86") (a "base") + "looping-around.x86.exe" - , exp1 "looping-around.ppc.expected" (e "ppc") (a "refined") - "looping-around.ppc.exe" + , exp1 "looping-around.ppc.expected" (e "ppc") (a "refined") + "looping-around.ppc.exe" - , exp1 "looping-around.ppc.expected" (e "ppc") (a "base") - "looping-around.ppc.exe" + , exp1 "looping-around.ppc.expected" (e "ppc") (a "base") + "looping-around.ppc.exe" + ] + } + , Sweets + { rootMatchName = "switching.c" + , rootBaseName = "switching" + , rootFile = p "switching.c" + , cubeParams = validParams sugarCube + , expected = + [ exp0 "switching.ppc.base-expected" (e "ppc") (e "base") + [ ("exe", p "switching.ppc.exe") + -- 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") ] - } - , Sweets { rootMatchName = "switching.c" - , rootBaseName = "switching" - , rootFile = p "switching.c" - , cubeParams = validParams sugarCube - , expected = - [ exp0 "switching.ppc.base-expected" (e "ppc") (e "base") - [ ("exe", p "switching.ppc.exe") - -- 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") - ] - , exp0 "switching.x86.base-expected" (e "x86") (e "base") - [ ("exe", p "switching.x86.exe") - , ("include", p "switching.h") - , ("c++-include", p "switching.hh") - , ("plain", p "switching") - ] + , exp0 "switching.x86.base-expected" (e "x86") (e "base") + [ ("exe", p "switching.x86.exe") + , ("include", p "switching.h") + , ("c++-include", p "switching.hh") + , ("plain", p "switching") + ] - , exp0 "switching.x86.refined-expected" (e "x86") (e "refined") - [ ("exe", p "switching.x86.exe") - , ("obj", p "switching-refined.x86.o") - , ("include", p "switching.h") - , ("c++-include", p "switching.hh") - , ("plain", p "switching") - ] + , exp0 "switching.x86.refined-expected" (e "x86") (e "refined") + [ ("exe", p "switching.x86.exe") + , ("obj", p "switching-refined.x86.o") + , ("include", p "switching.h") + , ("c++-include", p "switching.hh") + , ("plain", p "switching") + ] - ] - } - , Sweets { rootMatchName = "tailrecurse.c" - , rootBaseName = "tailrecurse" - , rootFile = p "tailrecurse.c" - , cubeParams = validParams sugarCube - , expected = - [ exp1 "tailrecurse.expected" (a "ppc") (a "refined") - "tailrecurse.ppc.exe" + ] + } + , Sweets + { rootMatchName = "tailrecurse.c" + , rootBaseName = "tailrecurse" + , rootFile = p "tailrecurse.c" + , cubeParams = validParams sugarCube + , expected = + [ exp1 "tailrecurse.expected" (a "ppc") (a "refined") + "tailrecurse.ppc.exe" - , exp1 "tailrecurse.expected" (a "ppc") (a "base") - "tailrecurse.ppc.exe" + , exp1 "tailrecurse.expected" (a "ppc") (a "base") + "tailrecurse.ppc.exe" - , exp1 "tailrecurse.x86.expected" (e "x86") (a "refined") - "tailrecurse.x86.exe" + , exp1 "tailrecurse.x86.expected" (e "x86") (a "refined") + "tailrecurse.x86.exe" - , exp1 "tailrecurse.x86.expected" (e "x86") (a "base") - "tailrecurse.x86.exe" - ] - } - ] - ] + , exp1 "tailrecurse.x86.expected" (e "x86") (a "base") + "tailrecurse.x86.exe" + ] + } + ] + ] diff --git a/test/TestNoAssoc.hs b/test/TestNoAssoc.hs --- a/test/TestNoAssoc.hs +++ b/test/TestNoAssoc.hs @@ -15,19 +15,19 @@ testInpPath = "tests/samples" sugarCube = mkCUBE - { rootName = "*.c" - , expectedSuffix = "expected" - , inputDirs = [ testInpPath ] - , associatedNames = [] - , validParams = [ ("arch", Just ["x86", "ppc"]) - , ("form", Just ["base", "refined"]) - ] - } + { rootName = "*.c" + , expectedSuffix = "expected" + , inputDirs = [ testInpPath ] + , associatedNames = [] + , validParams = [ ("arch", Just ["x86", "ppc"]) + , ("form", Just ["base", "refined"]) + ] + } + noAssocTests :: [TT.TestTree] noAssocTests = - let (sugar1,s1desc) = findSugarIn sugarCube (sample1 sugarCube testInpPath) - chkCandidate = checkCandidate sugarCube (\c -> sample1 c testInpPath) + let chkCandidate = checkCandidate sugarCube (\c -> sample1 c testInpPath) testInpPath [] in [ @@ -107,92 +107,100 @@ , sugarTestEq "correct found count" sugarCube (flip sample1 testInpPath) 6 length - , testCase "results" $ compareBags "results" sugar1 - $ let p = (testInpPath ) in - let exp0 e a f = + , testCase "results" $ + let p = (testInpPath ) + exp0 e a f = Expectation { expectedFile = p e , expParamsMatch = [("arch", a), ("form", f)] , associated = [] } e = Explicit a = Assumed - in - [ - Sweets { rootMatchName = "global-max-good.c" - , rootBaseName = "global-max-good" - , rootFile = p "global-max-good.c" - , cubeParams = validParams sugarCube - , expected = - [ - exp0 "global-max-good.ppc.expected" (e "ppc") (a "refined") - , exp0 "global-max-good.ppc.expected" (e "ppc") (a "base") - , exp0 "global-max-good.x86.expected" (e "x86") (a "refined") - , exp0 "global-max-good.x86.expected" (e "x86") (a "base") - ] - } + in do + (sugar1, _desc) <- findSugarIn sugarCube (sample1 sugarCube testInpPath) + compareBags "results" sugar1 + [ + Sweets + { rootMatchName = "global-max-good.c" + , rootBaseName = "global-max-good" + , rootFile = p "global-max-good.c" + , cubeParams = validParams sugarCube + , expected = + [ + exp0 "global-max-good.ppc.expected" (e "ppc") (a "refined") + , exp0 "global-max-good.ppc.expected" (e "ppc") (a "base") + , exp0 "global-max-good.x86.expected" (e "x86") (a "refined") + , exp0 "global-max-good.x86.expected" (e "x86") (a "base") + ] + } - , Sweets { rootMatchName = "jumpfar.c" - , rootBaseName = "jumpfar" - , rootFile = p "jumpfar.c" - , cubeParams = validParams sugarCube - , expected = - [ exp0 "jumpfar.ppc.expected" (e "ppc") (a "refined") - , exp0 "jumpfar.ppc.expected" (e "ppc") (a "base") - , exp0 "jumpfar.x86.expected" (e "x86") (a "refined") - , exp0 "jumpfar.x86.expected" (e "x86") (a "base") - ] - } - , Sweets { rootMatchName = "looping.c" - , rootBaseName = "looping" - , rootFile = p "looping.c" - , cubeParams = validParams sugarCube - , expected = - [ exp0 "looping.ppc.expected" (e "ppc") (a "refined") - , exp0 "looping.ppc.expected" (e "ppc") (a "base") - , exp0 "looping.x86.expected" (e "x86") (a "refined") - , exp0 "looping.x86.expected" (e "x86") (a "base") - ] - } - , Sweets { rootMatchName = "looping-around.c" - , rootBaseName = "looping-around" - , rootFile = p "looping-around.c" - , cubeParams = validParams sugarCube - , expected = - [ exp0 "looping-around.expected" (a "x86") (a "refined") - , exp0 "looping-around.expected" (a "x86") (a "base") - , exp0 "looping-around.ppc.expected" (e "ppc") (a "refined") - , exp0 "looping-around.ppc.expected" (e "ppc") (a "base") - ] - } - , Sweets { rootMatchName = "switching.c" - , rootBaseName = "switching" - , rootFile = p "switching.c" - , cubeParams = validParams sugarCube - , expected = - [ exp0 "switching.ppc.base-expected" (e "ppc") (e "base") - , exp0 "switching.x86.base-expected" (e "x86") (e "base") - , exp0 "switching.x86.refined-expected" (e "x86") (e "refined") - ] - } - , Sweets { rootMatchName = "tailrecurse.c" - , rootBaseName = "tailrecurse" - , rootFile = p "tailrecurse.c" - , cubeParams = validParams sugarCube - , expected = - [ exp0 "tailrecurse.expected" (a "ppc") (a "refined") - , exp0 "tailrecurse.expected" (a "ppc") (a "base") - , exp0 "tailrecurse.x86.expected" (e "x86") (a "refined") - , exp0 "tailrecurse.x86.expected" (e "x86") (a "base") - ] - } - ] + , Sweets + { rootMatchName = "jumpfar.c" + , rootBaseName = "jumpfar" + , rootFile = p "jumpfar.c" + , cubeParams = validParams sugarCube + , expected = + [ exp0 "jumpfar.ppc.expected" (e "ppc") (a "refined") + , exp0 "jumpfar.ppc.expected" (e "ppc") (a "base") + , exp0 "jumpfar.x86.expected" (e "x86") (a "refined") + , exp0 "jumpfar.x86.expected" (e "x86") (a "base") + ] + } + , Sweets + { rootMatchName = "looping.c" + , rootBaseName = "looping" + , rootFile = p "looping.c" + , cubeParams = validParams sugarCube + , expected = + [ exp0 "looping.ppc.expected" (e "ppc") (a "refined") + , exp0 "looping.ppc.expected" (e "ppc") (a "base") + , exp0 "looping.x86.expected" (e "x86") (a "refined") + , exp0 "looping.x86.expected" (e "x86") (a "base") + ] + } + , Sweets + { rootMatchName = "looping-around.c" + , rootBaseName = "looping-around" + , rootFile = p "looping-around.c" + , cubeParams = validParams sugarCube + , expected = + [ exp0 "looping-around.expected" (a "x86") (a "refined") + , exp0 "looping-around.expected" (a "x86") (a "base") + , exp0 "looping-around.ppc.expected" (e "ppc") (a "refined") + , exp0 "looping-around.ppc.expected" (e "ppc") (a "base") + ] + } + , Sweets + { rootMatchName = "switching.c" + , rootBaseName = "switching" + , rootFile = p "switching.c" + , cubeParams = validParams sugarCube + , expected = + [ exp0 "switching.ppc.base-expected" (e "ppc") (e "base") + , exp0 "switching.x86.base-expected" (e "x86") (e "base") + , exp0 "switching.x86.refined-expected" (e "x86") (e "refined") + ] + } + , Sweets + { rootMatchName = "tailrecurse.c" + , rootBaseName = "tailrecurse" + , rootFile = p "tailrecurse.c" + , cubeParams = validParams sugarCube + , expected = + [ exp0 "tailrecurse.expected" (a "ppc") (a "refined") + , exp0 "tailrecurse.expected" (a "ppc") (a "base") + , exp0 "tailrecurse.x86.expected" (e "x86") (a "refined") + , exp0 "tailrecurse.x86.expected" (e "x86") (a "base") + ] + } + ] ] mkNoAssocTests :: IO [TT.TestTree] -mkNoAssocTests = - let (sugar1,s1desc) = findSugarIn sugarCube $ sample1 sugarCube testInpPath - in do tt <- withSugarGroups sugar1 TT.testGroup $ +mkNoAssocTests = do + (sugar1, _desc) <- findSugarIn sugarCube $ sample1 sugarCube testInpPath + tt <- withSugarGroups sugar1 TT.testGroup $ \sw idx exp -> -- Verify this will suppress the "refined" tests for -- "looping-around.c" @@ -202,6 +210,6 @@ else return [ testCase (rootMatchName sw <> "." <> show idx) $ return () ] - return $ - (testCase "generated count" $ 21 @=? length (concatMap (testsNames mempty) tt)) - : tt + return $ + (testCase "generated count" $ 21 @=? length (concatMap (testsNames mempty) tt)) + : tt diff --git a/test/TestParams.hs b/test/TestParams.hs new file mode 100644 --- /dev/null +++ b/test/TestParams.hs @@ -0,0 +1,138 @@ +module TestParams ( paramTests ) where + +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Test.Tasty.Sugar +import TestUtils + + +testInpPath = "/test/data" + + +-- | These tests show the simple progression of parameter matching in expected +-- files, starting with a base where no parameters are matched and so everything +-- is assumed, through intermediate cases where some of the parameters are +-- matched (and therefore explicit) through to the end case where every parameter +-- match is present and explicit. + +paramTests :: [TT.TestTree] +paramTests = + let cube = mkCUBE { inputDirs = [ testInpPath ] + , rootName = "*.inp" + , separators = "-." + , expectedSuffix = "exp" + , validParams = [ ("p1", Just [ "one", "two", "three" ]) ] + } + chkExp res swNum expNum expF p1Match = + safeElem expNum .expected <$> safeElem swNum res @?= + (Just $ Just $ Expectation { expectedFile = expF + , expParamsMatch = [ ("p1", p1Match) ] + , associated = [] + }) + expbase = testInpPath <> "/first.exp" + expone = testInpPath <> "/first-one.exp" + exptwo = testInpPath <> "/first-two.exp" + expthree = testInpPath <> "/first-three.exp" + + checkTheStandardThings op = + [ + testCase "valid # results" $ do + (res, _) <- op + length res @?= 1 + + , testCase "rootMatchName" $ do + (res, _) <- op + rootMatchName <$> (safeElem 0 res) @?= Just "first.inp" + + , testCase "rootBaseName" $ do + (res, _) <- op + rootBaseName <$> (safeElem 0 res) @?= Just "first" + + , testCase "rootFile" $ do + (res, _) <- op + rootFile <$> (safeElem 0 res) @?= Just "/test/data/first.inp" + + , testCase "cubeParams" $ do + (res, _) <- op + cubeParams <$> (safeElem 0 res) @?= + Just [ ("p1", Just [ "one", "two", "three" ]) ] + + , testCase "num expecteds" $ do + (res, _) <- op + length . expected <$> safeElem 0 res @?= Just 3 + ] + + in [ TT.testGroup "no matching params" $ + + let sample = (makeCandidate cube testInpPath []) <$> + [ "first.inp" + , "first.exp" + ] + in do + checkTheStandardThings (findSugarIn cube sample) + -- No parameters match, all expectations are against the base file and + -- all parameter values are assumed. + <> [ testCase "expected 2" $ do + ( sugar, _desc ) <- findSugarIn cube sample + chkExp sugar 0 2 expbase (Assumed "one") + , testCase "expected 0" $ do + ( sugar, _desc ) <- findSugarIn cube sample + chkExp sugar 0 0 expbase (Assumed "two") + , testCase "expected 1" $ do + ( sugar, _desc ) <- findSugarIn cube sample + chkExp sugar 0 1 expbase (Assumed "three") + ] + + ---------------------------------------------------------------------- + + , TT.testGroup "one matching param" $ + + let sample = (makeCandidate cube testInpPath []) <$> + [ "first.inp" + , "first.exp" + , "first-one.exp" + ] + in do + checkTheStandardThings (findSugarIn cube sample) + -- One parameter matches a specific file which is therefore explicit, + -- all other expectations are against the base file and their parameter + -- values are assumed. + <> [ testCase "expected 0" $ do + ( sugar, _desc ) <- findSugarIn cube sample + chkExp sugar 0 0 expone (Explicit "one") + , testCase "expected 1" $ do + ( sugar, _desc ) <- findSugarIn cube sample + chkExp sugar 0 1 expbase (Assumed "two") + , testCase "expected 2" $ do + ( sugar, _desc ) <- findSugarIn cube sample + chkExp sugar 0 2 expbase (Assumed "three") + ] + + ---------------------------------------------------------------------- + + , TT.testGroup "all matching params" $ + + let sample = (makeCandidate cube testInpPath []) <$> + [ "first.inp" + , "first.exp" + , "first-one.exp" + , "first-two.exp" + , "first-three.exp" + ] + in do + checkTheStandardThings (findSugarIn cube sample) + -- All parameters match a specific expected file and are explicit. The + -- base expected file is never matched because the explicit matches are + -- more precise. + <> [ testCase "expected 0" $ do + ( sugar, _desc ) <- findSugarIn cube sample + chkExp sugar 0 0 expone (Explicit "one") + , testCase "expected 2" $ do + ( sugar, _desc ) <- findSugarIn cube sample + chkExp sugar 0 2 exptwo (Explicit "two") + , testCase "expected 1" $ do + ( sugar, _desc ) <- findSugarIn cube sample + chkExp sugar 0 1 expthree (Explicit "three") + ] + + ] diff --git a/test/TestParamsAssoc.hs b/test/TestParamsAssoc.hs --- a/test/TestParamsAssoc.hs +++ b/test/TestParamsAssoc.hs @@ -88,8 +88,7 @@ paramsAssocTests :: [TT.TestTree] paramsAssocTests = - let (sugar1,_s1desc) = findSugarIn sugarCube (sample sugarCube) - chkCandidate = checkCandidate sugarCube sample testInpPath [] 0 + let chkCandidate = checkCandidate sugarCube sample testInpPath [] 0 mkE' a cx cy p f c o = Expectation { expectedFile = p f , expParamsMatch = [ ("a param", cy "y") @@ -104,11 +103,15 @@ mkEo cs p f c ca = mkE' [] cs ca p f c NotSpecified p = (testInpPath ) chkFld :: Eq a => Show a - => Maybe Sweets -> String -> (Sweets -> a) -> a -> TT.TestTree - chkFld s n f w = testCase n $ maybe (error "fail") f s @?= w - chkExp s g n f c o = testCase ("Exp #" <> show n) - $ (safeElem n . expected =<< s) - @?= Just (g f c o) + => Int -> String -> (Sweets -> a) -> a -> TT.TestTree + chkFld sn n f w = testCase n + $ do (ss, _desc) <- findSugarIn sugarCube (sample sugarCube) + let s = safeElem sn ss + maybe (error "fail") f s @?= w + chkExp sn g n f c o = testCase ("Exp #" <> show n) + $ do (ss, _desc) <- findSugarIn sugarCube (sample sugarCube) + let s = safeElem sn ss + (safeElem n . expected =<< s) @?= Just (g f c o) in [ testCase "valid sample" $ 36 @=? length (sample sugarCube) , TT.testGroup "candidates" @@ -162,10 +165,9 @@ , sugarTestEq "correct found count" sugarCube sample 12 length , let sweetNum = 6 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE = chkExp sweet (mkEr p) + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE = chkExp sweetNum (mkEr p) in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "recursive.fast.exe" @@ -177,10 +179,9 @@ ] , let sweetNum = 9 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE = chkExp sweet (mkEc p) + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE = chkExp sweetNum (mkEc p) in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "simple.noopt.clang.exe" @@ -195,10 +196,9 @@ ] , let sweetNum = 10 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE = chkExp sweet (mkEc p) + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE = chkExp sweetNum (mkEc p) in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "simple.noopt.gcc.exe" @@ -213,10 +213,9 @@ ] , let sweetNum = 11 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE = chkExp sweet (mkEc p) + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE = chkExp sweetNum (mkEc p) in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "simple.opt-clang.exe" @@ -233,10 +232,9 @@ -- value. The duplicate value should be ignored, but both values should -- result in different Expectations. , let sweetNum = 8 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE = chkExp sweet (mkEc p) + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE = chkExp sweetNum (mkEc p) in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "simple.clang-noopt-clang.exe" @@ -256,10 +254,9 @@ -- are found that could be tried, along with an expect file that doesn't -- supply a potential value for this parameter. , let sweetNum = 7 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE = chkExp sweet (mkEc p) + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE = chkExp sweetNum (mkEc p) in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "simple.clang-gcc.exe" @@ -279,10 +276,9 @@ -- Verify that Expectations are selected based on better ParamMatches -- (sorted). , let sweetNum = 0 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE n cs ca f c = chkExp sweet (mkE' [] cs ca p) n f c NotSpecified + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE n cs ca f c = chkExp sweetNum (mkE' [] cs ca p) n f c NotSpecified in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "alpha.exe" @@ -298,10 +294,9 @@ -- expected filename *if* the parameter is higher (sorted on parameter -- name). , let sweetNum = 1 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE n cs ca f c = chkExp sweet (mkE' [] cs ca p) n f c NotSpecified + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE n cs ca f c = chkExp sweetNum (mkE' [] cs ca p) n f c NotSpecified in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "beta.exe" @@ -316,10 +311,9 @@ -- This is the same as beta, but with the separator extensions on the -- other side. , let sweetNum = 4 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE n cs ca f c = chkExp sweet (mkE' [] cs ca p) n f c NotSpecified + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE n cs ca f c = chkExp sweetNum (mkE' [] cs ca p) n f c NotSpecified in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "gamma.exe" @@ -333,10 +327,9 @@ -- This is the same as beta, but with a higher-precedence parameter , let sweetNum = 2 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE n cs ca f c = chkExp sweet (mkE' [] cs ca p) n f c NotSpecified + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE n cs ca f c = chkExp sweetNum (mkE' [] cs ca p) n f c NotSpecified in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "delta.exe" @@ -352,10 +345,9 @@ -- This is the same as beta, but with the separator extensions on the -- other side. , let sweetNum = 3 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE n cs ca f c = chkExp sweet (mkE' [] cs ca p) n f c NotSpecified + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE n cs ca f c = chkExp sweetNum (mkE' [] cs ca p) n f c NotSpecified in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "epsilon.exe" @@ -369,10 +361,9 @@ ] , let sweetNum = 5 - sweet = safeElem sweetNum sugar1 - chkF = chkFld sweet - chkP = chkFld sweet - chkE = chkExp sweet (mkE' [("c-source", p "gcc/hole-here.c")] Assumed Assumed p) + chkF = chkFld sweetNum + chkP = chkFld sweetNum + chkE = chkExp sweetNum (mkE' [("c-source", p "gcc/hole-here.c")] Assumed Assumed p) in TT.testGroup ("Sweet #" <> show sweetNum) [ chkF "rootMatchName" rootMatchName "hole-here.exe" diff --git a/test/TestSingleAssoc.hs b/test/TestSingleAssoc.hs --- a/test/TestSingleAssoc.hs +++ b/test/TestSingleAssoc.hs @@ -15,145 +15,152 @@ testInpPath = "test/samples" sugarCube = mkCUBE - { rootName = "*.c" - , expectedSuffix = "expected" - , inputDirs = [ testInpPath ] - , associatedNames = [ ("exe", "exe") ] - , validParams = [ ("arch", Just ["x86", "ppc"]) - , ("form", Just ["base", "refined"]) - ] - } + { rootName = "*.c" + , expectedSuffix = "expected" + , inputDirs = [ testInpPath ] + , associatedNames = [ ("exe", "exe") ] + , validParams = [ ("arch", Just ["x86", "ppc"]) + , ("form", Just ["base", "refined"]) + ] + } singleAssocTests :: [TT.TestTree] singleAssocTests = - let (sugar1,_s1desc) = findSugarIn sugarCube (sample1 sugarCube testInpPath) - 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" $ 57 @=? length (sample1 sugarCube testInpPath) + -- 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" $ 57 @=? length (sample1 sugarCube testInpPath) - , sugarTestEq "correct found count" sugarCube - (flip sample1 testInpPath) 6 length + , sugarTestEq "correct found count" sugarCube + (flip sample1 testInpPath) 6 length - , testCase "results" $ compareBags "results" sugar1 $ - let p = (testInpPath ) in - let exp1 e a f x = - Expectation { expectedFile = p e - , expParamsMatch = [("arch", a), ("form", f)] - , associated = [("exe", p x)] - } - e = Explicit - a = Assumed - in - [ - Sweets { rootMatchName = "global-max-good.c" - , rootBaseName = "global-max-good" - , rootFile = p "global-max-good.c" - , cubeParams = validParams sugarCube - , expected = - [ - exp1 "global-max-good.ppc.expected" (e "ppc") (a "refined") - "global-max-good.ppc.exe" + , testCase "results" $ do + (sugar1,_s1desc) <- findSugarIn sugarCube (sample1 sugarCube testInpPath) + compareBags "results" sugar1 $ + let p = (testInpPath ) + exp1 e a f x = + Expectation { expectedFile = p e + , expParamsMatch = [("arch", a), ("form", f)] + , associated = [("exe", p x)] + } + e = Explicit + a = Assumed + in + [ + Sweets + { rootMatchName = "global-max-good.c" + , rootBaseName = "global-max-good" + , rootFile = p "global-max-good.c" + , cubeParams = validParams sugarCube + , expected = + [ + exp1 "global-max-good.ppc.expected" (e "ppc") (a "refined") + "global-max-good.ppc.exe" - , exp1 "global-max-good.ppc.expected" (e "ppc") (a "base") - "global-max-good.ppc.exe" + , exp1 "global-max-good.ppc.expected" (e "ppc") (a "base") + "global-max-good.ppc.exe" - , exp1 "global-max-good.x86.expected" (e "x86") (a "refined") - "global-max-good.x86.exe" + , exp1 "global-max-good.x86.expected" (e "x86") (a "refined") + "global-max-good.x86.exe" - , exp1 "global-max-good.x86.expected" (e "x86") (a "base") - "global-max-good.x86.exe" - ] - } + , exp1 "global-max-good.x86.expected" (e "x86") (a "base") + "global-max-good.x86.exe" + ] + } - , Sweets { rootMatchName = "jumpfar.c" - , rootBaseName = "jumpfar" - , rootFile = p "jumpfar.c" - , cubeParams = validParams sugarCube - , expected = - [ exp1 "jumpfar.ppc.expected" (e "ppc") (a "refined") - "jumpfar.ppc.exe" + , Sweets + { rootMatchName = "jumpfar.c" + , rootBaseName = "jumpfar" + , rootFile = p "jumpfar.c" + , cubeParams = validParams sugarCube + , expected = + [ exp1 "jumpfar.ppc.expected" (e "ppc") (a "refined") + "jumpfar.ppc.exe" - , exp1 "jumpfar.ppc.expected" (e "ppc") (a "base") - "jumpfar.ppc.exe" + , exp1 "jumpfar.ppc.expected" (e "ppc") (a "base") + "jumpfar.ppc.exe" - , exp1 "jumpfar.x86.expected" (e "x86") (a "refined") - "jumpfar.x86.exe" + , exp1 "jumpfar.x86.expected" (e "x86") (a "refined") + "jumpfar.x86.exe" - , exp1 "jumpfar.x86.expected" (e "x86") (a "base") - "jumpfar.x86.exe" - ] - } - , Sweets { rootMatchName = "looping.c" - , rootBaseName = "looping" - , rootFile = p "looping.c" - , cubeParams = validParams sugarCube - , expected = - [ exp1 "looping.ppc.expected" (e "ppc") (a "refined") - "looping.ppc.exe" + , exp1 "jumpfar.x86.expected" (e "x86") (a "base") + "jumpfar.x86.exe" + ] + } + , Sweets + { rootMatchName = "looping.c" + , rootBaseName = "looping" + , rootFile = p "looping.c" + , cubeParams = validParams sugarCube + , expected = + [ exp1 "looping.ppc.expected" (e "ppc") (a "refined") + "looping.ppc.exe" - , exp1 "looping.ppc.expected" (e "ppc") (a "base") - "looping.ppc.exe" + , exp1 "looping.ppc.expected" (e "ppc") (a "base") + "looping.ppc.exe" - , exp1 "looping.x86.expected" (e "x86") (a "refined") - "looping.x86.exe" + , exp1 "looping.x86.expected" (e "x86") (a "refined") + "looping.x86.exe" - , exp1 "looping.x86.expected" (e "x86") (a "base") - "looping.x86.exe" - ] - } - , Sweets { rootMatchName = "looping-around.c" - , rootBaseName = "looping-around" - , rootFile = p "looping-around.c" - , cubeParams = validParams sugarCube - , expected = - [ exp1 "looping-around.expected" (a "x86") (a "refined") - "looping-around.x86.exe" + , exp1 "looping.x86.expected" (e "x86") (a "base") + "looping.x86.exe" + ] + } + , Sweets + { rootMatchName = "looping-around.c" + , rootBaseName = "looping-around" + , rootFile = p "looping-around.c" + , cubeParams = validParams sugarCube + , expected = + [ exp1 "looping-around.expected" (a "x86") (a "refined") + "looping-around.x86.exe" - , exp1 "looping-around.expected" (a "x86") (a "base") - "looping-around.x86.exe" + , exp1 "looping-around.expected" (a "x86") (a "base") + "looping-around.x86.exe" - , exp1 "looping-around.ppc.expected" (e "ppc") (a "refined") - "looping-around.ppc.exe" + , exp1 "looping-around.ppc.expected" (e "ppc") (a "refined") + "looping-around.ppc.exe" - , exp1 "looping-around.ppc.expected" (e "ppc") (a "base") - "looping-around.ppc.exe" - ] - } - , Sweets { rootMatchName = "switching.c" - , rootBaseName = "switching" - , rootFile = p "switching.c" - , cubeParams = validParams sugarCube - , expected = - [ exp1 "switching.ppc.base-expected" (e "ppc") (e "base") - "switching.ppc.exe" + , exp1 "looping-around.ppc.expected" (e "ppc") (a "base") + "looping-around.ppc.exe" + ] + } + , Sweets + { rootMatchName = "switching.c" + , rootBaseName = "switching" + , rootFile = p "switching.c" + , cubeParams = validParams sugarCube + , expected = + [ exp1 "switching.ppc.base-expected" (e "ppc") (e "base") + "switching.ppc.exe" - , exp1 "switching.x86.base-expected" (e "x86") (e "base") - "switching.x86.exe" + , exp1 "switching.x86.base-expected" (e "x86") (e "base") + "switching.x86.exe" - , exp1 "switching.x86.refined-expected" (e "x86") (e "refined") - "switching.x86.exe" - ] - } - , Sweets { rootMatchName = "tailrecurse.c" - , rootBaseName = "tailrecurse" - , rootFile = p "tailrecurse.c" - , cubeParams = validParams sugarCube - , expected = - [ exp1 "tailrecurse.expected" (a "ppc") (a "refined") - "tailrecurse.ppc.exe" + , exp1 "switching.x86.refined-expected" (e "x86") (e "refined") + "switching.x86.exe" + ] + } + , Sweets + { rootMatchName = "tailrecurse.c" + , rootBaseName = "tailrecurse" + , rootFile = p "tailrecurse.c" + , cubeParams = validParams sugarCube + , expected = + [ exp1 "tailrecurse.expected" (a "ppc") (a "refined") + "tailrecurse.ppc.exe" - , exp1 "tailrecurse.expected" (a "ppc") (a "base") - "tailrecurse.ppc.exe" + , exp1 "tailrecurse.expected" (a "ppc") (a "base") + "tailrecurse.ppc.exe" - , exp1 "tailrecurse.x86.expected" (e "x86") (a "refined") - "tailrecurse.x86.exe" + , exp1 "tailrecurse.x86.expected" (e "x86") (a "refined") + "tailrecurse.x86.exe" - , exp1 "tailrecurse.x86.expected" (e "x86") (a "base") - "tailrecurse.x86.exe" - ] - } - ] - ] + , exp1 "tailrecurse.x86.expected" (e "x86") (a "base") + "tailrecurse.x86.exe" + ] + } + ] + ] diff --git a/test/TestStrlen2.hs b/test/TestStrlen2.hs --- a/test/TestStrlen2.hs +++ b/test/TestStrlen2.hs @@ -19,144 +19,149 @@ ] sugarCube = mkCUBE - { rootName = "*.c" - , expectedSuffix = "good" - , inputDirs = [ testInpPath ] - , associatedNames = [ ("config", "config") - , ("stdio", "print") - ] - , validParams = testParams - } + { rootName = "*.c" + , expectedSuffix = "good" + , inputDirs = [ testInpPath ] + , associatedNames = [ ("config", "config") + , ("stdio", "print") + ] + , validParams = testParams + } strlen2SampleTests :: [TT.TestTree] strlen2SampleTests = - let (sugar,sdesc) = findSugarIn sugarCube (strlen2Samples sugarCube) - chkCandidate = checkCandidate sugarCube strlen2Samples testInpPath [] 0 - in [ testCase "valid sample" $ 24 @=? length (strlen2Samples sugarCube) - , sugarTestEq "correct found count" sugarCube strlen2Samples 1 length + let chkCandidate = checkCandidate sugarCube strlen2Samples testInpPath [] 0 + in + [ testCase "valid sample" $ 24 @=? length (strlen2Samples sugarCube) + , sugarTestEq "correct found count" sugarCube strlen2Samples 1 length - , TT.testGroup "candidates" - [ - chkCandidate "strlen_test2.boolector.boolector.out" - [ ("solver", Explicit "boolector") ] - , chkCandidate "strlen_test2.boolector.boolector.print.out" - [ ("solver", Explicit "boolector") ] - , chkCandidate "strlen_test2.boolector.good" - [ ("solver", Explicit "boolector") ] - , chkCandidate "strlen_test2.boolector.loopmerge.good" - [ ("loop-merging", Explicit "loopmerge") - , ("solver", Explicit "boolector") - ] - , chkCandidate "strlen_test2.c" [] - , chkCandidate "strlen_test2.cvc4.cvc4.out" - [ ("solver", Explicit "cvc4") ] - , chkCandidate "strlen_test2.cvc4.loop.good" - [ ("loop-merging", Explicit "loop") - , ("solver", Explicit "cvc4") - ] - , chkCandidate "strlen_test2.loopmerge.cvc4.good" - [ ("loop-merging", Explicit "loopmerge") - , ("solver", Explicit "cvc4") - ] - , chkCandidate "strlen_test2.good" [] - , chkCandidate "strlen_test2.loopmerge.config" - [ ("loop-merging", Explicit "loopmerge") ] - , chkCandidate "strlen_test2.loopmerge.stp.out" - [ ("loop-merging", Explicit "loopmerge") - ] - , chkCandidate "strlen_test2.loopmerge.yices.out" - [ ("loop-merging", Explicit "loopmerge") - , ("solver", Explicit "yices") - ] - , chkCandidate "strlen_test2.loopmerge.yices.print.out" - [ ("loop-merging", Explicit "loopmerge") - , ("solver", Explicit "yices") - ] - , chkCandidate "strlen_test2.print" [] - , chkCandidate "strlen_test2.stp.out" [] - , chkCandidate "strlen_test2.stp.print.out" [] - , chkCandidate "strlen_test2.yices.out" - [ ("solver", Explicit "yices") ] - , chkCandidate "strlen_test2.yices.print.out" - [ ("solver", Explicit "yices") ] - , chkCandidate "strlen_test2.z3.good" - [ ("solver", Explicit "z3") ] - , chkCandidate "strlen_test2.z3.z3.out" - [ ("solver", Explicit "z3") ] - , chkCandidate "strlen_test2.z3.z3.print.out" - [ ("solver", Explicit "z3") ] - ] + , TT.testGroup "candidates" + [ + chkCandidate "strlen_test2.boolector.boolector.out" + [ ("solver", Explicit "boolector") ] + , chkCandidate "strlen_test2.boolector.boolector.print.out" + [ ("solver", Explicit "boolector") ] + , chkCandidate "strlen_test2.boolector.good" + [ ("solver", Explicit "boolector") ] + , chkCandidate "strlen_test2.boolector.loopmerge.good" + [ ("loop-merging", Explicit "loopmerge") + , ("solver", Explicit "boolector") + ] + , chkCandidate "strlen_test2.c" [] + , chkCandidate "strlen_test2.cvc4.cvc4.out" + [ ("solver", Explicit "cvc4") ] + , chkCandidate "strlen_test2.cvc4.loop.good" + [ ("loop-merging", Explicit "loop") + , ("solver", Explicit "cvc4") + ] + , chkCandidate "strlen_test2.loopmerge.cvc4.good" + [ ("loop-merging", Explicit "loopmerge") + , ("solver", Explicit "cvc4") + ] + , chkCandidate "strlen_test2.good" [] + , chkCandidate "strlen_test2.loopmerge.config" + [ ("loop-merging", Explicit "loopmerge") ] + , chkCandidate "strlen_test2.loopmerge.stp.out" + [ ("loop-merging", Explicit "loopmerge") + ] + , chkCandidate "strlen_test2.loopmerge.yices.out" + [ ("loop-merging", Explicit "loopmerge") + , ("solver", Explicit "yices") + ] + , chkCandidate "strlen_test2.loopmerge.yices.print.out" + [ ("loop-merging", Explicit "loopmerge") + , ("solver", Explicit "yices") + ] + , chkCandidate "strlen_test2.print" [] + , chkCandidate "strlen_test2.stp.out" [] + , chkCandidate "strlen_test2.stp.print.out" [] + , chkCandidate "strlen_test2.yices.out" + [ ("solver", Explicit "yices") ] + , chkCandidate "strlen_test2.yices.print.out" + [ ("solver", Explicit "yices") ] + , chkCandidate "strlen_test2.z3.good" + [ ("solver", Explicit "z3") ] + , chkCandidate "strlen_test2.z3.z3.out" + [ ("solver", Explicit "z3") ] + , chkCandidate "strlen_test2.z3.z3.print.out" + [ ("solver", Explicit "z3") ] + ] - , 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 ] + , testCaseSteps "sweets info" $ \step -> do + (sugar,sdesc) <- findSugarIn sugarCube (strlen2Samples sugarCube) + 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 - let exp1 e a f = - Expectation { expectedFile = p e - , expParamsMatch = [("solver", a), ("loop-merging", f)] - , associated = [("stdio", p "strlen_test2.print")] - } - exp2 e a f c = - let e1 = exp1 e a f - in e1 { associated = ("config", p c) : associated e1 } - e = Explicit - a = Assumed - l = "loop" - m = "loopmerge" - in - [ - exp2 "strlen_test2.boolector.loopmerge.good" (e "boolector") (e m) - "strlen_test2.loopmerge.config" + , testCase "Expectations" $ + let p = (testInpPath ) + exp1 e a f = + Expectation { expectedFile = p e + , expParamsMatch = [("solver", a), ("loop-merging", f)] + , associated = [("stdio", p "strlen_test2.print")] + } + exp2 e a f c = + let e1 = exp1 e a f + in e1 { associated = ("config", p c) : associated e1 } + e = Explicit + a = Assumed + l = "loop" + m = "loopmerge" + in do + (sugar,sdesc) <- findSugarIn sugarCube (strlen2Samples sugarCube) + compareBags "expected" (expected $ head sugar) + [ + exp2 "strlen_test2.boolector.loopmerge.good" (e "boolector") (e m) + "strlen_test2.loopmerge.config" - , exp1 "strlen_test2.boolector.good" (e "boolector") (a l) + , exp1 "strlen_test2.boolector.good" (e "boolector") (a l) - , exp2 "strlen_test2.loopmerge.cvc4.good" (e "cvc4") (e m) - "strlen_test2.loopmerge.config" + , exp2 "strlen_test2.loopmerge.cvc4.good" (e "cvc4") (e m) + "strlen_test2.loopmerge.config" - , exp1 "strlen_test2.cvc4.loop.good" (e "cvc4") (e l) + , exp1 "strlen_test2.cvc4.loop.good" (e "cvc4") (e l) - , exp2 "strlen_test2.loopmerge.good" (a "yices") (e m) - "strlen_test2.loopmerge.config" + , exp2 "strlen_test2.loopmerge.good" (a "yices") (e m) + "strlen_test2.loopmerge.config" - , exp1 "strlen_test2.good" (a "yices") (a l) + , exp1 "strlen_test2.good" (a "yices") (a l) - , exp2 "strlen_test2.loopmerge.good" (a "z3") (e m) - "strlen_test2.loopmerge.config" + , exp2 "strlen_test2.loopmerge.good" (a "z3") (e m) + "strlen_test2.loopmerge.config" - , exp1 "strlen_test2.z3.good" (e "z3") (a l) + , exp1 "strlen_test2.z3.good" (e "z3") (a l) - -- 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. - -- - -- The removeNonExplicitMatchingExpectations function will then try to - -- select which one has the least number of explicit matches, but one is - -- always Explicit and one is always Assumed. The resuilt then comes - -- down to a comparison of the values, and "loopmerge" < "z3", so "z3" - -- is selected as the _maximum_ (i.e. best) match. - -- - -- Thus, the following Expectation is eliminated. - -- - -- , 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. + -- + -- The removeNonExplicitMatchingExpectations function will + -- then try to select which one has the least number of + -- explicit matches, but one is always Explicit and one is + -- always Assumed. The resuilt then comes down to a + -- comparison of the values, and "loopmerge" < "z3", so "z3" + -- is selected as the _maximum_ (i.e. best) match. + -- + -- Thus, the following Expectation is eliminated. + -- + -- , 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") + -- ] + -- } + ] + ] + strlen2Samples cube = fmap (makeCandidate cube "test-data/samples" []) $ filter (not . null) diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -119,13 +119,13 @@ else map (showEnt "ACTUAL") gotUnique) sugarTest name cube sample test = - let (r,d) = findSugarIn cube sample - in testCase name $ testWithFailInfo d test r + testCase name $ do (r,d) <- findSugarIn cube sample + testWithFailInfo d test r sugarTestEq name cube sample expVal test = - let (r,d) = findSugarIn cube (sample cube) - in testCase name $ eqTestWithFailInfo d expVal $ test r + testCase name $ do (r,d) <- findSugarIn cube (sample cube) + eqTestWithFailInfo d expVal $ test r checkCandidate cube files path subdirs sepSkip nm pm = diff --git a/test/TestWildcard.hs b/test/TestWildcard.hs --- a/test/TestWildcard.hs +++ b/test/TestWildcard.hs @@ -44,249 +44,245 @@ wildcardAssocTests :: [TT.TestTree] wildcardAssocTests = - [ let sugarCube = mkCUBE - { rootName = "*" - , expectedSuffix = "exp" - , inputDirs = [ testInpPath ] - , associatedNames = [ ("extern", "ex") ] - } - p = (testInpPath ) - in testCase "valid sample" $ 14 @=? length (sample1 sugarCube) + [ let sugarCube = mkCUBE + { rootName = "*" + , expectedSuffix = "exp" + , inputDirs = [ testInpPath ] + , associatedNames = [ ("extern", "ex") ] + } + p = (testInpPath ) + in testCase "valid sample" $ 14 @=? length (sample1 sugarCube) - -- The first CUBE uses the default set of separators, and the expected - -- suffix does not limit which separators can preceed the suffix. - , TT.testGroup "with default seps" $ - let sugarCube = mkCUBE - { rootName = "*" - , expectedSuffix = "exp" - , inputDirs = [ testInpPath ] - , associatedNames = [ ("extern", "ex") ] - } - p = (testInpPath ) - exp e = Expectation { expectedFile = p e - , associated = [] - , expParamsMatch = [] - } - expE e a = (exp e) { associated = [("extern", p a)] } - sw m b f e = Sweets { rootBaseName = b - , rootMatchName = m - , rootFile = p f - , cubeParams = [] - , expected = e - } - in [ sugarTestEq "correct found count" sugarCube sample1 9 length + -- The first CUBE uses the default set of separators, and the expected + -- suffix does not limit which separators can preceed the suffix. + , TT.testGroup "with default seps" $ + let sugarCube = mkCUBE + { rootName = "*" + , expectedSuffix = "exp" + , inputDirs = [ testInpPath ] + , associatedNames = [ ("extern", "ex") ] + } + p = (testInpPath ) + exp e = Expectation { expectedFile = p e + , associated = [] + , expParamsMatch = [] + } + expE e a = (exp e) { associated = [("extern", p a)] } + sw m b f e = Sweets { rootBaseName = b + , rootMatchName = m + , rootFile = p f + , cubeParams = [] + , expected = e + } + 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 - -- therefore a valid root as well. - , sugarTestEq "foo is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootMatchName x == "foo" ] - , sugarTestEq "foo.ex is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootMatchName x == "foo.ex" ] + -- foo.ex is an associated name for foo, but removing its + -- extension makes it a sibling for the expected file and + -- therefore a valid root as well. + , sugarTestEq "foo is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "foo" ] + , sugarTestEq "foo.ex is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "foo.ex" ] - -- Similarly, bar.ex is an associated name, but also - -- matches the expected Suffix when its .ex suffix is - -- removed. - , sugarTestEq "bar. is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootMatchName x == "bar." ] - , sugarTestEq "bar-ex is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootMatchName x == "bar-ex" ] + -- Similarly, bar.ex is an associated name, but also + -- matches the expected Suffix when its .ex suffix is + -- removed. + , sugarTestEq "bar. is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "bar." ] + , sugarTestEq "bar-ex is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "bar-ex" ] - , sugarTestEq "dog.bark is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootFile x == p "dog.bark" ] - -- n.b. cow.moo is not matched because there is no separator in cow.mooexp - , testCase "full results" $ - compareBags "default result" - (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" ] - -- 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 ] - ] + , sugarTestEq "dog.bark is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootFile x == p "dog.bark" ] + -- n.b. cow.moo is not matched because there is no separator in cow.mooexp + , testCase "full results" $ do + (sweets, _desc) <- findSugarIn sugarCube (sample1 sugarCube) + compareBags "default result" sweets + [ 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" ] + -- 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" ] - ] - ] + , testCase "full distinct results" $ do + (sweets, _desc) <- findSugarIn (sugarCube + { sweetAdjuster = const (return . distinctResults) }) + (sample1 sugarCube) + compareBags "default result" sweets + [ 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 - -- immediately follows the source name with no separator. - , TT.testGroup "no seps" $ - let sugarCube = mkCUBE - { rootName = "*" - , expectedSuffix = "exp" - , separators = "" - , inputDirs = [ testInpPath ] - , associatedNames = [ ("extern", "ex") ] - } - p = (testInpPath ) - exp e = Expectation { expectedFile = p e - , associated = [] - , expParamsMatch = [] - } - expE e a = (exp e) { associated = [("extern", p a)] } - sw m b f e = Sweets { rootBaseName = b - , rootMatchName = m - , rootFile = p f - , cubeParams = [] - , expected = e - } - in [ sugarTestEq "correct found count" sugarCube sample1 2 length - , sugarTestEq "bar is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootFile x == p "bar." ] - , sugarTestEq "cow.moo is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootFile x == p "cow.moo" ] - -- n.b. neither foo nor dog.bark is matched because they - -- both have a character between the name and the - -- expectedSuffix that is not a known separator - , testCase "full results" $ - compareBags "default result" - (fst $ findSugarIn sugarCube (sample1 sugarCube)) $ - let p = (testInpPath ) in - [ sw "bar." "bar." "bar." [ exp "bar.exp" ] - , sw "cow.moo" "cow.moo" "cow.moo" [ expE "cow.mooexp" "cow.mooex" ] - ] - ] + -- The second CUBE specifies no separators: the expected suffix + -- immediately follows the source name with no separator. + , TT.testGroup "no seps" $ + let sugarCube = mkCUBE + { rootName = "*" + , expectedSuffix = "exp" + , separators = "" + , inputDirs = [ testInpPath ] + , associatedNames = [ ("extern", "ex") ] + } + p = (testInpPath ) + exp e = Expectation { expectedFile = p e + , associated = [] + , expParamsMatch = [] + } + expE e a = (exp e) { associated = [("extern", p a)] } + sw m b f e = Sweets { rootBaseName = b + , rootMatchName = m + , rootFile = p f + , cubeParams = [] + , expected = e + } + in [ sugarTestEq "correct found count" sugarCube sample1 2 length + , sugarTestEq "bar is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootFile x == p "bar." ] + , sugarTestEq "cow.moo is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootFile x == p "cow.moo" ] + -- n.b. neither foo nor dog.bark is matched because they + -- both have a character between the name and the + -- expectedSuffix that is not a known separator + , testCase "full results" $ do + (sweets, _desc) <- findSugarIn sugarCube (sample1 sugarCube) + compareBags "default result" sweets + [ sw "bar." "bar." "bar." [ exp "bar.exp" ] + , sw "cow.moo" "cow.moo" "cow.moo" [ expE "cow.mooexp" "cow.mooex" ] + ] + ] - -- The third CUBE specifies one of the separators as part of the - -- suffix, so only that separator is matched. - , TT.testGroup "seps with suffix sep" $ - let sugarCube = mkCUBE - { rootName = "*" - , expectedSuffix = ".exp" - , inputDirs = [ testInpPath ] - , associatedNames = [ ("extern", "ex") ] - } - p = (testInpPath ) - exp e = Expectation { expectedFile = p e - , associated = [] - , expParamsMatch = [] - } - expE e a = (exp e) { associated = [("extern", p a)] } - sw m b f e = Sweets { rootBaseName = b - , rootMatchName = m - , rootFile = p f - , cubeParams = [] - , expected = e - } - in [ sugarTestEq "correct found count" sugarCube sample1 7 length + -- The third CUBE specifies one of the separators as part of the + -- suffix, so only that separator is matched. + , TT.testGroup "seps with suffix sep" $ + let sugarCube = mkCUBE + { rootName = "*" + , expectedSuffix = ".exp" + , inputDirs = [ testInpPath ] + , associatedNames = [ ("extern", "ex") ] + } + p = (testInpPath ) + exp e = Expectation { expectedFile = p e + , associated = [] + , expParamsMatch = [] + } + expE e a = (exp e) { associated = [("extern", p a)] } + sw m b f e = Sweets { rootBaseName = b + , rootMatchName = m + , rootFile = p f + , cubeParams = [] + , expected = e + } + in [ sugarTestEq "correct found count" sugarCube sample1 7 length - -- see notes for default seps tests above + -- see notes for default seps tests above - , sugarTestEq "foo is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootMatchName x == "foo" ] - , sugarTestEq "foo.ex is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootMatchName x == "foo.ex" ] + , sugarTestEq "foo is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "foo" ] + , sugarTestEq "foo.ex is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "foo.ex" ] - -- n.b. dog.bark is not matched because the separator in - -- dog.bark-exp is not the separator specified for the - -- expected suffix. + -- n.b. dog.bark is not matched because the separator in + -- dog.bark-exp is not the separator specified for the + -- expected suffix. - , sugarTestEq "bar. is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootMatchName x == "bar." ] - , sugarTestEq "bar-ex is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootMatchName x == "bar-ex" ] + , sugarTestEq "bar. is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "bar." ] + , sugarTestEq "bar-ex is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "bar-ex" ] - -- n.b. cow.moo is not matched because there is no separator in cow.mooexp - , testCase "full results" $ - compareBags "default result" - (fst $ findSugarIn sugarCube (sample1 sugarCube)) $ - let p = (testInpPath ) in + -- n.b. cow.moo is not matched because there is no separator in cow.mooexp + , testCase "full results" $ do + (sweets, _desc) <- findSugarIn sugarCube (sample1 sugarCube) + compareBags "default result" sweets [ 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" ] - -- rootName is a wildcard, so the expected can match the root: + -- 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 ] ] - ] + ] - -- The fourth CUBE specifies one of the separators as part of the suffix, so - -- only that separator is matched, and further specifies a non-wildcard - -- suffix for the match (which occludes the associated name). - , TT.testGroup "seps with suffix sep and root suffix" $ - let sugarCube = mkCUBE - { rootName = "*.ex" - , expectedSuffix = ".exp" - , inputDirs = [ testInpPath ] - , associatedNames = [ ("extern", "ex") ] - } - p = (testInpPath ) - exp e = Expectation { expectedFile = p e - , associated = [] - , expParamsMatch = [] - } - sw m b f e = Sweets { rootBaseName = b - , rootMatchName = m - , rootFile = p f - , cubeParams = [] - , expected = e - } - in [ sugarTestEq "correct found count" sugarCube sample1 1 length - , sugarTestEq "foo.ex is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootMatchName x == "foo.ex" ] - , testCase "full results" $ - compareBags "default result" - (fst $ findSugarIn sugarCube (sample1 sugarCube)) $ - let p = (testInpPath ) in - [ sw "foo.ex" "foo" "foo.ex" [ exp "foo.exp" ] - ] - ] + -- The fourth CUBE specifies one of the separators as part of the suffix, so + -- only that separator is matched, and further specifies a non-wildcard + -- suffix for the match (which occludes the associated name). + , TT.testGroup "seps with suffix sep and root suffix" $ + let sugarCube = mkCUBE + { rootName = "*.ex" + , expectedSuffix = ".exp" + , inputDirs = [ testInpPath ] + , associatedNames = [ ("extern", "ex") ] + } + p = (testInpPath ) + exp e = Expectation { expectedFile = p e + , associated = [] + , expParamsMatch = [] + } + sw m b f e = Sweets { rootBaseName = b + , rootMatchName = m + , rootFile = p f + , cubeParams = [] + , expected = e + } + in [ sugarTestEq "correct found count" sugarCube sample1 1 length + , sugarTestEq "foo.ex is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "foo.ex" ] + , testCase "full results" $ do + (sweets, _desc) <- findSugarIn sugarCube (sample1 sugarCube) + compareBags "default result" sweets + [ sw "foo.ex" "foo" "foo.ex" [ exp "foo.exp" ] + ] + ] - -- The fifth CUBE is like the fourth CUBE but it additionally matches - -- parameters. The fifth CUBE (like the fourth) specifies one of the - -- separators as part of the suffix, so only that separator is matched, and - -- further specifies a non-wildcard suffix for the match (which occludes the - -- associated name). - , TT.testGroup "seps with suffix sep and root suffix and params" $ - let sugarCube = mkCUBE - { rootName = "*.ex" - , expectedSuffix = ".exp" - , inputDirs = [ testInpPath ] - , validParams = [ ("dir", Just [ "right", "left" ]) ] - , associatedNames = [ ("extern", "ex") ] - } - p = (testInpPath ) - exp e d = Expectation { expectedFile = p e - , associated = [] - , expParamsMatch = [ ("dir", d) ] - } - sw m b f e = Sweets { rootBaseName = b - , rootMatchName = m - , rootFile = p f - , cubeParams = [("dir", Just ["right", "left"])] - , expected = e - } - in [ sugarTestEq "correct found count" sugarCube sample1 1 length - , sugarTestEq "foo.ex is a case" sugarCube sample1 1 $ - \sugar -> length [ x | x <- sugar, rootMatchName x == "foo.ex" ] - , testCase "full results" $ - compareBags "default result" - (fst $ findSugarIn sugarCube (sample1 sugarCube)) $ - let p = (testInpPath ) in - [ sw "foo.ex" "foo" "foo.ex" - [ exp "foo.exp" (Assumed "left") - , exp "foo.right.exp" (Explicit "right") - ] - ] - ] + -- The fifth CUBE is like the fourth CUBE but it additionally matches + -- parameters. The fifth CUBE (like the fourth) specifies one of the + -- separators as part of the suffix, so only that separator is matched, and + -- further specifies a non-wildcard suffix for the match (which occludes the + -- associated name). + , TT.testGroup "seps with suffix sep and root suffix and params" $ + let sugarCube = mkCUBE + { rootName = "*.ex" + , expectedSuffix = ".exp" + , inputDirs = [ testInpPath ] + , validParams = [ ("dir", Just [ "right", "left" ]) ] + , associatedNames = [ ("extern", "ex") ] + } + p = (testInpPath ) + exp e d = Expectation { expectedFile = p e + , associated = [] + , expParamsMatch = [ ("dir", d) ] + } + sw m b f e = Sweets { rootBaseName = b + , rootMatchName = m + , rootFile = p f + , cubeParams = [("dir", Just ["right", "left"])] + , expected = e + } + in [ sugarTestEq "correct found count" sugarCube sample1 1 length + , sugarTestEq "foo.ex is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "foo.ex" ] + , testCase "full results" $ do + (sweets, _desc) <- findSugarIn sugarCube (sample1 sugarCube) + compareBags "default result" sweets + [ sw "foo.ex" "foo" "foo.ex" + [ exp "foo.exp" (Assumed "left") + , exp "foo.right.exp" (Explicit "right") + ] + ] + ] - ] + ] diff --git a/test/data/issue3/test.42.c b/test/data/issue3/test.42.c new file mode 100644 --- /dev/null +++ b/test/data/issue3/test.42.c diff --git a/test/data/issue3/test.c b/test/data/issue3/test.c new file mode 100644 --- /dev/null +++ b/test/data/issue3/test.c