{-# LANGUAGE CPP #-}
--
-- Copyright (c) 2011, 2012   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(..), noColorsDiffConfig, coloredDiffConfig
  , defaultTerminalDiffConfig, defaultNoColorsDiffConfig
  , diffWithSensibleConfig, diff

) where

#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 Data.Algorithm.Diff hiding (First)
import qualified Data.Algorithm.Diff as D
import Test.Framework.Colors

-- for testing
import System.IO
import System.Directory
import System.Exit
import System.Process

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

isMiddle :: Pos -> Bool
isMiddle Middle = True
isMiddle _ = False

data DiffConfig = DiffConfig {
    -- for single line diffs
      dc_fromFirstPrefix :: String
    , dc_fromFirstSuffix :: String
    , dc_fromSecondPrefix :: String
    , dc_fromSecondSuffix :: String
    , dc_fromBothPrefix :: String
    , dc_fromBothSuffix :: String
    , dc_sep :: String
    , dc_skipPrefix :: String
    , dc_skipSuffix :: String
    -- for multi-line diffs
    , dc_lineFromFirstPrefix :: String
    , dc_lineFromSecondPrefix :: String
    , dc_lineFromFirstSuffix :: String
    , dc_lineFromSecondSuffix :: String
    }

noColorsDiffConfig :: Char -> Char -> DiffConfig
noColorsDiffConfig f s = DiffConfig {
      dc_fromFirstPrefix = f : " "
    , dc_fromFirstSuffix = ""
    , dc_fromSecondPrefix = s : " "
    , dc_fromSecondSuffix = ""
    , dc_fromBothPrefix = "C "
    , dc_fromBothSuffix = ""
    , dc_skipPrefix = "<..."
    , dc_skipSuffix = "...>"
    , dc_sep = "\n"
    , dc_lineFromFirstPrefix = ""
    , dc_lineFromSecondPrefix = ""
    , dc_lineFromFirstSuffix = ""
    , dc_lineFromSecondSuffix = ""
    }

coloredDiffConfig :: Color -> Color -> Color -> DiffConfig
coloredDiffConfig c1 c2 c3 = DiffConfig {
      dc_fromFirstPrefix = startColor c1
    , dc_fromFirstSuffix = reset
    , dc_fromSecondPrefix = startColor c2
    , dc_fromSecondSuffix = reset
    , dc_fromBothPrefix = ""
    , dc_fromBothSuffix = ""
    , dc_skipPrefix = startColor c3 ++ "..."
    , dc_skipSuffix = "..." ++ reset
    , dc_sep = ""
    , dc_lineFromFirstPrefix = startColor c1
    , dc_lineFromSecondPrefix = startColor c2
    , dc_lineFromFirstSuffix = reset
    , dc_lineFromSecondSuffix = reset
    }

defaultTerminalDiffConfig :: DiffConfig
defaultTerminalDiffConfig = coloredDiffConfig firstDiffColor secondDiffColor skipDiffColor

defaultNoColorsDiffConfig :: DiffConfig
defaultNoColorsDiffConfig = noColorsDiffConfig 'F' 'S'

contextSize :: Int
contextSize = 10

singleLineDiff :: DiffConfig -> String -> String -> String
singleLineDiff dc s1 s2
    | s1 == s2 = ""
    | otherwise =
        let groups = getGroupedDiff s1 s2
        in foldr (\(group, pos) string ->
                      (showDiffGroup pos group) ++
                      (if not (isLast pos) then dc_sep dc else "") ++
                      string)
                 "" (addPositions groups)
    where
#if MIN_VERSION_Diff(0,2,0)
      showDiffGroup _ (D.First s) = dc_fromFirstPrefix dc ++ s ++ dc_fromFirstSuffix dc
      showDiffGroup _ (D.Second s) = dc_fromSecondPrefix dc ++ s ++ dc_fromSecondSuffix dc
      showDiffGroup pos (D.Both inBoth _) =
#else
      showDiffGroup _ (D.F, s) = dc_fromFirstPrefix dc ++ s ++ dc_fromFirstSuffix dc
      showDiffGroup _ (D.S, s) = dc_fromSecondPrefix dc ++ s ++ dc_fromSecondSuffix dc
      showDiffGroup pos (D.B, inBoth) =
#endif
          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 = dc_skipPrefix dc ++ "skipped " ++ show n ++ " chars" ++
                                      dc_skipSuffix dc
                       in if n <= length replText then ignored else replText
          in dc_fromBothPrefix dc ++ contextStart ++ middle ++ contextEnd ++
             dc_fromBothSuffix dc
      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 String
multiLineDiff cfg left right =
    withTempFiles $ \(fpLeft, hLeft) (fpRight, hRight) ->
        do write hLeft left
           write hRight right
           doDiff fpLeft fpRight
    where
      doDiff leftFile rightFile =
          do (ecode, out, err) <- readProcessWithExitCode "diff" [leftFile, rightFile] ""
             case ecode of
               ExitSuccess -> return (format out)
               ExitFailure 1 -> return (format out)
               ExitFailure i ->
                   return ("'diff " ++ leftFile ++ " " ++ rightFile ++
                           "' failed with exit code " ++ show i ++
                           ": " ++ show err)
      saveRemove fp =
          removeFile fp `catch` (\e -> hPutStrLn stderr (show (e::IOException)))
      withTempFiles action =
          do dir <- getTemporaryDirectory
             left@(fpLeft, _) <- openTempFile dir "HTF-diff-left.txt"
             (do right@(fpRight, _) <- openTempFile dir "HTF-diff-right.txt"
                 action left right `finally` saveRemove fpRight
              `finally` saveRemove fpLeft)
      write h s =
          do hPutStr h s
             hClose h
      format out = unlines $ 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 ++ [c] ++ fromSecond right
                                  (left, []) -> left
                 | otherwise -> l
          where
            fromFirst s = dc_fromFirstPrefix cfg ++ s ++ dc_fromFirstSuffix cfg
            fromSecond s = dc_fromSecondPrefix cfg ++ s ++ dc_fromSecondSuffix cfg

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

diffWithSensibleConfig :: String -> String -> IO String
diffWithSensibleConfig s1 s2 =
    do b <- useColors
       let dc = if b then defaultTerminalDiffConfig else defaultNoColorsDiffConfig
       diff dc s1 s2

{-
NOTE: This is *nearly* working. Originally, I wanted to implemented a pure Haskell
diff solution. At some point, however, I decided that it would be better to implement
a solution based on the diff tool. For now, I leave the code as it is.

type PrimDiff = [(DI, Char)]
type LineNo = Int

data Line = Line { line_number :: LineNo
                 , line_content :: String {- without trailing \n -}
                 }
            deriving (Show)

data LineRange = LineRange { lr_numbers :: (LineNo, LineNo)
                           , lr_contents :: [String] {- without trailing \n -}
                           }
            deriving (Show)

data Diff a = OnlyInLeft a LineNo
            | OnlyInRight a LineNo
            | InBoth a a
            deriving (Show)

instance Functor Diff where
    fmap f d = case d of
                 OnlyInLeft x n -> OnlyInLeft (f x) n
                 OnlyInRight x n -> OnlyInRight (f x) n
                 InBoth x y -> InBoth (f x) (f y)

multiLineDiff :: DiffConfig -> String -> String -> String
multiLineDiff cfg left right =
    let diff = getDiff left right :: PrimDiff
        diffByLine = List.unfoldr nextLine diff
        diffLines = let (_, _, l) = foldl diffLine (1, 1, []) diffByLine
                    in reverse l
        diffLineRanges = maximize diffLines
    in debug ("diff: " ++ show diff ++
              "\ndiffByLine: " ++ show diffByLine ++
              "\ndiffLines: " ++ show diffLines ++
              "\ndiffLineRanges: " ++ show diffLineRanges) $
       render $ prettyDiffs diffLineRanges
    where
      nextLine :: PrimDiff -> Maybe (PrimDiff, PrimDiff)
      nextLine [] = Nothing
      nextLine diff =
          -- FIXME: add support for \r\n
          case List.span (\d -> d /= (B, '\n')) diff of
            ([], _ : rest) -> nextLine rest
            (l, _ : rest) -> Just (l, rest)
            (l, []) -> Just (l, [])
      diffLine :: (Int, Int, [Diff Line]) -> PrimDiff -> (Int, Int, [Diff Line])
      diffLine (leftLineNo, rightLineNo, l) diff =
          case (\(x, y) -> (reverse x, reverse y)) $
               foldl (\(l, r) d -> case d of
                                     (F, c) -> (c : l, r)
                                     (S, c) -> (l, c : r)
                                     (B, c) -> (c : l, c : r))
                     ([], []) diff
          of ([], rightLine) -> (leftLineNo, rightLineNo + 1,
                                 OnlyInRight (Line rightLineNo rightLine) leftLineNo : l)
             (leftLine, []) -> (leftLineNo + 1, rightLineNo,
                                OnlyInLeft (Line leftLineNo leftLine) rightLineNo : l)
             (leftLine, rightLine)
                 | leftLine /= rightLine ->
                     (leftLineNo + 1, rightLineNo + 1,
                      InBoth (Line leftLineNo leftLine) (Line rightLineNo rightLine) : l)
                 | otherwise ->
                     (leftLineNo + 1, rightLineNo + 1, l)
      maximize :: [Diff Line] -> [Diff LineRange]
      maximize [] = []
      maximize (x : l) = maximize' (fmap (\a -> [a]) x) l
          where
            maximize' (OnlyInLeft xs rightLineNo) (OnlyInLeft y _ : rest) =
                maximize' (OnlyInLeft (y : xs) rightLineNo) rest
            maximize' (OnlyInRight xs leftLineNo) (OnlyInRight y _ : rest) =
                maximize' (OnlyInRight (y : xs) leftLineNo) rest
            maximize' (InBoth xs ys) (InBoth x y : rest) =
                maximize' (InBoth (x:xs) (y:ys)) rest
            maximize' acc rest = fmap mkLineRange acc : maximize rest
            mkLineRange :: [Line] -> LineRange
            mkLineRange [] = error ("multilineDiff: cannot convert an empty list of lines " ++
                                    "into a LineRange")
            mkLineRange r@(Line lastLineNo _ : _) =
                case reverse r of
                  l@(Line firstLineNo _ : _) -> LineRange (firstLineNo, lastLineNo)
                                                          (map line_content l)

prettyDiffs :: [Diff LineRange] -> Doc
prettyDiffs [] = empty
prettyDiffs (d : rest) = prettyDiff d $$ prettyDiffs rest
    where
      prettyDiff (OnlyInLeft inLeft lineNoRight) =
          prettyRange (lr_numbers inLeft) <> char 'd' <> int lineNoRight $$
          prettyLines '<' (lr_contents inLeft)
      prettyDiff (OnlyInRight inRight lineNoLeft) =
          int lineNoLeft <> char 'a' <> prettyRange (lr_numbers inRight) $$
          prettyLines '>' (lr_contents inRight)
      prettyDiff (InBoth inLeft inRight) =
          prettyRange (lr_numbers inLeft) <> char 'c' <> prettyRange (lr_numbers inRight) $$
          prettyLines '<' (lr_contents inLeft) $$
          text "---" $$
          prettyLines '>' (lr_contents inRight)
      prettyRange (start, end) =
          if start == end then int start else int start <> comma <> int end
      prettyLines start lines =
          vcat (map (\l -> char start <+> text l) lines)

--
-- Tests for diff
--

prop_diffOk :: DiffInput -> Bool
prop_diffOk inp =
    multiLineDiff cfg (di_left inp) (di_right inp) ==
    unsafePerformIO (runDiff (di_left inp) (di_right inp))
    where
      cfg = noColorsDiffConfig 'l' 'r'
      runDiff left right =
          do leftFile <- writeTemp left
             rightFile <- writeTemp right
             (ecode, out, err) <-
                 readProcessWithExitCode "diff" [leftFile, rightFile] ""
             -- putStrLn ("OUT:\n" ++ out)
             -- putStrLn ("ERR:\n" ++ err)
             -- putStrLn ("ECODE:\n" ++ show ecode)
             case ecode of
               ExitSuccess -> return out
               ExitFailure 1 -> return out
               ExitFailure i -> error ("'diff " ++ leftFile ++ " " ++ rightFile ++
                                       "' failed with exit code " ++ show i ++
                                       ": " ++ show err)
      writeTemp s =
          do dir <- getTemporaryDirectory
             (fp, h) <- openTempFile dir "HTF-diff.txt"
             hPutStr h s
             hClose h
             return fp

data DiffInput = DiffInput { di_left :: String, di_right :: String }
               deriving (Show)

leftDiffInput = unlines ["1", "2", "3", "4", "", "5", "6", "7"]

instance Arbitrary DiffInput where
    arbitrary =
        do let leftLines = lines leftDiffInput
           rightLinesLines <- mapM modifyLine (leftLines ++ [""])
           return $ DiffInput (unlines leftLines)
                              (unlines (concat rightLinesLines))
      where
        randomString =
            do c <- (elements (['a'..'z']))
               return [c]
        modifyLine :: String -> Gen [String]
        modifyLine str =
            do prefixLen <- frequency [(20-i, return i) | i <- [0..5]]
               prefix <- mapM (\_ -> randomString) [1..prefixLen]
               frequency [ (5, return (prefix ++ [str]))
                         , (3, return (prefix ++ ["XXX" ++ str]))
                         , (2, return prefix)
                         , (2, return [str])]

debug = trace
-- debug _ x = x

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 $ multiLineDiff defaultTerminalDiffConfig left right
       putStr diff

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