{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Syd.Output where

import Control.Arrow (second)
import Control.Exception
import Data.List (sortOn)
import qualified Data.List as L
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as LTB
import qualified Data.Text.Lazy.Builder as Text
import qualified Data.Text.Lazy.IO as LTIO
import qualified Data.Vector as V
import Data.Word
import GHC.Stack
import Safe
import Test.QuickCheck.IO ()
import Test.Syd.Diff
import Test.Syd.OptParse
import Test.Syd.Run
import Test.Syd.SpecDef
import Test.Syd.SpecForest
import Text.Colour
import Text.Printf

printOutputSpecForest :: Settings -> Timed ResultForest -> IO ()
printOutputSpecForest settings results = do
  tc <- deriveTerminalCapababilities settings
  LTIO.putStr $ LTB.toLazyText $ renderResultReport settings tc results

renderResultReport :: Settings -> TerminalCapabilities -> Timed ResultForest -> Text.Builder
renderResultReport settings tc rf =
  mconcat $
    map
      (\line -> renderChunksBuilder tc line <> "\n")
      (outputResultReport settings rf)

outputResultReport :: Settings -> Timed ResultForest -> [[Chunk]]
outputResultReport settings trf =
  let rf = timedValue trf
   in concat
        [ outputTestsHeader,
          outputSpecForest settings 0 (resultForestWidth rf) rf,
          [ [chunk ""],
            [chunk ""]
          ],
          outputFailuresWithHeading settings rf,
          [[chunk ""]],
          outputStats (computeTestSuiteStats settings <$> trf),
          [[chunk ""]],
          if settingProfile settings
            then outputProfilingInfo trf
            else []
        ]

outputFailuresHeader :: [[Chunk]]
outputFailuresHeader = outputHeader "Failures:"

outputFailuresWithHeading :: Settings -> ResultForest -> [[Chunk]]
outputFailuresWithHeading settings rf =
  if shouldExitFail settings rf
    then
      concat
        [ outputFailuresHeader,
          outputFailures settings rf
        ]
    else []

outputStats :: Timed TestSuiteStats -> [[Chunk]]
outputStats timed =
  let TestSuiteStats {..} = timedValue timed
      sumTimeSeconds :: Double
      sumTimeSeconds = fromIntegral testSuiteStatSumTime / 1_000_000_000
      totalTimeSeconds :: Double
      totalTimeSeconds = fromIntegral (timedTime timed) / 1_000_000_000
   in map (padding :) $
        concat
          [ [ [ chunk "Examples:                     ",
                fore green $ chunk (T.pack (show testSuiteStatExamples))
              ]
              | testSuiteStatExamples /= testSuiteStatSuccesses
            ],
            [ [ chunk "Passed:                       ",
                fore green $ chunk (T.pack (show testSuiteStatSuccesses))
              ],
              [ chunk "Failed:                       ",
                ( if testSuiteStatFailures > 0
                    then fore red
                    else fore green
                )
                  $ chunk (T.pack (show testSuiteStatFailures))
              ]
            ],
            [ [ chunk "Flaky:                        ",
                fore red $ chunk (T.pack (show testSuiteStatFlakyTests))
              ]
              | testSuiteStatFlakyTests > 0
            ],
            [ [ chunk "Pending:                      ",
                fore magenta $ chunk (T.pack (show testSuiteStatPending))
              ]
              | testSuiteStatPending > 0
            ],
            [ [ chunk "Sum of test runtimes:",
                fore yellow $ chunk $ T.pack (printf "%13.2f seconds" sumTimeSeconds)
              ],
              [ chunk "Test suite took:     ",
                fore yellow $ chunk $ T.pack (printf "%13.2f seconds" totalTimeSeconds)
              ]
            ]
          ]

outputProfilingInfo :: Timed ResultForest -> [[Chunk]]
outputProfilingInfo Timed {..} =
  map
    ( \(path, nanos) ->
        [ timeChunkFor nanos,
          " ",
          chunk $ T.intercalate "." path
        ]
    )
    ( sortOn
        snd
        ( map
            (second (timedTime . testDefVal))
            (flattenSpecForest timedValue)
        )
    )

outputTestsHeader :: [[Chunk]]
outputTestsHeader = outputHeader "Tests:"

outputHeader :: Text -> [[Chunk]]
outputHeader t =
  [ [fore blue $ chunk t],
    [chunk ""]
  ]

outputSpecForest :: Settings -> Int -> Int -> ResultForest -> [[Chunk]]
outputSpecForest settings level treeWidth = concatMap (outputSpecTree settings level treeWidth)

outputSpecTree :: Settings -> Int -> Int -> ResultTree -> [[Chunk]]
outputSpecTree settings level treeWidth = \case
  SpecifyNode t td -> outputSpecifyLines settings level treeWidth t td
  PendingNode t mr -> outputPendingLines t mr
  DescribeNode t sf -> outputDescribeLine t : map (padding :) (outputSpecForest settings (level + 1) treeWidth sf)
  SubForestNode sf -> outputSpecForest settings level treeWidth sf

outputDescribeLine :: Text -> [Chunk]
outputDescribeLine t = [fore yellow $ chunk t]

outputSpecifyLines :: Settings -> Int -> Int -> Text -> TDef (Timed TestRunReport) -> [[Chunk]]
outputSpecifyLines settings level treeWidth specifyText (TDef timed _) =
  let testRunReport = timedValue timed
      executionTime = timedTime timed
      status = testRunReportStatus settings testRunReport
      TestRunResult {..} = testRunReportReportedRun testRunReport
      withStatusColour = fore (statusColour status)
      pad = (chunk (T.pack (replicate paddingSize ' ')) :)
      timeChunk = timeChunkFor executionTime
   in filter
        (not . null)
        $ concat
          [ [ [ withStatusColour $ chunk (statusCheckMark status),
                withStatusColour $ chunk specifyText,
                spacingChunk level specifyText (chunkText timeChunk) treeWidth,
                timeChunk
              ]
            ],
            map pad $ retriesChunks testRunReport,
            [ pad
                [ chunk "passed for all of ",
                  case w of
                    0 -> fore red $ chunk "0"
                    _ -> fore green $ chunk (T.pack (printf "%d" w)),
                  " inputs."
                ]
              | status == TestPassed,
                w <- maybeToList testRunResultNumTests
            ],
            map pad $ labelsChunks (fromMaybe 1 testRunResultNumTests) testRunResultLabels,
            map pad $ classesChunks testRunResultClasses,
            map pad $ tablesChunks testRunResultTables,
            [pad $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase]
          ]

exampleNrChunk :: Word -> Word -> Chunk
exampleNrChunk total current =
  let digits :: Word
      digits = max 2 $ succ $ floor $ logBase 10 $ (fromIntegral :: Word -> Double) total
      formatStr = "%" <> show digits <> "d"
   in chunk $ T.pack $ printf formatStr current

timeChunkFor :: Word64 -> Chunk
timeChunkFor executionTime =
  let t = fromIntegral executionTime / 1_000_000 :: Double -- milliseconds
      executionTimeText = T.pack (printf "%10.2f ms" t)
      withTimingColour =
        if
            | t < 10 -> fore green
            | t < 100 -> fore yellow
            | t < 1_000 -> fore orange
            | t < 10_000 -> fore red
            | otherwise -> fore darkRed
   in withTimingColour $ chunk executionTimeText

retriesChunks :: TestRunReport -> [[Chunk]]
retriesChunks testRunReport =
  case testRunReportRetries testRunReport of
    Nothing -> []
    Just retries ->
      let flaky = testRunReportWasFlaky testRunReport
          mMessage = case testRunReportFlakinessMode testRunReport of
            MayBeFlaky mmesg -> mmesg
            MayNotBeFlaky -> Nothing
       in if flaky
            then
              concat
                [ [["Retries: ", chunk (T.pack (show retries)), fore red " !!! FLAKY !!!"]],
                  [[fore magenta $ chunk $ T.pack message] | message <- maybeToList mMessage]
                ]
            else [["Retries: ", chunk (T.pack (show retries)), " (does not look flaky)"]]

labelsChunks :: Word -> Maybe (Map [String] Int) -> [[Chunk]]
labelsChunks _ Nothing = []
labelsChunks totalCount (Just labels)
  | M.null labels = []
  | map fst (M.toList labels) == [[]] = []
  | otherwise =
      [chunk "Labels"]
        : map
          ( pad
              . ( \(ss, i) ->
                    [ chunk
                        ( T.pack
                            ( printf
                                "%5.2f%% %s"
                                (100 * fromIntegral i / fromIntegral totalCount :: Double)
                                (commaList (map show ss))
                            )
                        )
                    ]
                )
          )
          (M.toList labels)
  where
    pad = (chunk (T.pack (replicate paddingSize ' ')) :)

classesChunks :: Maybe (Map String Int) -> [[Chunk]]
classesChunks Nothing = []
classesChunks (Just classes)
  | M.null classes = []
  | otherwise =
      [chunk "Classes"]
        : map
          ( pad
              . ( \(s, i) ->
                    [ chunk
                        ( T.pack
                            ( printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s
                            )
                        )
                    ]
                )
          )
          (M.toList classes)
  where
    pad = (chunk (T.pack (replicate paddingSize ' ')) :)
    total = sum $ map snd $ M.toList classes

tablesChunks :: Maybe (Map String (Map String Int)) -> [[Chunk]]
tablesChunks Nothing = []
tablesChunks (Just tables) = concatMap (uncurry goTable) $ M.toList tables
  where
    goTable :: String -> Map String Int -> [[Chunk]]
    goTable tableName percentages =
      [chunk " "]
        : [chunk (T.pack tableName)]
        : map
          ( pad
              . ( \(s, i) ->
                    [ chunk
                        ( T.pack
                            ( printf "%5.2f%% %s" (100 * fromIntegral i / fromIntegral total :: Double) s
                            )
                        )
                    ]
                )
          )
          (M.toList percentages)
      where
        pad = (chunk (T.pack (replicate paddingSize ' ')) :)
        total = sum $ map snd $ M.toList percentages

outputPendingLines :: Text -> Maybe Text -> [[Chunk]]
outputPendingLines specifyText mReason =
  filter
    (not . null)
    [ [fore magenta $ chunk specifyText],
      case mReason of
        Nothing -> []
        Just reason -> [padding, chunk reason]
    ]

outputFailureLabels :: Maybe (Map [String] Int) -> [[Chunk]]
outputFailureLabels Nothing = []
outputFailureLabels (Just labels)
  | labels == M.singleton [] 1 = []
  | otherwise = [["Labels: ", chunk (T.pack (commaList (map show (concat $ M.keys labels))))]]

commaList :: [String] -> String
commaList [] = []
commaList [s] = s
commaList (s1 : rest) = s1 ++ ", " ++ commaList rest

outputFailureClasses :: Maybe (Map String Int) -> [[Chunk]]
outputFailureClasses Nothing = []
outputFailureClasses (Just classes)
  | M.null classes = []
  | otherwise = [["Class: ", chunk (T.pack (commaList (M.keys classes)))]]

outputGoldenCase :: GoldenCase -> [Chunk]
outputGoldenCase = \case
  GoldenNotFound -> [fore red $ chunk "Golden output not found"]
  GoldenStarted -> [fore cyan $ chunk "Golden output created"]
  GoldenReset -> [fore cyan $ chunk "Golden output reset"]

-- The chunk for spacing between the description and the timing
--
-- initial padding | checkmark | description | THIS CHUNK | execution time
spacingChunk :: Int -> Text -> Text -> Int -> Chunk
spacingChunk level descriptionText executionTimeText treeWidth = chunk $ T.pack $ replicate paddingWidth ' '
  where
    paddingWidth =
      let preferredMaxWidth = 80
          checkmarkWidth = 2
          minimumSpacing = 1
          actualDescriptionWidth = T.length descriptionText
          actualTimingWidth = T.length executionTimeText
          totalNecessaryWidth = treeWidth + checkmarkWidth + minimumSpacing + actualTimingWidth -- All timings are the same width
          actualMaxWidth = max totalNecessaryWidth preferredMaxWidth
       in actualMaxWidth - paddingSize * level - actualTimingWidth - actualDescriptionWidth

outputFailures :: Settings -> ResultForest -> [[Chunk]]
outputFailures settings rf =
  let failures = filter (testRunReportFailed settings . timedValue . testDefVal . snd) $ flattenSpecForest rf
      nbDigitsInFailureCount :: Int
      nbDigitsInFailureCount = floor (logBase 10 (L.genericLength failures) :: Double)
      padFailureDetails = (chunk (T.pack (replicate (nbDigitsInFailureCount + 4) ' ')) :)
   in map (padding :) $
        filter (not . null) $
          concat $
            indexed failures $ \w (ts, TDef timed cs) ->
              let testRunReport = timedValue timed
                  status = testRunReportStatus settings testRunReport
                  TestRunResult {..} = testRunReportReportedRun testRunReport
               in concat
                    [ [ [ fore cyan $
                            chunk $
                              T.pack $
                                replicate 2 ' '
                                  ++ case headMay $ getCallStack cs of
                                    Nothing -> "Unknown location"
                                    Just (_, SrcLoc {..}) ->
                                      concat
                                        [ srcLocFile,
                                          ":",
                                          show srcLocStartLine
                                        ]
                        ],
                        map
                          (fore (statusColour status))
                          [ chunk $ statusCheckMark status,
                            chunk $ T.pack (printf ("%" ++ show nbDigitsInFailureCount ++ "d ") w),
                            chunk $ T.intercalate "." ts
                          ]
                      ],
                      map padFailureDetails $ retriesChunks testRunReport,
                      map (padFailureDetails . (: []) . chunk . T.pack) $
                        case (testRunResultNumTests, testRunResultNumShrinks) of
                          (Nothing, _) -> []
                          (Just numTests, Nothing) -> [printf "Failed after %d tests" numTests]
                          (Just numTests, Just 0) -> [printf "Failed after %d tests" numTests]
                          (Just numTests, Just numShrinks) -> [printf "Failed after %d tests and %d shrinks" numTests numShrinks],
                      map (padFailureDetails . (\c -> [chunk "Generated: ", c]) . fore yellow . chunk . T.pack) testRunResultFailingInputs,
                      map padFailureDetails $ outputFailureLabels testRunResultLabels,
                      map padFailureDetails $ outputFailureClasses testRunResultClasses,
                      map padFailureDetails $ maybe [] outputSomeException testRunResultException,
                      [padFailureDetails $ outputGoldenCase gc | gc <- maybeToList testRunResultGoldenCase],
                      concat [map padFailureDetails $ stringChunks ei | ei <- maybeToList testRunResultExtraInfo],
                      [[chunk ""]]
                    ]

outputSomeException :: SomeException -> [[Chunk]]
outputSomeException outerException =
  case fromException outerException :: Maybe Contextual of
    Just (Contextual innerException s) -> outputSomeException (SomeException innerException) ++ stringChunks s
    Nothing ->
      case fromException outerException :: Maybe Assertion of
        Just a -> outputAssertion a
        Nothing -> stringChunks $ displayException outerException

outputAssertion :: Assertion -> [[Chunk]]
outputAssertion = \case
  NotEqualButShouldHaveBeenEqual actual expected -> outputEqualityAssertionFailed actual expected
  EqualButShouldNotHaveBeenEqual actual notExpected -> outputNotEqualAssertionFailed actual notExpected
  PredicateFailedButShouldHaveSucceeded actual mName -> outputPredicateSuccessAssertionFailed actual mName
  PredicateSucceededButShouldHaveFailed actual mName -> outputPredicateFailAssertionFailed actual mName
  ExpectationFailed s -> stringChunks s
  Context a' context -> outputAssertion a' ++ stringChunks context

-- | Split a list of 'Chunk's into lines of [Chunks].
--
-- This is rather complicated because chunks may contain newlines, in which
-- case they need to be split into two chunks on separate lines but with the
-- same colour information.
-- However, separate chunks are not necessarily on separate lines because there
-- may not be a newline inbetween.
splitChunksIntoLines :: [Chunk] -> [[Chunk]]
splitChunksIntoLines =
  -- We maintain a list of 'currently traversing lines'.
  -- These are already split into newlines and therefore definitely belong on separate lines.
  -- We still need to keep the last of the current line though, because it
  -- does not end in a newline and should therefore not necessarily belong on
  -- a separate line by itself.
  go ([] :| []) -- Start with an empty current line.
  where
    -- CurrentlyTraversingLines -> ChunksToStillSplit -> SplitChunks
    go :: NonEmpty [Chunk] -> [Chunk] -> [[Chunk]]
    go cls cs = case NE.uncons cls of
      (currentLine, mRest) -> case mRest of
        -- If there's only one current line, that's the last one of the currently traversing lines.
        -- We split the next chunk into lines and append the first line of that to the current line.
        Nothing -> case cs of
          -- If there is only one current line, and no more chunks, it's the last line.
          [] -> [currentLine]
          -- If there are chunks left, split the first one into lines.
          (c : rest) -> case T.splitOn "\n" (chunkText c) of
            -- Should not happen, but would be fine, just skip this chunk
            [] -> go cls rest
            -- If the chunk had more than one lines
            (l : ls) -> case NE.nonEmpty ls of
              -- If there was only one line in the chunk, we continue with the
              -- same current line onto the rest of the chunks
              Nothing -> go ((currentLine <> [c {chunkText = l}]) :| []) rest
              -- If there was more than one line in that chunk, that line is now considered finished.
              -- We then make all the lines of this new chunk the new current lines, one chunk per line.
              Just ne -> (currentLine <> [c {chunkText = l}]) : go (NE.map (\l' -> [c {chunkText = l'}]) ne) rest
        -- If there is more than one current line, all but the last one are considered finished.
        -- We skip them one by one.
        Just ne -> currentLine : go ne cs

outputEqualityAssertionFailed :: String -> String -> [[Chunk]]
outputEqualityAssertionFailed actual expected =
  let diff = V.toList $ getTextDiff (T.pack actual) (T.pack expected)
      -- Add a header to a list of lines of chunks
      chunksLinesWithHeader :: Chunk -> [[Chunk]] -> [[Chunk]]
      chunksLinesWithHeader header = \case
        -- If there is only one line, put the header on that line.
        [cs] -> [header : cs]
        -- If there is more than one line, put the header on a separate line before
        cs -> [header] : cs

      -- If it's only whitespace, change the background, otherwise change the foreground
      foreOrBack :: Colour -> Text -> Chunk
      foreOrBack c t =
        (if T.null (T.strip t) then back c else fore c)
          (chunk t)
      actualChunks :: [[Chunk]]
      actualChunks = chunksLinesWithHeader (fore blue "Actual:   ") $
        splitChunksIntoLines $
          flip mapMaybe diff $ \case
            First t -> Just $ foreOrBack red t
            Second _ -> Nothing
            Both t _ -> Just $ chunk t
      expectedChunks :: [[Chunk]]
      expectedChunks = chunksLinesWithHeader (fore blue "Expected: ") $
        splitChunksIntoLines $
          flip mapMaybe diff $ \case
            First _ -> Nothing
            Second t -> Just $ foreOrBack green t
            Both t _ -> Just $ chunk t
      inlineDiffChunks :: [[Chunk]]
      inlineDiffChunks =
        if length (lines actual) == 1 && length (lines expected) == 1
          then []
          else chunksLinesWithHeader (fore blue "Inline diff: ") $
            splitChunksIntoLines $
              flip map diff $ \case
                First t -> foreOrBack red t
                Second t -> foreOrBack green t
                Both t _ -> chunk t
   in concat
        [ [[chunk "Expected these values to be equal:"]],
          actualChunks,
          expectedChunks,
          inlineDiffChunks
        ]

outputNotEqualAssertionFailed :: String -> String -> [[Chunk]]
outputNotEqualAssertionFailed actual notExpected =
  if actual == notExpected -- String equality
    then
      [ [chunk "Did not expect equality of the values but both were:"],
        [chunk (T.pack actual)]
      ]
    else
      [ [chunk "These two values were considered equal but should not have been equal:"],
        [fore blue "Actual      : ", chunk (T.pack actual)],
        [fore blue "Not Expected: ", chunk (T.pack notExpected)]
      ]

outputPredicateSuccessAssertionFailed :: String -> Maybe String -> [[Chunk]]
outputPredicateSuccessAssertionFailed actual mName =
  concat
    [ [ [chunk "Predicate failed, but should have succeeded, on this value:"],
        [chunk (T.pack actual)]
      ],
      concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]
    ]

outputPredicateFailAssertionFailed :: String -> Maybe String -> [[Chunk]]
outputPredicateFailAssertionFailed actual mName =
  concat
    [ [ [chunk "Predicate succeeded, but should have failed, on this value:"],
        [chunk (T.pack actual)]
      ],
      concat [map (chunk "Predicate: " :) (stringChunks name) | name <- maybeToList mName]
    ]

mContextChunks :: Maybe String -> [[Chunk]]
mContextChunks = maybe [] stringChunks

stringChunks :: String -> [[Chunk]]
stringChunks s =
  let ls = lines s
   in map ((: []) . chunk . T.pack) ls

indexed :: [a] -> (Word -> a -> b) -> [b]
indexed ls func = zipWith func [1 ..] ls

statusColour :: TestStatus -> Colour
statusColour = \case
  TestPassed -> green
  TestFailed -> red

statusCheckMark :: TestStatus -> Text
statusCheckMark = \case
  TestPassed -> "\10003 "
  TestFailed -> "\10007 "

resultForestWidth :: SpecForest a -> Int
resultForestWidth = goF 0
  where
    goF :: Int -> SpecForest a -> Int
    goF level = maximum . map (goT level)
    goT :: Int -> SpecTree a -> Int
    goT level = \case
      SpecifyNode t _ -> T.length t + level * paddingSize
      PendingNode t _ -> T.length t + level * paddingSize
      DescribeNode _ sdf -> goF (succ level) sdf
      SubForestNode sdf -> goF level sdf

specForestWidth :: SpecDefForest a b c -> Int
specForestWidth = goF 0
  where
    goF :: Int -> SpecDefForest a b c -> Int
    goF level = \case
      [] -> 0
      ts -> maximum $ map (goT level) ts
    goT :: Int -> SpecDefTree a b c -> Int
    goT level = \case
      DefSpecifyNode t _ _ -> T.length t + level * paddingSize
      DefPendingNode t _ -> T.length t + level * paddingSize
      DefDescribeNode _ sdf -> goF (succ level) sdf
      DefSetupNode _ sdf -> goF level sdf
      DefBeforeAllNode _ sdf -> goF level sdf
      DefBeforeAllWithNode _ sdf -> goF level sdf
      DefWrapNode _ sdf -> goF level sdf
      DefAroundAllNode _ sdf -> goF level sdf
      DefAroundAllWithNode _ sdf -> goF level sdf
      DefAfterAllNode _ sdf -> goF level sdf
      DefParallelismNode _ sdf -> goF level sdf
      DefRetriesNode _ sdf -> goF level sdf
      DefRandomisationNode _ sdf -> goF level sdf
      DefFlakinessNode _ sdf -> goF level sdf
      DefExpectationNode _ sdf -> goF level sdf

padding :: Chunk
padding = chunk $ T.replicate paddingSize " "

paddingSize :: Int
paddingSize = 2

orange :: Colour
orange = colour256 166

darkRed :: Colour
darkRed = colour256 160