HTF-0.10.0.7: Test/Framework/Diff.hs
{-# 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 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 = D.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
-}