content: {-# 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
  