{-# 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 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 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 -}