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
        let 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) $ do
                                putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)
                        hPutStr h (toText results)

        let stats = resultStatistics results
        let (_, _, 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 ()