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