module Test.Chell.Main
  ( defaultMain
  ) where

import           Control.Applicative
import           Control.Monad (forM, forM_, when)
import           Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Writer as Writer
import           Data.Char (ord)
import           Data.List (isPrefixOf)
import           System.Exit (exitSuccess, exitFailure)
import           System.IO (hPutStr, hPutStrLn, hIsTerminalDevice, stderr, stdout, withBinaryFile, IOMode(..))
import           System.Random (randomIO)
import           Text.Printf (printf)

import           Options

import           Test.Chell.Output
import           Test.Chell.Types

data MainOptions =
  MainOptions
    { optVerbose :: Bool
    , optXmlReport :: String
    , optJsonReport :: String
    , optTextReport :: String
    , optSeed :: Maybe Int
    , optTimeout :: Maybe Int
    , optColor :: ColorMode
    }

optionType_ColorMode :: OptionType ColorMode
optionType_ColorMode = optionType "ColorMode" ColorModeAuto parseMode showMode
  where
    parseMode s =
        case s of
            "always" -> Right ColorModeAlways
            "never" -> Right ColorModeNever
            "auto" -> Right ColorModeAuto
            _ -> Left (show s ++ " is not in {\"always\", \"never\", \"auto\"}.")
    showMode mode =
        case mode of
            ColorModeAlways -> "always"
            ColorModeNever -> "never"
            ColorModeAuto -> "auto"

instance Options MainOptions
  where
    defineOptions = pure MainOptions
        <*> defineOption optionType_bool
              (\o -> o
                  { optionShortFlags = ['v']
                  , optionLongFlags = ["verbose"]
                  , optionDefault = False
                  , optionDescription = "Print more output."
                  }
              )

        <*> simpleOption "xml-report" ""
                "Write a parsable report to a given path, in XML."
        <*> simpleOption "json-report" ""
                "Write a parsable report to a given path, in JSON."
        <*> simpleOption "text-report" ""
                "Write a human-readable report to a given path."

        <*> simpleOption "seed" Nothing
                "The seed used for random numbers in (for example) quickcheck."

        <*> simpleOption "timeout" Nothing
                "The maximum duration of a test, in milliseconds."

        <*> defineOption optionType_ColorMode
              (\o -> o
                  { optionLongFlags = ["color"]
                  , optionDefault = ColorModeAuto
                  , optionDescription = "Whether to enable color ('always', 'auto', or 'never')."
                  }
              )

-- | A simple default main function, which runs a list of tests and logs
-- statistics to stdout.
defaultMain :: [Suite] -> IO ()
defaultMain suites = runCommand $ \opts args ->
  do
    -- validate/sanitize test options
    seed <-
        case optSeed opts of
            Just s -> return s
            Nothing -> randomIO
    timeout <-
        case optTimeout opts of
            Nothing -> return Nothing
            Just t -> if toInteger t * 1000 > toInteger (maxBound :: Int)
                then
                  do
                    hPutStrLn stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large."
                    return Nothing
                else
                    return (Just t)
    let
        testOptions = defaultTestOptions
            { testOptionSeed = seed
            , testOptionTimeout = timeout
            }

    -- find which tests to run
    let
        allTests = concatMap suiteTests suites
        tests =
            if null args
                then allTests
                else filter (matchesFilter args) allTests

    -- output mode
    output <-
        case optColor opts of
            ColorModeNever -> return (plainOutput (optVerbose opts))
            ColorModeAlways -> return (colorOutput (optVerbose opts))
            ColorModeAuto ->
              do
                isTerm <- hIsTerminalDevice stdout
                return $
                    if isTerm
                        then colorOutput (optVerbose opts)
                        else plainOutput (optVerbose opts)

    -- run tests
    results <- forM tests $ \t ->
      do
        outputStart output t
        result <- runTest t testOptions
        outputResult output t result
        return (t, result)

    -- generate reports
    let
        reports = getReports opts

    forM_ reports $ \(path, fmt, toText) ->
        withBinaryFile path WriteMode $ \h ->
          do
            when (optVerbose opts) $
                putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)
            hPutStr h (toText results)

    let
        stats = resultStatistics results
        (_, _, failed, aborted) = stats
    putStrLn (formatResultStatistics stats)

    if failed == 0 && aborted == 0
        then exitSuccess
        else exitFailure

matchesFilter :: [String] -> Test -> Bool
matchesFilter filters = check
  where
    check t = any (matchName (testName t)) filters
    matchName name f = f == name || isPrefixOf (f ++ ".") name

type Report = [(Test, TestResult)] -> String

getReports :: MainOptions -> [(String, String, Report)]
getReports opts = concat [xml, json, text]
  where
    xml = case optXmlReport opts of
        "" -> []
        path -> [(path, "XML", xmlReport)]
    json = case optJsonReport opts of
        "" -> []
        path -> [(path, "JSON", jsonReport)]
    text = case optTextReport opts of
        "" -> []
        path -> [(path, "text", textReport)]

jsonReport :: [(Test, TestResult)] -> String
jsonReport results = Writer.execWriter writer
  where
    tell = Writer.tell

    writer =
      do
        tell "{\"test-runs\": ["
        commas results tellResult
        tell "]}"

    tellResult (t, result) =
        case result of
            TestPassed notes ->
              do
                tell "{\"test\": \""
                tell (escapeJSON (testName t))
                tell "\", \"result\": \"passed\""
                tellNotes notes
                tell "}"
            TestSkipped ->
              do
                tell "{\"test\": \""
                tell (escapeJSON (testName t))
                tell "\", \"result\": \"skipped\"}"
            TestFailed notes fs ->
              do
                tell "{\"test\": \""
                tell (escapeJSON (testName t))
                tell "\", \"result\": \"failed\", \"failures\": ["
                commas fs $ \f ->
                  do
                    tell "{\"message\": \""
                    tell (escapeJSON (failureMessage f))
                    tell "\""
                    case failureLocation f of
                      Just loc ->
                        do
                          tell ", \"location\": {\"module\": \""
                          tell (escapeJSON (locationModule loc))
                          tell "\", \"file\": \""
                          tell (escapeJSON (locationFile loc))
                          case locationLine loc of
                              Just line ->
                                do
                                  tell "\", \"line\": "
                                  tell (show line)
                              Nothing -> tell "\""
                          tell "}"
                      Nothing -> return ()
                    tell "}"
                tell "]"
                tellNotes notes
                tell "}"
            TestAborted notes msg ->
              do
                tell "{\"test\": \""
                tell (escapeJSON (testName t))
                tell "\", \"result\": \"aborted\", \"abortion\": {\"message\": \""
                tell (escapeJSON msg)
                tell "\"}"
                tellNotes notes
                tell "}"
            _ -> return ()

    escapeJSON =
        concatMap
            (\c ->
                case c of
                    '"' -> "\\\""
                    '\\' -> "\\\\"
                    _ | ord c <= 0x1F -> printf "\\u%04X" (ord c)
                    _ -> [c]
            )

    tellNotes notes =
      do
        tell ", \"notes\": ["
        commas notes $ \(key, value) ->
          do
            tell "{\"key\": \""
            tell (escapeJSON key)
            tell "\", \"value\": \""
            tell (escapeJSON value)
            tell "\"}"
        tell "]"

    commas xs block = State.evalStateT (commaState xs block) False
    commaState xs block = forM_ xs $ \x ->
      do
        let
            tell' = lift . Writer.tell
        needComma <- State.get
        if needComma
            then tell' "\n, "
            else tell' "\n  "
        State.put True
        lift (block x)

xmlReport :: [(Test, TestResult)] -> String
xmlReport results = Writer.execWriter writer
  where
    tell = Writer.tell

    writer =
      do
        tell "<?xml version=\"1.0\" encoding=\"utf8\"?>\n"
        tell "<report xmlns='urn:john-millikin:chell:report:1'>\n"
        mapM_ tellResult results
        tell "</report>"

    tellResult (t, result) =
      case result of
        TestPassed notes ->
          do
            tell "\t<test-run test='"
            tell (escapeXML (testName t))
            tell "' result='passed'>\n"
            tellNotes notes
            tell "\t</test-run>\n"
        TestSkipped ->
          do
            tell "\t<test-run test='"
            tell (escapeXML (testName t))
            tell "' result='skipped'/>\n"
        TestFailed notes fs ->
          do
            tell "\t<test-run test='"
            tell (escapeXML (testName t))
            tell "' result='failed'>\n"
            forM_ fs $ \f ->
              do
                tell "\t\t<failure message='"
                tell (escapeXML (failureMessage f))
                case failureLocation f of
                    Just loc ->
                      do
                        tell "'>\n"
                        tell "\t\t\t<location module='"
                        tell (escapeXML (locationModule loc))
                        tell "' file='"
                        tell (escapeXML (locationFile loc))
                        case locationLine loc of
                            Just line ->
                              do
                                tell "' line='"
                                tell (show line)
                            Nothing -> return ()
                        tell "'/>\n"
                        tell "\t\t</failure>\n"
                    Nothing -> tell "'/>\n"
            tellNotes notes
            tell "\t</test-run>\n"
        TestAborted notes msg ->
          do
            tell "\t<test-run test='"
            tell (escapeXML (testName t))
            tell "' result='aborted'>\n"
            tell "\t\t<abortion message='"
            tell (escapeXML msg)
            tell "'/>\n"
            tellNotes notes
            tell "\t</test-run>\n"
        _ -> return ()

    escapeXML =
        concatMap
            (\c ->
                case c of
                    '&' -> "&amp;"
                    '<' -> "&lt;"
                    '>' -> "&gt;"
                    '"' -> "&quot;"
                    '\'' -> "&apos;"
                    _ -> [c]
            )

    tellNotes notes = forM_ notes $ \(key, value) ->
      do
        tell "\t\t<note key=\""
        tell (escapeXML key)
        tell "\" value=\""
        tell (escapeXML value)
        tell "\"/>\n"

textReport :: [(Test, TestResult)] -> String
textReport results = Writer.execWriter writer
  where
    tell = Writer.tell

    writer =
      do
        forM_ results tellResult
        let stats = resultStatistics results
        tell (formatResultStatistics stats)

    tellResult (t, result) =
        case result of
            TestPassed notes ->
              do
                tell (replicate 70 '=')
                tell "\n"
                tell "PASSED: "
                tell (testName t)
                tell "\n"
                tellNotes notes
                tell "\n\n"
            TestSkipped ->
              do
                tell (replicate 70 '=')
                tell "\n"
                tell "SKIPPED: "
                tell (testName t)
                tell "\n\n"
            TestFailed notes fs ->
              do
                tell (replicate 70 '=')
                tell "\n"
                tell "FAILED: "
                tell (testName t)
                tell "\n"
                tellNotes notes
                tell (replicate 70 '-')
                tell "\n"
                forM_ fs $ \f ->
                  do
                    case failureLocation f of
                        Just loc ->
                          do
                            tell (locationFile loc)
                            case locationLine loc of
                                Just line ->
                                  do
                                    tell ":"
                                    tell (show line)
                                Nothing -> return ()
                            tell "\n"
                        Nothing -> return ()
                    tell (failureMessage f)
                    tell "\n\n"
            TestAborted notes msg ->
              do
                tell (replicate 70 '=')
                tell "\n"
                tell "ABORTED: "
                tell (testName t)
                tell "\n"
                tellNotes notes
                tell (replicate 70 '-')
                tell "\n"
                tell msg
                tell "\n\n"
            _ -> return ()

    tellNotes notes = forM_ notes $ \(key, value) ->
      do
        tell key
        tell "="
        tell value
        tell "\n"

formatResultStatistics :: (Integer, Integer, Integer, Integer) -> String
formatResultStatistics stats = Writer.execWriter writer where
  writer =
    do
      let
          (passed, skipped, failed, aborted) = stats

      if failed == 0 && aborted == 0
          then Writer.tell "PASS: "
          else Writer.tell "FAIL: "

      let
          putNum comma n what = Writer.tell $
              if n == 1
                  then comma ++ "1 test " ++ what
                  else comma ++ show n ++ " tests " ++ what

      let
          total = sum [passed, skipped, failed, aborted]

      putNum "" total "run"
      (putNum ", " passed "passed")
      when (skipped > 0) (putNum ", " skipped "skipped")
      when (failed > 0) (putNum ", " failed "failed")
      when (aborted > 0) (putNum ", " aborted "aborted")

resultStatistics :: [(Test, TestResult)] -> (Integer, Integer, Integer, Integer)
resultStatistics results = State.execState state (0, 0, 0, 0)
  where
    state = forM_ results $ \(_, result) -> case result of
        TestPassed{} ->  State.modify (\(p, s, f, a) -> (p+1, s, f, a))
        TestSkipped{} -> State.modify (\(p, s, f, a) -> (p, s+1, f, a))
        TestFailed{} ->  State.modify (\(p, s, f, a) -> (p, s, f+1, a))
        TestAborted{} -> State.modify (\(p, s, f, a) -> (p, s, f, a+1))
        _ -> return ()