HTF-0.8.1.0: Test/Framework/Diff.hs
--
-- 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
-}