{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall -Werror -funbox-strict-fields #-} -- | Sets HUnit-Plus tests can be specified using 'Filter's. These -- are used by "Test.HUnitPlus.Execution" and "Test.HUnitPlus.Main" to -- select which tests are run. Filters can specify tests belonging to -- a certain suite, starting with a certain path, having a certain -- tag, or combinations thereof. -- -- Filters are optimized for the behavior of programs created by the -- 'createMain' function, which runs a test if it matches /any/ of the -- filters specified. There is also a string format for filters, -- which is how filters are specified in testlist files and -- command-line arguments. The format is optimized for simplicity, -- and as such, it is not necessarily possible to describe a given -- "Filter" with a single textual representation of a filter. -- -- The format for filters is as follows: -- -- > [suite][path][tags][options] -- -- Where at least one of the /suite/, /path/, /tags/, or /options/ -- elements are present -- -- The /suite/ element is a comma-separated list of suite names (alphanumeric, -- no spaces), enclosed in brackets ('[' ']'). -- -- The /path/ element is a series of path elements (alphanumeric, no -- spaces), separated by dots ('.'). -- -- The /tags/ element consists of a '@' character, followed by a -- comma-separated list of tag names (alphanumeric, no spaces). -- -- The /options/ element consists of a '?' character, followed by a -- comma-separated list of \"name\"=\"value\" bindings. -- -- The following are examples of textual filters, and their meanings: -- -- * @first.second.third@: Run all tests starting with the path -- @first.second.third@. If there is a test named -- @first.second.third@, it will be run. -- -- * @[unit]@: Run all tests in the suite 'unit'. -- -- * @[unit,stress]@: Run all tests in the suites 'unit' and 'stress' -- -- * @\@parser@: Run all tests with the 'parser' tag -- -- * @\@parser,lexer@: Run all tests with the 'parser' /or/ the 'lexer' tags. -- -- * @backend.codegen\@asm@: Run all tests starting with the path -- @backend.codegen@ with the 'asm' tag. -- -- * @[stress]\@net@: Run all tests in the 'stress' suite with the tag 'net'. -- -- * @[perf,profile]inner.outer@: Run all tests in the 'perf' and -- 'profile' suites that start with the path @inner.outer@. -- -- * @[whitebox]network.protocol\@security@: Run all tests in the -- 'whitebox' suite beginning with the path @network.protocol@ that -- have the 'security' tag. -- -- * @first.second.third?\"var\"=\"val\"@: Run all tests starting with the path -- @first.second.third@, with the option \"var\" set to \"val\". -- -- * @[unit]?\"timeout\"=\"5\"@: Run all tests in the suite 'unit' -- with the option \"timeout\" set to \"\5". -- -- * @[system]?\"timeout\"=\"5\",\"threads\"=\"4\"@: Run all tests in -- the suite 'system' with the option 'timeout' set to '5' and -- 'threads' set to '4'. -- -- * ?\"user\"=\"jeffk\": Run all tests with the 'user' option set to 'jeffk'. -- -- The most common use case of filters is to select a single failing -- test to run, as part of fixing it. In this case, a single filter -- consisting of the path to the test will have this effect. module Test.HUnitPlus.Filter( Selector(..), Filter(..), OptionMap, combineTags, passFilter, allSelector, combineSelectors, suiteSelectors, parseFilter, parseFilterFile, parseFilterFileContent ) where import Control.Exception import Data.Foldable(foldl) import Data.Either import Data.Hashable import Data.HashMap.Strict(HashMap) import Data.Maybe import Data.HashSet(HashSet) import Data.List(sort) import Prelude hiding (foldl, elem) import System.IO.Error import Text.Parsec hiding (try) import Text.Parsec.Text import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Strict import qualified Data.Text.IO as Strict type OptionMap = HashMap Strict.Text Strict.Text -- | A tree-like structure that represents a set of tests within a -- given suite. data Selector = Selector { -- | @Selector@s for subgroups of this one. The entry for each -- path element contains the @Selector@ to be used for that -- group (or test). An empty map actually means 'select all -- tests'. selectorInners :: HashMap Strict.Text Selector, -- | Tags by which to filter all tests. The empty set actually -- means 'run all tests regardless of tags'. 'Nothing' means -- that all tests will be skipped (though this will be -- overridden by any @Selector@s in @selectorInners@. selectorTags :: !(Maybe (HashSet Strict.Text)) } deriving (Eq, Show) -- | Specifies zero or more test suites, to which the given 'Selector' -- is then applied. If no test suites are specified, then the -- 'Selector' applies to all test suites. data Filter = Filter { -- | The test suites to which the 'Selector' applies. The empty -- set actually means 'all suites'. filterSuites :: !(HashSet Strict.Text), -- | The 'Selector' to apply. filterSelector :: !(HashSet Selector), filterOptions :: !(HashMap Strict.Text Strict.Text) } deriving (Eq, Show) instance Ord Selector where compare Selector { selectorInners = inners1, selectorTags = Just tags1 } Selector { selectorInners = inners2, selectorTags = Just tags2 } = let sortedtags1 = sort (HashSet.toList tags1) sortedtags2 = sort (HashSet.toList tags2) sortedinners1 = sort (HashMap.toList inners1) sortedinners2 = sort (HashMap.toList inners2) in case compare sortedtags1 sortedtags2 of EQ -> compare sortedinners1 sortedinners2 out -> out compare Selector { selectorTags = Nothing } Selector { selectorTags = Just _ } = LT compare Selector { selectorTags = Just _ } Selector { selectorTags = Nothing } = GT compare Selector { selectorInners = inners1, selectorTags = Nothing } Selector { selectorInners = inners2, selectorTags = Nothing } = let sortedinners1 = sort (HashMap.toList inners1) sortedinners2 = sort (HashMap.toList inners2) in compare sortedinners1 sortedinners2 instance Hashable Selector where hashWithSalt s Selector { selectorInners = inners, selectorTags = Just tags } = let sortedtags = sort (HashSet.toList tags) sortedinners = sort (HashMap.toList inners) in s `hashWithSalt` sortedinners `hashWithSalt` sortedtags hashWithSalt s Selector { selectorInners = inners, selectorTags = Nothing } = let sortedinners = sort (HashMap.toList inners) in s `hashWithSalt` sortedinners -- | Combine two 'selectorTags' fields into one. This operation represents the -- union of the tests that are selected by the two fields. combineTags :: Maybe (HashSet Strict.Text) -> Maybe (HashSet Strict.Text) -> Maybe (HashSet Strict.Text) -- Nothing means we can't execute, so if the other side says we can, -- we can. combineTags Nothing t = t combineTags t Nothing = t combineTags (Just a) (Just b) -- The empty set means we execute everything, so it absorbs | HashSet.null a || HashSet.null b = Just $! HashSet.empty -- Otherwise, we do set union | otherwise = Just $! HashSet.union a b -- | Take the difference of one set of tags from another. diffTags :: Maybe (HashSet Strict.Text) -> Maybe (HashSet Strict.Text) -> Maybe (HashSet Strict.Text) -- Nothing means we can't execute, so if the other side says we can, -- we can. diffTags Nothing _ = Nothing diffTags t Nothing = t diffTags (Just a) (Just b) | HashSet.null a = Just HashSet.empty | HashSet.null b = Nothing -- Otherwise, we do set union | otherwise = let diff = HashSet.difference a b in if diff == HashSet.empty then Nothing else Just $! diff -- | A 'Filter' that selects all tests in all suites. passFilter :: Filter passFilter = Filter { filterSuites = HashSet.empty, filterSelector = HashSet.singleton allSelector, filterOptions = HashMap.empty } -- | A 'Selector' that selects all tests. allSelector :: Selector allSelector = Selector { selectorInners = HashMap.empty, selectorTags = Just HashSet.empty } noOptionsAllSelector :: HashMap OptionMap Selector noOptionsAllSelector = HashMap.singleton HashMap.empty allSelector -- | Eliminate redundant nested tags from a Selector. reduceSelector :: Maybe (HashSet Strict.Text) -> Selector -> Maybe Selector reduceSelector parentTags s @ Selector { selectorInners = inners, selectorTags = tags } = let newTags = diffTags tags parentTags newParentTags = combineTags parentTags tags newInners = HashMap.mapMaybe (reduceSelector newParentTags) inners in -- This selector goes away if we eliminate all inners and all tags if isNothing newTags && HashMap.null newInners then Nothing else Just $! s { selectorInners = inners, selectorTags = tags } -- | Combine two 'Selector's into a single 'Selector'. combineSelectors :: Selector -> Selector -> Selector combineSelectors selector1 selector2 = let tryCombineSelectors :: Maybe (HashSet Strict.Text) -> Selector -> Selector -> Maybe Selector tryCombineSelectors parentTags s1 @ Selector { selectorInners = inners1, selectorTags = tags1 } s2 @ Selector { selectorInners = inners2, selectorTags = tags2 } -- Short-circuit case for allSelector. | s1 == allSelector || s2 == allSelector = Just allSelector | otherwise = let combinedTags = combineTags tags1 tags2 newTags = diffTags combinedTags parentTags newParentTags = combineTags combinedTags parentTags -- | First pass: pull in everything from inners2. This will -- combine everything that can be combined and attempt to -- reduce the rest. firstpass :: HashMap Strict.Text Selector -> Strict.Text -> Selector -> HashMap Strict.Text Selector firstpass accum elem inner = case HashMap.lookup elem inners1 of -- If it exists in both, try to combine. Just inner' -> case tryCombineSelectors newParentTags inner inner' of -- If we get back an entry, insert it. Just entry -> HashMap.insert elem entry accum -- We might have reduced it to nothing. Nothing -> accum -- Otherwise, attempt to reduce. Nothing -> case reduceSelector newParentTags inner of -- If we get back an entry, insert it. Just entry -> HashMap.insert elem entry accum -- If we reduce it to nothing, leave it out. Nothing -> accum -- | Second pass: pull in everything from inners1. secondpass :: HashMap Strict.Text Selector -> Strict.Text -> Selector -> HashMap Strict.Text Selector secondpass accum elem inner = case HashMap.lookup elem accum of -- If there's nothing there, it means we either had -- nothing, or we combined and reduced to nothing in the -- first pass. Nothing -> case HashMap.lookup elem inners2 of -- If we find an entry in inners2, then we combined -- and reduced to nothing. Just _ -> accum -- Otherwise, try to reduce the entry and insert it Nothing -> case reduceSelector newParentTags inner of Just entry -> HashMap.insert elem entry accum Nothing -> accum -- If there's something already there, it's because we -- combined successfully in the first pass. Just _ -> accum firstPassMap = HashMap.foldlWithKey' firstpass HashMap.empty inners2 newInners = HashMap.foldlWithKey' secondpass firstPassMap inners1 in if isNothing newTags && HashMap.null newInners then Nothing else Just $! Selector { selectorInners = newInners, selectorTags = newTags } in case tryCombineSelectors Nothing selector1 selector2 of Just out -> out Nothing -> error ("Got Nothing back from combineSelectors " ++ show selector1 ++ " " ++ show selector2) -- | Collect all the selectors from filters that apply to all suites. collectUniversals :: Filter -> HashMap OptionMap (HashSet Selector) -> HashMap OptionMap (HashSet Selector) collectUniversals Filter { filterSuites = suites, filterOptions = options, filterSelector = selector } accum | HashSet.null suites = HashMap.insertWith HashSet.union options selector accum | otherwise = accum -- | Build a map from suite names to the selectors that get run on them. collectSelectors :: Filter -- ^ The current filter -> HashMap Strict.Text (HashMap OptionMap (HashSet Selector)) -- ^ The map from suites to sets of selectors that -- run on them. -> HashMap Strict.Text (HashMap OptionMap (HashSet Selector)) collectSelectors Filter { filterSuites = suites, filterOptions = options, filterSelector = selector } suitemap = let foldfun accum suite = HashMap.insertWith (HashMap.unionWith HashSet.union) suite (HashMap.singleton options selector) accum in foldl foldfun suitemap suites -- | Take a list of test suite names and a list of 'Filter's, and -- build a 'HashMap' that says for each test suite, what (combined) -- 'Selector' should be used to select tests. suiteSelectors :: [Strict.Text] -- ^ The names of all test suites. -> [Filter] -- ^ The list of 'Filter's from which to build the map. -> HashMap Strict.Text (HashMap OptionMap Selector) suiteSelectors allsuites filters -- Short-circuit case if we have no filters, we run everything | null filters = foldl (\suitemap suite -> HashMap.insert suite noOptionsAllSelector suitemap) HashMap.empty allsuites | otherwise = let -- First, pull out all the universals universals = foldr collectUniversals HashMap.empty filters -- If we have any universals, then seed the initial map with them, -- otherwise, use the empty map. initMap = if not (HashMap.null universals) then foldl (\suitemap suite -> HashMap.insert suite universals suitemap) HashMap.empty allsuites else HashMap.empty -- Now collect all the suite-specific selectors suiteMap :: HashMap Strict.Text (HashMap OptionMap (HashSet Selector)) suiteMap = foldr collectSelectors initMap filters in HashMap.map (HashMap.map (foldl1 combineSelectors . HashSet.toList)) suiteMap nameParser :: Parser Strict.Text nameParser = do out <- many1 (oneOf ("abcdefghijklmnopqrstuvwxyz" ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-_")) return $! Strict.pack out valueParser :: Parser Strict.Text valueParser = do out <- between (char '\"') (char '\"') (many1 (oneOf ("abcdefghijklmnopqrstuvwxyz" ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ++ "~!@#$%^&*()[]{}<>:;,\'.+=-_?/\\|"))) return $! Strict.pack out optionParser :: Parser (Strict.Text, Strict.Text) optionParser = do key <- valueParser _ <- char '=' val <- valueParser return (key, val) optionsParser :: Parser [(Strict.Text, Strict.Text)] optionsParser = char '?' >> many1 optionParser namesParser :: Parser [Strict.Text] namesParser = sepBy1 nameParser (string ",") pathParser :: Parser [Strict.Text] pathParser = sepBy nameParser (string ".") suitesParser :: Parser [Strict.Text] suitesParser = between (string "[") (string "]") namesParser tagsParser :: Parser [Strict.Text] tagsParser = char '@' >> namesParser filterParser :: Parser ([Strict.Text], [Strict.Text], [Strict.Text], [(Strict.Text, Strict.Text)]) filterParser = do suites <- option [] suitesParser path <- pathParser tagselector <- option [] tagsParser options <- option [] optionsParser return (suites, path, tagselector, options) makeFilter :: ([Strict.Text], [Strict.Text], [Strict.Text], [(Strict.Text, Strict.Text)]) -> Filter makeFilter (suites, path, tags, options) = let withTags = case tags of [] -> allSelector _ -> allSelector { selectorTags = Just $! HashSet.fromList tags } genPath [] = withTags genPath (elem : rest) = let innermap = HashMap.singleton elem $! genPath rest in Selector { selectorInners = innermap, selectorTags = Nothing } withPath = genPath path in Filter { filterSuites = HashSet.fromList suites, filterSelector = HashSet.singleton withPath, filterOptions = HashMap.fromList options } -- | Parse a 'Filter' expression. The format for filter expressions is -- described in the module documentation. parseFilter :: String -- ^ The name of the source. -> Strict.Text -- ^ The input. -> Either Strict.Text Filter parseFilter sourcename input = case parse filterParser sourcename input of Left e -> Left (Strict.pack (show e)) Right res -> Right (makeFilter res) commentParser :: Parser () commentParser = do _ <- char '#' _ <- many (noneOf "\n") return () lineParser :: Parser (Maybe Filter) lineParser = do _ <- many space content <- filterParser _ <- many space optional commentParser case content of ([], [], [], []) -> return Nothing _ -> return (Just $! makeFilter content) -- | Parse content from a testlist file. The file must contain one -- filter per line. Leading and trailing spaces are ignored, as are -- lines that contain no filter. A @\#@ will cause the parser to skip -- the rest of the line. parseFilterFileContent :: String -- ^ The name of the input file. -> Strict.Text -- ^ The file content. -> Either [Strict.Text] [Filter] parseFilterFileContent sourcename input = let inputlines = Strict.lines input results = map (parse lineParser sourcename) inputlines in case partitionEithers results of ([], maybes) -> Right $! catMaybes maybes (errs, _) -> Left $! map (Strict.pack . show) errs -- | Given a 'FilePath', get the contents of the file and parse it as -- a testlist file. parseFilterFile :: FilePath -> IO (Either [Strict.Text] [Filter]) parseFilterFile filename = do input <- try (Strict.readFile filename) case input of Left e | isAlreadyInUseError e -> return (Left [Strict.concat ["Error reading testlist file ", Strict.pack filename, ": File is already in use"]]) | isDoesNotExistError e -> return (Left [Strict.concat ["Error reading testlist file ", Strict.pack filename, ": File does not exist"]]) | isPermissionError e -> return (Left [Strict.concat ["Error reading testlist file ", Strict.pack filename, ": Permission denied"]]) | otherwise -> return (Left [Strict.concat ["Cannot read testlist file ", Strict.pack filename, ": Miscellaneous error"]]) Right contents -> case parseFilterFileContent filename contents of Left errs -> return (Left errs) Right out -> return (Right out)