diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,24 @@ # Revision history for tasty-sugar +## 2.0 + + * Performance improvements. Now scales better when there are more parameters. + + * Improved expected and associated file matching and Expected results parameter + identification. This may result in different results than the 1.x version of + tasty-sugar! + + * Parameter values explicit in the root match but not in the expected file are + now reported as Explicit in the expParamsMatch because they explicitly match + part of one of the filenames. This also means that files which were + previously provided as expectations are no longer matched because the better + root parameter matches exclude them. + + * Expectations are selected by best ParamMatch values, in order of parameter + name, with ties resolved in favor of the longest expected filename. + + * The --showsearch can now also report internal stats for tasty-sugar. + ## 1.3.0.2 -- 2022-09-06 * Add test files to cabal's `extra-sources` so they are included in the package diff --git a/src/Test/Tasty/Sugar.hs b/src/Test/Tasty/Sugar.hs --- a/src/Test/Tasty/Sugar.hs +++ b/src/Test/Tasty/Sugar.hs @@ -74,6 +74,8 @@ , ParameterPattern , mkCUBE , CandidateFile(..) + , makeCandidate + , findCandidates -- ** Output , Sweets(..) , Expectation(..) @@ -92,24 +94,23 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logic +import Data.Either ( lefts, rights ) import qualified Data.Foldable as F import Data.Function import qualified Data.List as L +import qualified Data.Map as Map import Data.Maybe ( isJust, isNothing, fromJust ) import Data.Proxy import qualified Data.Text as T import Data.Typeable ( Typeable ) import Numeric.Natural ( Natural ) import Prettyprinter -import System.Directory ( doesDirectoryExist, getCurrentDirectory - , listDirectory, doesDirectoryExist ) -import System.FilePath ( (), isRelative, makeRelative - , splitPath, takeDirectory, takeFileName) import System.IO ( hPutStrLn, stderr ) import Test.Tasty.Ingredients import Test.Tasty.Options import Test.Tasty.Sugar.Analysis +import Test.Tasty.Sugar.Candidates import Test.Tasty.Sugar.Report import Test.Tasty.Sugar.Types @@ -176,50 +177,14 @@ findSugar cube = fst <$> findSugar' cube findSugar' :: MonadIO m => CUBE -> m ([Sweets], Doc ann) -findSugar' pat = - let collectDirEntries d = - let recurse = takeFileName d == "*" - top = if recurse then Just (takeDirectory d) else Nothing - start = if recurse then takeDirectory d else d - in dirListWithPaths top start - dirListWithPaths topDir d = - -- putStrLn ("Reading " <> show d) >> - doesDirectoryExist d >>= \case - True -> - do dirContents <- listDirectory d - case topDir of - Nothing -> do - let mkC f = CandidateFile { candidateDir = d - , candidateSubdirs = [] - , candidateFile = f - } - return (mkC <$> dirContents) - Just topdir -> do - let subs = filter (not . null) - (init - <$> init (splitPath - $ makeRelative topdir (d "x"))) - let mkC f = CandidateFile { candidateDir = topdir - , candidateSubdirs = subs - , candidateFile = f - } - subdirs <- filterM (doesDirectoryExist . (d )) dirContents - let here = mkC <$> (filter (not . (`elem` subdirs)) dirContents) - subCandidates <- mapM (dirListWithPaths topDir) - ((d ) <$> subdirs) - return (here <> (concat subCandidates)) - False -> do - showD <- case isRelative d of - True -> do cwd <- getCurrentDirectory - return $ "[" <> cwd <> "/]" <> d - False -> return d - hPutStrLn stderr $ "WARNING: " <> showD <> " does not exist" - return [] - in findSugarIn pat - <$> liftIO (concat <$> (mapM collectDirEntries +findSugar' pat = do + candidates <- liftIO (concat + <$> (mapM (findCandidates pat) $ L.filter (not . null) $ L.nub $ inputDir pat : inputDirs pat)) + mapM_ (liftIO . hPutStrLn stderr . ("WARNING: " <>)) $ lefts candidates + return $ findSugarIn pat $ rights candidates -- | Given a list of filepaths and a CUBE, returns the list of matching @@ -232,7 +197,7 @@ findSugarIn :: CUBE -> [CandidateFile] -> ([Sweets], Doc ann) findSugarIn pat allFiles = - let (nCandidates, sres) = checkRoots pat allFiles + let (nCandidates, sres, stats) = checkRoots pat allFiles inps = concat $ fst <$> sres expl = vsep $ [ "Checking for test inputs in:" <+> @@ -247,6 +212,11 @@ pretty (length sres) , "parameters = " <+> pretty (validParams pat) ] <> ((("--?" <+>) . pretty) <$> (concatMap snd sres)) + <> if null stats + then [] + else [ "", "Stats:" ] + <> ((\(k,v) -> " #" <+> pretty k <+> " = " <> pretty v) + <$> Map.toList stats) ] in case cubeIsValid pat of Right _ -> (L.sortBy (compare `on` rootFile) inps, expl) diff --git a/src/internal/Test/Tasty/Sugar/Analysis.hs b/src/internal/Test/Tasty/Sugar/Analysis.hs --- a/src/internal/Test/Tasty/Sugar/Analysis.hs +++ b/src/internal/Test/Tasty/Sugar/Analysis.hs @@ -9,7 +9,7 @@ ) where -import Control.Monad.Logic +import Control.Parallel.Strategies import Data.Bifunctor ( bimap ) import Data.Function ( on ) import qualified Data.List as L @@ -18,23 +18,29 @@ import qualified System.FilePath.GlobPattern as FPGP import Test.Tasty.Sugar.ExpectCheck -import Test.Tasty.Sugar.RootCheck +import Test.Tasty.Sugar.Iterations import Test.Tasty.Sugar.ParamCheck ( pmatchCmp ) import Test.Tasty.Sugar.Types +import Prelude hiding ( exp ) + -- | Given a 'CUBE' and a list of candidate files in the target directories, -- return all 'Sweets' matches along with an explanation of the search process. -- This is the core implementation for the 'Test.Tasty.Sugar.findSugar' API -- interface. checkRoots :: CUBE -> [CandidateFile] - -> (Int, [([Sweets], [SweetExplanation])]) + -> (Int, [([Sweets], [SweetExplanation])], IterStat) checkRoots pat allFiles = let isRootMatch n = candidateFile n FPGP.~~ (rootName pat) - roots = filter isRootMatch allFiles - checked = filter (not . null . fst) - ((checkRoot pat allFiles) <$> roots) - in (length checked, checked) + -- roots is all *possible* roots, but some of these are not roots at all, + -- and some of these may be the other files associated with a root, so + -- "root" files cannot be eliminated from the search space yet. + roots = L.filter isRootMatch allFiles + allSweets = (checkRoot pat allFiles) <$> roots + checked = filter (not . null . fst) (fst <$> allSweets) + allStats = foldr joinStats emptyStats (snd <$> allSweets) + in (length checked, checked, allStats) -- checkRoot will attempt to split the identified root file into three @@ -49,13 +55,36 @@ checkRoot :: CUBE -> [CandidateFile] -- all possible expect candidates -> CandidateFile -- root path - -> ([Sweets], [SweetExplanation]) + -> (([Sweets], [SweetExplanation]), IterStat) checkRoot pat allFiles rootF = - let seps = separators pat - params = validParams pat + let params = L.sort $ validParams pat combineExpRes (swts, expl) = bimap (swts :) (expl :) - mergeSweets swl = + roots = [( candidatePMatch rootF + , rootF { candidateFile = + -- truncate the candidateFile to the first separator + -- point preceeding parameter matches. + let i = fromEnum $ candidateMatchIdx rootF + l = length $ candidateFile rootF + e = l > 0 && last (candidateFile rootF) `elem` (separators pat) + t = if i == l && not e then i else i - 1 + in take t (candidateFile rootF) } + ) + , (candidatePMatch rootF, rootF) + ] + + expAndStats = parMap rpar (findExpectation pat params rootF allFiles) roots + + sumStats = foldr joinStats emptyStats (snd <$> expAndStats) + exps = foldr combineExpRes (mempty, mempty) $ mergeSweets + $ catMaybes (fst <$> expAndStats) + + in (exps, sumStats) + + +mergeSweets :: Foldable t + => t (Sweets, SweetExplanation) -> [(Sweets, SweetExplanation)] +mergeSweets swl = -- If multiple Sweets have the same rootMatchName this likely means that -- there were multiple expected files that could have matched. Merge the -- Expectations: for each of the second Sweet's expectations: @@ -91,19 +120,12 @@ let swts = s { expected = foldr mergeExp (expected s) (expected sm) } - mergeExp oneExp exps = + mergeExp oneExp expcts = concat $ fmap (take 1) $ L.groupBy ((==) `on` (fmap (fmap getParamVal) . expParamsMatch)) $ L.sortBy (pmatchCmp `on` expParamsMatch) - $ oneExp : exps + $ oneExp : expcts in ( swts, e { results = swts } ) in foldr combineIfRootsMatch [] swl - - in foldr combineExpRes ([], []) $ - mergeSweets $ - catMaybes $ - fmap (findExpectation pat rootF allFiles) $ - observeAll $ - rootMatch rootF seps params (rootName pat) diff --git a/src/internal/Test/Tasty/Sugar/AssocCheck.hs b/src/internal/Test/Tasty/Sugar/AssocCheck.hs --- a/src/internal/Test/Tasty/Sugar/AssocCheck.hs +++ b/src/internal/Test/Tasty/Sugar/AssocCheck.hs @@ -2,6 +2,7 @@ -- identified test root file. {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Test.Tasty.Sugar.AssocCheck ( @@ -9,10 +10,12 @@ ) where -import Control.Monad.Logic -import qualified Data.List as L -import Data.Maybe ( catMaybes ) +import Control.Monad ( guard ) +import Data.Function ( on ) +import qualified Data.List as DL +import Test.Tasty.Sugar.Candidates +import Test.Tasty.Sugar.Iterations import Test.Tasty.Sugar.ParamCheck import Test.Tasty.Sugar.Types @@ -26,79 +29,27 @@ -> [NamedParamMatch] -> [ (String, FileSuffix) ] -> [CandidateFile] - -> Logic [(String, CandidateFile)] + -> LogicI [(String, CandidateFile)] getAssoc rootPrefix seps pmatch assocNames allNames = assocSet where + assocSet = concat <$> mapM fndBestAssoc assocNames fndBestAssoc :: (String, FileSuffix) - -> Logic [(String, CandidateFile)] -- usually just one - fndBestAssoc assoc = - do let candidates = L.nub $ catMaybes $ - observeAll (fndAnAssoc assoc) - let highestRank = maximum (fst <$> candidates) - c = filter ((== highestRank) . fst) candidates - if null candidates - then return [] - else return (snd <$> c) - - fndAnAssoc :: (String, FileSuffix) - -> Logic (Maybe (Int, (String, CandidateFile))) - fndAnAssoc assoc = ifte (fndAssoc assoc) - (return . Just) - (return Nothing) + -> LogicI [(String, CandidateFile)] -- usually just one + fndBestAssoc assoc = addSubLogicStats (observeIT (fndAssoc assoc)) - fndAssoc :: (String, FileSuffix) -> Logic (Int, (String, CandidateFile)) + fndAssoc :: (String, FileSuffix) -> LogicI (String, CandidateFile) fndAssoc assoc = - do pseq <- npseq pmatch - (rank, assocPfx, assocSfx) <- sepParams seps (fmap snd pseq) - let possible = - if null assocSfx - then let justSep = null (snd assoc) && length assocPfx == 1 - rootNm = candidateFile rootPrefix - assocFName = if justSep - then rootNm - else rootNm <> assocPfx <> (snd assoc) - in (assocFName ==) - else let assocStart = candidateFile rootPrefix <> assocPfx - assocEnd = assocSfx <> snd assoc - aSL = length assocStart - aEL = length assocEnd - chk f = - and [ assocStart `L.isPrefixOf` f - , assocEnd `L.isSuffixOf` f - , length f > (aSL + aEL) - , let mid = drop aSL (take (length f - aEL) f) - in and $ fmap (not . flip elem mid) seps - ] - in chk - f <- eachFrom $ filter (possible . candidateFile) allNames - return (rank, (fst assoc, f)) - - sepParams :: Separators -> [ParamMatch] -> Logic (Int, String, String) - sepParams sl = - let rank (n,_,_) = n - pfx (_,l,_) = l - in \case - [] -> if null sl - then return (0, [], []) - else do s <- eachFrom sl - return (0, [s], []) - (NotSpecified:ps) -> do r <- sepParams sl ps - return (rank r, [], pfx r) - ((Explicit v):ps) -> do (n,l,r) <- sepParams sl ps - if null sl - then return (n+1, v <> l, r) - else do s <- eachFrom sl - return (n+1, [s] <> v <> l, r) - ((Assumed v):ps) -> do (n,l,r) <- sepParams sl ps - if null sl - then return (n+1, v <> l, r) - else do s <- eachFrom sl - return (n+1, [s] <> v <> l, r) - - npseq = eachFrom - . ([]:) -- consider no parameters just once - . filter (not . null) -- excluding multiple blanks in - . concatMap L.inits -- any number of the - . L.permutations -- parameters in each possible order + -- First, eliminate any files that don't start with rootPrefix or end in + -- this assoc suffix (do this before trying any backtracking). + do let sfxMatch cf = + and [ candidateMatchPrefix seps rootPrefix cf + , candidateMatchSuffix seps (snd assoc) rootPrefix cf + ] + assocNms = DL.reverse + $ DL.sortBy (compare `on` (matchStrength . fmap snd . candidatePMatch)) + $ filter sfxMatch allNames + afile <- eachFrom "assoc candidate" assocNms + guard (isCompatible (fmap getParamVal <$> pmatch) afile) + return (fst assoc, afile) diff --git a/src/internal/Test/Tasty/Sugar/Candidates.hs b/src/internal/Test/Tasty/Sugar/Candidates.hs new file mode 100644 --- /dev/null +++ b/src/internal/Test/Tasty/Sugar/Candidates.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Test.Tasty.Sugar.Candidates + ( + candidateToPath + , findCandidates + , makeCandidate + , candidateMatchPrefix + , candidateMatchSuffix + ) +where + +import Control.Monad ( filterM, guard ) +import Data.Bifunctor ( first ) +import qualified Data.List as DL +import Data.Maybe ( fromMaybe, isNothing ) +import Numeric.Natural +import System.Directory ( doesDirectoryExist, getCurrentDirectory + , listDirectory, doesDirectoryExist ) +import System.FilePath ( (), isRelative, makeRelative + , splitPath, takeDirectory, takeFileName) + +import Test.Tasty.Sugar.Iterations +import Test.Tasty.Sugar.Types + + +findCandidates :: CUBE -> FilePath -> IO ([Either String CandidateFile]) +findCandidates cube inDir = + let collectDirEntries d = + let recurse = takeFileName d == "*" + top = if recurse then Just (takeDirectory d) else Nothing + start = if recurse then takeDirectory d else d + in dirListWithPaths top start + dirListWithPaths topDir d = + -- putStrLn ("Reading " <> show d) >> + doesDirectoryExist d >>= \case + True -> + do dirContents <- listDirectory d + case topDir of + Nothing -> do + let mkC = makeCandidate cube d [] + return (Right . mkC <$> dirContents) + Just topdir -> do + let subs = filter (not . null) + (init + <$> init (splitPath + $ makeRelative topdir (d "x"))) + let mkC = makeCandidate cube topdir subs + subdirs <- filterM (doesDirectoryExist . (d )) dirContents + let here = Right . mkC <$> (filter (not . (`elem` subdirs)) dirContents) + subCandidates <- mapM (dirListWithPaths topDir) + ((d ) <$> subdirs) + return $ here <> (concat subCandidates) + False -> do + showD <- case isRelative d of + True -> do cwd <- getCurrentDirectory + return $ "[" <> cwd <> "/]" <> d + False -> return d + return [Left $ showD <> " does not exist"] + in collectDirEntries inDir + + +-- | Create a CandidateFile entry for this top directory, sub-paths, and +-- filename. In addition, any Explicit parameters with known values that appear +-- in the filename are captured. Note that: +-- +-- * There may be multiple possible matches for a single parameter (e.g. the +-- value is repeated in the name or path, or an undefind value (Nothing) +-- parameter could have multiple possible values extracted from the filename. +-- +-- * File name matches are preferred over sub-path matches and will occlude the +-- latter. +-- +-- * 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 + isSep = (`elem` separators cube) + firstSep = maybe fl (+1) $ DL.findIndex isSep fName + fle = maybe fl (fl-) $ DL.findIndex isSep $ DL.reverse fName + -- pmatches is all known parameter values found in the name or directory of + -- the file. Note that a single parameter with multiple values may result + -- in multiple pmatches if more than one of the values is present in a + -- single filename. + pmatches = fst $ observeIAll + $ do p <- eachFrom "param for candidate" $ validParams cube + v <- eachFrom "value for param" (fromMaybe [] (snd p)) + -- Note: there maybe multiple v values for a single p that + -- are matched in the name. This is accepted here (and + -- this file presumably satisfies either with an Explicit + -- match). + let vl = DL.length v + i <- eachFrom "param starts" + $ DL.findIndices (`elem` (separators cube)) fName + let vs = i + 1 + let ve = vs + vl + if and [ ve + 1 < fl -- v fits in fName[i..] + , v == DL.take vl (DL.drop vs fName) + , head (DL.drop ve fName) `elem` (separators cube) + ] + then return ((fst p, Explicit v), (toEnum vs, ve)) + else do guard $ v `elem` subPath + return ((fst p, Explicit v), (0, 0)) + -- pmatchArbitrary will find a parameter with an unspecified value and + -- assigned otherwise unmatched portions of the filename to that parameter. + pmatchArbitrary = + case DL.find (isNothing . snd) $ validParams cube of + Nothing -> [] + Just (p,_) -> + let chkRange = [(firstSep, fle)] + -- arbs is the (start,len) spans where arbitrary values could + -- occur + arbs = holes chkRange (snd <$> pmatches) + -- getRange extracts a substring range from the fName + getRange (s,e) = let s' = fromEnum s + in DL.take (e - s' - 1) $ DL.drop s' fName + -- holeVals are the separator-divided values extracted from the + -- arbs ranges of fName. + holeVals = let neither f a b = not $ or [f a, f b] + splitBySep = filter (not . all isSep) + . DL.groupBy (neither isSep) + rangeVals r = (,r) <$> (splitBySep $ getRange r) + in + concatMap rangeVals arbs + -- dirVals are the subdirectory elements that could be used for + -- arbitrary value matching (i.e. they don't explicitly match). + dirVals = + let pvals = getParamVal . snd . fst <$> pmatches + in (, (0,0)) <$> filter (not . (`elem` pvals) . Just) subPath + in (first ((p,) . Explicit)) <$> (holeVals <> dirVals) + pAll = pmatches <> pmatchArbitrary + dropSeps i = + let lst = last $ DL.group $ DL.take (fromEnum i) fName + in if isSep $ head lst + then i - (toEnum (length lst) - 1) + else i + mtchIdx = dropSeps + $ minimum + $ toEnum fle + : filter (/= 0) (fst . snd <$> pAll) + in CandidateFile { candidateDir = topDir + , candidateSubdirs = subPath + , candidateFile = fName + -- nub the results in case a v value appears twice in a single + -- file. Sort the results for stability in testing. + , candidatePMatch = DL.nub $ DL.sort $ (fst <$> pAll) + , candidateMatchIdx = mtchIdx + } + + +-- Remove present from chkRange leaving holes. +holes :: [(Int,Int)] -> [(Natural,Int)] -> [(Natural,Int)] +holes chkRange present = + let rmvKnown _ [] = [] + rmvKnown p@(ps,pe) ((s,e):rs) = + if abs(ps-s) <= 1 + then if pe > e + then rmvKnown (toEnum e,pe) rs + else if abs(pe-e) <= 1 + then rs + else (toEnum pe + 1, e) : rs + else if ps >= s && fromEnum ps < e + then if abs(pe - e) <= 1 + then (s, fromEnum ps) : rs + else if pe < e + then (s, fromEnum ps) : (toEnum pe, e) : rs + else (s, fromEnum ps) : rmvKnown (toEnum e, pe) rs + else rmvKnown p rs + r' = filter (\x -> fst x /= snd x) chkRange + in foldr rmvKnown (first toEnum <$> r') (DL.sort present) + + +-- | This converts a CandidatFile into a regular FilePath for access +candidateToPath :: CandidateFile -> FilePath +candidateToPath c = + candidateDir c foldr () (candidateFile c) (candidateSubdirs c) + + +-- | Determines if the second CandidateFile argument matches the prefix of the +-- first CandidateFile, up to any separator (if applicable). This can be used to +-- match possible expected files against the current root file, or possible +-- associated files against the current expected file. +candidateMatchPrefix :: Separators -> CandidateFile -> CandidateFile -> Bool +candidateMatchPrefix seps mf cf = + let mStart = candidateFile mf + mStartLen = length mStart + f = candidateFile cf + pfxlen = let cl = candidateMatchIdx cf + in if fromEnum cl == length f + then if null seps then toEnum mStartLen else cl + else cl - 1 + in mStart == DL.take (fromEnum pfxlen) f + + +candidateMatchSuffix :: Separators -> FileSuffix -> CandidateFile + -> CandidateFile -> Bool +candidateMatchSuffix seps sfx rootf cf = + let f = candidateFile cf + sfxsep = not (null sfx) && head sfx `elem` seps + in if null sfx + then f == DL.takeWhile (not . (`elem` seps)) f + else and [ length f >= (length (candidateFile rootf) + length sfx) + , sfx `DL.isSuffixOf` f + -- is char before sfx a separator (and fEnd didn't start + -- with a separator)? + , if null seps + then length f == length (candidateFile rootf) + length sfx + else if sfxsep + then True + else maybe False ((`elem` seps) . fst) + $ DL.uncons + $ DL.drop (length sfx) + $ reverse f + ] diff --git a/src/internal/Test/Tasty/Sugar/ExpectCheck.hs b/src/internal/Test/Tasty/Sugar/ExpectCheck.hs --- a/src/internal/Test/Tasty/Sugar/ExpectCheck.hs +++ b/src/internal/Test/Tasty/Sugar/ExpectCheck.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- | Function to find expected results files for a specific root file, @@ -7,15 +8,20 @@ module Test.Tasty.Sugar.ExpectCheck ( findExpectation - , removeNonExplicitMatchingExpectations + , collateExpectations ) where +import Control.Applicative ( (<|>) ) import Control.Monad -import Control.Monad.Logic +import Data.Bifunctor ( first ) +import Data.Function ( on ) import qualified Data.List as L +import Data.Maybe ( isNothing ) import Test.Tasty.Sugar.AssocCheck +import Test.Tasty.Sugar.Candidates +import Test.Tasty.Sugar.Iterations import Test.Tasty.Sugar.ParamCheck import Test.Tasty.Sugar.Types @@ -23,35 +29,37 @@ -- | Finds the possible expected files matching the selected -- source. There will be either one or none. findExpectation :: CUBE + -> [ParameterPattern] -> CandidateFile -- original name of source -> [CandidateFile] -- all of the names to choose from - -> ([NamedParamMatch], CandidateFile, String) -- param constraints from the root name - -> Maybe ( Sweets, SweetExplanation ) -findExpectation pat rootN allNames (rootPMatches, matchPrefix, _) = - let r = mkSweet $ - trimExpectations $ - observeAll $ - do guard (not $ null candidates) - expectedSearch - matchPrefix - rootPMatches seps params expSuffix o - candidates + -> ([NamedParamMatch], CandidateFile) -- param constraints from the root name + -> (Maybe ( Sweets, SweetExplanation ), IterStat) +findExpectation pat params rootN allNames (rootPMatches, matchPrefix) = + let r = first (mkSweet . trimExpectations) + $ observeIAll + $ do guard (not $ null candidates) + expectedSearch + matchPrefix + rootPMatches + seps params expSuffix o + candidates o = associatedNames pat seps = separators pat - params = validParams pat expSuffix = expectedSuffix pat + sfxMatch = if null expSuffix then const True else (expSuffix `L.isSuffixOf`) candidates = filter possible allNames possible f = and [ candidateFile matchPrefix `L.isPrefixOf` candidateFile f , rootN /= f ] - mkSweet e = Just $ Sweets { rootMatchName = candidateFile rootN - , rootBaseName = candidateFile matchPrefix - , rootFile = candidateToPath rootN - , cubeParams = validParams pat - , expected = e - } + mkSweet e = Just + $ Sweets { rootMatchName = candidateFile rootN + , rootBaseName = candidateFile matchPrefix + , rootFile = candidateToPath rootN + , cubeParams = validParams pat + , expected = L.sortBy (compare `on` expectedFile) e + } -- The expectedSearch tries various combinations and ordering of -- parameter values, separators, and such to find all valid @@ -62,7 +70,7 @@ trimExpectations = -- If a parameter is Explicitly matched, discard any -- Expectation with the same Assumed matches. - removeNonExplicitMatchingExpectations + collateExpectations -- remove duplicates (uses the Eq instance for Expectation -- that ignores the order of the expParamsMatch and associated -- to ensure that different ordering with the same values @@ -70,21 +78,24 @@ . L.nub in case r of - Nothing -> Nothing - Just r' | [] <- expected r' -> Nothing - Just r' -> Just ( r' - , SweetExpl { rootPath = candidateToPath rootN - , base = candidateToPath matchPrefix - , expectedNames = - filter - (if null expSuffix then const True - else (expSuffix `L.isSuffixOf`)) - (candidateToPath <$> candidates) - , results = r' - }) + (Nothing, stats) -> (Nothing, stats) + (Just r', stats) | [] <- expected r' -> (Nothing, stats) + (Just r', stats) -> + ( Just ( r' + , SweetExpl { rootPath = candidateToPath rootN + , base = candidateToPath matchPrefix + , expectedNames = + filter sfxMatch (candidateToPath <$> candidates) + , results = r' + }) + , stats ) --- Find all Expectations matching this rootMatch +-- Find all Expectations matching this rootMatch. +-- +-- Note that rootPVMatches may contain multiple entries for the same parameter +-- value: the root file name may contain these duplications. The code here +-- should be careful to check against each value instead of assuming just one. expectedSearch :: CandidateFile -> [NamedParamMatch] -> Separators @@ -92,159 +103,140 @@ -> FileSuffix -> [ (String, FileSuffix) ] -> [CandidateFile] - -> Logic Expectation + -> LogicI Expectation expectedSearch rootPrefix rootPVMatches seps params expSuffix assocNames allNames = - do params' <- singlePVals rootPVMatches params - (expFile, pmatch, assocFiles) <- - let bestRanked :: (Eq a, Eq b, Eq c) - => [((a, Int, [b]),c)] -> Logic (a, [b], c) - bestRanked l = - if null l then mzero - else let m = maximum $ fmap rankValue l - rankValue ((_,r,_),_) = r - rankMatching v ((_,r,_),_) = v == r - dropRank ((a,_,b),c) = (a,b,c) - in eachFrom $ L.nub $ fmap dropRank $ filter (rankMatching m) l + do let expMatch cf = and [ candidateMatchPrefix seps rootPrefix cf + , candidateMatchSuffix seps expSuffix rootPrefix cf + ] - in bestRanked $ - observeAll $ - do pseq <- eachFrom $ - ([] :) $ - filter (not . null) $ - concatMap L.inits $ - L.permutations params' - pvals <- getPVals pseq - let compatNames = filter (isCompatible seps params pvals) allNames - guard (not $ null compatNames) - e@(_,_,pmatch) <- getExp rootPrefix rootPVMatches seps params pvals - expSuffix compatNames - a <- (getAssoc rootPrefix seps pmatch assocNames compatNames) - return (e,a) - return $ Expectation { expectedFile = candidateToPath expFile - , associated = fmap candidateToPath <$> assocFiles - , expParamsMatch = L.sort pmatch - } + let unconstrained = fst <$> L.filter (isNothing . snd) params + -- Get the parameters matched by the root, and suggested values for the + -- other parameters. This will backtrack through alternative values for + -- each parameter. --- | Get all expected files for a particular sequence of param+value. --- Returns the expected file, the sequence of parameter values that --- match that expect file, and a ranking (the number of those paramter --- values that actually appear in the expect file. -getExp :: CandidateFile - -> [NamedParamMatch] - -> Separators - -> [ParameterPattern] - -> [(String, Maybe String)] - -> FileSuffix - -> [CandidateFile] - -> Logic (CandidateFile, Int, [NamedParamMatch]) -getExp rootPrefix rootPMatches seps params pvals expSuffix allNames = - do -- Some of the params may be encoded in the subdirectories instead of in the - -- target filename (each param value could appear in either). If a - -- rootPMatches value is in a subdirectory, no other values for that - -- parameter can appear, otherwise all possible values could appear. A - -- subset of the rootPMatches may appear in the subdirs, but only the - -- maximal subset can be considered. + (rmatch, pvals) <- getSinglePVals rootPVMatches params + -- If some of rootPVMatches were related to values that + -- might have been useable for an unconstrained + -- parameter, then we also need to consider roots that + -- don't match those unconstrained values (because those + -- might not be a match for that parameter): + <|> + (if null unconstrained + then mzero + else let unConstr = (`elem` unconstrained) . fst + rm = L.filter (not . unConstr) rootPVMatches + in if null rm + then mzero + else getSinglePVals rm params + ) - let rootMatchesInSubdir :: CandidateFile -> [NamedParamMatch] - rootMatchesInSubdir f = - let chkRootMatch d r = - let chkRPMatch p r' = - case getExplicit $ snd p of - Just v -> if d == v then p : r' else r' - Nothing -> r' - in foldr chkRPMatch r rootPMatches - in foldr chkRootMatch mempty $ candidateSubdirs f + efile <- eachFrom "exp candidate" + $ L.reverse + $ L.sortBy (compare `on` matchStrength . fmap snd . candidatePMatch) + $ filter expMatch allNames + guard $ isCompatible pvals efile - let inpDirMatches = fmap rootMatchesInSubdir <$> zip allNames allNames + let onlyOneOfEach (p,v) r = case lookup p r of + Nothing -> (p,v) : r + Just _ -> r + rAndeMatches <- return (foldr onlyOneOfEach rmatch (candidatePMatch efile)) + <|> (if null unconstrained + then mzero + else let unConstr = (`elem` unconstrained) . fst + rm = filter (not . unConstr) (candidatePMatch efile) + in if null rm + then mzero + else return (foldr onlyOneOfEach rmatch rm) + ) - (dirName, inpDirMatch) <- eachFrom inpDirMatches + let pmatch = namedPMatches rAndeMatches pvals + assocFiles <- getAssoc rootPrefix seps + pmatch + assocNames allNames + return $ Expectation { expectedFile = candidateToPath efile + , associated = fmap candidateToPath <$> assocFiles + , expParamsMatch = L.sort pmatch + } - let nonRootMatchPVals = removePVals pvals inpDirMatch - (otherMatchesInSubdir, _) <- - dirMatches dirName params $ (fmap (fmap (:[])) <$> nonRootMatchPVals) - let remPVals = removePVals nonRootMatchPVals otherMatchesInSubdir - - let remRootMatches = removePVals rootPMatches inpDirMatch - let validNames = [ dirName ] - - (fp, cnt, npm) <- getExpFileParams rootPrefix - remRootMatches - seps remPVals expSuffix validNames - - - -- Corner case: a wildcard parameter could be selected from both a subdir - -- and the filename... if the values are the same, that's OK, but if the - -- values are different it should be rejected. - - let dpm = inpDirMatch <> otherMatchesInSubdir - - let conflict = let chkNPM (pn,pv) acc = - acc || case lookup pn dpm of - Nothing -> False - Just v -> v /= pv - in foldr chkNPM False npm - guard (not conflict) - - return (fp, length dpm + cnt, dpm <> npm) - - -getExpFileParams :: CandidateFile - -> [NamedParamMatch] - -> Separators - -> [(String, Maybe String)] - -> FileSuffix - -> [CandidateFile] - -> Logic (CandidateFile, Int, [NamedParamMatch]) -getExpFileParams rootPrefix rootPMatches seps pvals expSuffix hereNames = - do let suffixSpecifiesSep = and [ not (null expSuffix) - , head expSuffix `elem` seps - ] - (pm, pmcnt, pmstr) <- pvalMatch seps rootPMatches pvals - - -- If the expSuffix starts with a separator then *only that* - -- separator is allowed for the suffix (other seps are still - -- allowed for parameter value separation). - let suffixSepMatch = not suffixSpecifiesSep - || and [ not (null pmstr) - , last pmstr == head expSuffix - ] - guard suffixSepMatch - - let ending = if suffixSpecifiesSep then tail expSuffix else expSuffix - - expFile <- - eachFrom - $ filter (((candidateFile rootPrefix <> pmstr <> ending) ==) . candidateFile) - $ hereNames - - return (expFile, pmcnt, pm) - - -- | Determines the best Expectations to use from a list of Expectations that may -- have different parameter match status against an expected file. When two -- Expectations differ only in an Explicit v.s. Assumed (or wildcard) the -- Explicit is preferred. Expectations with more parameter matches are preferred -- over those with less. -removeNonExplicitMatchingExpectations :: [Expectation] -> [Expectation] -removeNonExplicitMatchingExpectations = - let removeNonExplicits e l = - let (similarExpl, diffExpl) = L.partition (cmpPVals e) l - cmpPVals ref ps = - -- Compare the two on the intersection subset of parameters - if length (expParamsMatch ref) < length (expParamsMatch ps) - then expPVals ref ref == expPVals ref ps - else expPVals ps ps == expPVals ps ref - expPVals ref ps = - -- Compare parameters by comparing the values of matching names - let ps' = expParamsMatch ps - ref' = expParamsMatch ref - refNames = fst <$> ref' - in (\n -> lookup n ps' >>= getParamVal) <$> refNames - in if null similarExpl - then e : l - else (pmatchMax expParamsMatch e <$> similarExpl) <> diffExpl - in foldr removeNonExplicits mempty +collateExpectations :: [Expectation] -> [Expectation] +collateExpectations allExps = + let paramsAndVals = fmap (fmap getParamVal) + . L.sortBy (compare `on` fst) + . expParamsMatch + + -- The matching named parameters should have matching values; there could + -- be extra parameters in on or the other, but not both. Give more weight + -- to Explicit matches, even those not present in the other match. This + -- requires both a and b parameter lists to be sorted on parameter name. + pvMatch a b = + let pvCmp _ [] = True + pvCmp ((xn,xv):xs) y@((yn,yv):ys) = + if xn == yn + then xv == yv && pvCmp xs ys + else pvCmp xs y + pvCmp [] _ = error "first argument must be longest list for pvMatch" + in if length a > length b then pvCmp a b else pvCmp b a + pvCompare a b = + let pvCmpN n [] [] = (n, EQ) + pvCmpN n ((_,xv):xs) [] = const GT <$> pvCmpN (n + weight xv) xs [] + pvCmpN n [] _ = (n, LT) + pvCmpN n ((xn,xv):xs) y@((yn,yv):ys) = + if xn == yn + then case compare (getParamVal xv) (getParamVal yv) of + EQ -> pvCmpN (n + weight xv - weight yv) xs ys + o -> (n, o) + else pvCmpN (n + weight xv) xs y + pvCmp x y = case pvCmpN (0::Int) x y of + (n, EQ) -> if n > 0 + then GT + else if n < 0 then LT + else compare x y + (_, o) -> o + weight = \case + NotSpecified -> 0 + Assumed _ -> 0 + Explicit _ -> 1 + invertCmp = \case + LT -> GT + GT -> LT + EQ -> EQ + in if length a > length b + then pvCmp a b + else invertCmp $ pvCmp b a + + -- expGrps are expectations grouped by having the same parameter names and + -- values (just the value, not the ParamMatch). + expGrps = collectBy (pvMatch `on` paramsAndVals) + $ L.reverse + $ L.sortBy (compare `on` (length . expParamsMatch)) + $ allExps + + collectBy _ [] = [] + collectBy f (e:es) = let (s,d) = L.partition (f e) es + in (e : s) : collectBy f d + in + -- For each group of expectations that have the same values, find the best of + -- the group by ordering first on ParamMatch, and then resolving ties based + -- on the length of the expected filename. + concatMap (take 1 + -- Resolve ties by taking the longest filename + . L.reverse + . L.sortBy (compare `on` (length . expectedFile)) + -- Discard all but the best ParamMatch + . L.reverse + . head + -- Group by equal ParamMatch (may be multiple files) + . L.groupBy ((==) `on` expParamsMatch) + -- Order this group by best ParamsMatch (Explicit) to worst + . L.reverse + . L.sortBy (pvCompare `on` expParamsMatch) + ) expGrps diff --git a/src/internal/Test/Tasty/Sugar/Iterations.hs b/src/internal/Test/Tasty/Sugar/Iterations.hs new file mode 100644 --- /dev/null +++ b/src/internal/Test/Tasty/Sugar/Iterations.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Test.Tasty.Sugar.Iterations +where + +import Control.Monad ( mplus, mzero ) +import Control.Monad.Logic +import Control.Monad.State ( StateT, runStateT, modify ) +import Data.Function ( on ) +import Data.Functor.Identity ( Identity, runIdentity ) +import qualified Data.List as DL +import qualified Data.Map as Map +import Data.Text ( Text ) + + +type IterStat = Map.Map Text Int + +emptyStats :: IterStat +emptyStats = mempty + +joinStats :: IterStat -> IterStat -> IterStat +joinStats = Map.unionWith (+) + + +---------------------------------------------------------------------- + +type LogicI a = LogicT (StateT IterStat Identity) a + +-- Note: stats collection can increase the runtime if the amount of backtracking +-- becomes significant. It can also increase runtime because a stats report +-- (from --showsearch) will force the evaluation of branches that might otherwise +-- have been lazily ignored. To disable the dilatory effects (and disable stats +-- collection), disable the modify statements in addSubLogicStats and eachFrom. + +addSubLogicStats :: (a, IterStat) -> LogicI a +addSubLogicStats (r, stats) = do modify $ joinStats stats + return r + +observeIAll :: LogicI a -> ([a], IterStat) +observeIAll op = runIdentity $ runStateT (observeAllT op) emptyStats + +observeIT :: LogicI a -> ([a], IterStat) +observeIT op = runIdentity $ runStateT (observeManyT 1 op) emptyStats + +---------------------------------------------------------------------- + +-- | Core Logic function to iteratively return elements of a list via +-- backtracking. +eachFrom :: Text -> [a] -> LogicI a +eachFrom location = + let attempt c a = do modify $ Map.insertWith (+) location 1 + return c `mplus` a + in foldr attempt mzero + + +-- | Given a list, return the list of lists representing all permutations of the +-- same length or shorter, removing any duplications, from longest to shortest +-- (shortest being the empty list). +combosLongToShort :: Eq a => [a] -> [ [a] ] +combosLongToShort = reverse + . DL.sortBy (compare `on` length) + . DL.nub + . concatMap DL.inits + . DL.permutations diff --git a/src/internal/Test/Tasty/Sugar/ParamCheck.hs b/src/internal/Test/Tasty/Sugar/ParamCheck.hs --- a/src/internal/Test/Tasty/Sugar/ParamCheck.hs +++ b/src/internal/Test/Tasty/Sugar/ParamCheck.hs @@ -1,147 +1,64 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} -- | Functions for checking different parameter/value combinations. module Test.Tasty.Sugar.ParamCheck ( - eachFrom - , getPVals - , singlePVals - , pvalMatch - , removePVals + getSinglePVals + , namedPMatches , pmatchCmp , pmatchMax - , dirMatches - , inEachNothing , isCompatible ) where import Control.Monad -import Control.Monad.Logic import Data.Function ( on ) -import qualified Data.List as L -import Data.Maybe ( catMaybes, fromJust, isNothing, listToMaybe ) -import Data.Bifunctor ( first ) -import Data.Maybe ( fromMaybe ) +import qualified Data.List as DL import Test.Tasty.Sugar.Types - - --- | Core Logic function to iteratively return elements of a list via --- backtracking. -eachFrom :: [a] -> Logic a -eachFrom = foldr (mplus . return) mzero - - --- | Returns various combinations of parameter value selections -getPVals :: [ParameterPattern] -> Logic [(String, Maybe String)] -getPVals = mapM getPVal - where - getPVal (pn, Nothing) = return (pn, Nothing) - getPVal (pn, Just pv) = do pv' <- eachFrom pv - return (pn, Just pv') - --- | Returns a ParameterPattern admitting only a single value for each parameter, --- ensuring that the value is compatible with any existing NamedParamMatch. This --- is useful for callers wishing to handle each combination of parameter values --- separately. -singlePVals :: [NamedParamMatch] -> [ParameterPattern] - -> Logic [ParameterPattern] -singlePVals sel = eachVal . L.sort - where eachVal [] = return [] - eachVal ((pn,Nothing):ps) = - let this = (pn, (:[]) <$> (lookup pn sel >>= getParamVal)) - in (this :) <$> eachVal ps - eachVal ((pn,Just pvs):ps) = - do pv <- eachFrom $ case lookup pn sel >>= getParamVal of - Nothing -> L.sort pvs - Just v -> [v] - ((pn, Just [pv]) :) <$> eachVal ps - - --- | Generate each possible combination of Explicit or non-Explicit --- (Assumed or NotSpecified) parameter value and the corresponding --- string with each combination of separators. The string will be --- used to match against input files. --- --- Note that valid combinations require that if a parameter is --- non-Explicit, all following parameters must also be non-Explicit. --- --- The preset set of parameters are any parameters *already* matched --- against (usually in the rootName); these parameters may or may not --- be present in the filename matched from the output of this --- function, but if they are present, they must have the values --- specified in the preset (instead of having any of the possible --- values allowed for that parameter). --- --- It's also possible that since this returns varying combinations of --- parameters, that there may be multiple files that will match --- against these combinations. Therefore, the results also indicate --- how many of the parameters are used in the associated matching --- string since the caller will usually select the match with the --- highest ranking (number of matched parameters) in the filename. --- [Note that it is not possibly to simply use the length of the --- @[NamedParamMatch]@ return component since that may contain values --- from the preset that don't actually occur in the match string. -pvalMatch :: Separators - -> [NamedParamMatch] - -> [(String, Maybe String)] - -> Logic ([NamedParamMatch], Int, String) -pvalMatch seps preset pvals = - let (ppv, _rpv) = L.partition isPreset pvals - isPreset p = fst p `elem` (fmap fst preset) - - matchesPreset = all matchPreset ppv - matchPreset (pn,mpv) = maybe False (matchPresetVal mpv) $ - lookup pn preset - matchPresetVal mpv pv = case mpv of - Just v -> paramMatchVal v pv - Nothing -> True - - genPVStr :: [NamedParamMatch] -> Logic String - genPVStr pvs = - let vstr = fromMaybe "" . getExplicit . snd - sepJoin :: String -> NamedParamMatch -> Logic String - sepJoin r v = if isExplicit (snd v) - then do s <- eachFrom seps - return $ [s] <> vstr v <> r - else return r - in if null seps - then return $ foldr (\v r -> vstr v <> r) "" pvs - else do s <- eachFrom seps - foldM sepJoin [s] pvs - - in do guard $ matchesPreset - candidateVals <- pvVals preset pvals - let rset = preset <> removePVals candidateVals preset - orderedRset = fmap from_rset $ fmap fst pvals - from_rset n = let v = maybe NotSpecified id $ L.lookup n rset in (n,v) - pvstr <- genPVStr orderedRset - return (rset, length orderedRset, pvstr) +import Test.Tasty.Sugar.Iterations ( LogicI, eachFrom ) --- | Generate the various combinations of parameters+values from the possible --- set specified by the input. +-- | Return a value to use for each parameter in the pattern, retricting those +-- values to the name parameter matches already established. This is a little +-- more complicated because there could be parameter name duplicates in the +-- already established matches (e.g. a matched file contains multiple values for +-- a parameter), so the actual subset of the named parameter matches associated +-- with this pattern selection is also returned. -pvVals :: [NamedParamMatch] -> [(String, Maybe String)] -> Logic [NamedParamMatch] -pvVals _ [] = return [] -pvVals presets ((pn, mpv):ps) = - do nxt <- pvVals presets ps - let explicit v = return $ (pn, Explicit v) : nxt - notExplicit = let pMatchImpl = - case lookup pn presets of - Nothing -> maybe NotSpecified Assumed - Just presetV -> const presetV - in return $ (pn, pMatchImpl mpv) : nxt - (maybe mzero explicit mpv) `mplus` notExplicit +getSinglePVals :: [NamedParamMatch] -> [ParameterPattern] + -> LogicI ([NamedParamMatch], [(String, Maybe String)]) +getSinglePVals sel = fmap (fmap DL.sort) . foldM eachVal (mempty, mempty) + where eachVal (an,av) (pn, Nothing) = + case filter ((pn ==) . fst) sel of + [] -> return (an, (pn, Nothing) : av) + pvsets -> do npv <- snd <$> eachFrom "assigned param value" pvsets + return ((pn, npv) : an, (pn, getParamVal npv) : av) + eachVal (an,av) (pn, Just pvs) = + case filter ((pn ==) . fst) sel of + [] -> do pv <- eachFrom "assumed (non-root) param value" $ DL.sort pvs + return (an, (pn, Just pv) : av) + pvsets -> do npv <- eachFrom "matched param value" (snd <$> pvsets) + return ((pn, npv) : an, (pn, getParamVal npv) : av) --- | Removes the second set of named params from the first set, leaving the --- remainder of the first set that isn't matched in the second set. +-- | namedPMatches supplements the core set of named matches with the extended +-- set of parameter values, marking all parameters not in the core set as Assumed +-- or NotSpecified. -removePVals :: [(String, a)] -> [(String, b)] -> [(String, a)] -removePVals main rmv = filter (not . (`elem` (fst <$> rmv)) . fst) main +namedPMatches :: [NamedParamMatch] -> [(String, Maybe String)] + -> [NamedParamMatch] +namedPMatches pmatch = + let inCore = (`elem` (fst <$> pmatch)) + go = \case + [] -> pmatch + ((p, Just v):r) | not (inCore p) -> (p, Assumed v) : go r + ((p, Nothing):r) | not (inCore p) -> (p, NotSpecified) : go r + (_:r) -> go r + in go -- | This provides an Ordering result of comparing two sets of NamedParamMatch. @@ -156,7 +73,7 @@ -- the one with more parameters (usually the same) , compare `on` length -- comparing keys - , compare `on` (L.sort . fmap fst) + , compare `on` (DL.sort . fmap fst) ] -- comparing the correlated ParamMatch values <> map (\k -> compare `on` (lookup k)) (fst <$> p1) @@ -168,6 +85,7 @@ EQ -> cascadeCompare os a b x -> x + -- | Returns the maximum of two arguments based on comparing the -- [NamedParamMatch] extracted from each argument (via the passed function). @@ -177,82 +95,16 @@ _ -> a --- | Given the root directory and a file in that directory, along with the --- possible parameters and values, return each valid set of parameter matches --- from that file, along with the remaining unmatched parameter possibilities. --- --- The first set of parameters is the total set, and the second set represents --- those that could be identified in the path subdirs; this is needed to prevent --- a wildcard ParameterPattern in the second set from matching values explicit to --- other parameters. - -dirMatches :: CandidateFile -> [ParameterPattern] -> [ParameterPattern] - -> Logic ([NamedParamMatch], [ParameterPattern]) -dirMatches fname fullParams params = do - let pathPart = candidateSubdirs fname - - let findVMatch :: FilePath -> (String, Maybe [String]) -> Maybe String - findVMatch e (pn,pv) = - case pv of - Nothing -> Nothing - Just vs -> if e `elem` vs then Just pn else Nothing - let findPVMatch parms pthPartE found = - listToMaybe (catMaybes (map (findVMatch pthPartE) parms)) : found - - let pmatches = foldr (findPVMatch params) [] pathPart - - let freeParam = fst <$> L.find (isNothing . snd) params - - let freeParts = - let allpvals = concat $ catMaybes (snd <$> fullParams) - in (not . (`elem` allpvals)) <$> pathPart - - dmatch <- fmap (fmap Explicit) - . fmap (first fromJust) - . filter (not . isNothing . fst) - <$> ((return (zip pmatches pathPart)) - `mplus` - (inEachNothing freeParam $ zip3 pmatches freeParts pathPart)) - - let drem = removePVals params dmatch - - return (dmatch, drem) - - --- | Return each substitution of the first argument for each location in the --- second list that has a Nothing label and a True parameter; leave non-Nothings --- in the second list unchanged. - -inEachNothing :: Maybe a -> [(Maybe a,Bool,b)] -> Logic [(Maybe a,b)] -inEachNothing mark into = do - let canSubst (a,b,_) = b && isNothing a - let spots = filter (\i -> canSubst (into !! i)) $ [0..(length into) - 1] - i <- eachFrom spots - let deBool (a,_,c) = (a,c) - let thrd (_,_,c) = c - return - $ (deBool <$> take i into) - <> [ (mark, thrd (into !! i)) ] - <> (deBool <$> drop (i + 1) into) - - -- | isCompatible can be used as a filter predicate to determine if the specified -- file is compatible with the provided parameters and chosen parameter values. -- One principle compatibility check is ensuring that there is no *other* -- parameter value in the filename that conflicts with a chosen parameter value. -isCompatible :: Separators - -> [ParameterPattern] - -> [(String, Maybe String)] +isCompatible :: [(String, Maybe String)] -> CandidateFile -> Bool -isCompatible seps params pvals fname = - let splitFName n = let (p,r) = break (`elem` seps) n - in p : if null r then [] else splitFName (tail r) - parts = let n' = splitFName $ candidateFile fname - in candidateSubdirs fname <> n' - noConflict _ (_,Nothing) = True - noConflict ps (pn,Just vs) = all (not . isConflict pn vs) ps - isConflict pn vs p = and [ p `elem` vs - , maybe False (Just p /=) $ lookup pn pvals - ] - in all (noConflict parts) params +isCompatible pvals fname = + let isCompatParam (n,v) = case DL.lookup n pvals of + Nothing -> True + Just Nothing -> True + Just (Just cv) -> paramMatchVal cv v + in all isCompatParam $ candidatePMatch fname diff --git a/src/internal/Test/Tasty/Sugar/RootCheck.hs b/src/internal/Test/Tasty/Sugar/RootCheck.hs deleted file mode 100644 --- a/src/internal/Test/Tasty/Sugar/RootCheck.hs +++ /dev/null @@ -1,270 +0,0 @@ --- | Function and associated helpers to determine the matching root --- name. The root name may contain zero or more parameter values. - -{-# LANGUAGE LambdaCase #-} - -module Test.Tasty.Sugar.RootCheck - ( - rootMatch - ) - where - -import Control.Monad -import Control.Monad.Logic -import qualified Data.List as L -import Data.Maybe ( catMaybes, isNothing ) - -import Test.Tasty.Sugar.ParamCheck -import Test.Tasty.Sugar.Types - - --- | Determine which parts of the input name form the basePrefix and any --- parameter values for searching for related files (expected and associated). --- Parameter values are taken from subdirectory paths or filename elements (in --- that order). -rootMatch :: CandidateFile -> Separators -> [ParameterPattern] -> String - -> Logic ([NamedParamMatch], CandidateFile, String) -rootMatch origRoot seps params rootCmp = do - (dmatch, drem) <- dirMatches origRoot params params - (rpm, p, s) <- ifte - (rootParamMatch origRoot seps drem rootCmp) - return - (noRootParamMatch origRoot seps) - return (dmatch <> rpm, p, s) - - -data RootPart = RootSep String - | RootParNm String String - | RootText String - | RootSuffix String - deriving Show - -isRootParNm :: RootPart -> Bool -isRootParNm (RootParNm _ _) = True -isRootParNm _ = False - -isRootSep :: RootPart -> Bool -isRootSep (RootSep _) = True -isRootSep _ = False - -rpStr :: [RootPart] -> String -rpStr = let s = \case - RootSep x -> x - RootParNm _ x -> x - RootText x -> x - RootSuffix x -> x - bld b a = a <> s b - in foldr bld "" - -rpNPM :: [RootPart] -> [NamedParamMatch] -rpNPM = let bld (RootParNm n v) = Just [(n, Explicit v)] - bld (RootSep _) = Nothing - bld p = error ("Invalid RootPart for NamedParamMatch: " <> show p) - in concat . catMaybes . fmap bld - - --- Return the prefix and suffix of the root name along with the --- explicit parameter matches that comprise the central portion. -rootParamMatch :: CandidateFile - -> Separators -> [ParameterPattern] -> String - -> Logic ([NamedParamMatch], CandidateFile, String) -rootParamMatch origRoot seps params rootCmp = - if null seps - then rootParamMatchNoSeps origRoot seps params - else rootParamFileMatches origRoot seps params rootCmp - - -rootParamFileMatches :: CandidateFile - -> Separators -> [ParameterPattern] -> String - -> Logic ([NamedParamMatch], CandidateFile, String) -rootParamFileMatches rootF seps parms rMatch = do - let rnSplit = sepSplit $ candidateFile rootF - sepSplit = L.groupBy sepPoint - sepPoint a b = not $ or [a `elem` seps, b `elem` seps ] - rnPartIndices = [ n | n <- [0 .. length rnParts - 1] , even n ] - freeValueParm = L.find (isNothing . snd) parms - - txtRootSfx = sepSplit $ reverse $ - -- Find the concrete extension in the - -- rootName. Somewhat crude, but basically stops at - -- any character that could be part of a filemanip - -- GlobPattern. - takeWhile (not . flip elem "[*]\\(|)") $ reverse rMatch - - -- if a part of the root filename matches a known parameter value, that is - -- the only way that part can be interpreted, and that anchors it. - - rnParts :: [RootPart] - rnParts = - let assignPart (ptxt,pidx) = - let matchesParmValue (_, Nothing) = False - matchesParmValue (_, Just vl) = ptxt `elem` vl - in if pidx `elem` rnPartIndices - then - if length rnSplit - pidx < length txtRootSfx - then RootSuffix ptxt - else case L.find matchesParmValue parms of - Just (pn,_) -> RootParNm pn ptxt - Nothing -> RootText ptxt - else RootSep ptxt - in fmap assignPart $ zip rnSplit [0..] - - -- want [prefix, sep, MATCHES, [suffix]] - guard (length rnSplit > 2 + length txtRootSfx) - - let hasDupParNm = - let getParNm = \case - RootParNm pn _ -> Just pn - _ -> Nothing - parNms = catMaybes (getParNm <$> rnParts) - in not $ length parNms == length (L.nub parNms) - - guard (not hasDupParNm) - - guard (not $ isRootParNm $ head rnParts) -- must have a prefix - - let rnChunks = - -- pfx parms1 mid parms2 sfx - -- r1------------------- - -- r2------------ - -- r3-------- - let (pfx,r1) = L.span (not . isRootParNm) rnParts - (parms1,r2) = L.span paramPart r1 - (mid,r3) = L.span (not . isRootParNm) r2 - (parms2,sfx) = L.span paramPart r3 - (_,extraprm) = L.span (not . isRootParNm) sfx - paramPart x = isRootParNm x || isRootSep x - in if null r3 - then Just $ Left (pfx, parms1, mid) - else if null extraprm - then Just $ Right (pfx, parms1, mid, parms2, sfx) - else Nothing - - freeFirst Nothing = mzero - freeFirst (Just (Right _)) = mzero - freeFirst (Just (Left (allRP, [], []))) = - -- There were no parameter value matches. If there is - -- a wildcard parameter, try it in all the possible - -- positions. - if length allRP < 3 - then mzero - else case freeValueParm of - Nothing -> mzero - Just p -> - do idx <- eachFrom [i | i <- [2..length allRP], even i] - case drop idx allRP of - (RootText idxv:_) -> do - let free = RootParNm (fst p) idxv - start = take (idx - 1) allRP - return ( rpNPM [free] - , rpStr $ start - , rpStr $ drop (idx + 2) allRP ) - _ -> mzero - freeFirst (Just (Left (pfx, pl1, sfx))) = - case freeValueParm of - Nothing -> - -- No wildcard param, so just try the observed - -- pattern - return ( rpNPM pl1, rpStr $ init pfx, rpStr sfx ) - Just p -> - if length pfx < 3 - then - -- not enough elements of pfx to support a wildcard, so there must - -- be no expression of the wildcard and just the observed pattern. - -- Also remove any separator from the prefix. - return ( rpNPM pl1, rpStr $ take 1 pfx, rpStr sfx ) - else - -- There is a wildcard parameter, try it at the end - -- of pfx and before pl1 - case reverse pfx of - (_:RootText lpv:_) -> - return ( rpNPM $ RootParNm (fst p) lpv : pl1 - , rpStr $ reverse $ drop 3 $ reverse pfx - , rpStr sfx ) - _ -> mzero - - freeLast Nothing = mzero - freeLast (Just (Right _)) = mzero - freeLast (Just (Left (_, [], []))) = mzero -- handled by freeFirst - freeLast (Just (Left (_, _, []))) = mzero - freeLast (Just (Left (pfx, parms1, sfx))) = - case freeValueParm of - Nothing -> mzero -- handled by freeFirst - Just p -> - -- There is a wildcard parameter, try it at the end - -- of pfx and before pl1 - case sfx of - (RootText fsv:_) -> - return ( rpNPM $ parms1 <> [RootParNm (fst p) fsv] - , rpStr $ init pfx - , rpStr $ tail sfx ) - _ -> mzero - - freeMid Nothing = mzero - freeMid (Just (Left _)) = mzero - freeMid (Just (Right (pfx, parms1, mid, parms2, sfx))) = - -- If there is a wildcard param and mid is a single - -- element, then try converting the mid to the - -- wildcard, otherwise this is an invalid name. - if length mid /= 3 - then mzero - else case freeValueParm of - Nothing -> mzero - Just p -> - case mid of - (ms1:RootText mv:ms2:[]) -> - return ( rpNPM ( parms1 <> [RootParNm (fst p) mv] <> - parms2 ) - , rpStr $ pfx <> [ms1] - , rpStr $ ms2 : sfx ) - _ -> mzero - - (\(a,fn,b) -> (a, rootF { candidateFile = fn }, b)) - <$> ((freeFirst rnChunks) - `mplus` (freeLast rnChunks) - `mplus` (freeMid rnChunks)) - - --- If no separators, there are no "rnParts" identifiable, so fall --- back on a cruder algorithm that simply attempts to find a --- sequence of paramvals in the middle of the string and extract --- the prefix and suffix (if any) around those paramvals. -rootParamMatchNoSeps :: CandidateFile -> Separators -> [ParameterPattern] - -> Logic ([NamedParamMatch], CandidateFile, String) -rootParamMatchNoSeps rootF seps' parms = do - pseq <- eachFrom $ filter (not . null) $ L.permutations parms - pvals <- getPVals pseq - (pvset, _pvcnt, pvstr) <- pvalMatch seps' [] pvals - -- _pvcnt can be ignored because each is a different root - let explicit = filter (isExplicit . snd) pvset - let rootNm = candidateFile rootF - guard (and [ not $ null explicit - , pvstr `L.isInfixOf` rootNm - , not $ pvstr `L.isPrefixOf` rootNm - ]) - let l1 = length rootNm - l2 = length pvstr - bslen = l1 - l2 - matches n = pvstr `L.isPrefixOf` (drop n rootNm) - case L.find matches $ reverse [1..bslen] of - Just pfxlen -> - let basefname = take pfxlen rootNm - basename = rootF { candidateFile = basefname } - suffix = drop (pfxlen + l2) rootNm - in return (explicit, basename, suffix) - _ -> mzero - --- Return origRootName up to each sep-indicated point. -noRootParamMatch :: CandidateFile -> Separators - -> Logic ([NamedParamMatch], CandidateFile, String) -noRootParamMatch origRoot seps = - return ([], origRoot, "") `mplus` - do s <- eachFrom seps - let origRootName = candidateFile origRoot - i <- eachFrom [1..length origRootName - 1] - let a = origRoot { candidateFile = take i origRootName } - let b = drop i origRootName - if null b - then do return ([], a, "") - else do guard (and [ not $ null b, head b == s ]) - return ([], a, tail b) diff --git a/src/internal/Test/Tasty/Sugar/Types.hs b/src/internal/Test/Tasty/Sugar/Types.hs --- a/src/internal/Test/Tasty/Sugar/Types.hs +++ b/src/internal/Test/Tasty/Sugar/Types.hs @@ -10,6 +10,7 @@ import Data.Function ( on ) import qualified Data.List as L import Data.Maybe ( catMaybes ) +import Numeric.Natural import System.FilePath -- ( () ) import qualified System.FilePath.GlobPattern as FPGP #if MIN_VERSION_prettyprinter(1,7,0) @@ -113,6 +114,10 @@ -- Specified as a list of tuples, where each tuple is the -- (arbitrary) name of the associated file type, and the file -- type suffix (with no period or other separator). + -- + -- If there is a blank FileSuffix for an associated name, that indicates + -- that the associated name matches the rootname *without* any suffix (and + -- implies that the root name has a suffix that can be removed). , associatedNames :: [ (String, FileSuffix) ] -- | The 'validParams' can be used to specify various parameters @@ -158,7 +163,7 @@ -- an explicit blank value). , validParams :: [ParameterPattern] } - deriving (Show, Read) + deriving Show {-# DEPRECATED inputDir "Use inputDirs instead" #-} @@ -169,8 +174,6 @@ type ParameterPattern = (String, Maybe [String]) - -- KWQ: if this could be an exact string or a regexp (or a glob?) then that would remove the need for a complete enumeration but not be a full wildcard. For example: llvm* to capture different llvm versions available. However, this is super-hard, because many elements use Logic to generate all potential parameter value combinations, so this would need to be inverted, and still wouldn't handle Assumed values well. - -- | Separators for the path and suffix specifications. Any separator -- is accepted in any position between parameters and prior to the -- expected suffix. The synonym name is primarily used to indicate @@ -237,16 +240,31 @@ -- directory it came from. The "file" portion is relative to the input -- directory. -data CandidateFile = CandidateFile { candidateDir :: FilePath - , candidateSubdirs :: [ FilePath ] - , candidateFile :: FilePath - } - deriving (Eq, Show) -- Show is for for debugging/tracing - --- | This converts a CandidatFile into a regular FilePath for access -candidateToPath :: CandidateFile -> FilePath -candidateToPath c = - candidateDir c foldr () (candidateFile c) (candidateSubdirs c) +data CandidateFile = CandidateFile + { + -- | The 'candidateDir' is the top-level directory path + -- for this candidate and is usually one of the CUBE + -- inputDirs + candidateDir :: FilePath + -- | The 'candidateSubdirs' is the sequence of + -- subdirectories beneath the 'candidateDir' where the + -- 'candidateFile' is located. These subdirectories may + -- 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). + , candidateFile :: FilePath + -- | Portions of the candidateFile (or candidateSubdirs) + -- that match parameters + , candidatePMatch :: [NamedParamMatch] + -- | If there are candidatePMatch, this is the index of + -- the first match. This therefore is also the end of the + -- "root" file match portion. If no candidatePMatch, this + -- is the length of the candidateFile. + , candidateMatchIdx :: Natural + } + deriving (Eq, Show) -- Show is for for debugging/tracing -- | Each identified test input set is represented as a 'Sweets' @@ -349,9 +367,13 @@ -- NotSpecified if there are no known 'ParameterPattern' values. data ParamMatch = - -- | This parameter value was explicitly specified in the filename - -- of the expected file. - Explicit String + -- | This parameter value was not specified in the filename for the + -- expected file. In addition, the associated 'ParameterPattern' + -- specified no defined values (i.e. 'Nothing'), so it is not + -- possible to identify any actual values. Instead, the + -- 'Expectation' generated for this expected file will supply this + -- 'NotSpecified' for this type of parameter. + NotSpecified -- | This parameter value was not specified in the filename of the -- expected file, so the value is being synthetically supplied. @@ -360,13 +382,9 @@ -- value, identifying each as 'Assumed'. | Assumed String - -- | This parameter value was not specified in the filename for the - -- expected file. In addition, the associated 'ParameterPattern' - -- specified no defined values (i.e. 'Nothing'), so it is not - -- possible to identify any actual values. Instead, the - -- 'Expectation' generated for this expected file will supply this - -- 'NotSpecified' for this type of parameter. - | NotSpecified + -- | This parameter value was explicitly specified in the filename + -- of the expected file. + | Explicit String deriving (Show, Eq, Ord) @@ -403,6 +421,17 @@ getParamVal (Explicit v) = Just v getParamVal (Assumed v) = Just v getParamVal _ = Nothing + +-- | Returns a value indicating how "strong" a set of ParamMatch values is. This +-- is used to compare between sets of ParamMatches to prefer stronger matches +-- over weaker matches. +matchStrength :: [ParamMatch] -> Natural +matchStrength = \case + [] -> 0 + (NotSpecified : ps) -> matchStrength ps + ((Explicit _) : ps) -> 1 + matchStrength ps + ((Assumed _) : ps) -> 1 + matchStrength ps + ---------------------------------------------------------------------- diff --git a/tasty-sugar.cabal b/tasty-sugar.cabal --- a/tasty-sugar.cabal +++ b/tasty-sugar.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: tasty-sugar -version: 1.3.0.2 +version: 2.0.0.0 synopsis: Tests defined by Search Using Golden Answer References description: . @@ -87,6 +87,7 @@ library exposed-modules: Test.Tasty.Sugar build-depends: base >=4.10 && < 5 + , containers , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.5 , filemanip >= 0.3 && < 0.4 @@ -109,18 +110,22 @@ library tasty-sugar-internal exposed-modules: Test.Tasty.Sugar.Analysis , Test.Tasty.Sugar.AssocCheck + , Test.Tasty.Sugar.Candidates , Test.Tasty.Sugar.ExpectCheck + , Test.Tasty.Sugar.Iterations , Test.Tasty.Sugar.ParamCheck , Test.Tasty.Sugar.Report - , Test.Tasty.Sugar.RootCheck , Test.Tasty.Sugar.Types build-depends: base >= 4.10 + , containers >= 0.6 && < 0.7 + , directory , filepath , filemanip , kvitable >= 1.0 && < 1.1 , logict , microlens >= 0.4 && < 0.5 , mtl >= 2.2 && < 2.3 + , parallel >= 3.2 && < 3.3 , prettyprinter >= 1.7 && < 1.8 , text >= 1.2 && < 1.3 hs-source-dirs: src/internal @@ -136,6 +141,7 @@ hs-source-dirs: test default-language: Haskell2010 GHC-options: -fhide-source-paths + -threaded -with-rtsopts=-N main-is: TestMain.hs other-modules: TestMultiAssoc TestNoAssoc @@ -165,6 +171,7 @@ hs-source-dirs: examples/example1 default-language: Haskell2010 GHC-options: -fhide-source-paths + -threaded -with-rtsopts=-N main-is: test-passthru-ascii.hs other-modules: NiftyText build-depends: base @@ -177,6 +184,7 @@ hs-source-dirs: examples/params default-language: Haskell2010 GHC-options: -fhide-source-paths + -threaded -with-rtsopts=-N main-is: test-params.hs build-depends: base , pretty-show @@ -189,6 +197,7 @@ hs-source-dirs: test/internals default-language: Haskell2010 GHC-options: -fhide-source-paths + -threaded -with-rtsopts=-N main-is: test-internals.hs build-depends: base , pretty-show diff --git a/test/Sample1.hs b/test/Sample1.hs --- a/test/Sample1.hs +++ b/test/Sample1.hs @@ -9,12 +9,9 @@ import Text.RawString.QQ -sample1 :: FilePath -> [CandidateFile] -sample1 testInpPath = - fmap (\f -> CandidateFile { candidateDir = testInpPath - , candidateSubdirs = [] - , candidateFile = f }) - +sample1 :: CUBE -> FilePath -> [CandidateFile] +sample1 cube testInpPath = + fmap (makeCandidate cube testInpPath []) $ filter (not . null) $ lines [r| global-max-good.c diff --git a/test/TestFileSys.hs b/test/TestFileSys.hs --- a/test/TestFileSys.hs +++ b/test/TestFileSys.hs @@ -1,1115 +1,663 @@ module TestFileSys ( fileSysTests ) where -import qualified Data.List as L -import qualified Data.Text as T -import System.FilePath ( (), takeDirectory ) -import qualified Test.Tasty as TT -import Test.Tasty.HUnit -import Test.Tasty.Sugar -import TestUtils -import Text.RawString.QQ -import Text.Show.Pretty - - -testInpPath = "test/data/single" -testInpPath2 = "test/data/second" -testInpPath3 = "test/builds/*" - -testParams = [ ("llvm", Just [ "llvm9", "llvm10", "llvm13" ]) - , ("debug", Just [ "yes", "no" ]) - , ("opt", Nothing ) - ] - -sugarCube1 = mkCUBE - { inputDirs = [ testInpPath ] - , rootName = "*.exe" - , validParams = testParams - , associatedNames = [ ("config", "config") - , ("ld-config", "lnk") - , ("source", "c") - ] - } - -sugarCube2 = mkCUBE - { inputDirs = [ testInpPath, "foo/baz", testInpPath2, "/foo/bar" ] - , rootName = "*.exe" - , validParams = testParams - , associatedNames = [ ("config", "config") - , ("ld-config", "lnk") - , ("source", "c") - ] - } - -sugarCube3 = mkCUBE - { inputDirs = [ testInpPath - , "foo/baz" - , testInpPath2 - , testInpPath3 - ] - , rootName = "*.exe" - , validParams = testParams - , associatedNames = [ ("config", "config") - , ("ld-config", "lnk") - , ("source", "c") - ] - } - - -fileSysTests :: IO [TT.TestTree] -fileSysTests = do tsts <- sequence [ fsTests1, fsTests2, fsTests3 ] - return [ TT.testGroup "FileSys" $ concat tsts ] - - -fsTests1 :: IO [TT.TestTree] -fsTests1 = do - sweets <- findSugar sugarCube1 - -- putStrLn $ ppShow sweets - return - [ TT.testGroup "Cube 1" - [ testCase "correct # of sweets" $ 3 @=? length sweets - - , TT.testGroup "Sweet #1" $ - let sweet = head sweets in - [ - testCase "root match" $ "foo.llvm10.O2.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath "foo.llvm10.O2.exe" @=? rootFile sweet - , testCase "# expectations" $ 4 @=? length (expected sweet) - , testCase "Exp #1" $ head (expected sweet) @?= - Expectation - { - expectedFile = testInpPath "foo.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm10") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { - expectedFile = testInpPath "foo.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm10") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #3" $ head (drop 2 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm10-O2-exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #4" $ head (drop 3 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm10-O2-exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - ] - , TT.testGroup "Sweet #2" $ - let sweet = head $ drop 1 sweets in - [ - testCase "root match" $ "foo.llvm13.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath "foo.llvm13.exe" @=? rootFile sweet - , testCase "# expectations" $ 2 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - ] - , TT.testGroup "Sweet #3" $ - let sweet = head $ drop 2 sweets in - [ - testCase "root match" $ "foo.llvm9.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath "foo.llvm9.exe" @=? rootFile sweet - , testCase "# expectations" $ 2 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm9.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm9.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - ] - ] - ] - - -fsTests2 :: IO [TT.TestTree] -fsTests2 = do - sweets <- findSugar sugarCube2 - -- putStrLn $ ppShow sweets - return - [ TT.testGroup "Cube 2" - [ testCase "correct # of sweets" $ 5 @=? length sweets - , TT.testGroup "Sweet #1" $ - let sweet = head sweets in - [ - testCase "root match" $ "cow-O2.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath2 "cow-O2.exe" @=? rootFile sweet - , testCase "# expectations" $ 6 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Assumed "llvm10") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Assumed "llvm13") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #3" $ head (drop 2 $ expected sweet) @?= - Expectation - { - expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Assumed "llvm9") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #4" $ head (drop 3 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Assumed "llvm10") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #5" $ head (drop 4 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Assumed "llvm13") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #6" $ head (drop 5 $ expected sweet) @?= - Expectation - { - expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Assumed "llvm9") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - ] - , TT.testGroup "Sweet #2" $ - let sweet = head $ drop 1 sweets in - [ - testCase "root match" $ "foo.O1-llvm10.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath2 "foo.O1-llvm10.exe" @=? rootFile sweet - , testCase "# expectations" $ 2 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { - expectedFile = testInpPath "foo.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "O1") - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { - expectedFile = testInpPath "foo.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "O1") - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - ] - , TT.testGroup "Sweet #3" $ - let sweet = head $ drop 2 sweets in - [ - testCase "root match" $ "foo.llvm10.O2.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath "foo.llvm10.O2.exe" @=? rootFile sweet - , testCase "# expectations" $ 4 @=? length (expected sweet) - , testCase "Exp #1" $ head (expected sweet) @?= - Expectation - { - expectedFile = testInpPath "foo.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm10") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { - expectedFile = testInpPath "foo.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm10") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #3" $ head (drop 2 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm10-O2-exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #4" $ head (drop 3 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm10-O2-exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - ] - , TT.testGroup "Sweet #4" $ - let sweet = head $ drop 3 sweets in - [ - testCase "root match" $ "foo.llvm13.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath "foo.llvm13.exe" @=? rootFile sweet - , testCase "# expectations" $ 2 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath2 "foo-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath2 "foo-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - ] - , TT.testGroup "Sweet #5" $ - let sweet = head $ drop 4 sweets in - [ - testCase "root match" $ "foo.llvm9.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath "foo.llvm9.exe" @=? rootFile sweet - , testCase "# expectations" $ 2 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm9.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm9.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - ] - ] - ] - -fsTests3 :: IO [TT.TestTree] -fsTests3 = do - sweets <- findSugar sugarCube3 - -- putStrLn $ ppShow sweets - return - [ TT.testGroup "Cube 3" - [ testCase "correct # of sweets" $ 12 @=? length sweets - , let sweetNum = 8 - sweet = head $ drop (sweetNum - 1) sweets - in TT.testGroup ("Sweet #" <> show sweetNum) $ - [ - testCase "root match" $ "cow-O2.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath2 "cow-O2.exe" @=? rootFile sweet - , testCase "# expectations" $ 6 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Assumed "llvm10") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Assumed "llvm13") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #3" $ head (drop 2 $ expected sweet) @?= - Expectation - { - expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Assumed "llvm9") - , ("opt", Explicit "O2") - ] - , associated = [ ("ld-config", takeDirectory testInpPath3 "O0/llvm9/cow.lnk") - , ("source", testInpPath "cow.c") ] - } - , testCase "Exp #4" $ head (drop 3 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Assumed "llvm10") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #5" $ head (drop 4 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Assumed "llvm13") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #6" $ head (drop 5 $ expected sweet) @?= - Expectation - { - expectedFile = testInpPath "cow.O2.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Assumed "llvm9") - , ("opt", Explicit "O2") - ] - -- n.b. O0/llvm9/cow.lnk matches because opt is a wildcard, so no - -- way to know that O0 in cow.lnk is conflicing with O2 in - -- cow.O2.exp. - , associated = [ ("ld-config", takeDirectory testInpPath3 "O0/llvm9/cow.lnk") - , ("source", testInpPath "cow.c") ] - } - ] - - - , let sweetNum = 6 - sweet = head $ drop (sweetNum - 1) sweets - in TT.testGroup ("Sweet #" <> show sweetNum) $ - [ - testCase "root match" $ "cow.exe" @=? rootMatchName sweet - , testCase "root file" - $ takeDirectory testInpPath3 "llvm13/cow.exe" @=? rootFile sweet - , testCase "# expectations" $ 4 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "O0") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #3" $ head (drop 2 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #4" $ head (drop 3 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "O0") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - ] - - , let sweetNum = 7 - sweet = head $ drop (sweetNum - 1) sweets - exp n = head $ drop (n-1) $ expected sweet - in TT.testGroup ("Sweet #" <> show sweetNum) $ - [ - testCase "root match" $ "cow.exe" @=? rootMatchName sweet - , testCase "root file" - $ takeDirectory testInpPath3 "llvm13/opts/O3/cow.exe" @=? rootFile sweet - , testCase "# expectations" $ 8 @=? length (expected sweet) - , testCase "Exp #1" $ exp 1 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #2" $ exp 2 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - -- Note: the expectations match an exp with O0 in the name, which - -- would seem to conflict with O3, but since "opt" is a wildcard - -- parameter there's no way for tasty-sweet to know that O3 and O0 - -- conflict, and the match on the llvm13 value makes that .exp more - -- attractive than the generic one. - , testCase "Exp #3" $ exp 3 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "O0") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #4" $ exp 4 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "O3") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #5" $ exp 5 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "opts") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #6" $ exp 6 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "O0") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #7" $ exp 7 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "O3") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #8" $ exp 8 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "opts") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - ] - - , let sweetNum = 1 - sweet = head $ drop (sweetNum - 1) sweets - exp n = head $ drop (n-1) $ expected sweet - in TT.testGroup ("Sweet #" <> show sweetNum) $ - -- n.b. Although O0 appears in the root file and in the O0/cow.exp - -- expected files in Exp 3 and Exp 4 below, O0 is a wildcard, so it's - -- also possible to match NotSpecified for the "opt" parameter, and in - -- that case, the base cow.exp from Exp 1 and Exp 2 are found. - -- Eliminating these would involve matching the O0 portions of the - -- filepath even though it is not associated with any parameter; that - -- becomes even more complex and the results will be less - -- consistent/explainable than the current situation, thus the current - -- functionality. - [ - testCase "root match" $ "cow.exe" @=? rootMatchName sweet - , testCase "root file" - $ takeDirectory testInpPath3 "O0/cow.exe" @=? rootFile sweet - , testCase "# expectations" $ 12 @=? length (expected sweet) - , testCase "Exp #1" $ exp 1 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "cow.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Assumed "llvm10") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "cow.c") - ] - } - , testCase "Exp #2" $ exp 2 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "cow.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Assumed "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ("ld-config", takeDirectory testInpPath3 "O0/llvm9/cow.lnk") - , ("source", testInpPath "cow.c") - ] - } - , testCase "Exp #3" $ exp 3 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "cow.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Assumed "llvm10") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "cow.c") - ] - } - , testCase "Exp #4" $ exp 4 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "cow.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Assumed "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ("ld-config", takeDirectory testInpPath3 "O0/llvm9/cow.lnk") - , ("source", testInpPath "cow.c") - ] - } - , testCase "Exp #5" $ exp 5 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "cow.c") - ] - } - - - , testCase "Exp #6" $ exp 6 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Assumed "llvm10") - , ("opt", Explicit "O0") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #7" $ exp 7 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Assumed "llvm9") - , ("opt", Explicit "O0") - ] - , associated = [ ("ld-config", takeDirectory testInpPath3 "O0/llvm9/cow.lnk") - , ("source", testInpPath "cow.c") - ] - } - , testCase "Exp #8" $ exp 8 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #9" $ exp 9 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Assumed "llvm10") - , ("opt", Explicit "O0") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #10" $ exp 10 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Assumed "llvm9") - , ("opt", Explicit "O0") - ] - , associated = [ ("ld-config", takeDirectory testInpPath3 "O0/llvm9/cow.lnk") - , ("source", testInpPath "cow.c") - ] - } - , testCase "Exp #11" $ exp 11 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "O0") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - , testCase "Exp #12" $ exp 12 @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "O0") - ] - , associated = [ ("source", testInpPath "cow.c") ] - } - ] - - , let sweetNum = 2 - sweet = head $ drop (sweetNum - 1) sweets - in TT.testGroup ("Sweet #" <> show sweetNum) $ - [ - testCase "root match" $ "cow.exe" @=? rootMatchName sweet - , testCase "root file" $ takeDirectory testInpPath3 "O0/llvm9/cow.exe" @=? rootFile sweet - , testCase "# expectations" $ 4 @=? length (expected sweet) - -- n.b. See note for Sweet #1 - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "cow.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ("ld-config", takeDirectory testInpPath3 "O0/llvm9/cow.lnk") - , ("source", testInpPath "cow.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "cow.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ("ld-config", takeDirectory testInpPath3 "O0/llvm9/cow.lnk") - , ("source", testInpPath "cow.c") ] - } - , testCase "Exp #3" $ head (drop 2 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm9") - , ("opt", Explicit "O0") - ] - , associated = [ ("ld-config", takeDirectory testInpPath3 "O0/llvm9/cow.lnk") - , ("source", testInpPath "cow.c") ] - } - , testCase "Exp #4" $ head (drop 3 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "O0" "cow.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm9") - , ("opt", Explicit "O0") - ] - , associated = [ ("ld-config", takeDirectory testInpPath3 "O0/llvm9/cow.lnk") - , ("source", testInpPath "cow.c") ] - } - ] - - , let sweetNum = 9 - sweet = head $ drop (sweetNum - 1) sweets - in TT.testGroup ("Sweet #" <> show sweetNum) $ - [ - testCase "root match" $ "foo.O1-llvm10.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath2 "foo.O1-llvm10.exe" @=? rootFile sweet - , testCase "# expectations" $ 2 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "llvm10" "foo.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "O1") - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "llvm10" "foo.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "O1") - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - ] - - , let sweetNum = 10 - sweet = head $ drop (sweetNum - 1) sweets - in TT.testGroup ("Sweet #" <> show sweetNum) $ - [ - testCase "root match" $ "foo.llvm10.O2.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath "foo.llvm10.O2.exe" @=? rootFile sweet - , testCase "# expectations" $ 4 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "llvm10" "foo.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm10") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { - expectedFile = takeDirectory testInpPath3 "llvm10" "foo.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm10") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #3" $ head (drop 2 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm10-O2-exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #4" $ head (drop 3 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm10-O2-exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "O2") - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - ] - - , let sweetNum = 11 - sweet = head $ drop (sweetNum - 1) sweets - in TT.testGroup ("Sweet #" <> show sweetNum) $ - [ - testCase "root match" $ "foo.llvm13.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath "foo.llvm13.exe" @=? rootFile sweet - , testCase "# expectations" $ 2 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath2 "foo-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath2 "foo-llvm13.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - ] - - , let sweetNum = 12 - sweet = head $ drop (sweetNum - 1) sweets - in TT.testGroup ("Sweet #" <> show sweetNum) $ - [ - testCase "root match" $ "foo.llvm9.exe" @=? rootMatchName sweet - , testCase "root file" $ testInpPath "foo.llvm9.exe" @=? rootFile sweet - , testCase "# expectations" $ 2 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm9.exp" - , expParamsMatch = [ ("debug", Assumed "no") - , ("llvm", Explicit "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { expectedFile = testInpPath "foo.llvm9.exp" - , expParamsMatch = [ ("debug", Assumed "yes") - , ("llvm", Explicit "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ("source", testInpPath "foo.c") ] - } - ] - - , let sweetNum = 5 - sweet = head $ drop (sweetNum - 1) sweets - in TT.testGroup ("Sweet #" <> show sweetNum) $ - [ - testCase "root match" $ "frog.exe" @=? rootMatchName sweet - , testCase "root file" $ takeDirectory testInpPath3 "gen/llvm9/frog.exe" @=? rootFile sweet - , testCase "# expectations" $ 6 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-llvm9-no.exp" - , expParamsMatch = [ ("debug", Explicit "no") - , ("llvm", Explicit "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-yes.exp" - , expParamsMatch = [ ("debug", Explicit "yes") - , ("llvm", Explicit "llvm9") - , ("opt", NotSpecified) - ] - , associated = [ ] - } - , testCase "Exp #3" $ head (drop 2 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-llvm9-no.exp" - , expParamsMatch = [ ("debug", Explicit "no") - , ("llvm", Explicit "llvm9") - , ("opt", Explicit "gen") - ] - , associated = [ ] - } - , testCase "Exp #4" $ head (drop 3 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-llvm9-no.exp" - , expParamsMatch = [ ("debug", Explicit "no") - , ("llvm", Explicit "llvm9") - , ("opt", Explicit "want") - ] - , associated = [ ] - } - , testCase "Exp #5" $ head (drop 4 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-yes.exp" - , expParamsMatch = [ ("debug", Explicit "yes") - , ("llvm", Explicit "llvm9") - , ("opt", Explicit "gen") - ] - , associated = [ ] - } - , testCase "Exp #6" $ head (drop 5 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-yes.exp" - , expParamsMatch = [ ("debug", Explicit "yes") - , ("llvm", Explicit "llvm9") - , ("opt", Explicit "want") - ] - , associated = [ ] - } - ] - - , let sweetNum = 3 - sweet = head $ drop (sweetNum - 1) sweets - in TT.testGroup ("Sweet #" <> show sweetNum) $ - [ - testCase "root match" $ "frog.exe" @=? rootMatchName sweet - , testCase "root file" $ takeDirectory testInpPath3 "gen/llvm10/frog.exe" @=? rootFile sweet - , testCase "# expectations" $ 6 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-no.exp" - , expParamsMatch = [ ("debug", Explicit "no") - , ("llvm", Explicit "llvm10") - , ("opt", NotSpecified) - ] - , associated = [ ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-yes.exp" - , expParamsMatch = [ ("debug", Explicit "yes") - , ("llvm", Explicit "llvm10") - , ("opt", NotSpecified) - ] - , associated = [ ] - } - , testCase "Exp #3" $ head (drop 2 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-no.exp" - , expParamsMatch = [ ("debug", Explicit "no") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "gen") - ] - , associated = [ ] - } - , testCase "Exp #4" $ head (drop 3 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-no.exp" - , expParamsMatch = [ ("debug", Explicit "no") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "want") - ] - , associated = [ ] - } - , testCase "Exp #5" $ head (drop 4 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-yes.exp" - , expParamsMatch = [ ("debug", Explicit "yes") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "gen") - ] - , associated = [ ] - } - , testCase "Exp #6" $ head (drop 5 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-yes.exp" - , expParamsMatch = [ ("debug", Explicit "yes") - , ("llvm", Explicit "llvm10") - , ("opt", Explicit "want") - ] - , associated = [ ] - } - ] - - , let sweetNum = 4 - sweet = head $ drop (sweetNum - 1) sweets - in TT.testGroup ("Sweet #" <> show sweetNum) $ - [ - testCase "root match" $ "frog.exe" @=? rootMatchName sweet - , testCase "root file" $ takeDirectory testInpPath3 "gen/llvm13/frog.exe" @=? rootFile sweet - , testCase "# expectations" $ 6 @=? length (expected sweet) - , testCase "Exp #1" $ head (drop 0 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-no.exp" - , expParamsMatch = [ ("debug", Explicit "no") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ] - } - , testCase "Exp #2" $ head (drop 1 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-yes.exp" - , expParamsMatch = [ ("debug", Explicit "yes") - , ("llvm", Explicit "llvm13") - , ("opt", NotSpecified) - ] - , associated = [ ] - } - , testCase "Exp #3" $ head (drop 2 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-no.exp" - , expParamsMatch = [ ("debug", Explicit "no") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "gen") - ] - , associated = [ ] - } - , testCase "Exp #4" $ head (drop 3 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-no.exp" - , expParamsMatch = [ ("debug", Explicit "no") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "want") - ] - , associated = [ ] - } - , testCase "Exp #5" $ head (drop 4 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-yes.exp" - , expParamsMatch = [ ("debug", Explicit "yes") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "gen") - ] - , associated = [ ] - } - , testCase "Exp #6" $ head (drop 5 $ expected sweet) @?= - Expectation - { expectedFile = takeDirectory testInpPath3 "want/frog-yes.exp" - , expParamsMatch = [ ("debug", Explicit "yes") - , ("llvm", Explicit "llvm13") - , ("opt", Explicit "want") - ] - , associated = [ ] - } +import Data.Either ( lefts, rights ) +import qualified Data.List as L +import Data.Maybe ( isJust ) +import qualified Data.Text as T +import System.FilePath ( (), takeDirectory ) +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Test.Tasty.Sugar +import TestUtils +import Text.RawString.QQ +import Text.Show.Pretty + + +testInpPath = "test/data/single" +testInpPath2 = "test/data/second" +testInpPath3 = "test/builds/*" + +testParams = [ ("llvm", Just [ "llvm9", "llvm10", "llvm13" ]) + , ("debug", Just [ "yes", "no" ]) + , ("opt", Nothing ) + ] + +sugarCube1 = mkCUBE + { inputDirs = [ testInpPath ] + , rootName = "*.exe" + , validParams = testParams + , associatedNames = [ ("config", "config") + , ("ld-config", "lnk") + , ("source", "c") + ] + } + +sugarCube2 = mkCUBE + { inputDirs = [ testInpPath, "foo/baz", testInpPath2, "/foo/bar" ] + , rootName = "*.exe" + , validParams = testParams + , associatedNames = [ ("config", "config") + , ("ld-config", "lnk") + , ("source", "c") + ] + } + +sugarCube3 = mkCUBE + { inputDirs = [ testInpPath + , "foo/baz" + , testInpPath2 + , testInpPath3 + ] + , rootName = "*.exe" + , validParams = testParams + , associatedNames = [ ("config", "config") + , ("ld-config", "lnk") + , ("source", "c") + ] + } + + +fileSysTests :: IO [TT.TestTree] +fileSysTests = do tsts <- sequence [ fsTests1, fsTests2, fsTests3 ] + return [ TT.testGroup "FileSys" $ concat tsts ] + + +fsTests1 :: IO [TT.TestTree] +fsTests1 = do + sweets <- findSugar sugarCube1 + cands <- findCandidates sugarCube1 testInpPath + -- putStrLn $ ppShow sweets + let chkCandidate = checkCandidate sugarCube1 (const $ rights cands) + testInpPath [] 0 + let exp0 f d l o = Expectation + { expectedFile = testInpPath f + , expParamsMatch = [ ("debug", d) , ("llvm", l) , ("opt", o)] + , associated = [ ("source", testInpPath "foo.c") ] + } + let exp f d l o = exp0 f (Assumed d) (Explicit l) o + testExp s i f d l o = testCase ("Exp #" <> show i) + $ safeElem i (expected s) @?= Just (exp f d l o) + return + [ TT.testGroup "Cube 1" + [ testCase "correct # of sweets" $ 3 @=? length sweets + + , testCase "correct # of candidate warnings" $ 0 @=? length (lefts cands) + , testCase "correct # of candidate files" $ 11 @=? length (rights cands) + , TT.testGroup "Candidates" + [ + chkCandidate "bar.exe" [] + , chkCandidate "cow.O2.exp" [("opt", Explicit "O2")] + , chkCandidate "cow.c" [] + , chkCandidate "foo.c" [] + , chkCandidate "foo.exp" [] + , chkCandidate "foo.llvm10-O2-exp" [("llvm", Explicit "llvm10") + ,("opt", Explicit "O2")] + , chkCandidate "foo.llvm10.O2.exe" [("llvm", Explicit "llvm10") + ,("opt", Explicit "O2")] + , chkCandidate "foo.llvm13.exe" [("llvm", Explicit "llvm13")] + , chkCandidate "foo.llvm199.exp" [("opt", Explicit "llvm199")] + , chkCandidate "foo.llvm9.exe" [("llvm", Explicit "llvm9")] + , chkCandidate "foo.llvm9.exp" [("llvm", Explicit "llvm9")] + ] + + , TT.testGroup "Sweet #1" $ + let sweet = head sweets in + let tE n e d o = testExp sweet n e d "llvm10" o in + [ + testCase "root match" $ "foo.llvm10.O2.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath "foo.llvm10.O2.exe" @=? rootFile sweet + , testCase "# expectations" $ 6 @=? length (expected sweet) + , tE 3 "foo.llvm10-O2-exp" "no" (Explicit "O2") + , tE 2 "foo.llvm10-O2-exp" "yes" (Explicit "O2") + , tE 1 "foo.llvm10-O2-exp" "no" NotSpecified + , tE 0 "foo.llvm10-O2-exp" "yes" NotSpecified + , tE 5 "foo.llvm199.exp" "no" (Explicit "llvm199") + , tE 4 "foo.llvm199.exp" "yes" (Explicit "llvm199") + ] + , TT.testGroup "Sweet #2" $ + let sweet = head $ drop 1 sweets in + [ + testCase "root match" $ "foo.llvm13.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath "foo.llvm13.exe" @=? rootFile sweet + , testCase "# expectations" $ 4 @=? length (expected sweet) + , testExp sweet 1 "foo.exp" "no" "llvm13" NotSpecified + , testExp sweet 0 "foo.exp" "yes" "llvm13" NotSpecified + -- llvm199 is not a registered value for the "llvm" parameter, so it + -- can match the "opt" parameter as an alternate expectation match. + , testExp sweet 3 "foo.llvm199.exp" "no" "llvm13" (Explicit "llvm199") + , testExp sweet 2 "foo.llvm199.exp" "yes" "llvm13" (Explicit "llvm199") + ] + , TT.testGroup "Sweet #3" $ + let sweet = head $ drop 2 sweets in + [ + testCase "root match" $ "foo.llvm9.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath "foo.llvm9.exe" @=? rootFile sweet + , testCase "# expectations" $ 4 @=? length (expected sweet) + -- llvm199 is not a registered value for the "llvm" parameter, so it + -- can match the "opt" parameter as an alternate expectation match. + , testExp sweet 1 "foo.llvm199.exp" "no" "llvm9" (Explicit "llvm199") + , testExp sweet 0 "foo.llvm199.exp" "yes" "llvm9" (Explicit "llvm199") + , testExp sweet 3 "foo.llvm9.exp" "no" "llvm9" NotSpecified + , testExp sweet 2 "foo.llvm9.exp" "yes" "llvm9" NotSpecified + ] + ] + ] + + +fsTests2 :: IO [TT.TestTree] +fsTests2 = do + sweets <- findSugar sugarCube2 + -- putStrLn $ ppShow sweets + cands <- concat <$> mapM (findCandidates sugarCube2) (inputDirs sugarCube2) + let warns = lefts cands + -- putStrLn $ ppShow sweets + let chkCand d = checkCandidate sugarCube2 (const $ rights cands) d [] 0 + let chkCandidate1 = chkCand testInpPath + let chkCandidate2 = chkCand testInpPath2 + let exp p sf f d l o = Expectation + { expectedFile = p f + , expParamsMatch = [ ("debug", Assumed d) + , ("llvm", l) + , ("opt", o) + ] + , associated = [ ("source", testInpPath sf) ] + } + testExp s sf i f d l o = + testCase ("Exp #" <> show i) + $ safeElem i (expected s) @?= Just (exp testInpPath sf f d l o) + return + [ TT.testGroup "Cube 2" + [ testCase "correct # of sweets" $ 5 @=? length sweets + + , testCase "correct # of candidate warnings" $ 2 @=? length warns + , testCase "Warn about foo/baz" + $ isJust (L.find ("]foo/baz does not exist" `L.isSuffixOf`) warns) + @? ("foo/baz warning missing in " <> show warns) + , testCase "Warn about /foo/bar" + $ "/foo/bar does not exist" `elem` warns + @? ("/foo/bar warning missing in " <> show warns) + , testCase "correct # of candidate files" $ 14 @=? length (rights cands) + , TT.testGroup "Candidates" + [ + chkCandidate1 "bar.exe" [] + , chkCandidate1 "cow.O2.exp" [("opt", Explicit "O2")] + , chkCandidate1 "cow.c" [] + , chkCandidate1 "foo.c" [] + , chkCandidate1 "foo.exp" [] + , chkCandidate1 "foo.llvm10-O2-exp" [("llvm", Explicit "llvm10") + ,("opt", Explicit "O2")] + , chkCandidate1 "foo.llvm10.O2.exe" [("llvm", Explicit "llvm10") + ,("opt", Explicit "O2")] + , chkCandidate1 "foo.llvm13.exe" [("llvm", Explicit "llvm13")] + , chkCandidate1 "foo.llvm199.exp" [("opt", Explicit "llvm199")] + , chkCandidate1 "foo.llvm9.exe" [("llvm", Explicit "llvm9")] + , chkCandidate1 "foo.llvm9.exp" [("llvm", Explicit "llvm9")] + , chkCandidate2 "cow-O2.exe" [("opt", Explicit "O2")] + , chkCandidate2 "foo-llvm13.exp" [("llvm", Explicit "llvm13")] + , chkCandidate2 "foo.O1-llvm10.exe" [("llvm", Explicit "llvm10") + , ("opt", Explicit "O1")] + ] + + , TT.testGroup "Sweet #1" $ + let sweet = head sweets in + let testExp' n d l = testExp sweet "cow.c" n "cow.O2.exp" d + (Assumed l) (Explicit "O2") + in + [ + testCase "root match" $ "cow-O2.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath2 "cow-O2.exe" @=? rootFile sweet + , testCase "# expectations" $ 6 @=? length (expected sweet) + , testExp' 5 "no" "llvm10" + , testExp' 4 "no" "llvm13" + , testExp' 3 "no" "llvm9" + , testExp' 2 "yes" "llvm10" + , testExp' 1 "yes" "llvm13" + , testExp' 0 "yes" "llvm9" + ] + , TT.testGroup "Sweet #2" $ + let sweet = head $ drop 1 sweets in + let testExp' n e d o = testExp sweet "foo.c" n e d (Explicit "llvm10") o + in + [ + testCase "root match" $ "foo.O1-llvm10.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath2 "foo.O1-llvm10.exe" @=? rootFile sweet + , testCase "# expectations" $ 8 @=? length (expected sweet) + , testExp' 1 "foo.exp" "no" (Explicit "O1") + , testExp' 0 "foo.exp" "yes" (Explicit "O1") + , testExp' 5 "foo.llvm10-O2-exp" "no" (Explicit "O2") + , testExp' 4 "foo.llvm10-O2-exp" "no" NotSpecified + , testExp' 3 "foo.llvm10-O2-exp" "yes" (Explicit "O2") + , testExp' 2 "foo.llvm10-O2-exp" "yes" NotSpecified + , testExp' 7 "foo.llvm199.exp" "no" (Explicit "llvm199") + , testExp' 6 "foo.llvm199.exp" "yes" (Explicit "llvm199") + ] + , TT.testGroup "Sweet #3" $ + let sweet = head $ drop 2 sweets in + let testExp' n e d o = testExp sweet "foo.c" n e d (Explicit "llvm10") o + in + [ + testCase "root match" $ "foo.llvm10.O2.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath "foo.llvm10.O2.exe" @=? rootFile sweet + , testCase "# expectations" $ 6 @=? length (expected sweet) + , testExp' 3 "foo.llvm10-O2-exp" "no" (Explicit "O2") + , testExp' 2 "foo.llvm10-O2-exp" "yes" (Explicit "O2") + , testExp' 1 "foo.llvm10-O2-exp" "no" NotSpecified + , testExp' 0 "foo.llvm10-O2-exp" "yes" NotSpecified + , testExp' 5 "foo.llvm199.exp" "no" (Explicit "llvm199") + , testExp' 4 "foo.llvm199.exp" "yes" (Explicit "llvm199") + ] + , TT.testGroup "Sweet #4" $ + let sweet = head $ drop 3 sweets in + let testExp' s n e d o = + testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (exp s "foo.c" e d (Explicit "llvm13") o) + testExp1 = testExp' testInpPath2 + testExp2 = testExp' testInpPath + in + [ + testCase "root match" $ "foo.llvm13.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath "foo.llvm13.exe" @=? rootFile sweet + , testCase "# expectations" $ 4 @=? length (expected sweet) + , testExp1 1 "foo-llvm13.exp" "no" NotSpecified + , testExp1 0 "foo-llvm13.exp" "yes" NotSpecified + , testExp2 3 "foo.llvm199.exp" "no" (Explicit "llvm199") + , testExp2 2 "foo.llvm199.exp" "yes" (Explicit "llvm199") + ] + , TT.testGroup "Sweet #5" $ + let sweet = head $ drop 4 sweets in + let testExp' n e d o = + testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (exp testInpPath "foo.c" e d (Explicit "llvm9") o) + in + [ + testCase "root match" $ "foo.llvm9.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath "foo.llvm9.exe" @=? rootFile sweet + , testCase "# expectations" $ 4 @=? length (expected sweet) + , testExp' 1 "foo.llvm199.exp" "no" (Explicit "llvm199") + , testExp' 0 "foo.llvm199.exp" "yes" (Explicit "llvm199") + , testExp' 3 "foo.llvm9.exp" "no" NotSpecified + , testExp' 2 "foo.llvm9.exp" "yes" NotSpecified + ] + ] + ] + +fsTests3 :: IO [TT.TestTree] +fsTests3 = do + sweets <- findSugar sugarCube3 + -- putStrLn $ ppShow sweets + cands <- concat <$> mapM (findCandidates sugarCube3) (inputDirs sugarCube3) + let warns = lefts cands + let chkCand t s = checkCandidate sugarCube3 (const $ rights cands) t s 0 + let chkCandidate1 = chkCand testInpPath [] + let chkCandidate2 = chkCand testInpPath2 [] + let tbDir = "test/builds" + let exp0 p sf f d l o = Expectation + { expectedFile = p f + , expParamsMatch = [ ("debug", d) , ("llvm", l) , ("opt", o)] + , associated = [ ("source", testInpPath sf) ] + } + let exp p sf f d l o = exp0 p sf f (Assumed d) l o + testExp s sf i f d l o = + testCase ("Exp #" <> show i) + $ safeElem i (expected s) @?= Just (exp testInpPath sf f d l o) + return + [ TT.testGroup "Cube 3" + [ testCase "correct # of sweets" $ 12 @=? length sweets + + , testCase "correct # of candidate warnings" $ 1 @=? length warns + , testCase "Warn about foo/baz" + $ isJust (L.find ("]foo/baz does not exist" `L.isSuffixOf`) warns) + @? ("foo/baz warning missing in " <> show warns) + , testCase "correct # of candidate files" $ 29 @=? length (rights cands) + , TT.testGroup "Candidates" + [ + chkCandidate1 "bar.exe" [] + , chkCandidate1 "cow.O2.exp" [("opt", Explicit "O2")] + , chkCandidate1 "cow.c" [] + , chkCandidate1 "foo.c" [] + , chkCandidate1 "foo.exp" [] + , chkCandidate1 "foo.llvm10-O2-exp" [("llvm", Explicit "llvm10") + ,("opt", Explicit "O2") + ] + , chkCandidate1 "foo.llvm10.O2.exe" [("llvm", Explicit "llvm10") + ,("opt", Explicit "O2") + ] + , chkCandidate1 "foo.llvm13.exe" [("llvm", Explicit "llvm13")] + , chkCandidate1 "foo.llvm199.exp" [("opt", Explicit "llvm199")] + , chkCandidate1 "foo.llvm9.exe" [("llvm", Explicit "llvm9")] + , chkCandidate1 "foo.llvm9.exp" [("llvm", Explicit "llvm9")] + , chkCandidate2 "cow-O2.exe" [("opt", Explicit "O2")] + , chkCandidate2 "foo-llvm13.exp" [("llvm", Explicit "llvm13")] + , chkCandidate2 "foo.O1-llvm10.exe" [("llvm", Explicit "llvm10") + , ("opt", Explicit "O1") + ] + , chkCand tbDir ["O0"] "cow-llvm13.exp" [("llvm", Explicit "llvm13") + ,("opt", Explicit "O0") + ] + , chkCand tbDir ["O0"] "cow.exe" [("opt", Explicit "O0")] + , chkCand tbDir ["O0"] "cow.exp" [("opt", Explicit "O0")] + , chkCand tbDir ["O0", "llvm9"] "cow.exe" [("llvm", Explicit "llvm9") + ,("opt", Explicit "O0") + ] + , chkCand tbDir ["O0", "llvm9"] "cow.lnk" [("llvm", Explicit "llvm9") + ,("opt", Explicit "O0") + ] + , chkCand tbDir [] "cow.exp" [] + , chkCand tbDir ["gen", "llvm10"] "frog.exe" [("llvm", Explicit "llvm10") + ,("opt", Explicit "gen") + ] + , chkCand tbDir ["gen", "llvm13"] "frog.exe" [("llvm", Explicit "llvm13") + ,("opt", Explicit "gen") + ] + , chkCand tbDir ["gen", "llvm9"] "frog.exe" [("llvm", Explicit "llvm9") + ,("opt", Explicit "gen") + ] + , chkCand tbDir ["llvm10"] "foo.exp" [("llvm", Explicit "llvm10")] + , chkCand tbDir ["llvm13"] "cow.exe" [("llvm", Explicit "llvm13")] + , chkCand tbDir ["llvm13", "opts", "O3"] "cow.exe" + [("llvm", Explicit "llvm13") + ,("opt", Explicit "O3") + ,("opt", Explicit "opts") + ] + , chkCand tbDir ["want"] "frog-llvm9-no.exp" [("debug", Explicit "no") + ,("llvm", Explicit "llvm9") + ,("opt", Explicit "want") + ] + , chkCand tbDir ["want"] "frog-no.exp" [("debug", Explicit "no") + ,("opt", Explicit "want") + ] + , chkCand tbDir ["want"] "frog-yes.exp" [("debug", Explicit "yes") + ,("opt", Explicit "want") + ] + ] + + , let sweetNum = 8 + sweet = head $ drop (sweetNum - 1) sweets + testExp' n e d l o = + testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (exp testInpPath "cow.c" e d (Assumed l) o) + in TT.testGroup ("Sweet #" <> show sweetNum) $ + [ + testCase "root match" $ "cow-O2.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath2 "cow-O2.exe" @=? rootFile sweet + , testCase "# expectations" $ 6 @=? length (expected sweet) + , testExp' 5 "cow.O2.exp" "no" "llvm10" (Explicit "O2") + , testExp' 4 "cow.O2.exp" "no" "llvm13" (Explicit "O2") + , testExp' 3 "cow.O2.exp" "no" "llvm9" (Explicit "O2") + , testExp' 2 "cow.O2.exp" "yes" "llvm10" (Explicit "O2") + , testExp' 1 "cow.O2.exp" "yes" "llvm13" (Explicit "O2") + , testExp' 0 "cow.O2.exp" "yes" "llvm9" (Explicit "O2") + ] + + + , let sweetNum = 6 + sweet = head $ drop (sweetNum - 1) sweets + testExp' s n e d o = + testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (exp s "cow.c" e d (Explicit "llvm13") o) + testExp1 = testExp' testInpPath + testExp3 = testExp' (takeDirectory testInpPath3) + in TT.testGroup ("Sweet #" <> show sweetNum) $ + [ + testCase "root match" $ "cow.exe" @=? rootMatchName sweet + , testCase "root file" + $ takeDirectory testInpPath3 "llvm13/cow.exe" @=? rootFile sweet + , testCase "# expectations" $ 6 @=? length (expected sweet) + , testExp3 3 "O0/cow-llvm13.exp" "no" (Explicit "O0") + , testExp3 2 "O0/cow-llvm13.exp" "no" NotSpecified + , testExp3 1 "O0/cow-llvm13.exp" "yes" (Explicit "O0") + , testExp3 0 "O0/cow-llvm13.exp" "yes" NotSpecified + , testExp1 5 "cow.O2.exp" "no" (Explicit "O2") + , testExp1 4 "cow.O2.exp" "yes" (Explicit "O2") + ] + + , let sweetNum = 7 + sweet = head $ drop (sweetNum - 1) sweets + testExp' s n e d l o = + testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (exp s "cow.c" e d (Explicit l) o) + tE1 = testExp' testInpPath + tE3 = testExp' (takeDirectory testInpPath3) + in TT.testGroup ("Sweet #" <> show sweetNum) $ + [ + testCase "root match" $ "cow.exe" @=? rootMatchName sweet + , testCase "root file" + $ takeDirectory testInpPath3 "llvm13/opts/O3/cow.exe" @=? rootFile sweet + , testCase "# expectations" $ 10 @=? length (expected sweet) + , tE3 3 "O0/cow-llvm13.exp" "no" "llvm13" (Explicit "O0") + , tE3 1 "O0/cow-llvm13.exp" "yes" "llvm13" (Explicit "O0") + , tE3 7 "cow.exp" "no" "llvm13" (Explicit "O3") + , tE3 6 "cow.exp" "no" "llvm13" (Explicit "opts") + , tE3 5 "cow.exp" "yes" "llvm13" (Explicit "O3") + , tE3 4 "cow.exp" "yes" "llvm13" (Explicit "opts") + , tE1 9 "cow.O2.exp" "no" "llvm13" (Explicit "O2") + , tE1 8 "cow.O2.exp" "yes" "llvm13" (Explicit "O2") + -- n.b. O0/cow-llvm13.exp is longer than cow.exp, so it is the + -- preferred expected file for the following two entries: + , tE3 2 "O0/cow-llvm13.exp" "no" "llvm13" NotSpecified + , tE3 0 "O0/cow-llvm13.exp" "yes" "llvm13" NotSpecified + ] + + , let sweetNum = 1 + sweet = head $ drop (sweetNum - 1) sweets + exp' n = head $ drop (n-1) $ expected sweet + tE1 n e d l o = + testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (exp (takeDirectory testInpPath3) "cow.c" e d l o) + tE2 n e d l o = + let lda = ("ld-config" + , takeDirectory testInpPath3 "O0/llvm9/cow.lnk") + ex = exp (takeDirectory testInpPath3) "cow.c" e d l o + in testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (ex { associated = lda : associated ex }) + in TT.testGroup ("Sweet #" <> show sweetNum) $ + -- n.b. Although O0 appears in the root file and in the O0/cow.exp + -- expected files in Exp 3 and Exp 4 below, O0 is a wildcard, so it's + -- also possible to match NotSpecified for the "opt" parameter, and in + -- that case, the base cow.exp from Exp 1 and Exp 2 are found. + -- Eliminating these would involve matching the O0 portions of the + -- filepath even though it is not associated with any parameter; that + -- becomes even more complex and the results will be less + -- consistent/explainable than the current situation, thus the current + -- functionality. + [ + testCase "root match" $ "cow.exe" @=? rootMatchName sweet + , testCase "root file" + $ takeDirectory testInpPath3 "O0/cow.exe" @=? rootFile sweet + , testCase "# expectations" $ 6 @=? length (expected sweet) + , tE1 1 "O0/cow-llvm13.exp" "no" (Explicit "llvm13") (Explicit "O0") + , tE1 0 "O0/cow-llvm13.exp" "yes" (Explicit "llvm13") (Explicit "O0") + , tE1 5 "O0/cow.exp" "no" (Assumed "llvm10") (Explicit "O0") + , tE2 4 "O0/cow.exp" "no" (Assumed "llvm9") (Explicit "O0") + , tE1 3 "O0/cow.exp" "yes" (Assumed "llvm10") (Explicit "O0") + , tE2 2 "O0/cow.exp" "yes" (Assumed "llvm9") (Explicit "O0") + ] + + , let sweetNum = 2 + sweet = head $ drop (sweetNum - 1) sweets + tExp' s lda n e d l o = + let ex = exp s "cow.c" e d (Explicit l) o + in testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (ex { associated = lda <> associated ex }) + tExp1 = tExp' testInpPath [] + tExp3 = tExp' (takeDirectory testInpPath3) + [ ("ld-config" + , takeDirectory testInpPath3 "O0/llvm9/cow.lnk") + ] + in TT.testGroup ("Sweet #" <> show sweetNum) $ + [ + testCase "root match" $ "cow.exe" @=? rootMatchName sweet + , testCase "root file" $ takeDirectory testInpPath3 "O0/llvm9/cow.exe" @=? rootFile sweet + , testCase "# expectations" $ 6 @=? length (expected sweet) + , tExp3 1 "O0/cow.exp" "no" "llvm9" (Explicit "O0") + , tExp3 0 "O0/cow.exp" "yes" "llvm9" (Explicit "O0") + , tExp3 3 "cow.exp" "no" "llvm9" NotSpecified + , tExp3 2 "cow.exp" "yes" "llvm9" NotSpecified + , tExp1 5 "cow.O2.exp" "no" "llvm9" (Explicit "O2") + , tExp1 4 "cow.O2.exp" "yes" "llvm9" (Explicit "O2") + ] + + , let sweetNum = 9 + sweet = head $ drop (sweetNum - 1) sweets + tE' s n e d l o = + testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (exp s "foo.c" e d (Explicit l) o) + tE1 = tE' testInpPath + tE3 = tE' (takeDirectory testInpPath3) + in TT.testGroup ("Sweet #" <> show sweetNum) $ + [ + testCase "root match" $ "foo.O1-llvm10.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath2 "foo.O1-llvm10.exe" @=? rootFile sweet + , testCase "# expectations" $ 8 @=? length (expected sweet) + , tE3 1 "llvm10/foo.exp" "no" "llvm10" (Explicit "O1") + , tE3 0 "llvm10/foo.exp" "yes" "llvm10" (Explicit "O1") + , tE1 5 "foo.llvm10-O2-exp" "no" "llvm10" (Explicit "O2") + , tE1 3 "foo.llvm10-O2-exp" "yes" "llvm10" (Explicit "O2") + -- n.b. foo.llvm10-O2-exp is longer than llvm10/foo.exp, so it is the + -- preferred expected file for the following two expected entries + , tE1 4 "foo.llvm10-O2-exp" "no" "llvm10" NotSpecified + , tE1 2 "foo.llvm10-O2-exp" "yes" "llvm10" NotSpecified + , tE1 7 "foo.llvm199.exp" "no" "llvm10" (Explicit "llvm199") + , tE1 6 "foo.llvm199.exp" "yes" "llvm10" (Explicit "llvm199") + ] + + , let sweetNum = 10 + sweet = head $ drop (sweetNum - 1) sweets + tE1 n e d l o = + testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (exp testInpPath "foo.c" e d (Explicit l) o) + tE3 n e d l o = + testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (exp (takeDirectory testInpPath3) "foo.c" e d (Explicit l) o) + in TT.testGroup ("Sweet #" <> show sweetNum) $ + [ + testCase "root match" $ "foo.llvm10.O2.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath "foo.llvm10.O2.exe" @=? rootFile sweet + , testCase "# expectations" $ 6 @=? length (expected sweet) + , tE1 3 "foo.llvm10-O2-exp" "no" "llvm10" (Explicit "O2") + , tE1 2 "foo.llvm10-O2-exp" "yes" "llvm10" (Explicit "O2") + , tE1 5 "foo.llvm199.exp" "no" "llvm10" (Explicit "llvm199") + , tE1 4 "foo.llvm199.exp" "yes" "llvm10" (Explicit "llvm199") + -- n.b. foo.llvm10-O2-exp is longer than llvm10/foo.exp so it is the + -- preferred expected file for the following two entries: + , tE1 1 "foo.llvm10-O2-exp" "no" "llvm10" NotSpecified + , tE1 0 "foo.llvm10-O2-exp" "yes" "llvm10" NotSpecified + ] + + , let sweetNum = 11 + sweet = head $ drop (sweetNum - 1) sweets + tE' s n e d o = + testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (exp s "foo.c" e d (Explicit "llvm13") o) + tE1 = tE' testInpPath + tE2 = tE' testInpPath2 + in TT.testGroup ("Sweet #" <> show sweetNum) $ + [ + testCase "root match" $ "foo.llvm13.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath "foo.llvm13.exe" @=? rootFile sweet + , testCase "# expectations" $ 4 @=? length (expected sweet) + , tE2 1 "foo-llvm13.exp" "no" NotSpecified + , tE2 0 "foo-llvm13.exp" "yes" NotSpecified + , tE1 3 "foo.llvm199.exp" "no" (Explicit "llvm199") + , tE1 2 "foo.llvm199.exp" "yes" (Explicit "llvm199") + ] + + , let sweetNum = 12 + sweet = head $ drop (sweetNum - 1) sweets + tE1 n e d o = + testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (exp testInpPath "foo.c" e d (Explicit "llvm9") o) + in TT.testGroup ("Sweet #" <> show sweetNum) $ + [ + testCase "root match" $ "foo.llvm9.exe" @=? rootMatchName sweet + , testCase "root file" $ testInpPath "foo.llvm9.exe" @=? rootFile sweet + , testCase "# expectations" $ 4 @=? length (expected sweet) + , tE1 1 "foo.llvm199.exp" "no" (Explicit "llvm199") + , tE1 0 "foo.llvm199.exp" "yes" (Explicit "llvm199") + , tE1 3 "foo.llvm9.exp" "no" NotSpecified + , tE1 2 "foo.llvm9.exp" "yes" NotSpecified + ] + + , let sweetNum = 5 + sweet = head $ drop (sweetNum - 1) sweets + tE1 n e d o = + let ex = exp0 (takeDirectory testInpPath3) "foo.c" e d (Explicit "llvm9") o + in testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (ex { associated = [] }) + in TT.testGroup ("Sweet #" <> show sweetNum) $ + [ + testCase "root match" $ "frog.exe" @=? rootMatchName sweet + , testCase "root file" + $ takeDirectory testInpPath3 "gen/llvm9/frog.exe" + @=? rootFile sweet + , testCase "# expectations" $ 4 @=? length (expected sweet) + , tE1 1 "want/frog-llvm9-no.exp" (Explicit "no") (Explicit "want") + , tE1 0 "want/frog-llvm9-no.exp" (Explicit "no") NotSpecified + , tE1 3 "want/frog-yes.exp" (Explicit "yes") (Explicit "want") + , tE1 2 "want/frog-yes.exp" (Explicit "yes") NotSpecified + -- TODO not using dir elements from root for unconstrained params + -- , tE1 2 "want/frog-llvm9-no.exp" (Explicit "no") (Explicit "gen") + -- , tE1 4 "want/frog-yes.exp" (Explicit "yes") (Explicit "gen") + ] + + , let sweetNum = 3 + sweet = head $ drop (sweetNum - 1) sweets + tE1 n e d o = + let ex = exp0 (takeDirectory testInpPath3) "foo.c" e d (Explicit "llvm10") o + in testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (ex { associated = [] }) + in TT.testGroup ("Sweet #" <> show sweetNum) $ + [ + testCase "root match" $ "frog.exe" @=? rootMatchName sweet + , testCase "root file" + $ takeDirectory testInpPath3 "gen/llvm10/frog.exe" + @=? rootFile sweet + , testCase "# expectations" $ 4 @=? length (expected sweet) + , tE1 1 "want/frog-no.exp" (Explicit "no") (Explicit "want") + , tE1 0 "want/frog-no.exp" (Explicit "no") NotSpecified + , tE1 3 "want/frog-yes.exp" (Explicit "yes") (Explicit "want") + , tE1 2 "want/frog-yes.exp" (Explicit "yes") NotSpecified + -- TODO not using dir elements from root for unconstrained params + -- , tE1 4 "want/frog-yes.exp" (Explicit "yes") (Explicit "gen") + -- , tE1 2 "want/frog-no.exp" (Explicit "no") (Explicit "gen") + ] + + , let sweetNum = 4 + sweet = head $ drop (sweetNum - 1) sweets + tE1 n e d o = + let ex = exp0 (takeDirectory testInpPath3) "foo.c" e d (Explicit "llvm13") o + in testCase ("Exp #" <> show n) + $ safeElem n (expected sweet) + @?= Just (ex { associated = [] }) + in TT.testGroup ("Sweet #" <> show sweetNum) $ + [ + testCase "root match" $ "frog.exe" @=? rootMatchName sweet + , testCase "root file" + $ takeDirectory testInpPath3 "gen/llvm13/frog.exe" + @=? rootFile sweet + , testCase "# expectations" $ 4 @=? length (expected sweet) + , tE1 1 "want/frog-no.exp" (Explicit "no") (Explicit "want") + , tE1 0 "want/frog-no.exp" (Explicit "no") NotSpecified + , tE1 3 "want/frog-yes.exp" (Explicit "yes") (Explicit "want") + , tE1 2 "want/frog-yes.exp" (Explicit "yes") NotSpecified + -- TODO not using dir elements from root for unconstrained params + -- , tE1 2 "want/frog-no.exp" (Explicit "no") (Explicit "gen") + -- , tE1 4 "want/frog-yes.exp" (Explicit "yes") (Explicit "gen") ] , testCase "correct # of foo sweets" $ 4 @=? diff --git a/test/TestGCD.hs b/test/TestGCD.hs --- a/test/TestGCD.hs +++ b/test/TestGCD.hs @@ -11,7 +11,9 @@ import TestUtils import Text.RawString.QQ +import Prelude hiding ( exp ) + testInpPath = "test-data/samples" testParams = [ ("solver", Just ["z3", "yices", "boolector", "cvc4"]) @@ -31,8 +33,8 @@ gcdSampleTests :: [TT.TestTree] gcdSampleTests = - let (sugar,sdesc) = findSugarIn sugarCube gcdSamples - in [ testCase "valid sample" $ 19 @=? length gcdSamples + let (sugar,sdesc) = findSugarIn sugarCube (gcdSamples sugarCube) + in [ testCase "valid sample" $ 19 @=? length (gcdSamples sugarCube) , sugarTestEq "correct found count" sugarCube gcdSamples 1 length , testCase "sweets rendering" $ @@ -53,90 +55,54 @@ , 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 [ - Expectation - { expectedFile = p "gcd-test.boolector.good" - , expParamsMatch = [ ("solver", Explicit "boolector") - , ("loop-merging", Assumed "loopmerge") - ] - , associated = [ ("config", p "gcd-test.loopmerge.config") - , ("stdio", p "gcd-test.boolector.print") - ] - } - , Expectation - { expectedFile = p "gcd-test.boolector.good" - , expParamsMatch = [ ("solver", Explicit "boolector") - , ("loop-merging", Assumed "loop") - ] - , associated = [ ("config", p "gcd-test.config") - , ("stdio", p "gcd-test.boolector.print") - ] - } + exp "gcd-test.boolector.good" (e "boolector") (a "loopmerge") + "gcd-test.loopmerge.config" + "gcd-test.boolector.print" - , Expectation - { expectedFile = p "gcd-test.good" - , expParamsMatch = [ ("solver", Assumed "cvc4") - , ("loop-merging", Assumed "loopmerge") - ] - , associated = [ ("config", p "gcd-test.loopmerge.config") - , ("stdio", p "gcd-test.print") - ] - } - , Expectation - { expectedFile = p "gcd-test.good" - , expParamsMatch = [ ("solver", Assumed "cvc4") - , ("loop-merging", Assumed "loop") - ] - , associated = [ ("config", p "gcd-test.config") - , ("stdio", p "gcd-test.print") - ] - } + , exp "gcd-test.boolector.good" (e "boolector") (a "loop") + "gcd-test.config" + "gcd-test.boolector.print" - , Expectation - { expectedFile = p "gcd-test.good" - , expParamsMatch = [ ("solver", Assumed "yices") - , ("loop-merging", Assumed "loopmerge") - ] - , associated = [ ("config", p "gcd-test.loopmerge.config") - , ("stdio", p "gcd-test.print") - ] - } - , Expectation - { expectedFile = p "gcd-test.good" - , expParamsMatch = [ ("solver", Assumed "yices") - , ("loop-merging", Assumed "loop") - ] - , associated = [ ("config", p "gcd-test.config") - , ("stdio", p "gcd-test.print") - ] - } + , exp "gcd-test.good" (a "cvc4") (a "loopmerge") + "gcd-test.loopmerge.config" + "gcd-test.print" - , Expectation - { expectedFile = p "gcd-test.good" - , expParamsMatch = [ ("solver", Assumed "z3") - , ("loop-merging", Assumed "loopmerge") - ] - , associated = [ ("config", p "gcd-test.loopmerge.config") - , ("stdio", p "gcd-test.print") - ] - } - , Expectation - { expectedFile = p "gcd-test.good" - , expParamsMatch = [ ("solver", Assumed "z3") - , ("loop-merging", Assumed "loop") - ] - , associated = [ ("config", p "gcd-test.config") - , ("stdio", p "gcd-test.print") - ] - } + , 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 "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 "loop") + "gcd-test.config" + "gcd-test.print" + ] ] -gcdSamples = fmap (\f -> CandidateFile { candidateDir = testInpPath - , candidateSubdirs = [] - , candidateFile = f }) - $ filter (not . null) - $ lines [r| +gcdSamples cube = fmap (makeCandidate cube testInpPath []) + $ filter (not . null) + $ lines [r| gcd-test.boolector.boolector.out gcd-test.boolector.boolector.print.out gcd-test.boolector.good diff --git a/test/TestMultiAssoc.hs b/test/TestMultiAssoc.hs --- a/test/TestMultiAssoc.hs +++ b/test/TestMultiAssoc.hs @@ -35,12 +35,12 @@ multiAssocTests :: [TT.TestTree] multiAssocTests = - let (sugar1,_s1desc) = findSugarIn sugarCube (sample1 testInpPath) + 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 testInpPath) + 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 (?) @@ -51,10 +51,31 @@ -- putStrLn $ T.unpack actual -- T.length actual > 0 @? "change this to see the table" - , sugarTestEq "correct found count" sugarCube (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" @@ -62,36 +83,19 @@ , cubeParams = validParams sugarCube , expected = [ - Expectation - { expectedFile = p "global-max-good.ppc.expected" - , expParamsMatch = [("arch", Explicit "ppc"), - ("form", Assumed "base")] - , associated = [ ("exe", p "global-max-good.ppc.exe") - , ("obj", p "global-max-good.ppc.o") - ] - } - , Expectation - { expectedFile = p "global-max-good.ppc.expected" - , expParamsMatch = [("arch", Explicit "ppc"), - ("form", Assumed "refined")] - , associated = [ ("exe", p "global-max-good.ppc.exe") - , ("obj", p "global-max-good.ppc.o") - ] - } - , Expectation - { expectedFile = p "global-max-good.x86.expected" - , expParamsMatch = [("arch", Explicit "x86"), - ("form", Assumed "base")] - , associated = [ ("exe", p "global-max-good.x86.exe") - ] - } - , Expectation - { expectedFile = p "global-max-good.x86.expected" - , expParamsMatch = [("arch", Explicit "x86"), - ("form", Assumed "refined")] - , associated = [ ("exe", p "global-max-good.x86.exe") - ] - } + 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" + + , 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" ] } @@ -100,42 +104,23 @@ , rootFile = p "jumpfar.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "jumpfar.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "base") ] - , associated = [ ("exe", p "jumpfar.ppc.exe") - , ("include", p "jumpfar.h") - -- The x86 versions should not match this - , ("obj", p "jumpfar.ppc.o") - ] - } - , Expectation - { expectedFile = p "jumpfar.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "refined") ] - , associated = [ ("exe", p "jumpfar.ppc.exe") - , ("include", p "jumpfar.h") - -- The x86 versions should not match this - , ("obj", p "jumpfar.ppc.o") - ] - } - , Expectation - { expectedFile = p "jumpfar.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "base") ] - , associated = [ ("exe", p "jumpfar.x86.exe") - , ("include", p "jumpfar.h") - ] - } - , Expectation - { expectedFile = p "jumpfar.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "refined")] - , associated = [ ("exe", p "jumpfar.x86.exe") - , ("include", p "jumpfar.h") - ] - } + [ 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" + + , 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" @@ -143,34 +128,17 @@ , rootFile = p "looping.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "looping.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "base") ] - , associated = [ ("exe", p "looping.ppc.exe") - ] - } - , Expectation - { expectedFile = p "looping.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "refined") ] - , associated = [ ("exe", p "looping.ppc.exe") - ] - } - , Expectation - { expectedFile = p "looping.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "base") ] - , associated = [ ("exe", p "looping.x86.exe") - ] - } - , Expectation - { expectedFile = p "looping.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "refined")] - , associated = [ ("exe", p "looping.x86.exe") - ] - } + [ exp1 "looping.ppc.expected" (e "ppc") (a "refined") + "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 "base") + "looping.x86.exe" ] } , Sweets { rootMatchName = "looping-around.c" @@ -178,34 +146,17 @@ , rootFile = p "looping-around.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "looping-around.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "base") ] - , associated = [ ("exe", p "looping-around.ppc.exe") - ] - } - , Expectation - { expectedFile = p "looping-around.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "refined") ] - , associated = [ ("exe", p "looping-around.ppc.exe") - ] - } - , Expectation - { expectedFile = p "looping-around.expected" - , expParamsMatch = [ ("arch", Assumed "x86") - , ("form", Assumed "base") ] - , associated = [ ("exe", p "looping-around.x86.exe") - ] - } - , Expectation - { expectedFile = p "looping-around.expected" - , expParamsMatch = [ ("arch", Assumed "x86") - , ("form", Assumed "refined")] - , associated = [ ("exe", p "looping-around.x86.exe") - ] - } + [ 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.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" @@ -213,46 +164,32 @@ , rootFile = p "switching.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "switching.ppc.base-expected" - , expParamsMatch = [ ("form", Explicit "base") - , ("arch", Explicit "ppc") - ] - , associated = [ ("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") - ] - } - , Expectation - { expectedFile = p "switching.x86.base-expected" - , expParamsMatch = [ ("form", Explicit "base") - , ("arch", Explicit "x86") - ] - , associated = [ ("exe", p "switching.x86.exe") - , ("include", p "switching.h") - , ("c++-include", p "switching.hh") - , ("plain", p "switching") - ] - } - , Expectation - { expectedFile = p "switching.x86.refined-expected" - , expParamsMatch = [ ("form", Explicit "refined") - , ("arch", Explicit "x86") - ] - , associated = [ ("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.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.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" @@ -260,34 +197,17 @@ , rootFile = p "tailrecurse.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "tailrecurse.expected" - , expParamsMatch = [ ("arch", Assumed "ppc"), - ("form", Assumed "base") ] - , associated = [ ("exe", p "tailrecurse.ppc.exe") - ] - } - , Expectation - { expectedFile = p "tailrecurse.expected" - , expParamsMatch = [ ("arch", Assumed "ppc") - , ("form", Assumed "refined") ] - , associated = [ ("exe", p "tailrecurse.ppc.exe") - ] - } - , Expectation - { expectedFile = p "tailrecurse.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86"), - ("form", Assumed "base") ] - , associated = [ ("exe", p "tailrecurse.x86.exe") - ] - } - , Expectation - { expectedFile = p "tailrecurse.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "refined") ] - , associated = [ ("exe", p "tailrecurse.x86.exe") - ] - } + [ exp1 "tailrecurse.expected" (a "ppc") (a "refined") + "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 "base") + "tailrecurse.x86.exe" ] } ] diff --git a/test/TestNoAssoc.hs b/test/TestNoAssoc.hs --- a/test/TestNoAssoc.hs +++ b/test/TestNoAssoc.hs @@ -26,18 +26,97 @@ noAssocTests :: [TT.TestTree] noAssocTests = - let (sugar1,s1desc) = findSugarIn sugarCube (sample1 testInpPath) + let (sugar1,s1desc) = findSugarIn sugarCube (sample1 sugarCube testInpPath) + chkCandidate = checkCandidate sugarCube (\c -> sample1 c testInpPath) + 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 testInpPath) + testCase "valid sample" $ 57 @=? length (sample1 sugarCube testInpPath) - , sugarTestEq "correct found count" sugarCube (sample1 testInpPath) 6 length + , TT.testGroup "candidates" + [ + chkCandidate 0 "global-max-good.c" [] + , chkCandidate 2 "global-max-good.ppc.o" [ ("arch", Explicit "ppc") ] + , chkCandidate 2 "global-max-good.ppc.exe" [ ("arch", Explicit "ppc") ] + , chkCandidate 2 "global-max-good.ppc.expected" [ ("arch", Explicit "ppc") ] + , chkCandidate 2 "global-max-good.x86.exe" [ ("arch", Explicit "x86") ] + , chkCandidate 2 "global-max-good.x86.expected" [ ("arch", Explicit "x86") ] + , chkCandidate 0 "jumpfar.c" [] + , chkCandidate 0 "jumpfar.h" [] + , chkCandidate 0 "jumpfar.ppc.exe" [ ("arch", Explicit "ppc") ] + , chkCandidate 0 "jumpfar.ppc.o" [ ("arch", Explicit "ppc") ] + , chkCandidate 0 "jumpfar.ppc.expected" [ ("arch", Explicit "ppc") ] + , chkCandidate 0 "jumpfar.x86.exe" [ ("arch", Explicit "x86") ] + , chkCandidate 0 "jumpfar.x86.expected" [ ("arch", Explicit "x86") ] + , chkCandidate 0 "looping.c" [] + , chkCandidate 0 "looping.ppc.exe" [ ("arch", Explicit "ppc") ] + , chkCandidate 0 "looping.ppc.expected" [ ("arch", Explicit "ppc") ] + , chkCandidate 0 "looping.x86.exe" [ ("arch", Explicit "x86") ] + , chkCandidate 0 "looping.x86.expected" [ ("arch", Explicit "x86") ] + , chkCandidate 0 "looping-around.c" [] + , chkCandidate 1 "looping-around.ppc.exe" [ ("arch", Explicit "ppc") ] + , chkCandidate 1 "looping-around.ppc.expected" [ ("arch", Explicit "ppc") ] + , chkCandidate 1 "looping-around.x86.exe" [ ("arch", Explicit "x86") ] + , chkCandidate 0 "looping-around.expected" [] + , chkCandidate 0 "Makefile" [] + , chkCandidate 0 "README.org" [] + , chkCandidate 0 "switching" [] + , chkCandidate 0 "switching_stuff" [] + , chkCandidate 0 "switching.c" [] + , chkCandidate 0 "switching.h" [] + , chkCandidate 0 "switching.hh" [] + , chkCandidate 0 "switching_llvm.c" [] + , chkCandidate 0 "switching_llvm.h" [] + , chkCandidate 0 "switching_llvm.x86.exe" [ ("arch", Explicit "x86") ] + , chkCandidate 0 "switching_many.c" [] + , chkCandidate 0 "switching_many_llvm.c" [] + , chkCandidate 0 "switching_many_llvm.x86.exe" [ ("arch", Explicit "x86") ] + , chkCandidate 0 "switching_many.ppc.exe" [ ("arch", Explicit "ppc") ] + , chkCandidate 0 "switching.ppc.base-expected" [ ("arch", Explicit "ppc") + , ("form", Explicit "base") ] + , chkCandidate 0 "switching.ppc.o" [ ("arch", Explicit "ppc") ] + , chkCandidate 0 "switching.ppc.base.o" [ ("arch", Explicit "ppc") + , ("form", Explicit "base") ] + , chkCandidate 0 "switching.ppc.extra.o" [ ("arch", Explicit "ppc") ] + , chkCandidate 0 "switching.ppc.other" [ ("arch", Explicit "ppc") ] + , chkCandidate 0 "switching.ppc.exe" [ ("arch", Explicit "ppc") ] + , chkCandidate 0 "switching.x86.base-expected" [ ("arch", Explicit "x86") + , ("form", Explicit "base") ] + , chkCandidate 0 "switching.x86.exe" [ ("arch", Explicit "x86") ] + , chkCandidate 0 "switching-refined.x86.o" [ ("arch", Explicit "x86") + , ("form", Explicit "refined") ] + , chkCandidate 0 "switching.x86.orig" [ ("arch", Explicit "x86") ] + , chkCandidate 0 "switching.x86.refined-expected" [ ("arch", Explicit "x86") + , ("form", Explicit "refined") ] + , chkCandidate 0 "switching.x86.refined-expected-orig" [ ("arch", Explicit "x86") + , ("form", Explicit "refined") ] + , chkCandidate 0 "switching.x86.refined-last-actual" [ ("arch", Explicit "x86") + , ("form", Explicit "refined") ] + , chkCandidate 0 "tailrecurse.c" [] + , chkCandidate 0 "tailrecurse.expected" [] + , chkCandidate 0 "tailrecurse.expected.expected" [] + , chkCandidate 0 "tailrecurse.food.expected" [] + , chkCandidate 0 "tailrecurse.ppc.exe" [ ("arch", Explicit "ppc") ] + , chkCandidate 0 "tailrecurse.x86.exe" [ ("arch", Explicit "x86") ] + , chkCandidate 0 "tailrecurse.x86.expected" [ ("arch", Explicit "x86") ] + ] + , sugarTestEq "correct found count" sugarCube + (flip sample1 testInpPath) 6 length + , testCase "results" $ compareBags "results" sugar1 $ let p = (testInpPath ) in + let 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" @@ -45,30 +124,10 @@ , cubeParams = validParams sugarCube , expected = [ - Expectation - { expectedFile = p "global-max-good.ppc.expected" - , expParamsMatch = [("arch", Explicit "ppc"), - ("form", Assumed "base")] - , associated = [] - } - , Expectation - { expectedFile = p "global-max-good.ppc.expected" - , expParamsMatch = [("arch", Explicit "ppc"), - ("form", Assumed "refined")] - , associated = [] - } - , Expectation - { expectedFile = p "global-max-good.x86.expected" - , expParamsMatch = [("arch", Explicit "x86"), - ("form", Assumed "base")] - , associated = [] - } - , Expectation - { expectedFile = p "global-max-good.x86.expected" - , expParamsMatch = [("arch", Explicit "x86"), - ("form", Assumed "refined")] - , associated = [] - } + 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") ] } @@ -77,30 +136,10 @@ , rootFile = p "jumpfar.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "jumpfar.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "base") ] - , associated = [] - } - , Expectation - { expectedFile = p "jumpfar.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "refined") ] - , associated = [] - } - , Expectation - { expectedFile = p "jumpfar.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "base") ] - , associated = [] - } - , Expectation - { expectedFile = p "jumpfar.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "refined")] - , associated = [] - } + [ 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" @@ -108,30 +147,10 @@ , rootFile = p "looping.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "looping.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "base") ] - , associated = [] - } - , Expectation - { expectedFile = p "looping.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "refined") ] - , associated = [] - } - , Expectation - { expectedFile = p "looping.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "base") ] - , associated = [] - } - , Expectation - { expectedFile = p "looping.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "refined")] - , associated = [] - } + [ 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" @@ -139,30 +158,10 @@ , rootFile = p "looping-around.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "looping-around.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "base") ] - , associated = [] - } - , Expectation - { expectedFile = p "looping-around.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "refined") ] - , associated = [] - } - , Expectation - { expectedFile = p "looping-around.expected" - , expParamsMatch = [ ("arch", Assumed "x86") - , ("form", Assumed "base") ] - , associated = [] - } - , Expectation - { expectedFile = p "looping-around.expected" - , expParamsMatch = [ ("arch", Assumed "x86") - , ("form", Assumed "refined")] - , associated = [] - } + [ 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" @@ -170,58 +169,20 @@ , rootFile = p "switching.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "switching.ppc.base-expected" - , expParamsMatch = [ ("arch", Explicit "ppc") - , ("form", Explicit "base") - ] - , associated = [] - } - , Expectation - { expectedFile = p "switching.x86.base-expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Explicit "base") - ] - , associated = [] - } - , Expectation - { expectedFile = p "switching.x86.refined-expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Explicit "refined") - ] - , associated = [] - } - ] - } + [ 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 = - [ Expectation - { expectedFile = p "tailrecurse.expected" - , expParamsMatch = [ ("arch", Assumed "ppc"), - ("form", Assumed "base") ] - , associated = [] - } - , Expectation - { expectedFile = p "tailrecurse.expected" - , expParamsMatch = [ ("arch", Assumed "ppc") - , ("form", Assumed "refined") ] - , associated = [] - } - , Expectation - { expectedFile = p "tailrecurse.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86"), - ("form", Assumed "base") ] - , associated = [] - } - , Expectation - { expectedFile = p "tailrecurse.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "refined") ] - , associated = [] - } + [ 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") ] } ] @@ -230,7 +191,7 @@ mkNoAssocTests :: IO [TT.TestTree] mkNoAssocTests = - let (sugar1,s1desc) = findSugarIn sugarCube $ sample1 testInpPath + let (sugar1,s1desc) = findSugarIn sugarCube $ sample1 sugarCube testInpPath in do tt <- withSugarGroups sugar1 TT.testGroup $ \sw idx exp -> -- Verify this will suppress the "refined" tests for diff --git a/test/TestParamsAssoc.hs b/test/TestParamsAssoc.hs --- a/test/TestParamsAssoc.hs +++ b/test/TestParamsAssoc.hs @@ -12,10 +12,8 @@ import Text.RawString.QQ -sample :: [CandidateFile] -sample = fmap (\f -> CandidateFile { candidateDir = testInpPath - , candidateSubdirs = [] - , candidateFile = f }) +sample :: CUBE -> [CandidateFile] +sample cube = fmap (makeCandidate cube testInpPath []) $ filter (not . null) $ lines [r| recursive.rs @@ -31,8 +29,29 @@ simple.clang-gcc.exe simple-opt.expct simple-opt.gcc-exe +alpha.exe +alpha.expct +alpha.clang.expct +alpha.x.expct +beta.exe +beta.expct +beta.clang.expct +beta......x.expct +gamma.exe +gamma.expct +gamma.clang.expct +gamma.x......expct +delta.exe +delta.expct +delta.clang.expct +delta......y.expct +epsilon.exe +epsilon.expct +epsilon.clang.expct +epsilon.y......expct |] + testInpPath = "test/params/samples" -- Note: in addition to other differences when compared to the tests @@ -53,137 +72,284 @@ , validParams = [ ("optimization", Nothing) ,("c-compiler", Just ["gcc", "clang"]) + ,("other", Just ["x"]) -- follows c-compiler + ,("a param", Just ["y"]) -- preceeds c-compiler ] } paramsAssocTests :: [TT.TestTree] paramsAssocTests = - let (sugar1,_s1desc) = findSugarIn sugarCube sample - in [ testCase "valid sample" $ 13 @=? length sample - , sugarTestEq "correct found count" sugarCube sample 6 length - , testCase "results" $ compareBags "results" sugar1 $ - let p = (testInpPath ) in + let (sugar1,_s1desc) = findSugarIn sugarCube (sample sugarCube) + chkCandidate = checkCandidate sugarCube sample testInpPath [] 0 + mkE' a cx cy p f c o = Expectation + { expectedFile = p f + , expParamsMatch = [ ("a param", cy "y") + , ("c-compiler", c) + , ("optimization", o) + , ("other", cx "x") + ] + , associated = a + } + mkEr p = mkE' [ ("rust-source", p "recursive.rs") ] Assumed Assumed p + mkEc p f c = mkE' [ ("c-source", p "simple.c") ] Assumed Assumed p f (Explicit c) + mkEo cs p f c ca = mkE' [] cs ca p f c NotSpecified + mkEq cs ca p f c = mkE' [] cs ca p f c + 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) + in [ testCase "valid sample" $ 33 @=? length (sample sugarCube) + + , TT.testGroup "candidates" [ - Sweets { rootMatchName = "recursive.fast.exe" - , rootBaseName = "recursive" - , rootFile = p "recursive.fast.exe" - , cubeParams = validParams sugarCube - , expected = - [ - Expectation - { expectedFile = p "recursive.fast.expct" - , expParamsMatch = [ ("optimization", Explicit "fast") - , ("c-compiler", Assumed "clang") - ] - , associated = [ ("rust-source", p "recursive.rs") ] - } - , Expectation - { expectedFile = p "recursive.fast.expct" - , expParamsMatch = [ ("optimization", Explicit "fast") - , ("c-compiler", Assumed "gcc") - ] - , associated = [ ("rust-source", p "recursive.rs") ] - } - ] - } + chkCandidate "recursive.rs" [] + , chkCandidate "recursive.fast.exe" [("optimization", Explicit "fast")] + , chkCandidate "simple.noopt.clang.exe" [("c-compiler", Explicit "clang") + , ("optimization", Explicit "noopt")] + , chkCandidate "simple.noopt.gcc.exe" [("c-compiler", Explicit "gcc") + , ("optimization", Explicit "noopt")] + , chkCandidate "simple.noopt-gcc.expct" [("c-compiler", Explicit "gcc") + , ("optimization", Explicit "noopt")] + , chkCandidate "simple.opt-clang.exe" [("c-compiler", Explicit "clang") + , ("optimization", Explicit "opt")] + , chkCandidate "simple.clang-noopt-clang.exe" [("c-compiler", Explicit "clang") + , ("optimization", Explicit "noopt")] + , chkCandidate "simple.clang-gcc.exe" [("c-compiler", Explicit "clang") + ,("c-compiler", Explicit "gcc")] + , chkCandidate "simple-opt.expct" [("optimization", Explicit "opt")] + , chkCandidate "simple-opt.gcc-exe" [("c-compiler", Explicit "gcc") + , ("optimization", Explicit "opt")] + , chkCandidate "alpha.exe" [] + , chkCandidate "alpha.expct" [] + , chkCandidate "alpha.clang.expct" [("c-compiler", Explicit "clang")] + , chkCandidate "alpha.x.expct" [("other", Explicit "x")] + , chkCandidate "beta.exe" [] + , chkCandidate "beta.expct" [] + , chkCandidate "beta.clang.expct" [("c-compiler", Explicit "clang")] + , chkCandidate "beta......x.expct" [("other", Explicit "x")] + , chkCandidate "gamma.exe" [] + , chkCandidate "gamma.expct" [] + , chkCandidate "gamma.clang.expct" [("c-compiler", Explicit "clang")] + , chkCandidate "gamma.x......expct" [("other", Explicit "x")] + , chkCandidate "delta.exe" [] + , chkCandidate "delta.expct" [] + , chkCandidate "delta.clang.expct" [("c-compiler", Explicit "clang")] + , chkCandidate "delta......y.expct" [("a param", Explicit "y")] + , chkCandidate "epsilon.exe" [] + , chkCandidate "epsilon.expct" [] + , chkCandidate "epsilon.clang.expct" [("c-compiler", Explicit "clang")] + , chkCandidate "epsilon.y......expct" [("a param", Explicit "y")] + ] - , Sweets { rootMatchName = "simple.noopt.clang.exe" - , rootBaseName = "simple" - , rootFile = p "simple.noopt.clang.exe" - , cubeParams = validParams sugarCube - , expected = - [ - Expectation - { expectedFile = p "simple.expct" - , expParamsMatch = [ ("optimization", Explicit "noopt") - , ("c-compiler", Explicit "clang") - ] - , associated = [ ("c-source", p "simple.c")] - } - ] - } + , sugarTestEq "correct found count" sugarCube sample 11 length - , Sweets { rootMatchName = "simple.noopt.gcc.exe" - , rootBaseName = "simple" - , rootFile = p "simple.noopt.gcc.exe" - , cubeParams = validParams sugarCube - , expected = - [ Expectation - { expectedFile = p "simple.noopt-gcc.expct" - , expParamsMatch = [ ("optimization", Explicit "noopt") - , ("c-compiler", Explicit "gcc") - ] - , associated = [ ("c-source", p "simple.c")] - } - ] - } + , let sweetNum = 5 + sweet = safeElem sweetNum sugar1 + chkF = chkFld sweet + chkP = chkFld sweet + chkE = chkExp sweet (mkEr p) + in TT.testGroup ("Sweet #" <> show sweetNum) + [ + chkF "rootMatchName" rootMatchName "recursive.fast.exe" + , chkF "rootBaseName" rootBaseName "recursive" + , chkF "rootFile" rootFile $ p "recursive.fast.exe" + , chkP "cubeParams" cubeParams $ validParams sugarCube + , chkE 1 "recursive.fast.expct" (Assumed "clang") (Explicit "fast") + , chkE 0 "recursive.fast.expct" (Assumed "gcc") (Explicit "fast") + ] - , Sweets { rootMatchName = "simple.opt-clang.exe" - , rootBaseName = "simple" - , rootFile = p "simple.opt-clang.exe" - , cubeParams = validParams sugarCube - , expected = - [ Expectation - { expectedFile = p "simple-opt.expct" - , expParamsMatch = [ ("optimization", Explicit "opt") - , ("c-compiler", Explicit "clang") - ] - , associated = [ ("c-source", p "simple.c")] - } - ] - } + , let sweetNum = 8 + sweet = safeElem sweetNum sugar1 + chkF = chkFld sweet + chkP = chkFld sweet + chkE = chkExp sweet (mkEc p) + in TT.testGroup ("Sweet #" <> show sweetNum) + [ + chkF "rootMatchName" rootMatchName "simple.noopt.clang.exe" + , chkF "rootBaseName" rootBaseName "simple" + , chkF "rootFile" rootFile $ p "simple.noopt.clang.exe" + , chkP "cubeParams" cubeParams $ validParams sugarCube + -- Note that opt is an unconstrained parameter, so it can + -- match "noopt" or it can match something else. + , chkE 0 "simple-opt.expct" "clang" (Explicit "opt") + , chkE 1 "simple.expct" "clang" NotSpecified + , chkE 2 "simple.expct" "clang" (Explicit "noopt") + ] - -- This repeats a parameter value, which nullifies any - -- parameter matching and so those elements that look like - -- parameters are just part of the base. - , Sweets { rootMatchName = "simple.clang-noopt-clang.exe" - , rootBaseName = "simple" - , rootFile = p "simple.clang-noopt-clang.exe" - , cubeParams = validParams sugarCube - , expected = - [ Expectation - { expectedFile = p "simple.expct" - , expParamsMatch = [ ("optimization", NotSpecified) - , ("c-compiler", Assumed "clang") - ] - , associated = [ ("c-source", p "simple.c")] - } - , Expectation - { expectedFile = p "simple.expct" - , expParamsMatch = [ ("optimization", NotSpecified) - , ("c-compiler", Assumed "gcc") - ] - , associated = [ ("c-source", p "simple.c")] - } - ] - } + , let sweetNum = 9 + sweet = safeElem sweetNum sugar1 + chkF = chkFld sweet + chkP = chkFld sweet + chkE = chkExp sweet (mkEc p) + in TT.testGroup ("Sweet #" <> show sweetNum) + [ + chkF "rootMatchName" rootMatchName "simple.noopt.gcc.exe" + , chkF "rootBaseName" rootBaseName "simple" + , chkF "rootFile" rootFile $ p "simple.noopt.gcc.exe" + , chkP "cubeParams" cubeParams $ validParams sugarCube + -- Note that opt is an unconstrained parameter, so it can + -- match "noopt" or it can match something else. + , chkE 0 "simple-opt.expct" "gcc" (Explicit "opt") + , chkE 1 "simple.noopt-gcc.expct" "gcc" NotSpecified + , chkE 2 "simple.noopt-gcc.expct" "gcc" (Explicit "noopt") + ] - -- This repeats a parameter with a different value, which - -- nullifies any parameter matching and so those elements - -- that look like parameters are just part of the base. - , Sweets { rootMatchName = "simple.clang-gcc.exe" - , rootBaseName = "simple" - , rootFile = p "simple.clang-gcc.exe" - , cubeParams = validParams sugarCube - , expected = - [ Expectation - { expectedFile = p "simple.expct" - , expParamsMatch = [ ("optimization", NotSpecified) - , ("c-compiler", Assumed "clang") - ] - , associated = [ ("c-source", p "simple.c")] - } - , Expectation - { expectedFile = p "simple.expct" - , expParamsMatch = [ ("optimization", NotSpecified) - , ("c-compiler", Assumed "gcc") - ] - , associated = [ ("c-source", p "simple.c")] - } - ] - } + , let sweetNum = 10 + sweet = safeElem sweetNum sugar1 + chkF = chkFld sweet + chkP = chkFld sweet + chkE = chkExp sweet (mkEc p) + in TT.testGroup ("Sweet #" <> show sweetNum) + [ + chkF "rootMatchName" rootMatchName "simple.opt-clang.exe" + , chkF "rootBaseName" rootBaseName "simple" + , chkF "rootFile" rootFile $ p "simple.opt-clang.exe" + , chkP "cubeParams" cubeParams $ validParams sugarCube + -- Note that opt is an unconstrained parameter, so it can + -- match "noopt" or it can match something else. + , chkE 0 "simple-opt.expct" "clang" (Explicit "opt") + , chkE 1 "simple.expct" "clang" NotSpecified + ] + -- This repeats a parameter value and also matches with a different + -- value. The duplicate value should be ignored, but both values should + -- result in different Expectations. + , let sweetNum = 7 + sweet = safeElem sweetNum sugar1 + chkF = chkFld sweet + chkP = chkFld sweet + chkE = chkExp sweet (mkEc p) + in TT.testGroup ("Sweet #" <> show sweetNum) + [ + chkF "rootMatchName" rootMatchName "simple.clang-noopt-clang.exe" + , chkF "rootBaseName" rootBaseName "simple" + , chkF "rootFile" rootFile $ p "simple.clang-noopt-clang.exe" + , chkP "cubeParams" cubeParams $ validParams sugarCube + -- Note that opt is an unconstrained parameter, so it can + -- match "noopt" or it can match something else. + , chkE 0 "simple-opt.expct" "clang" (Explicit "opt") + , chkE 1 "simple.expct" "clang" NotSpecified + , chkE 2 "simple.expct" "clang" (Explicit "noopt") + ] + + -- This repeats a parameter with a different value, which causes a + -- separate explicit match to be claimed for each value. In addition, + -- the optimization parameter has no value specified, so multiple values + -- are found that could be tried, along with an expect file that doesn't + -- supply a potential value for this parameter. + , let sweetNum = 6 + sweet = safeElem sweetNum sugar1 + chkF = chkFld sweet + chkP = chkFld sweet + chkE = chkExp sweet (mkEc p) + in TT.testGroup ("Sweet #" <> show sweetNum) + [ + chkF "rootMatchName" rootMatchName "simple.clang-gcc.exe" + , chkF "rootBaseName" rootBaseName "simple" + , chkF "rootFile" rootFile $ p "simple.clang-gcc.exe" + , chkP "cubeParams" cubeParams $ validParams sugarCube + , chkE 1 "simple-opt.expct" "clang" (Explicit "opt") + , chkE 0 "simple-opt.expct" "gcc" (Explicit "opt") + , chkE 2 "simple.expct" "clang" NotSpecified + , chkE 3 "simple.noopt-gcc.expct" "gcc" NotSpecified + , chkE 4 "simple.noopt-gcc.expct" "gcc" (Explicit "noopt") + ] + -- n.b. simple-opt.gcc-exe is *not* matched: the rootname is -- "*.exe" so the '.' separator is required. - ] + + -- 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 (mkEq cs ca p) n f c NotSpecified + in TT.testGroup ("Sweet #" <> show sweetNum) + [ + chkF "rootMatchName" rootMatchName "alpha.exe" + , chkF "rootBaseName" rootBaseName "alpha" + , chkF "rootFile" rootFile $ p "alpha.exe" + , chkP "cubeParams" cubeParams $ validParams sugarCube + , chkE 0 Assumed Assumed "alpha.clang.expct" (Explicit "clang") + , chkE 1 Explicit Assumed "alpha.x.expct" (Assumed "gcc") + ] + + -- Verify that lengthening the expected filename by adding separators will + -- not change the parameter identification but will select the longer + -- 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 (mkEq cs ca p) n f c NotSpecified + in TT.testGroup ("Sweet #" <> show sweetNum) + [ + chkF "rootMatchName" rootMatchName "beta.exe" + , chkF "rootBaseName" rootBaseName "beta" + , chkF "rootFile" rootFile $ p "beta.exe" + , chkP "cubeParams" cubeParams $ validParams sugarCube + -- sorted: "c-compiler":"clang", "other":"x", so clang is preferred. + , chkE 0 Explicit Assumed "beta......x.expct" (Assumed "gcc") + , chkE 1 Assumed Assumed "beta.clang.expct" (Explicit "clang") + ] + + -- 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 (mkEq cs ca p) n f c NotSpecified + in TT.testGroup ("Sweet #" <> show sweetNum) + [ + chkF "rootMatchName" rootMatchName "gamma.exe" + , chkF "rootBaseName" rootBaseName "gamma" + , chkF "rootFile" rootFile $ p "gamma.exe" + , chkP "cubeParams" cubeParams $ validParams sugarCube + -- sorted: "c-compiler":"clang", "other":"x", so clang is preferred. + , chkE 0 Assumed Assumed "gamma.clang.expct" (Explicit "clang") + , chkE 1 Explicit Assumed "gamma.x......expct" (Assumed "gcc") + ] + + -- 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 (mkEq cs ca p) n f c NotSpecified + in TT.testGroup ("Sweet #" <> show sweetNum) + [ + chkF "rootMatchName" rootMatchName "delta.exe" + , chkF "rootBaseName" rootBaseName "delta" + , chkF "rootFile" rootFile $ p "delta.exe" + , chkP "cubeParams" cubeParams $ validParams sugarCube + -- sorted: "a param":"y", "c-compiler":"clang" so "a param" is + -- preferred. + , chkE 1 Assumed Explicit "delta......y.expct" (Assumed "clang") + , chkE 0 Assumed Explicit "delta......y.expct" (Assumed "gcc") + ] + + -- 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 (mkEq cs ca p) n f c NotSpecified + in TT.testGroup ("Sweet #" <> show sweetNum) + [ + chkF "rootMatchName" rootMatchName "epsilon.exe" + , chkF "rootBaseName" rootBaseName "epsilon" + , chkF "rootFile" rootFile $ p "epsilon.exe" + , chkP "cubeParams" cubeParams $ validParams sugarCube + -- sorted: "a param":"y", "c-compiler":"clang" so "a param" is + -- preferred. + , chkE 1 Assumed Explicit "epsilon.y......expct" (Assumed "clang") + , chkE 0 Assumed Explicit "epsilon.y......expct" (Assumed "gcc") + ] ] diff --git a/test/TestSingleAssoc.hs b/test/TestSingleAssoc.hs --- a/test/TestSingleAssoc.hs +++ b/test/TestSingleAssoc.hs @@ -26,18 +26,27 @@ singleAssocTests :: [TT.TestTree] singleAssocTests = - let (sugar1,_s1desc) = findSugarIn sugarCube (sample1 testInpPath) + 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 testInpPath) + testCase "valid sample" $ 57 @=? length (sample1 sugarCube testInpPath) - , sugarTestEq "correct found count" sugarCube (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" @@ -45,34 +54,17 @@ , cubeParams = validParams sugarCube , expected = [ - Expectation - { expectedFile = p "global-max-good.ppc.expected" - , expParamsMatch = [("arch", Explicit "ppc"), - ("form", Assumed "base")] - , associated = [ ("exe", p "global-max-good.ppc.exe") - ] - } - , Expectation - { expectedFile = p "global-max-good.ppc.expected" - , expParamsMatch = [("arch", Explicit "ppc"), - ("form", Assumed "refined")] - , associated = [ ("exe", p "global-max-good.ppc.exe") - ] - } - , Expectation - { expectedFile = p "global-max-good.x86.expected" - , expParamsMatch = [("arch", Explicit "x86"), - ("form", Assumed "base")] - , associated = [ ("exe", p "global-max-good.x86.exe") - ] - } - , Expectation - { expectedFile = p "global-max-good.x86.expected" - , expParamsMatch = [("arch", Explicit "x86"), - ("form", Assumed "refined")] - , associated = [ ("exe", p "global-max-good.x86.exe") - ] - } + 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.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" ] } @@ -81,34 +73,17 @@ , rootFile = p "jumpfar.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "jumpfar.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "base") ] - , associated = [ ("exe", p "jumpfar.ppc.exe") - ] - } - , Expectation - { expectedFile = p "jumpfar.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "refined") ] - , associated = [ ("exe", p "jumpfar.ppc.exe") - ] - } - , Expectation - { expectedFile = p "jumpfar.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "base") ] - , associated = [ ("exe", p "jumpfar.x86.exe") - ] - } - , Expectation - { expectedFile = p "jumpfar.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "refined")] - , associated = [ ("exe", p "jumpfar.x86.exe") - ] - } + [ exp1 "jumpfar.ppc.expected" (e "ppc") (a "refined") + "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 "base") + "jumpfar.x86.exe" ] } , Sweets { rootMatchName = "looping.c" @@ -116,34 +91,17 @@ , rootFile = p "looping.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "looping.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "base") ] - , associated = [ ("exe", p "looping.ppc.exe") - ] - } - , Expectation - { expectedFile = p "looping.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "refined") ] - , associated = [ ("exe", p "looping.ppc.exe") - ] - } - , Expectation - { expectedFile = p "looping.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "base") ] - , associated = [ ("exe", p "looping.x86.exe") - ] - } - , Expectation - { expectedFile = p "looping.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "refined")] - , associated = [ ("exe", p "looping.x86.exe") - ] - } + [ exp1 "looping.ppc.expected" (e "ppc") (a "refined") + "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 "base") + "looping.x86.exe" ] } , Sweets { rootMatchName = "looping-around.c" @@ -151,34 +109,17 @@ , rootFile = p "looping-around.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "looping-around.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "base") ] - , associated = [ ("exe", p "looping-around.ppc.exe") - ] - } - , Expectation - { expectedFile = p "looping-around.ppc.expected" - , expParamsMatch = [ ("arch" , Explicit "ppc") - , ("form" , Assumed "refined") ] - , associated = [ ("exe", p "looping-around.ppc.exe") - ] - } - , Expectation - { expectedFile = p "looping-around.expected" - , expParamsMatch = [ ("arch", Assumed "x86") - , ("form", Assumed "base") ] - , associated = [ ("exe", p "looping-around.x86.exe") - ] - } - , Expectation - { expectedFile = p "looping-around.expected" - , expParamsMatch = [ ("arch", Assumed "x86") - , ("form", Assumed "refined")] - , associated = [ ("exe", p "looping-around.x86.exe") - ] - } + [ 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.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" @@ -186,30 +127,14 @@ , rootFile = p "switching.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "switching.ppc.base-expected" - , expParamsMatch = [ ("arch", Explicit "ppc") - , ("form", Explicit "base") - ] - , associated = [ ("exe", p "switching.ppc.exe") - ] - } - , Expectation - { expectedFile = p "switching.x86.base-expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Explicit "base") - ] - , associated = [ ("exe", p "switching.x86.exe") - ] - } - , Expectation - { expectedFile = p "switching.x86.refined-expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Explicit "refined") - ] - , associated = [ ("exe", p "switching.x86.exe") - ] - } + [ 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.refined-expected" (e "x86") (e "refined") + "switching.x86.exe" ] } , Sweets { rootMatchName = "tailrecurse.c" @@ -217,34 +142,17 @@ , rootFile = p "tailrecurse.c" , cubeParams = validParams sugarCube , expected = - [ Expectation - { expectedFile = p "tailrecurse.expected" - , expParamsMatch = [ ("arch", Assumed "ppc"), - ("form", Assumed "base") ] - , associated = [ ("exe", p "tailrecurse.ppc.exe") - ] - } - , Expectation - { expectedFile = p "tailrecurse.expected" - , expParamsMatch = [ ("arch", Assumed "ppc") - , ("form", Assumed "refined") ] - , associated = [ ("exe", p "tailrecurse.ppc.exe") - ] - } - , Expectation - { expectedFile = p "tailrecurse.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86"), - ("form", Assumed "base") ] - , associated = [ ("exe", p "tailrecurse.x86.exe") - ] - } - , Expectation - { expectedFile = p "tailrecurse.x86.expected" - , expParamsMatch = [ ("arch", Explicit "x86") - , ("form", Assumed "refined") ] - , associated = [ ("exe", p "tailrecurse.x86.exe") - ] - } + [ exp1 "tailrecurse.expected" (a "ppc") (a "refined") + "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 "base") + "tailrecurse.x86.exe" ] } ] diff --git a/test/TestStrlen2.hs b/test/TestStrlen2.hs --- a/test/TestStrlen2.hs +++ b/test/TestStrlen2.hs @@ -30,10 +30,63 @@ strlen2SampleTests :: [TT.TestTree] strlen2SampleTests = - let (sugar,sdesc) = findSugarIn sugarCube strlen2Samples - in [ testCase "valid sample" $ 24 @=? length strlen2Samples + 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 + , 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"] @@ -46,78 +99,40 @@ , 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 [ - Expectation - { expectedFile = p "strlen_test2.boolector.loopmerge.good" - , expParamsMatch = [ ("solver", Explicit "boolector") - , ("loop-merging", Explicit "loopmerge") - ] - , associated = [ ("config", p "strlen_test2.loopmerge.config") - , ("stdio", p "strlen_test2.print") - ] - } - , Expectation - { expectedFile = p "strlen_test2.boolector.good" - , expParamsMatch = [ ("solver", Explicit "boolector") - , ("loop-merging", Assumed "loop") - ] - , associated = [ ("stdio", p "strlen_test2.print") - ] - } + exp2 "strlen_test2.boolector.loopmerge.good" (e "boolector") (e m) + "strlen_test2.loopmerge.config" - , Expectation - { expectedFile = p "strlen_test2.loopmerge.cvc4.good" - , expParamsMatch = [ ("solver", Explicit "cvc4") - , ("loop-merging", Explicit "loopmerge") - ] - , associated = [ ("config", p "strlen_test2.loopmerge.config") - , ("stdio", p "strlen_test2.print") - ] - } - , Expectation - { expectedFile = p "strlen_test2.cvc4.loop.good" - , expParamsMatch = [ ("solver", Explicit "cvc4") - , ("loop-merging", Explicit "loop") - ] - , associated = [ ("stdio", p "strlen_test2.print") - ] - } + , exp1 "strlen_test2.boolector.good" (e "boolector") (a l) - , Expectation - { expectedFile = p "strlen_test2.loopmerge.good" - , expParamsMatch = [ ("loop-merging", Explicit "loopmerge") - , ("solver", Assumed "yices") - ] - , associated = [ ("config", p "strlen_test2.loopmerge.config") - , ("stdio", p "strlen_test2.print") - ] - } - , Expectation - { expectedFile = p "strlen_test2.good" - , expParamsMatch = [ ("loop-merging", Assumed "loop") - , ("solver", Assumed "yices") - ] - , associated = [ ("stdio", p "strlen_test2.print") - ] - } + , exp2 "strlen_test2.loopmerge.cvc4.good" (e "cvc4") (e m) + "strlen_test2.loopmerge.config" - , Expectation - { expectedFile = p "strlen_test2.z3.good" - , expParamsMatch = [ ("solver", Explicit "z3") - , ("loop-merging", Assumed "loopmerge") - ] - , associated = [ ("config", p "strlen_test2.loopmerge.config") - , ("stdio", p "strlen_test2.print") - ] - } - , Expectation - { expectedFile = p "strlen_test2.z3.good" - , expParamsMatch = [ ("solver", Explicit "z3") - , ("loop-merging", Assumed "loop") - ] - , associated = [ ("stdio", p "strlen_test2.print") - ] - } + , exp1 "strlen_test2.cvc4.loop.good" (e "cvc4") (e l) + + , exp2 "strlen_test2.loopmerge.good" (a "yices") (e m) + "strlen_test2.loopmerge.config" + + , exp1 "strlen_test2.good" (a "yices") (a l) + + , exp2 "strlen_test2.loopmerge.good" (a "z3") (e m) + "strlen_test2.loopmerge.config" + + , 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 @@ -143,11 +158,9 @@ ] ] -strlen2Samples = fmap (\f -> CandidateFile { candidateDir = "test-data/samples" - , candidateSubdirs = [] - , candidateFile = f }) - $ filter (not . null) - $ lines [r| +strlen2Samples cube = fmap (makeCandidate cube "test-data/samples" []) + $ filter (not . null) + $ lines [r| strlen_test2.boolector.boolector.out strlen_test2.boolector.boolector.print.out strlen_test2.boolector.good diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -48,11 +48,19 @@ testEach = map testElem $ zip3 [0..] lst elemTests in testCase (name <> " count") (assertEqual "length" (length elemTests) (length lst)) : testEach +safeElem :: Int -> [a] -> Maybe a +safeElem idx lst = case drop idx lst of + [] -> Nothing + (e:_) -> Just e compareBags name gotBag expBag = if gotBag `elem` L.permutations expBag then return () - else let expCnt = length expBag + else mismatchedColl name gotBag expBag + + +mismatchedColl name gotBag expBag = + let expCnt = length expBag gotCnt = length gotBag uGot = L.nub gotBag expUCnt = length $ L.nub expBag @@ -116,5 +124,32 @@ sugarTestEq name cube sample expVal test = - let (r,d) = findSugarIn cube sample + let (r,d) = findSugarIn cube (sample cube) in testCase name $ eqTestWithFailInfo d expVal $ test r + + +checkCandidate cube files path subdirs sepSkip nm pm = + testCase (nm <> " candidate") + $ L.find (\c -> and [ nm == candidateFile c + , subdirs == candidateSubdirs c + ]) (files cube) + @?= Just (CandidateFile { candidateDir = path + , candidateSubdirs = subdirs + , candidateFile = nm + , candidatePMatch = pm + , candidateMatchIdx = toEnum + $ let isSep = (`elem` (separators cube)) + sepsAt = L.findIndices isSep nm + fstSep = case L.drop sepSkip sepsAt of + (l:_) -> Just l + [] -> Nothing + lstSep = case reverse sepsAt of + (l:_) -> Just l + [] -> Nothing + ln = length nm + in if null pm + then maybe ln (1+) lstSep + else if null pm + then ln + else maybe ln (+1) fstSep + }) diff --git a/test/TestWildcard.hs b/test/TestWildcard.hs --- a/test/TestWildcard.hs +++ b/test/TestWildcard.hs @@ -22,14 +22,13 @@ testInpPath = "some/path/to/test/samples" -sample1 = fmap (\f -> CandidateFile { candidateDir = testInpPath - , candidateSubdirs = [] - , candidateFile = f }) +sample1 cube = fmap (makeCandidate cube testInpPath []) $ filter (not . null) $ lines [r| foo foo.exp foo.ex +foo.right.exp bar.exp bar. bar-ex @@ -45,7 +44,14 @@ wildcardAssocTests :: [TT.TestTree] wildcardAssocTests = - [ testCase "valid sample" $ 13 @=? length sample1 + [ 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. @@ -57,6 +63,17 @@ , 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 5 length -- foo.ex is an associated name for foo, but removing its @@ -80,69 +97,13 @@ -- 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) $ + (fst $ findSugarIn sugarCube (sample1 sugarCube)) $ let p = (testInpPath ) in - [ - Sweets { rootMatchName = "foo" - , rootBaseName = "foo" - , rootFile = p "foo" - , cubeParams = [] - , expected = - [ Expectation - { expectedFile = p "foo.exp" - , expParamsMatch = [] - , associated = [ ("extern", p "foo.ex") ] - } - ] - } - , Sweets { rootMatchName = "foo.ex" - , rootBaseName = "foo" - , rootFile = p "foo.ex" - , cubeParams = [] - , expected = - [ Expectation - { expectedFile = p "foo.exp" - , expParamsMatch = [] - , associated = [] - } - ] - } - , Sweets { rootMatchName = "bar." - , rootBaseName = "bar" - , rootFile = p "bar." - , cubeParams = [] - , expected = - [ Expectation - { expectedFile = p "bar.exp" - , expParamsMatch = [] - , associated = [ ("extern", p "bar-ex") ] - } - ] - } - , Sweets { rootMatchName = "bar-ex" - , rootBaseName = "bar" - , rootFile = p "bar-ex" - , cubeParams = [] - , expected = - [ Expectation - { expectedFile = p "bar.exp" - , expParamsMatch = [] - , associated = [] - } - ] - } - , Sweets { rootMatchName = "dog.bark" - , rootBaseName = "dog.bark" - , rootFile = p "dog.bark" - , cubeParams = [] - , expected = - [ Expectation - { expectedFile = p "dog.bark-exp" - , expParamsMatch = [] - , associated = [] - } - ] - } + [ 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" ] ] ] @@ -157,6 +118,17 @@ , 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." ] @@ -167,33 +139,10 @@ -- expectedSuffix that is not a known separator , testCase "full results" $ compareBags "default result" - (fst $ findSugarIn sugarCube sample1) $ + (fst $ findSugarIn sugarCube (sample1 sugarCube)) $ let p = (testInpPath ) in - [ - Sweets { rootMatchName = "bar." - , rootBaseName = "bar." - , rootFile = p "bar." - , cubeParams = [] - , expected = - [ Expectation - { expectedFile = p "bar.exp" - , expParamsMatch = [] - , associated = [] - } - ] - } - , Sweets { rootMatchName = "cow.moo" - , rootBaseName = "cow.moo" - , rootFile = p "cow.moo" - , cubeParams = [] - , expected = - [ Expectation - { expectedFile = p "cow.mooexp" - , expParamsMatch = [] - , associated = [ ("extern", p "cow.mooex") ] - } - ] - } + [ sw "bar." "bar." "bar." [ exp "bar.exp" ] + , sw "cow.moo" "cow.moo" "cow.moo" [ expE "cow.mooexp" "cow.mooex" ] ] ] @@ -208,6 +157,17 @@ , 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 4 length -- see notes for default seps tests above @@ -229,57 +189,82 @@ -- 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) $ + (fst $ findSugarIn sugarCube (sample1 sugarCube)) $ let p = (testInpPath ) in - [ - Sweets { rootMatchName = "foo" - , rootBaseName = "foo" - , rootFile = p "foo" - , cubeParams = [] - , expected = - [ Expectation - { expectedFile = p "foo.exp" - , expParamsMatch = [] - , associated = [ ("extern", p "foo.ex") ] - } - ] - } - , Sweets { rootMatchName = "foo.ex" - , rootBaseName = "foo" - , rootFile = p "foo.ex" - , cubeParams = [] - , expected = - [ Expectation - { expectedFile = p "foo.exp" - , expParamsMatch = [] - , associated = [] - } - ] - } - , Sweets { rootMatchName = "bar." - , rootBaseName = "bar" - , rootFile = p "bar." - , cubeParams = [] - , expected = - [ Expectation - { expectedFile = p "bar.exp" - , expParamsMatch = [] - , associated = [ ("extern", p "bar-ex") ] - } - ] + [ 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" ] + ] + ] + + -- 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") ] } - , Sweets { rootMatchName = "bar-ex" - , rootBaseName = "bar" - , rootFile = p "bar-ex" - , cubeParams = [] - , expected = - [ Expectation - { expectedFile = p "bar.exp" - , expParamsMatch = [] - , associated = [] - } - ] + 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 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") + ] ] ] diff --git a/test/internals/test-internals.hs b/test/internals/test-internals.hs --- a/test/internals/test-internals.hs +++ b/test/internals/test-internals.hs @@ -84,7 +84,7 @@ in testGroup "Expected trimming" [ testCase "non-explicit removals" $ pCmpExp (init sample) - (removeNonExplicitMatchingExpectations sample) + (collateExpectations sample) , testCase "supermatch supercedes" $ -- Normally the trimming occurs on Expectations which all have @@ -94,6 +94,9 @@ -- supercede any Expectation that has the same set but fewer, -- as this test checks. This test is not critical to overall -- functionality, but serves to capture behavior. + -- + -- Here, "adding" replaces the first element of sample because it + -- otherwise matches sample but has more parameters. let adding = Expectation { expectedFile = "test.file" , expParamsMatch = @@ -104,10 +107,12 @@ ] , associated = [] } - test l = pCmpExp (adding : (tail $ init sample)) - (removeNonExplicitMatchingExpectations l) - in mapM test (L.permutations $ adding : sample) - >> return () + test l = pCmpExp ((take 2 $ tail $ init sample) + <> [adding] + <> (drop 3 $ init sample) + ) + (collateExpectations l) + in mapM_ test (L.permutations $ adding : sample) , testCase "submatch removed" $ -- This is the inverse of the supermatch: an entry is added @@ -122,10 +127,8 @@ ] , associated = [] } - test l = pCmpExp (init sample) - (removeNonExplicitMatchingExpectations l) - in mapM test (L.permutations $ adding : sample) - >> return () + test l = pCmpExp (init sample) (collateExpectations l) + in mapM_ test (L.permutations $ adding : sample) , testCase "superset and subset distinct" $ -- As a variation of the supermatch and submatch tests, if an @@ -149,16 +152,19 @@ [ ("foo", Explicit "a") , ("cow", Explicit "moo") -- Explicit "moo" here against Assumed "moo" plus two - -- more explicits... this gets removed + -- more explicits above... this gets removed. Note + -- also that this matches the first element of + -- sample, but that element and the adding element + -- above are incompatible, so this will be associated + -- with one or the other, but not both. ] , associated = [] } ] - test l = pCmpExp (take 1 adding <> init sample) - (removeNonExplicitMatchingExpectations l) - in mapM test (L.permutations $ adding <> sample) - >> return () + test l = pCmpExp (take 1 adding <> init sample) (collateExpectations l) + in mapM_ test (L.permutations $ adding <> sample) + , testCase "distinct if different" $ let adding = [ Expectation { expectedFile = "test.file" @@ -170,8 +176,7 @@ , associated = [] } ] - test l = pCmpExp (adding <> init sample) - (removeNonExplicitMatchingExpectations l) + test l = pCmpExp (adding <> init sample) (collateExpectations l) in mapM test (L.permutations $ adding <> sample) >> return ()