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
data Selector =
Selector {
selectorInners :: HashMap Strict.Text Selector,
selectorTags :: !(Maybe (HashSet Strict.Text))
}
deriving (Eq, Show)
data Filter =
Filter {
filterSuites :: !(HashSet Strict.Text),
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
combineTags :: Maybe (HashSet Strict.Text) -> Maybe (HashSet Strict.Text) ->
Maybe (HashSet Strict.Text)
combineTags Nothing t = t
combineTags t Nothing = t
combineTags (Just a) (Just b)
| HashSet.null a || HashSet.null b = Just $! HashSet.empty
| otherwise = Just $! HashSet.union a b
diffTags :: Maybe (HashSet Strict.Text) -> Maybe (HashSet Strict.Text) ->
Maybe (HashSet Strict.Text)
diffTags Nothing _ = Nothing
diffTags t Nothing = t
diffTags (Just a) (Just b)
| HashSet.null a = Just HashSet.empty
| HashSet.null b = Nothing
| otherwise =
let
diff = HashSet.difference a b
in
if diff == HashSet.empty
then Nothing
else Just $! diff
passFilter :: Filter
passFilter = Filter { filterSuites = HashSet.empty,
filterSelector = HashSet.singleton allSelector,
filterOptions = HashMap.empty }
allSelector :: Selector
allSelector = Selector { selectorInners = HashMap.empty,
selectorTags = Just HashSet.empty }
noOptionsAllSelector :: HashMap OptionMap Selector
noOptionsAllSelector = HashMap.singleton HashMap.empty allSelector
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
if isNothing newTags && HashMap.null newInners
then Nothing
else Just $! s { selectorInners = inners, selectorTags = tags }
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 }
| s1 == allSelector || s2 == allSelector = Just allSelector
| otherwise =
let
combinedTags = combineTags tags1 tags2
newTags = diffTags combinedTags parentTags
newParentTags = combineTags combinedTags parentTags
firstpass :: HashMap Strict.Text Selector ->
Strict.Text -> Selector ->
HashMap Strict.Text Selector
firstpass accum elem inner =
case HashMap.lookup elem inners1 of
Just inner' ->
case tryCombineSelectors newParentTags inner inner' of
Just entry -> HashMap.insert elem entry accum
Nothing -> accum
Nothing -> case reduceSelector newParentTags inner of
Just entry -> HashMap.insert elem entry accum
Nothing -> accum
secondpass :: HashMap Strict.Text Selector ->
Strict.Text -> Selector ->
HashMap Strict.Text Selector
secondpass accum elem inner =
case HashMap.lookup elem accum of
Nothing -> case HashMap.lookup elem inners2 of
Just _ -> accum
Nothing -> case reduceSelector newParentTags inner of
Just entry -> HashMap.insert elem entry accum
Nothing -> accum
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)
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
collectSelectors :: Filter
-> HashMap Strict.Text (HashMap OptionMap (HashSet Selector))
-> 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
suiteSelectors :: [Strict.Text]
-> [Filter]
-> HashMap Strict.Text (HashMap OptionMap Selector)
suiteSelectors allsuites filters
| null filters =
foldl (\suitemap suite -> HashMap.insert suite noOptionsAllSelector
suitemap)
HashMap.empty allsuites
| otherwise =
let
universals = foldr collectUniversals HashMap.empty filters
initMap =
if not (HashMap.null universals)
then foldl (\suitemap suite ->
HashMap.insert suite universals suitemap)
HashMap.empty allsuites
else HashMap.empty
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 }
parseFilter :: String
-> Strict.Text
-> 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)
parseFilterFileContent :: String
-> Strict.Text
-> 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
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)