diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,9 @@ -* 0.8.0.0 ? +* 0.8.1.0 (2011-09-?) + - multi-line diff with pretty-printing + - bugfixes + - build support for GHC 7.2.1 + +* 0.8.0.0 (2011-09-20) - support for `--quiet' option to report failures only - color support - diff support: if an equality assertions fails, HTF shows a diff of diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -1,5 +1,5 @@ Name: HTF -Version: 0.8.0.0 +Version: 0.8.1.0 License: LGPL License-File: LICENSE Copyright: (c) 2005-2011 Stefan Wehr @@ -38,9 +38,9 @@ Executable htfpp Main-Is: HTFPP.hs - Build-Depends: cpphs == 1.11.*, - haskell-src-exts >= 1.8.2 && < 1.10, - base >= 4 && < 5 + Build-Depends: cpphs >= 1.12, + haskell-src-exts == 1.11.*, + base == 4.* Other-Modules: Test.Framework.Preprocessor Test.Framework.HaskellParser @@ -48,17 +48,18 @@ Library Build-Depends: HUnit == 1.2.*, QuickCheck >= 2.3 && < 2.4, - base >= 4 && < 5, + base == 4.*, random == 1.0.*, containers >= 0.3 && < 0.5, process == 1.0.*, directory >= 1.0 && < 1.2, mtl >= 1.1 && < 2.1, - pretty == 1.0.*, + pretty >= 1.0 && < 1.2, Diff >= 0.1.3 && < 0.2, - unix == 2.4.*, + unix >= 2.4 && < 2.6, bytestring == 0.9.*, - regex-compat == 0.93.* + regex-compat >= 0.92 && < 0.96, + haskell-src-exts == 1.11.* Exposed-Modules: Test.Framework Test.Framework.HUnitWrapper diff --git a/Test/Framework/Colors.hs b/Test/Framework/Colors.hs --- a/Test/Framework/Colors.hs +++ b/Test/Framework/Colors.hs @@ -20,7 +20,7 @@ Color(..), PrimColor(..), startColor, withColor, colorize , reset - , firstDiffColor, secondDiffColor, skipDiffColor + , firstDiffColor, secondDiffColor, skipDiffColor, diffColor , warningColor, testStartColor, testOkColor, pendingColor ) where @@ -32,6 +32,7 @@ firstDiffColor = Color Magenta False secondDiffColor = Color Blue False skipDiffColor = Color DarkGray False +diffColor = Color Brown False warningColor = Color Red True testStartColor = Color NoColor True testOkColor = Color Green False diff --git a/Test/Framework/Diff.hs b/Test/Framework/Diff.hs --- a/Test/Framework/Diff.hs +++ b/Test/Framework/Diff.hs @@ -18,17 +18,33 @@ module Test.Framework.Diff ( - DiffConfig(..), noColorsDiffConfig, coloredDiffConfig, showDiff + DiffConfig(..), noColorsDiffConfig, coloredDiffConfig , defaultTerminalDiffConfig, defaultNoColorsDiffConfig - , diffWithSensibleConfig + , 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) @@ -47,6 +63,7 @@ isMiddle _ = False data DiffConfig = DiffConfig { + -- for single line diffs dc_fromFirstPrefix :: String , dc_fromFirstSuffix :: String , dc_fromSecondPrefix :: String @@ -56,6 +73,11 @@ , 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 @@ -66,9 +88,13 @@ , dc_fromSecondSuffix = "" , dc_fromBothPrefix = "C " , dc_fromBothSuffix = "" - , dc_skipPrefix = "<" - , dc_skipSuffix = ">" + , dc_skipPrefix = "<..." + , dc_skipSuffix = "...>" , dc_sep = "\n" + , dc_lineFromFirstPrefix = "" + , dc_lineFromSecondPrefix = "" + , dc_lineFromFirstSuffix = "" + , dc_lineFromSecondSuffix = "" } coloredDiffConfig :: Color -> Color -> Color -> DiffConfig @@ -79,12 +105,15 @@ , dc_fromSecondSuffix = reset , dc_fromBothPrefix = "" , dc_fromBothSuffix = "" - , dc_skipPrefix = startColor c3 - , dc_skipSuffix = reset + , 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 @@ -94,14 +123,16 @@ contextSize :: Int contextSize = 10 -showDiff :: DiffConfig -> String -> String -> String -showDiff dc s1 s2 = - 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) +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 @@ -117,9 +148,11 @@ (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 + 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 + in dc_fromBothPrefix dc ++ contextStart ++ middle ++ contextEnd ++ + dc_fromBothSuffix dc addPositions [] = [] addPositions (x:[]) = (x, FirstLast) : [] addPositions (x:xs) = (x, First) : addPositions' xs @@ -127,9 +160,243 @@ 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 - return $ showDiff dc s1 s2 + 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 +-} diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -65,6 +65,8 @@ import Control.Exception import Control.Monad import qualified Test.HUnit as HU hiding ( assertFailure ) +import qualified Language.Haskell.Exts.Parser as HE +import qualified Language.Haskell.Exts.Pretty as HE import Test.Framework.TestManager import Test.Framework.TestManagerInternal @@ -124,12 +126,36 @@ equalityFailedMessage :: String -> String -> IO String equalityFailedMessage exp act = - do d <- diffWithSensibleConfig exp act - expected_ <- colorize firstDiffColor "expected:" - but_got_ <- colorize secondDiffColor "but got:" - return ("\n " ++ expected_ ++ " " ++ exp ++ - "\n " ++ but_got_ ++ " " ++ act ++ - "\n diff:\n" ++ d) + do d <- diffWithSensibleConfig expP actP + expected_ <- colorize firstDiffColor "* expected:" + but_got_ <- colorize secondDiffColor "* but got:" + diff_ <- colorize diffColor "* diff:" + return ("\n" ++ expected_ ++ " " ++ withNewline expP ++ + "\n" ++ but_got_ ++ " " ++ withNewline actP ++ + "\n" ++ diff_ ++ " " ++ withNewline d ++ + (if stringEq + then "\nWARNING: strings are equal but actual values differ!" + else "")) + where + withNewline s = + case lines s of + [] -> s + [_] -> s + _ -> '\n':s + (expP, actP, stringEq) = + case (pp exp, pp act) of + (Nothing, _) -> (exp, act, exp == act) + (_, Nothing) -> (exp, act, exp == act) + (Just expP, Just actP) + | expP == actP -> + if exp /= act + then (exp, act, exp == act) + else (expP, actP, True) + | otherwise -> (expP, actP, False) + pp s = + case HE.parseExp s of + HE.ParseOk x -> Just $ HE.prettyPrint x + HE.ParseFailed{} -> Nothing _assertEqual_ :: (Eq a, Show a) => String -> Location -> String -> a -> a -> HU.Assertion diff --git a/Test/Framework/HaskellParser.hs b/Test/Framework/HaskellParser.hs --- a/Test/Framework/HaskellParser.hs +++ b/Test/Framework/HaskellParser.hs @@ -73,8 +73,8 @@ , Parser.ignoreLinePragmas = False , Parser.extensions = Ext.glasgowExts , Parser.fixities = - Fix.baseFixities ++ - Fix.infixr_ 0 ["==>"] + Just (Fix.baseFixities ++ + Fix.infixr_ 0 ["==>"]) } unknownLoc :: Syn.SrcLoc unknownLoc = Syn.SrcLoc originalFileName 0 0