tasty-sugar 2.1.0.0 → 2.2.0.0
raw patch · 22 files changed
+2195/−862 lines, 22 filesdep +transformersdep ~hedgehogdep ~pretty-showdep ~raw-strings-qqPVP ok
version bump matches the API change (PVP)
Dependencies added: transformers
Dependency ranges changed: hedgehog, pretty-show, raw-strings-qq, tasty-hedgehog, tasty-hunit
API changes (from Hackage documentation)
+ Test.Tasty.Sugar: [sweetAdjuster] :: CUBE -> forall (m :: Type -> Type). MonadIO m => CUBE -> [Sweets] -> m [Sweets]
+ Test.Tasty.Sugar: candidateToPath :: CandidateFile -> FilePath
+ Test.Tasty.Sugar: rangedParamAdjuster :: (Enum a, Ord a, MonadIO m) => String -> (String -> Maybe a) -> (a -> a -> Bool) -> Maybe a -> CUBE -> [Sweets] -> m [Sweets]
- Test.Tasty.Sugar: CUBE :: FilePath -> [FilePath] -> GlobPattern -> FileSuffix -> Separators -> [(String, FileSuffix)] -> [ParameterPattern] -> CUBE
+ Test.Tasty.Sugar: CUBE :: FilePath -> [FilePath] -> GlobPattern -> FileSuffix -> Separators -> [(String, FileSuffix)] -> [ParameterPattern] -> (forall (m :: Type -> Type). MonadIO m => CUBE -> [Sweets] -> m [Sweets]) -> CUBE
- Test.Tasty.Sugar: findSugarIn :: CUBE -> [CandidateFile] -> ([Sweets], Doc ann)
+ Test.Tasty.Sugar: findSugarIn :: MonadIO m => CUBE -> [CandidateFile] -> m ([Sweets], Doc ann)
Files
- CHANGELOG.md +12/−0
- README.org +32/−0
- src/Test/Tasty/Sugar.hs +31/−16
- src/internal/Test/Tasty/Sugar/Candidates.hs +18/−2
- src/internal/Test/Tasty/Sugar/Ranged.hs +255/−0
- src/internal/Test/Tasty/Sugar/Report.hs +1/−1
- src/internal/Test/Tasty/Sugar/Types.hs +47/−3
- tasty-sugar.cabal +18/−10
- test/TestGCD.hs +67/−64
- test/TestIssue3.hs +70/−0
- test/TestLLVMRange.hs +708/−0
- test/TestMain.hs +21/−3
- test/TestMultiAssoc.hs +160/−153
- test/TestNoAssoc.hs +96/−88
- test/TestParams.hs +138/−0
- test/TestParamsAssoc.hs +46/−55
- test/TestSingleAssoc.hs +125/−118
- test/TestStrlen2.hs +129/−124
- test/TestUtils.hs +4/−4
- test/TestWildcard.hs +217/−221
- test/data/issue3/test.42.c +0/−0
- test/data/issue3/test.c +0/−0
CHANGELOG.md view
@@ -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
README.org view
@@ -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...
src/Test/Tasty/Sugar.hs view
@@ -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
src/internal/Test/Tasty/Sugar/Candidates.hs view
@@ -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
+ src/internal/Test/Tasty/Sugar/Ranged.hs view
@@ -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
src/internal/Test/Tasty/Sugar/Report.hs view
@@ -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"
src/internal/Test/Tasty/Sugar/Types.hs view
@@ -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
tasty-sugar.cabal view
@@ -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
test/TestGCD.hs view
@@ -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)
+ test/TestIssue3.hs view
@@ -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
+ test/TestLLVMRange.hs view
@@ -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
test/TestMain.hs view
@@ -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)))
test/TestMultiAssoc.hs view
@@ -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"+ ]+ }+ ]+ ]
test/TestNoAssoc.hs view
@@ -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
+ test/TestParams.hs view
@@ -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")+ ]++ ]
test/TestParamsAssoc.hs view
@@ -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"
test/TestSingleAssoc.hs view
@@ -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"+ ]+ }+ ]+ ]
test/TestStrlen2.hs view
@@ -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)
test/TestUtils.hs view
@@ -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 =
test/TestWildcard.hs view
@@ -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")+ ]+ ]+ ] - ]+ ]
+ test/data/issue3/test.42.c view
+ test/data/issue3/test.c view