HTF 0.8.0.0 → 0.8.1.0
raw patch · 6 files changed
+336/−36 lines, 6 filesdep ~cpphsdep ~haskell-src-extsdep ~pretty
Dependency ranges changed: cpphs, haskell-src-exts, pretty, regex-compat, unix
Files
- ChangeLog +6/−1
- HTF.cabal +9/−8
- Test/Framework/Colors.hs +2/−1
- Test/Framework/Diff.hs +285/−18
- Test/Framework/HUnitWrapper.hs +32/−6
- Test/Framework/HaskellParser.hs +2/−2
ChangeLog view
@@ -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
HTF.cabal view
@@ -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
Test/Framework/Colors.hs view
@@ -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
Test/Framework/Diff.hs view
@@ -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+-}
Test/Framework/HUnitWrapper.hs view
@@ -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
Test/Framework/HaskellParser.hs view
@@ -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