content: {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  --
  -- Copyright (c) 2009-2022   Stefan Wehr - http://www.stefanwehr.de
  --
  -- This library is free software; you can redistribute it and/or
  -- modify it under the terms of the GNU Lesser General Public
  -- License as published by the Free Software Foundation; either
  -- version 2.1 of the License, or (at your option) any later version.
  --
  -- This library is distributed in the hope that it will be useful,
  -- but WITHOUT ANY WARRANTY; without even the implied warranty of
  -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  -- Lesser General Public License for more details.
  --
  -- You should have received a copy of the GNU Lesser General Public
  -- License along with this library; if not, write to the Free Software
  -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
  --
  
  {- |
  
  This module defines the commandline options of the test driver provided by HTF.
  
  -}
  module Test.Framework.CmdlineOptions (
  
      CmdlineOptions(..), defaultCmdlineOptions, parseTestArgs, helpString,
      testConfigFromCmdlineOptions
  
  ) where
  
  import Test.Framework.TestReporter
  import Test.Framework.TestTypes
  import Test.Framework.History
  import Test.Framework.Utils
  
  #ifndef MIN_VERSION_base
  #define MIN_VERSION_base(a,b,c) 1
  #endif
  #if !MIN_VERSION_base(4,6,0)
  import Prelude hiding ( catch )
  #endif
  import Control.Exception
  
  import Data.Char (toLower)
  import Data.Maybe
  
  import System.IO
  import System.Environment hiding (getEnv)
  import System.Directory
  import System.Console.GetOpt
  import qualified Text.Regex as R
  
  #ifndef mingw32_HOST_OS
  import System.Posix.Terminal
  import System.Posix.IO (stdOutput)
  import System.Posix.Env
  #endif
  
  #ifdef __GLASGOW_HASKELL__
  import GHC.Conc ( numCapabilities )
  #endif
  
  import qualified Data.ByteString as BS
  import Control.Monad
  
  --
  -- CmdlineOptions
  --
  
  -- | Commandline options for running tests.
  data CmdlineOptions = CmdlineOptions {
        opts_quiet :: Bool                -- ^ Be quiet or not.
      , opts_filter :: TestFilter         -- ^ Run only tests matching this filter.
      , opts_help :: Bool                 -- ^ If 'True', display a help message and exit.
      , opts_negated :: [String]          -- ^ Regular expressions matching test names which should /not/ run.
      , opts_threads :: Maybe Int         -- ^ Use @Just i@ for parallel execution with @i@ threads, @Nothing@ for sequential execution.
      , opts_shuffle :: Bool              -- ^ If 'True', shuffle tests when running them in parallel. Default: 'False'
      , opts_machineOutput :: Bool        -- ^ Format output for machines (JSON format) or humans. See 'Test.Framework.JsonOutput' for a definition of the JSON format.
      , opts_machineOutputXml :: Maybe FilePath -- ^ Output file for junit-style XML output. See 'Test.Framework.XmlOutput' for a definition of the XML format.
      , opts_useColors :: Maybe Bool      -- ^ Use @Just b@ to enable/disable use of colors, @Nothing@ infers the use of colors.
      , opts_outputFile :: Maybe FilePath -- ^ The output file, defaults to stdout
      , opts_listTests :: Bool            -- ^ If 'True', lists all tests available and exits.
      , opts_split :: Bool                -- ^ If 'True', each message is sent to a new ouput file (derived by appending an index to 'opts_outputFile').
      , opts_historyFile :: Maybe FilePath -- ^ History file, default: @./.HTF/<ProgramName>.history@
      , opts_failFast :: Bool             -- ^ Fail and terminate test run as soon as the first test fails. Default: 'False'
      , opts_sortByPrevTime :: Bool       -- ^ Sort tests by their previous run times (ascending). Default: 'False'
      , opts_maxPrevTimeMs :: Maybe Milliseconds -- ^ Ignore tests with a runtime greater than given in a previous test run.
      , opts_maxCurTimeMs :: Maybe Milliseconds  -- ^ Abort tests that run more than the given milliseconds.
      , opts_prevFactor :: Maybe Double -- ^ Warn if a test runs more than N times slower than in a previous run.
      , opts_timeoutIsSuccess :: Bool -- ^ Do not regard test timeout as an error.
      , opts_repeat :: Int                 -- ^ Number of times to repeat tests selected on the command line before reporting them as a success.
      }
  
  {- |
  The default 'CmdlineOptions'.
  -}
  defaultCmdlineOptions :: CmdlineOptions
  defaultCmdlineOptions = CmdlineOptions {
        opts_quiet = False
      , opts_filter = const True
      , opts_help = False
      , opts_negated = []
      , opts_threads = Nothing
      , opts_shuffle = False
      , opts_machineOutput = False
      , opts_machineOutputXml = Nothing
      , opts_useColors = Nothing
      , opts_outputFile = Nothing
      , opts_listTests = False
      , opts_split = False
      , opts_historyFile = Nothing
      , opts_failFast = False
      , opts_sortByPrevTime = False
      , opts_maxPrevTimeMs = Nothing
      , opts_maxCurTimeMs = Nothing
      , opts_prevFactor = Nothing
      , opts_timeoutIsSuccess = False
      , opts_repeat = 1
      }
  
  processorCount :: Int
  #ifdef __GLASGOW_HASKELL__
  processorCount = numCapabilities
  #else
  processorCount = 1
  #endif
  
  optionDescriptions :: [OptDescr (CmdlineOptions -> Either String CmdlineOptions)]
  optionDescriptions =
      [ Option ['q']     ["quiet"]
               (NoArg (\o -> Right $ o { opts_quiet = True }))
               "Only display errors."
      , Option ['n']     ["not"]
               (ReqArg (\s o -> Right $ o { opts_negated = s : (opts_negated o) }) "PATTERN")
               "Tests to exclude."
      , Option ['l']     ["list"]
               (NoArg (\o -> Right $ o { opts_listTests = True }))
               "List all matching tests."
      , Option ['j']     ["threads"]
               (OptArg (\ms o -> parseThreads ms >>= \i -> Right $ o { opts_threads = Just i }) "N")
               ("Run N tests in parallel, default N=" ++ show processorCount ++ ".")
      , Option []        ["shuffle"]
               (ReqArg (\s o -> parseBool s >>= \b -> Right $ o { opts_shuffle = b }) "BOOL")
               "Shuffle test order. Default: false"
      , Option ['o']     ["output-file"]
               (ReqArg (\s o -> Right $ o { opts_outputFile = Just s }) "FILE")
               "Name of output file."
      , Option []        ["json"]
               (NoArg (\o -> Right $ o { opts_machineOutput = True }))
               "Output results in machine-readable JSON format (incremental)."
      , Option []        ["xml"]
               (ReqArg (\s o -> Right $ o { opts_machineOutputXml = Just s }) "FILE")
               "Output results in junit-style XML format."
      , Option []        ["split"]
               (NoArg (\o -> Right $ o { opts_split = True }))
               "Splits results in separate files to avoid file locking (requires -o/--output-file)."
      , Option []        ["colors"]
               (ReqArg (\s o -> parseBool s >>= \b -> Right $ o { opts_useColors = Just b }) "BOOL")
               "Use colors or not."
      , Option []        ["history"]
               (ReqArg (\s o -> Right $ o { opts_historyFile = Just s }) "FILE")
               "Path to the history file. Default: ./.HTF/<ProgramName>.history"
      , Option []        ["fail-fast"]
               (NoArg (\o -> Right $ o { opts_failFast = True }))
               "Fail and abort test run as soon as the first test fails."
      , Option []        ["sort-by-prev-time"]
               (NoArg (\o -> Right $ o { opts_sortByPrevTime = True }))
               "Sort tests ascending by their execution of the previous test run (if available). Default: false"
      , Option []        ["max-prev-ms"]
               (ReqArg (\s o -> parseRead "--max-prev-ms" s >>= \(ms::Int) -> Right $ o { opts_maxPrevTimeMs = Just ms }) "MILLISECONDS")
               "Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run."
      , Option []        ["max-cur-ms"]
               (ReqArg (\s o -> parseRead "--max-cur-ms" s >>= \(ms::Int) ->
                                Right $ o { opts_maxCurTimeMs = Just ms }) "MILLISECONDS")
               "Abort a test that runs more than MILLISECONDS."
      , Option []        ["prev-factor"]
               (ReqArg (\s o -> parseRead "--prev-factor" s >>= \(ms::Double) ->
                                Right $ o { opts_prevFactor = Just ms }) "DOUBLE")
               "Abort a test that runs more than DOUBLE times slower than in a previous run."
      , Option []        ["timeout-is-success"]
               (NoArg (\o -> Right $ o { opts_timeoutIsSuccess = True }))
               "Do not regard a test timeout as an error."
      , Option []        ["repeat"]
               (ReqArg (\s o -> parseRead "--repeat" s >>= \(i::Int) ->
                                Right $ o { opts_repeat = i}) "NUMBER")
               "Execute the tests selected on the command line NUMBER times."
      , Option ['h']     ["help"]
               (NoArg (\o -> Right $ o { opts_help = True }))
               "Display this message."
      ]
      where
        parseThreads Nothing = Right processorCount
        parseThreads (Just s) =
            case readM s of
              Just i -> Right i
              Nothing -> Left ("invalid number of threads: " ++ s)
        parseBool s =
            Right $
            if map toLower s `elem` ["1", "true", "yes", "on"] then True else False
        parseRead opt s =
            case readM s of
              Just i -> Right i
              Nothing -> Left ("invalid value for option " ++ opt ++ ": " ++ s)
  
  {- |
  
  Parse commandline arguments into 'CmdlineOptions'. Here is a synopsis
  of the format of the commandline arguments:
  
  > USAGE: COMMAND [OPTION ...] PATTERN ...
  >
  >   where PATTERN is a posix regular expression matching
  >   the names of the tests to run.
  >
  >   -q          --quiet                     Only display errors.
  >   -n PATTERN  --not=PATTERN               Tests to exclude.
  >   -l          --list                      List all matching tests.
  >   -j[N]       --threads[=N]               Run N tests in parallel, default N=1.
  >               --shuffle=BOOL              Shuffle test order. Default: false
  >   -o FILE     --output-file=FILE          Name of output file.
  >               --json                      Output results in machine-readable JSON format (incremental).
  >               --xml=FILE                  Output results in junit-style XML format.
  >               --split                     Splits results in separate files to avoid file locking (requires -o/--output-file).
  >               --colors=BOOL               Use colors or not.
  >               --history=FILE              Path to the history file. Default: ./.HTF/<ProgramName>.history
  >               --fail-fast                 Fail and abort test run as soon as the first test fails.
  >               --sort-by-prev-time         Sort tests ascending by their execution of the previous test run (if available). Default: false
  >               --max-prev-ms=MILLISECONDS  Do not try to execute tests that had a execution time greater than MILLISECONDS in a previous test run.
  >               --max-cur-ms=MILLISECONDS   Abort a test that runs more than MILLISECONDS.
  >               --prev-factor=DOUBLE        Abort a test that runs more than DOUBLE times slower than in a previous run.
  >               --timeout-is-success        Do not regard a test timeout as an error.
  >   -h          --help                      Display this message.
  
  -}
  
  parseTestArgs :: [String] -> Either String CmdlineOptions
  parseTestArgs args =
      case getOpt Permute optionDescriptions args of
        (optTrans, tests, []) ->
            do opts <- foldM (\o f -> f o) defaultCmdlineOptions optTrans
               when (opts_shuffle opts && opts_sortByPrevTime opts) $
                   Left ("Options --shuffle=true and --sort-by-prev-time are in conflict. " ++
                         "Can only use one of both.\n\n" ++
                         usageInfo usageHeader optionDescriptions)
               case (opts_outputFile opts, opts_split opts) of
                 (Nothing, True) -> Left ("Option --split requires -o or --output-file\n\n" ++
                                          usageInfo usageHeader optionDescriptions)
                 _ -> let posStrs = tests
                          negStrs = opts_negated opts
                          pos = map mkRegex posStrs
                          neg = map mkRegex negStrs
                          pred (FlatTest _ path _ _) =
                              let flat = flatName path
                              in if (any (\s -> s `matches` flat) neg)
                                    then False
                                    else null pos || any (\s -> s `matches` flat) pos
                      in Right (opts { opts_filter = pred })
        (_,_,errs) ->
            Left (concat errs ++ usageInfo usageHeader optionDescriptions)
      where
        matches r s = isJust $ R.matchRegex r s
        mkRegex s = R.mkRegexWithOpts s True False
  
  usageHeader :: String
  usageHeader = ("USAGE: COMMAND [OPTION ...] PATTERN ...\n\n" ++
                 "  where PATTERN is a posix regular expression matching\n" ++
                 "  the names of the tests to run.\n")
  
  -- | The string displayed for the @--help@ option.
  helpString :: String
  helpString = usageInfo usageHeader optionDescriptions
  
  --
  -- TestConfig
  --
  
  -- | Turn the 'CmdlineOptions' into a 'TestConfig'.
  testConfigFromCmdlineOptions :: CmdlineOptions -> IO TestConfig
  testConfigFromCmdlineOptions opts =
      do (output, colors) <-
             case (opts_outputFile opts, opts_split opts) of
               (Just fname, True) -> return (TestOutputSplitted fname, False)
               _ -> do (outputHandle, closeOutput, mOutputFd) <- openOutputFile
                       colors <- checkColors mOutputFd
                       return (TestOutputHandle outputHandle closeOutput, colors)
         let threads = opts_threads opts
             reporters = defaultTestReporters (isParallelFromBool $ isJust threads)
                                              (if opts_machineOutput opts then JsonOutput else NoJsonOutput)
                                              (if isJust (opts_machineOutputXml opts) then XmlOutput else NoXmlOutput)
         historyFile <- getHistoryFile
         history <- getHistory historyFile
         return $ TestConfig { tc_quiet = opts_quiet opts
                             , tc_threads = threads
                             , tc_shuffle = opts_shuffle opts
                             , tc_output = output
                             , tc_outputXml = opts_machineOutputXml opts
                             , tc_reporters = reporters
                             , tc_filter = opts_filter opts `mergeFilters` (historicFilter history)
                             , tc_useColors = colors
                             , tc_historyFile = historyFile
                             , tc_history = history
                             , tc_sortByPrevTime = opts_sortByPrevTime opts
                             , tc_failFast = opts_failFast opts
                             , tc_maxSingleTestTime = opts_maxCurTimeMs opts
                             , tc_prevFactor = opts_prevFactor opts
                             , tc_timeoutIsSuccess = opts_timeoutIsSuccess opts
                             , tc_repeat = opts_repeat opts
                             }
      where
  #ifdef mingw32_HOST_OS
        openOutputFile =
            case opts_outputFile opts of
              Nothing -> return (stdout, False, Nothing)
              Just fname ->
                  do f <- openFile fname WriteMode
                     return (f, True, Nothing)
        checkColors mOutputFd =
            case opts_useColors opts of
              Just b -> return b
              Nothing -> return False
  #else
        openOutputFile =
            case opts_outputFile opts of
              Nothing -> return (stdout, False, Just stdOutput)
              Just fname ->
                  do f <- openFile fname WriteMode
                     return (f, True, Nothing)
        checkColors mOutputFd =
            case opts_useColors opts of
              Just b -> return b
              Nothing ->
                  do mterm <- getEnv "TERM"
                     case mterm of
                       Nothing -> return False
                       Just s | map toLower s == "dumb" -> return False
                       _ -> do mx <- getEnv "HTF_NO_COLORS"
                               case mx of
                                 Just s | map toLower s `elem` ["", "1", "y", "yes", "true"] -> return False
                                 _ -> case mOutputFd of
                                        Just fd -> queryTerminal fd
                                        _ -> return False
  #endif
        getHistoryFile =
            case opts_historyFile opts of
              Just fp -> return fp
              Nothing ->
                  do progName <- getProgName
                     let x = if progName == "<interactive>" then "interactive" else progName
                     curDir <- getCurrentDirectory
                     let dir = curDir </> ".HTF"
                     createDirectoryIfMissing False dir
                     return $ dir </> (x ++ ".history")
        getHistory fp =
            do b <- doesFileExist fp
               if not b
               then return emptyTestHistory
               else do bs <- BS.readFile fp
                       case deserializeTestHistory bs of
                         Right history -> return history
                         Left err ->
                             do hPutStrLn stderr ("Error deserializing content of HTF history file " ++ fp ++ ": " ++ err)
                                return emptyTestHistory
                    `catch` (\(e::IOException) ->
                                 do hPutStrLn stderr ("Error reading HTF history file " ++ fp ++ ": " ++ show e)
                                    return emptyTestHistory)
        mergeFilters f1 f2 t =
            f1 t && f2 t
        historicFilter history t =
            case opts_maxPrevTimeMs opts of
              Nothing -> True
              Just ms ->
                  case max (fmap htr_timeMs (findHistoricTestResult (historyKey t) history))
                           (fmap htr_timeMs (findHistoricSuccessfulTestResult (historyKey t) history))
                  of
                    Nothing -> True
                    Just t -> t <= ms
  