    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 ()