-- -- Copyright (c) 2011 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 import Prelude hiding (catch) import Control.Exception (catch, finally, IOException) import qualified Data.List as List import Data.Algorithm.Diff import Data.Char (isDigit) import Test.QuickCheck import Text.PrettyPrint import Debug.Trace (trace) import Test.Framework.Colors import Test.Framework.TestConfig -- for testing import System.IO import System.Environment import System.Directory import System.IO.Unsafe (unsafePerformIO) 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 showDiffGroup _ (F, s) = dc_fromFirstPrefix dc ++ s ++ dc_fromFirstSuffix dc showDiffGroup _ (S, s) = dc_fromSecondPrefix dc ++ s ++ dc_fromSecondSuffix dc showDiffGroup pos (B, 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 = 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 -}