{-# LANGUAGE CPP, ScopedTypeVariables #-}
--
-- Copyright (c) 2011-2022   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

module Test.Framework.Diff (

    DiffConfig(..), diffWithSensibleConfig, diff, main

) where

#ifndef MIN_VERSION_base
#define MIN_VERSION_base(a,b,c) 1
#endif

#if !MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif

import Control.Exception (catch, finally, IOException)
import qualified Data.List as List
import Data.Char
import qualified Data.Algorithm.Diff as D
import Data.Algorithm.DiffOutput
import Test.Framework.Colors

-- for testing
import System.IO
import System.Directory
import System.Exit
import System.Process
import System.Environment (getArgs)
import qualified Data.Text as T

data Pos = First | Middle | Last | FirstLast
         deriving (Eq)

isLast :: Pos -> Bool
isLast Last = True
isLast FirstLast = True
isLast _ = False

isFirst :: Pos -> Bool
isFirst First = True
isFirst FirstLast = True
isFirst _ = False

data DiffConfig = DiffConfig {
    -- for single line diffs
      dc_fromFirst :: String -> ColorString
    , dc_fromSecond :: String -> ColorString
    , dc_fromBoth :: String -> ColorString
    , dc_sep :: ColorString
    , dc_skip :: String -> ColorString
    -- for multi-line diffs
    , dc_lineFromFirst :: String -> ColorString
    , dc_lineFromSecond :: String -> ColorString
    }

mkDefaultDiffConfig :: Color -> Color -> Color -> Char -> Char -> DiffConfig
mkDefaultDiffConfig c1 c2 c3 f s = DiffConfig {
      dc_fromFirst = \x -> colorize' c1 x (f : " " ++ x)
    , dc_fromSecond = \x -> colorize' c2 x (s : " " ++ x)
    , dc_fromBoth = \x -> noColor' x ("C " ++ x)
    , dc_skip = \x -> colorize' c3 ("..." ++ x ++ "...") ("<..." ++ x ++ "...>")
    , dc_sep = noColor' "" "\n"
    , dc_lineFromFirst = colorize c1
    , dc_lineFromSecond = colorize c2
    }

defaultDiffConfig :: DiffConfig
defaultDiffConfig = mkDefaultDiffConfig firstDiffColor secondDiffColor skipDiffColor 'F' 'S'

contextSize :: Int
contextSize = 10

prepareStringsForDiff :: String -> String -> (String, String, Maybe (String, String))
prepareStringsForDiff s1 s2 =
    case (List.splitAt 1024 s1, List.splitAt 1024 s2) of
      ((start1, rest1@(_:_)), (start2, rest2@(_:_))) -> (start1, start2, Just (rest1, rest2))
      ((start1, []), (start2, _)) -> (start1, start2, Nothing)
      ((start1, _), (start2, [])) -> (start1, start2, Nothing)

singleLineDiff :: DiffConfig -> String -> String -> ColorString
singleLineDiff dc s1 s2 = loop (0, 0) (s1, s2)
    where
      loop :: (Int, Int) -> (String, String) -> ColorString
      loop (skipped1, skipped2) (s1, s2) =
          let (start1, start2, cont) = prepareStringsForDiff s1 s2
          in case singleLineDiff' dc start1 start2 of
               Just cs ->
                   let prefix =
                           if skipped1 == 0 && skipped1 == 0
                           then emptyColorString
                           else dc_skip dc
                                    ("skipped " ++ show skipped1 ++
                                     " chars from first string, "
                                    ++ show skipped2 ++ " chars from second string")
                       suffix =
                           case cont of
                             Nothing -> emptyColorString
                             Just (r1, r2) ->
                                 dc_skip dc
                                     ("skipped " ++ show (length r1) ++
                                      " chars from first string, " ++
                                      show (length r2) ++ " chars from second string")
                   in prefix +++ cs +++ suffix
               Nothing ->
                   case cont of
                     Just (r1, r2) ->
                         loop (skipped1 + length start1, skipped2 + length start2) (r1, r2)
                     Nothing -> emptyColorString

singleLineDiff' :: DiffConfig -> String -> String -> Maybe ColorString
singleLineDiff' dc s1 s2
    | s1 == s2 = Nothing
    | otherwise =
        let groups = D.getGroupedDiff s1 s2
        in Just $
           foldr (\(group, pos) string ->
                      (showDiffGroup pos group) +++
                      (if not (isLast pos) then dc_sep dc else emptyColorString) +++
                      string)
                 emptyColorString (addPositions groups)
    where
      showDiffGroup _ (D.First s) = dc_fromFirst dc s
      showDiffGroup _ (D.Second s) = dc_fromSecond dc s
      showDiffGroup pos (D.Both inBoth _) =
          let showStart = not $ isFirst pos
              showEnd = not $ isLast pos
              (contextStart, ignored, contextEnd) =
                  let (s, rest) = splitAt contextSize inBoth
                      (i, e) = splitAt (length rest - contextSize) rest
                      start = if showStart then s else ""
                      end = if showEnd then e else ""
                      ign = (if showStart then "" else s) ++ i ++
                            (if showEnd then "" else e)
                  in (start, ign, end)
              middle = let n = length ignored
                           replText = "skipped " ++ show n ++ " chars"
                       in if n <= length replText
                          then dc_skip dc ignored
                          else dc_skip dc replText
          in dc_fromBoth dc contextStart +++ middle +++ dc_fromBoth dc contextEnd
      addPositions [] = []
      addPositions (x:[]) = (x, FirstLast) : []
      addPositions (x:xs) = (x, First) : addPositions' xs
      addPositions' [] = []
      addPositions' (x:[]) = (x, Last) : []
      addPositions' (x:xs) = (x, Middle) : addPositions' xs

multiLineDiff :: DiffConfig -> String -> String -> IO ColorString
multiLineDiff cfg left right =
    withTempFiles $ \(fpLeft, hLeft) (fpRight, hRight) ->
        do write hLeft leftForFile
           write hRight rightForFile
           doDiff fpLeft fpRight
    where
      (leftForFile, rightForFile) =
        if lastChar left /= Just '\n' && lastChar right /= Just '\n'
        then (left ++ "\n", right ++ "\n") -- avoid "No newline at end of file" error messages
        else (left, right)
      lastChar s =
        case reverse s of
          [] -> Nothing
          (c:_) -> Just c
      doDiff leftFile rightFile =
          (do (ecode, out, _err) <- readProcessWithExitCode "diff" ["-u", leftFile, rightFile] ""
              case ecode of
                ExitSuccess -> return (format out)
                ExitFailure 1 -> return (format out)
                ExitFailure _i -> return $ multiLineDiffHaskell left right)
             -- if we can't launch diff, use the Haskell code.
             -- We don't write the exception anywhere to not pollute test results.
            `catch` (\(_::IOException) -> return $ multiLineDiffHaskell left right)
      saveRemove fp =
          removeFile fp `catch` (\e -> hPutStrLn stderr (show (e::IOException)))
      withTempFiles action =
          do dir <- getTemporaryDirectory
             left@(fpLeft, _) <- openTempFile dir "HTF-diff-EXPECTED_.txt"
             (do right@(fpRight, _) <- openTempFile dir "HTF-diff-ACTUAL_.txt"
                 action left right `finally` saveRemove fpRight
              `finally` saveRemove fpLeft)
      write h s =
          do hPutStr h s
             hClose h
      format out = unlinesColorString $ map formatLine (lines out)
      formatLine l =
          case l of
            ('<' : _) -> fromFirst l
            ('>' : _) -> fromSecond l
            (c : _)
                 | isDigit c -> case List.span (\c -> c /= 'a' && c /= 'c' && c /= 'd') l of
                                  (left, c:right) -> fromFirst left +++
                                                     noColor [c] +++
                                                     fromSecond right
                                  (left, []) -> noColor left
                 | otherwise -> noColor l
            [] -> noColor l
          where
            fromFirst s = dc_fromFirst cfg s
            fromSecond s = dc_fromSecond cfg s

diff :: DiffConfig -> String -> String -> IO ColorString
diff cfg left right = do
    case (lines left, lines right) of
      ([], []) -> return emptyColorString
      ([], [_]) -> return (singleLineDiff cfg left right)
      ([_], []) -> return (singleLineDiff cfg left right)
      ([_], [_]) -> return (singleLineDiff cfg left right)
      _ -> multiLineDiff cfg left right

diffWithSensibleConfig :: String -> String -> IO ColorString
diffWithSensibleConfig s1 s2 =
    diff defaultDiffConfig s1 s2

{-
Haskell diff, in case the diff tool is not present
-}
multiLineDiffHaskell :: String -> String -> ColorString
multiLineDiffHaskell left right =
    if length left > maxLen || length right > maxLen
    then noColor
             ("Refusing to compute a multiline diff for strings with more than " ++ show maxLen ++
              " chars. Please install the 'diff' tool to get a diff ouput.")
    else noColor $ ppDiff $ D.getGroupedDiff (lines left) (lines right)
    where
      maxLen = 10000

main =
    do args <- getArgs
       (leftFp, rightFp) <-
           case args of
             [x] -> return (x, x)
             [x, y] -> return (x, y)
             _ -> fail ("USAGE: diff FILE1 FILE2")
       left <- readFile leftFp
       right <- readFile rightFp
       diff <- return $ multiLineDiffHaskell left right
       putStr $ T.unpack $ renderColorString diff True

-- Testcases:
--
-- < 12
-- vs.
-- > 1
-- > 2
