{-# 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)