diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,47 @@ +# 1.0.2 + + - Output correct format when an input file is empty, e.g. `@@ --0,0 +1,3 @@`. + +# 1.0.1.1 + + - Require `base >= 4.11` (GHC 8.4). + +# 1.0 + + - Add Unix diff style annotations to output of `prettyContextDiff`, + e.g `@@ -1,5 +1,4 @@`. This required three changes to the + signature of `getContextDiff` due to the addition of a wrapper type + `Numbered`, which enumerates the elements of the input list. + + - Signature change 1: The element pretty printer type changes from + `(a -> Doc)` to `(Numbered a -> Doc)`. An unnumber function is + provided so that the old behavior can be obtained by changing that + argument from `pretty` to `(pretty . unnumber)` + + - Signature change 2: The result type of getContextDiff changes from + `ContextDiff a` to `ContextDiff (Numbered a)`. A function + `unNumberContextDiff` is provided to convert the result back to + the old type. + + - Signature change 3: the context argument is now `Maybe Int` rather + than `Int`, reflecting the change made to `getContextDiffNew` in 0.5. + + - A `prettyContextDiffOld` function is provided to get the old + style output. + + - The old broken version of getContextDiffOld is removed. + + - Document the behavior of `groupBy'`. + +# 0.5 + + - Bring space complexity down to D^2 (Bodigrim). + - Add `Bifunctor` instance (Jonathan King). Requires `base` >= 4.8. + - Fix for the grouped context diff. It was omitting all trailing contexts. + - Allow unlimited number of context elements (`getContextDiffNew`). + +# 0.4 + + - Generalize `Diff a` to `PolyDiff a b`. + `Diff` has been replaced with a specialized synonym `type Diff a = PolyDiff a a`, + but it's still not backward compatible if you imported `Diff(..)`. diff --git a/Data/Algorithm/Diff.hs b/Data/Algorithm/Diff.hs deleted file mode 100644 --- a/Data/Algorithm/Diff.hs +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Algorithm.Diff --- Copyright : (c) Sterling Clover 2008 --- License : BSD 3 Clause --- Maintainer : s.clover@gmail.com --- Stability : experimental --- Portability : portable --- --- This is an implementation of the O(ND) diff algorithm as described in --- \"An O(ND) Difference Algorithm and Its Variations (1986)\" --- . It is O(mn) in space. --- The algorithm is the same one used by standared Unix diff. --- The assumption is that users of this library will want to diff over --- interesting things or peform interesting tasks with the results --- (given that, otherwise, they would simply use the standard Unix diff --- utility). Thus no attempt is made to present a fancier API to aid --- in doing standard and uninteresting things with the results. ------------------------------------------------------------------------------ - -module Data.Algorithm.Diff (DI(..), getDiff, getGroupedDiff) where -import Data.Array -import Data.List - --- | Difference Indicator. A value is either from the First list, the Second --- or from Both. -data DI = F | S | B deriving (Show, Eq) - -data DL = DL {poi::Int, poj::Int, path::[DI]} deriving (Show, Eq) - -instance Ord DL where x <= y = poi x <= poi y - -canDiag :: (Eq a) => [a] -> [a] -> Int -> Int -> (Int, Int) -> Bool -canDiag as bs lena lenb = \(i,j) -> - if i < lena && j < lenb then arAs ! i == arBs ! j else False - where arAs = listArray (0,lena - 1) as - arBs = listArray (0,lenb - 1) bs - -chunk :: Int -> [a] -> [[a]] -chunk x = unfoldr (\a -> case splitAt x a of ([],[]) -> Nothing; a' -> Just a') - -dstep :: ((Int,Int)->Bool) -> [DL] -> [DL] -dstep cd dls = map maximum $ [hd]:(chunk 2 rst) - where (hd:rst) = concatMap extend dls - extend dl = let pdl = path dl - in [addsnake cd $ dl {poi=poi dl + 1, path=(F : pdl)}, - addsnake cd $ dl {poj=poj dl + 1, path=(S : pdl)}] - -addsnake :: ((Int,Int)->Bool) -> DL -> DL -addsnake cd dl - | cd (pi, pj) = addsnake cd $ - dl {poi = pi + 1, poj = pj + 1, path=(B : path dl)} - | otherwise = dl - where pi = poi dl; pj = poj dl - -lcs :: (Eq a) => [a] -> [a] -> [DI] -lcs as bs = path . head . dropWhile (\dl -> poi dl /= lena || poj dl /= lenb) . - concat . iterate (dstep cd) . (:[]) . addsnake cd $ - DL {poi=0,poj=0,path=[]} - where cd = canDiag as bs lena lenb - lena = length as; lenb = length bs - --- | Takes two lists and returns a list indicating the differences --- between them. -getDiff :: (Eq t) => [t] -> [t] -> [(DI, t)] -getDiff a b = markup a b . reverse $ lcs a b - where markup (x:xs) ys (F:ds) = (F, x) : markup xs ys ds - markup xs (y:ys) (S:ds) = (S, y) : markup xs ys ds - markup (x:xs) (_:ys) (B:ds) = (B, x) : markup xs ys ds - markup _ _ _ = [] - --- | Takes two lists and returns a list indicating the differences --- between them, grouped into chunks. -getGroupedDiff :: (Eq t) => [t] -> [t] -> [(DI, [t])] -getGroupedDiff a b = map go . groupBy (\x y -> fst x == fst y) $ getDiff a b - where go ((d,x) : xs) = (d, x : map snd xs) diff --git a/Diff.cabal b/Diff.cabal --- a/Diff.cabal +++ b/Diff.cabal @@ -1,23 +1,63 @@ +Cabal-Version: 1.18 name: Diff -version: 0.1.2 -synopsis: O(ND) diff algorithm in haskell. -description: Basic implementation of the standard diff algorithm. +version: 1.0.2 +synopsis: Diff algorithm in pure Haskell +description: Implementation of the standard diff algorithm in Haskell. + . + Time complexity is O(ND) (input length * number of differences). + Space complexity is O(D^2). Includes utilities for pretty printing. category: Algorithms +homepage: https://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.4.6927 license: BSD3 license-file: LICENSE author: Sterling Clover -maintainer: s.clover@gmail.com -Tested-With: GHC == 6.8.2 +maintainer: David Fox Build-Type: Simple -build-Depends: base -Cabal-Version: >= 1.2 -flag small-base +tested-with: + GHC == 9.12.0 + GHC == 9.10.1 + GHC == 9.8.2 + GHC == 9.6.6 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 +extra-doc-files: CHANGELOG.md + library - if flag(small-base) - build-depends: base >= 3, array - else - build-depends: base < 3 - exposed-modules: Data.Algorithm.Diff - ghc-options: -Wall + default-language: Haskell2010 + build-depends: + base >= 4.11 && <= 6 + , array + , pretty >= 1.1 + hs-source-dirs: src + exposed-modules: + Data.Algorithm.Diff, + Data.Algorithm.DiffOutput + Data.Algorithm.DiffContext + ghc-options: -Wall -funbox-strict-fields + +source-repository head + type: git + location: https://github.com/seereason/Diff + +test-suite diff-tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + build-depends: + Diff + , base >= 3 && <= 6 + , array + , pretty + , directory + , process + , QuickCheck + , test-framework + , test-framework-quickcheck2 diff --git a/src/Data/Algorithm/Diff.hs b/src/Data/Algorithm/Diff.hs new file mode 100644 --- /dev/null +++ b/src/Data/Algorithm/Diff.hs @@ -0,0 +1,137 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Algorithm.Diff +-- Copyright : (c) Sterling Clover 2008-2011, Kevin Charter 2011 +-- License : BSD 3 Clause +-- Maintainer : s.clover@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This is an implementation of the diff algorithm as described in +-- /An \( O(ND) \) Difference Algorithm and Its Variations (1986)/ +-- . +-- For inputs of size \( O(N) \) with the number of differences \( D \) +-- it has \( O(ND) \) time and \( O(D^2) \) space complexity. +----------------------------------------------------------------------------- + +module Data.Algorithm.Diff + ( Diff, PolyDiff(..) + -- * Comparing lists for differences + , getDiff + , getDiffBy + + -- * Finding chunks of differences + , getGroupedDiff + , getGroupedDiffBy + ) where + +import Prelude hiding (pi) +import Data.Array (listArray, (!)) +import Data.Bifunctor + +data DI = F | S deriving (Show, Eq) + +-- | A value is either from the 'First' list, the 'Second' or from 'Both'. +-- 'Both' contains both the left and right values, in case you are using a form +-- of equality that doesn't check all data (for example, if you are using a +-- newtype to only perform equality on side of a tuple). +data PolyDiff a b = First a | Second b | Both a b + deriving (Show, Eq) + +instance Functor (PolyDiff a) where + fmap _ (First a) = First a + fmap g (Second b) = Second (g b) + fmap g (Both a b) = Both a (g b) + +instance Bifunctor PolyDiff where + bimap f _ (First a) = First (f a) + bimap _ g (Second b) = Second (g b) + bimap f g (Both a b) = Both (f a) (g b) + +-- | This is 'PolyDiff' specialized so both sides are the same type. +type Diff a = PolyDiff a a + +data DL = DL {poi :: !Int, poj :: !Int, path::[DI]} deriving (Show, Eq) + +instance Ord DL + where x <= y = if poi x == poi y + then poj x > poj y + else poi x <= poi y + +canDiag :: (a -> b -> Bool) -> [a] -> [b] -> Int -> Int -> Int -> Int -> Bool +canDiag eq as bs lena lenb = \ i j -> + if i < lena && j < lenb then (arAs ! i) `eq` (arBs ! j) else False + where arAs = listArray (0,lena - 1) as + arBs = listArray (0,lenb - 1) bs + +dstep :: (Int -> Int -> Bool) -> [DL] -> [DL] +dstep cd dls = hd:pairMaxes rst + where (hd:rst) = nextDLs dls + nextDLs [] = [] + nextDLs (dl:rest) = dl':dl'':nextDLs rest + where dl' = addsnake cd $ dl {poi=poi dl + 1, path=(F : pdl)} + dl'' = addsnake cd $ dl {poj=poj dl + 1, path=(S : pdl)} + pdl = path dl + pairMaxes [] = [] + pairMaxes [x] = [x] + pairMaxes (x:y:rest) = max x y:pairMaxes rest + +addsnake :: (Int -> Int -> Bool) -> DL -> DL +addsnake cd dl + | cd pi pj = addsnake cd $ + dl {poi = pi + 1, poj = pj + 1, path = path dl} + | otherwise = dl + where pi = poi dl; pj = poj dl + +lcs :: (a -> b -> Bool) -> [a] -> [b] -> [DI] +lcs eq as bs = path . head . dropWhile (\dl -> poi dl /= lena || poj dl /= lenb) . + concat . iterate (dstep cd) . (:[]) . addsnake cd $ + DL {poi=0,poj=0,path=[]} + where cd = canDiag eq as bs lena lenb + lena = length as; lenb = length bs + +-- | Takes two lists and returns a list of differences between them. This is +-- 'getDiffBy' with '==' used as predicate. +-- +-- > > getDiff ["a","b","c","d","e"] ["a","c","d","f"] +-- > [Both "a" "a",First "b",Both "c" "c",Both "d" "d",First "e",Second "f"] +-- > > getDiff "abcde" "acdf" +-- > [Both 'a' 'a',First 'b',Both 'c' 'c',Both 'd' 'd',First 'e',Second 'f'] +getDiff :: (Eq a) => [a] -> [a] -> [Diff a] +getDiff = getDiffBy (==) + +-- | Takes two lists and returns a list of differences between them, grouped +-- into chunks. This is 'getGroupedDiffBy' with '==' used as predicate. +-- +-- > > getGroupedDiff "abcde" "acdf" +-- > [Both "a" "a",First "b",Both "cd" "cd",First "e",Second "f"] +getGroupedDiff :: (Eq a) => [a] -> [a] -> [Diff [a]] +getGroupedDiff = getGroupedDiffBy (==) + +-- | A form of 'getDiff' with no 'Eq' constraint. Instead, an equality predicate +-- is taken as the first argument. +getDiffBy :: (a -> b -> Bool) -> [a] -> [b] -> [PolyDiff a b] +getDiffBy eq a b = markup a b . reverse $ lcs eq a b + where markup (x:xs) (y:ys) ds + | eq x y = Both x y : markup xs ys ds + markup (x:xs) ys (F:ds) = First x : markup xs ys ds + markup xs (y:ys) (S:ds) = Second y : markup xs ys ds + markup _ _ _ = [] + +getGroupedDiffBy :: (a -> b -> Bool) -> [a] -> [b] -> [PolyDiff [a] [b]] +getGroupedDiffBy eq a b = go $ getDiffBy eq a b + where go (First x : xs) = let (fs, rest) = goFirsts xs in First (x:fs) : go rest + go (Second x : xs) = let (fs, rest) = goSeconds xs in Second (x:fs) : go rest + go (Both x y : xs) = let (fs, rest) = goBoth xs + (fxs, fys) = unzip fs + in Both (x:fxs) (y:fys) : go rest + go [] = [] + + goFirsts (First x : xs) = let (fs, rest) = goFirsts xs in (x:fs, rest) + goFirsts xs = ([],xs) + + goSeconds (Second x : xs) = let (fs, rest) = goSeconds xs in (x:fs, rest) + goSeconds xs = ([],xs) + + goBoth (Both x y : xs) = let (fs, rest) = goBoth xs in ((x,y):fs, rest) + goBoth xs = ([],xs) diff --git a/src/Data/Algorithm/DiffContext.hs b/src/Data/Algorithm/DiffContext.hs new file mode 100644 --- /dev/null +++ b/src/Data/Algorithm/DiffContext.hs @@ -0,0 +1,187 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Algorithm.DiffContext +-- Copyright : (c) David Fox (2015) +-- License : BSD 3 Clause +-- Maintainer : s.clover@gmail.com +-- Stability : experimental +-- Portability : portable +-- Author : David Fox (ddssff at the email service from google) +-- +-- Generates a grouped diff with merged runs, and outputs them in the manner of diff -u +----------------------------------------------------------------------------- +module Data.Algorithm.DiffContext + ( ContextDiff, Hunk + , getContextDiff + , prettyContextDiff + , prettyContextDiffOld + , getContextDiffNumbered + , Numbered(Numbered), numbered, unnumber + , unNumberContextDiff + , groupBy' + ) where + +import Data.Algorithm.Diff (PolyDiff(..), Diff, getGroupedDiff) +-- import Data.List (groupBy) +import Data.Bifunctor +import Text.PrettyPrint (Doc, text, empty, hcat) + +type ContextDiff c = [Hunk c] +type Hunk c = [Diff [c]] + +-- | A version of 'groupBy' that does not assume the argument function +-- is transitive. This is used to partition the 'Diff' list into +-- segments that begin and end with matching ('Both') text, with and +-- have non-matching ('First' and 'Second') text in the middle. +-- +-- > let notBoth1 a b = not (a == 1 || b == 1) in +-- > +-- > groupBy' notBoth1 [1,1,2,3,1,1,4,5,6,1] +-- > [[1],[1,2,3,1],[1,4,5,6,1]] +-- > +-- > groupBy notBoth1 [1,1,2,3,1,1,4,5,6,1] +-- > [[1],[1,2,3],[1],[1,4,5,6],[1]] +-- +-- In the first result the list is split anywhere there are two +-- adjacent ones, as desired. +groupBy' :: (a -> a -> Bool) -> [a] -> [[a]] +groupBy' _ [] = [] +groupBy' eq (x0 : xs0) = go [x0] xs0 + where + go (x : xs) (y : zs) | eq x y = go (y : x : xs) zs + go g (y : zs) = reverse g : go [y] zs + go g [] = [reverse g] + +data Numbered a = Numbered Int a deriving Show +instance Eq a => Eq (Numbered a) where + Numbered _ a == Numbered _ b = a == b +instance Ord a => Ord (Numbered a) where + compare (Numbered _ a) (Numbered _ b) = compare a b + +numbered :: [a] -> [Numbered a] +numbered xs = fmap (uncurry Numbered) (zip [1..] xs) + +unnumber :: Numbered a -> a +unnumber (Numbered _ a) = a + +-- | +-- > > let textA = ["a","b","c","d","e","f","g","h","i","j","k"] +-- > > let textB = ["a","b","d","e","f","g","h","i","j"] +-- > > let diff = getContextDiff (Just 2) textA textB +-- > > prettyContextDiff (text "file1") (text "file2") (text . unnumber) diff +-- > --- file1 +-- > +++ file2 +-- > @@ -1,5 +1,4 @@ +-- > a +-- > b +-- > -c +-- > d +-- > e +-- > @@ -9,3 +8,2 @@ +-- > i +-- > j +-- > -k +getContextDiff :: + Eq a + => Maybe Int -- ^ Number of context elements, Nothing means infinite + -> [a] + -> [a] + -> ContextDiff (Numbered a) +getContextDiff context a b = + getContextDiffNumbered context (numbered a) (numbered b) + +-- | If for some reason you need the line numbers stripped from the +-- result of getContextDiff for backwards compatibility. +unNumberContextDiff :: ContextDiff (Numbered a) -> ContextDiff a +unNumberContextDiff = fmap (fmap (bimap (fmap unnumber) (fmap unnumber))) + +getContextDiffNumbered :: + Eq a + => Maybe Int -- ^ Number of context elements, Nothing means infinite + -> [Numbered a] + -> [Numbered a] + -> ContextDiff (Numbered a) +getContextDiffNumbered context a0 b0 = + groupBy' (\a b -> not (isBoth a && isBoth b)) $ doPrefix $ getGroupedDiff a0 b0 + where + isBoth (Both _ _) = True + isBoth _ = False + -- Handle the common text leading up to a diff. + doPrefix [] = [] + doPrefix [Both _ _] = [] + doPrefix (Both xs ys : more) = + Both (maybe xs (\n -> drop (max 0 (length xs - n)) xs) context) + (maybe ys (\n -> drop (max 0 (length ys - n)) ys) context) : doSuffix more + -- Prefix finished, do the diff then the following suffix + doPrefix (d : ds) = doSuffix (d : ds) + -- Handle the common text following a diff. + doSuffix [] = [] + doSuffix [Both xs ys] = [Both (maybe xs (\n -> take n xs) context) (maybe ys (\n -> take n ys) context)] + doSuffix (Both xs ys : more) + | maybe True (\n -> length xs <= n * 2) context = + Both xs ys : doPrefix more + doSuffix (Both xs ys : more) = + Both (maybe xs (\n -> take n xs) context) (maybe ys (\n -> take n ys) context) + : doPrefix (Both (maybe mempty (\n -> drop n xs) context) (maybe mempty (\n -> drop n ys) context) : more) + doSuffix (d : ds) = d : doSuffix ds + +-- | Pretty print a ContextDiff in the manner of diff -u. +prettyContextDiff :: + Doc -- ^ Document 1 name + -> Doc -- ^ Document 2 name + -> (Numbered c -> Doc) -- ^ Element pretty printer + -> ContextDiff (Numbered c) + -> Doc +prettyContextDiff _ _ _ [] = empty +prettyContextDiff old new prettyElem hunks = + hcat . map (<> text "\n") $ (text "--- " <> old : + text "+++ " <> new : + concatMap prettyRun hunks) + where + -- Pretty print a run of adjacent changes + prettyRun hunk = + text ("@@ " <> formatHunk hunk <> " @@") : concatMap prettyChange hunk + + -- Pretty print a single change (e.g. one line of a text file) + prettyChange (Both ts _) = map (\ l -> text " " <> prettyElem l) ts + prettyChange (First ts) = map (\ l -> text "-" <> prettyElem l) ts + prettyChange (Second ts) = map (\ l -> text "+" <> prettyElem l) ts + + formatHunk hunk = "-" <> formatRun (firsts hunk) <> " +" <> formatRun (seconds hunk) + + formatRun :: [Int] -> String + formatRun [] = "-0,0" + formatRun [n] = show n + formatRun ns@(n : _) = show n <> "," <> show (length ns) + + firsts (Both ns _ : more) = fmap (\(Numbered n _) -> n) ns <> firsts more + firsts (First ns : more) = fmap (\(Numbered n _) -> n) ns <> firsts more + firsts (Second _ : more) = firsts more + firsts [] = [] + + seconds (Both _ ns : more) = fmap (\(Numbered n _) -> n) ns <> seconds more + seconds (First _ : more) = seconds more + seconds (Second ns : more) = fmap (\(Numbered n _) -> n) ns <> seconds more + seconds [] = [] + +-- | Pretty print without line numbers. +prettyContextDiffOld :: + Doc -- ^ Document 1 name + -> Doc -- ^ Document 2 name + -> (c -> Doc) -- ^ Element pretty printer + -> ContextDiff c + -> Doc +prettyContextDiffOld _ _ _ [] = empty +prettyContextDiffOld old new prettyElem hunks = + hcat . map (<> text "\n") $ (text "--- " <> old : + text "+++ " <> new : + concatMap prettyRun hunks) + where + -- Pretty print a run of adjacent changes + prettyRun hunk = + text "@@" : concatMap prettyChange hunk + + -- Pretty print a single change (e.g. one line of a text file) + prettyChange (Both ts _) = map (\ l -> text " " <> prettyElem l) ts + prettyChange (First ts) = map (\ l -> text "-" <> prettyElem l) ts + prettyChange (Second ts) = map (\ l -> text "+" <> prettyElem l) ts diff --git a/src/Data/Algorithm/DiffOutput.hs b/src/Data/Algorithm/DiffOutput.hs new file mode 100644 --- /dev/null +++ b/src/Data/Algorithm/DiffOutput.hs @@ -0,0 +1,138 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Algorithm.DiffOutput +-- Copyright : (c) Sterling Clover 2008-2011, Kevin Charter 2011 +-- License : BSD 3 Clause +-- Maintainer : s.clover@gmail.com +-- Stability : experimental +-- Portability : portable +-- Author : Stephan Wehr (wehr@factisresearch.com) and JP Moresmau (jp@moresmau.fr) +-- +-- Generates a string output that is similar to diff normal mode +----------------------------------------------------------------------------- +module Data.Algorithm.DiffOutput where +import Data.Algorithm.Diff +import Text.PrettyPrint hiding ((<>)) +import Data.Char +import Data.List + +-- | Converts Diffs to DiffOperations +diffToLineRanges :: [Diff [String]] -> [DiffOperation LineRange] +diffToLineRanges = toLineRange 1 1 + where + toLineRange :: Int -> Int -> [Diff [String]] -> [DiffOperation LineRange] + toLineRange _ _ []=[] + toLineRange leftLine rightLine (Both ls _:rs)= + let lins=length ls + in toLineRange (leftLine+lins) (rightLine+lins) rs + toLineRange leftLine rightLine (Second lsS:First lsF:rs)= + toChange leftLine rightLine lsF lsS rs + toLineRange leftLine rightLine (First lsF:Second lsS:rs)= + toChange leftLine rightLine lsF lsS rs + toLineRange leftLine rightLine (Second lsS:rs)= + let linesS=length lsS + diff=Addition (LineRange (rightLine,rightLine+linesS-1) lsS) (leftLine-1) + in diff : toLineRange leftLine (rightLine+linesS) rs + toLineRange leftLine rightLine (First lsF:rs)= + let linesF=length lsF + diff=Deletion (LineRange (leftLine,leftLine+linesF-1) lsF) (rightLine-1) + in diff: toLineRange(leftLine+linesF) rightLine rs + toChange leftLine rightLine lsF lsS rs= + let linesS=length lsS + linesF=length lsF + in Change (LineRange (leftLine,leftLine+linesF-1) lsF) (LineRange (rightLine,rightLine+linesS-1) lsS) + : toLineRange (leftLine+linesF) (rightLine+linesS) rs + +-- | pretty print the differences. The output is similar to the output of the diff utility +-- +-- > > putStr (ppDiff (getGroupedDiff ["a","b","c","d","e"] ["a","c","d","f"])) +-- > 2d1 +-- > < b +-- > 5c4 +-- > < e +-- > --- +-- > > f +ppDiff :: [Diff [String]] -> String +ppDiff gdiff = + let diffLineRanges = diffToLineRanges gdiff + in + render (prettyDiffs diffLineRanges) ++ "\n" + + +-- | pretty print of diff operations +prettyDiffs :: [DiffOperation LineRange] -> Doc +prettyDiffs [] = empty +prettyDiffs (d : rest) = prettyDiff d $$ prettyDiffs rest + where + prettyDiff (Deletion inLeft lineNoRight) = + prettyRange (lrNumbers inLeft) <> char 'd' <> int lineNoRight $$ + prettyLines '<' (lrContents inLeft) + prettyDiff (Addition inRight lineNoLeft) = + int lineNoLeft <> char 'a' <> prettyRange (lrNumbers inRight) $$ + prettyLines '>' (lrContents inRight) + prettyDiff (Change inLeft inRight) = + prettyRange (lrNumbers inLeft) <> char 'c' <> prettyRange (lrNumbers inRight) $$ + prettyLines '<' (lrContents inLeft) $$ + text "---" $$ + prettyLines '>' (lrContents inRight) + prettyRange (start, end) = + if start == end then int start else int start <> comma <> int end + prettyLines start lins = + vcat (map (\l -> char start <+> text l) lins) + +-- | Parse pretty printed Diffs as DiffOperations +parsePrettyDiffs :: String -> [DiffOperation LineRange] +parsePrettyDiffs = reverse . doParse [] . lines + where + doParse diffs [] = diffs + doParse diffs s = + let (mnd,r) = parseDiff s + in case mnd of + Just nd -> doParse (nd:diffs) r + _ -> doParse diffs r + parseDiff [] = (Nothing,[]) + parseDiff (h:rs) = let + (r1,hrs1) = parseRange h + in case hrs1 of + ('d':hrs2) -> parseDel r1 hrs2 rs + ('a':hrs2) -> parseAdd r1 hrs2 rs + ('c':hrs2) -> parseChange r1 hrs2 rs + _ -> (Nothing,rs) + parseDel r1 hrs2 rs = let + (r2,_) = parseRange hrs2 + (ls,rs2) = span (isPrefixOf "<") rs + in (Just $ Deletion (LineRange r1 (map (drop 2) ls)) (fst r2), rs2) + parseAdd r1 hrs2 rs = let + (r2,_) = parseRange hrs2 + (ls,rs2) = span (isPrefixOf ">") rs + in (Just $ Addition (LineRange r2 (map (drop 2) ls)) (fst r1), rs2) + parseChange r1 hrs2 rs = let + (r2,_) = parseRange hrs2 + (ls1,rs2) = span (isPrefixOf "<") rs + in case rs2 of + ("---":rs3) -> let + (ls2,rs4) = span (isPrefixOf ">") rs3 + in (Just $ Change (LineRange r1 (map (drop 2) ls1)) (LineRange r2 (map (drop 2) ls2)), rs4) + _ -> (Nothing,rs2) + parseRange :: String -> ((LineNo, LineNo),String) + parseRange l = let + (fstLine,rs) = span isDigit l + (sndLine,rs3) = case rs of + (',':rs2) -> span isDigit rs2 + _ -> (fstLine,rs) + in ((read fstLine,read sndLine),rs3) + +-- | Line number alias +type LineNo = Int + +-- | Line Range: start, end and contents +data LineRange = LineRange { lrNumbers :: (LineNo, LineNo) + , lrContents :: [String] + } + deriving (Show,Read,Eq,Ord) + +-- | Diff Operation representing changes to apply +data DiffOperation a = Deletion a LineNo + | Addition a LineNo + | Change a a + deriving (Show,Read,Eq,Ord) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck +import Data.Algorithm.Diff +import Data.Algorithm.DiffContext +import Data.Algorithm.DiffOutput +import qualified Data.Array as A +import Data.Foldable +import Data.Semigroup (Arg(..)) +import Text.PrettyPrint + +import System.IO +import System.Exit +import System.IO.Unsafe (unsafePerformIO) +import Debug.Trace (trace) +import System.Environment (getArgs) +import Data.Maybe (mapMaybe, catMaybes) +import System.Process (readProcessWithExitCode) +import System.Directory (getTemporaryDirectory) + + +main :: IO () +main = defaultMain [ testGroup "sub props" [ + slTest "empty in subs" prop_emptyInSubs, + slTest "self in subs" prop_selfInSubs, + slTest "count subs" prop_countSubs, + slTest "every sub is a sub" prop_everySubIsSub, + slTest2 "sub prop" prop_sub + ], + testGroup "diff props" [ + slTest "lcsEmpty" prop_lcsEmpty, + slTest "lcsSelf" prop_lcsSelf, + slTest2 "lcsBoth" prop_lcsBoth, + slTest2 "recover first" prop_recoverFirst, + slTest2 "recover second" prop_recoverSecond, + slTest2 "lcs" prop_lcs, + testProperty "compare random with reference" prop_compare_with_reference + ], + testGroup "output props" [ + testProperty "self generates empty" $ forAll shortLists prop_ppDiffEqual, + --testProperty "compare our lists with diff" $ forAll2 shortLists prop_ppDiffShort, + testProperty "compare random with diff" prop_ppDiffR, + testProperty "compare with diff, issue #5" $ prop_ppDiffR + (DiffInput + { diLeft = ["1","2","3","4","","5","6","7"] + , diRight = ["1","2","3","q","b","u","l","","XXX6",""] + }), + testProperty "test parse" prop_parse + ], + testGroup "context props" [ + testProperty "test context" $ prop_ppContextDiffUnitTest + (DiffInput + { diLeft = ["a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k"] + , diRight = ["a", "b", "d", "e", "f", "g", "h", "i", "j"] + }) + "--- a\n+++ b\n@@ -1,5 +1,4 @@\n a\n b\n-c\n d\n e\n@@ -9,3 +8,2 @@\n i\n j\n-k\n", + testProperty "compare with empty" $ prop_ppContextDiffUnitTest + (DiffInput + { diLeft = [] + , diRight = ["1","2","3"] + }) + "--- a\n+++ b\n@@ --0,0 +1,3 @@\n+1\n+2\n+3\n", + testProperty "compare with empty" $ prop_ppContextDiffUnitTest + (DiffInput + { diLeft = ["1","2","3"] + , diRight = [] + }) + "--- a\n+++ b\n@@ -1,3 +-0,0 @@\n-1\n-2\n-3\n" + ] + ] +slTest s t = testProperty s $ forAll shortLists (t :: [Bool] -> Bool) +slTest2 s t = testProperty s $ forAll2 shortLists (t :: [Bool] -> [Bool] -> Bool) + +-- We need some quick and dirty subsequence stuff for the diff tests, +-- so we build that and some tests for it. + +-- | Determines whether one list is a subsequence of another. +isSub :: (Eq a) => [a] -> [a] -> Bool +isSub [] _ = True +isSub (_:_) [] = False +isSub (x:xs) (y:ys) | x == y = isSub xs ys + | otherwise = isSub (x:xs) ys + +-- | Lists the subsequences of a list. +subs :: [a] -> [[a]] +subs [] = [[]] +subs (x:rest) = map (x:) restss ++ restss + where restss = subs rest + +prop_emptyInSubs = elem [] . subs +prop_selfInSubs xs = elem xs (subs xs) +prop_countSubs xs = length (subs xs) == 2^(length xs) +prop_sub xs ys = isSub xs ys == elem xs (subs ys) +prop_everySubIsSub xs = all (flip isSub xs) (subs xs) + + +-- | Obtains a longest common subsequence of two lists using their +-- diff. Note that there is an @lcs@ function in the +-- 'Data.Algorithm.Diff' module, but it's not exported. It's trivial +-- to reconstruct the LCS though, just by taking the 'B' elements. +diffLCS :: (Eq a) => [a] -> [a] -> [a] +diffLCS xs ys = recoverLCS $ getDiff xs ys + +-- | Recovers the (longest) common subsequence from a diff. +recoverLCS :: [Diff a] -> [a] +recoverLCS (Both x _ : xs) = x : recoverLCS xs +recoverLCS (_ : xs) = recoverLCS xs +recoverLCS [] = [] + +-- | Recovers the first list from a diff. +recoverFirst :: [Diff a] -> [a] +recoverFirst (First x : xs) = x : recoverFirst xs +recoverFirst (Both x _ : xs) = x : recoverFirst xs +recoverFirst (_ : xs) = recoverFirst xs +recoverFirst [] = [] + +-- | Recovers the second list from a diff. +recoverSecond :: [Diff a] -> [a] +recoverSecond (Second x : xs) = x : recoverSecond xs +recoverSecond (Both x _ : xs) = x : recoverSecond xs +recoverSecond (_ : xs) = recoverSecond xs +recoverSecond [] = [] + +-- | Indicates whether a list is a longest common subsequence of two +-- lists. +isLCS :: (Eq a) => [a] -> [a] -> [a] -> Bool +isLCS ss xs ys = isSub ss ys && isSub ss ys && length ss == lenLCS xs ys + +-- | Computes the length of the longest common subsequence of two +-- lists. This is a naive and inefficient recursive implementation +-- that doesn't memoize repeated sub-calls, so don't use it with large +-- lists. +lenLCS :: (Eq a) => [a] -> [a] -> Int +lenLCS [] _ = 0 +lenLCS _ [] = 0 +lenLCS (x:xs) (y:ys) | x == y = 1 + lenLCS xs ys + | otherwise = max (lenLCS (x:xs) ys) (lenLCS xs (y:ys)) + + +prop_recoverFirst xs ys = recoverFirst (getDiff xs ys) == xs +prop_recoverSecond xs ys = recoverSecond (getDiff xs ys) == ys +prop_lcs xs ys = isLCS (diffLCS xs ys) xs ys +prop_lcsEmpty xs = diffLCS xs [] == [] && diffLCS [] xs == [] +prop_lcsSelf xs = diffLCS xs xs == xs +prop_lcsBoth xs ys = all areMatch $ getDiff xs ys + where areMatch (Both x y) = x == y + areMatch _ = True + +-- | Lists of no more than twelve elements. +shortLists :: (Arbitrary a) => Gen [a] +shortLists = sized $ \n -> resize (min n 12) $ listOf arbitrary + +-- | 'forAll' where the generator is used twice. +forAll2 :: (Show a, Testable prop) => Gen a -> (a -> a -> prop) -> Property +forAll2 gen f = forAll gen $ \x -> forAll gen (f x) + +prop_ppDiffEqual xs=ppDiff (getGroupedDiff xs xs)=="\n" + +-- | truly random tests +prop_ppDiffR :: DiffInput -> Property +prop_ppDiffR (DiffInput le ri) = + let haskDiff=ppDiff $ getGroupedDiff le ri + utilDiff= unsafePerformIO (runDiff (unlines le) (unlines ri)) + in cover 90 (haskDiff == utilDiff) "exact match" $ + classify (haskDiff == utilDiff) "exact match" + (div ((length (lines haskDiff))*100) (length (lines utilDiff)) < 110) -- less than 10% bigger + where + 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 + +prop_ppContextDiffUnitTest :: DiffInput -> String -> Property +prop_ppContextDiffUnitTest (DiffInput le ri) expected = + show diff === expected + where + hunks = getContextDiff (Just 2) le ri + diff = prettyContextDiff (text "a") (text "b") (text . unnumber) hunks + +-- | Check pretty printed DiffOperations can be parsed again +prop_parse :: DiffInput -> Bool +prop_parse (DiffInput le ri) = + let difflrs = diffToLineRanges $ getGroupedDiff le ri + output = render (prettyDiffs difflrs) ++ "\n" + parsed = parsePrettyDiffs output + in difflrs == parsed + +data DiffInput = DiffInput { diLeft :: [String], diRight :: [String] } + deriving (Show) + +leftDiffInput = ["1", "2", "3", "4", "", "5", "6", "7"] + +instance Arbitrary DiffInput where + arbitrary = + do let leftLines = leftDiffInput + rightLinesLines <- mapM modifyLine (leftLines ++ [""]) + return $ DiffInput leftLines + (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 (const randomString) [1..prefixLen] + frequency [ (5, return (prefix ++ [str])) + , (3, return (prefix ++ ["XXX" ++ str])) + , (2, return prefix) + , (2, return [str])] + +-- | Reference implementation, very slow. +naiveGetDiffBy :: forall a b. (a -> b -> Bool) -> [a] -> [b] -> [PolyDiff a b] +naiveGetDiffBy eq as bs = reverse $ (\(Arg _ ds) -> ds) $ tbl A.! (length us, length vs) + where + us = A.listArray (0, length as - 1) as + vs = A.listArray (0, length bs - 1) bs + + -- Indices run up to length us/vs *inclusive* + tbl :: A.Array (Int, Int) (Arg Word [PolyDiff a b]) + tbl = A.listArray ((0, 0), (length us, length vs)) + [ gen ui vi | ui <- [0..length us], vi <- [0..length vs] ] + + gen :: Int -> Int -> Arg Word [PolyDiff a b] + gen ui vi + | ui == 0, vi == 0 = Arg 0 [] + | ui == 0 + = left' + | vi == 0 + = top' + | otherwise + = if eq u v + then min (min left' top') diag' + else min left' top' + where + Arg leftL leftP = tbl A.! (ui, vi - 1) + Arg diagL diagP = tbl A.! (ui - 1, vi - 1) + Arg topL topP = tbl A.! (ui - 1, vi) + + u = us A.! (ui - 1) + v = vs A.! (vi - 1) + + left' = Arg (leftL + 1) (Second v : leftP) + top' = Arg (topL + 1) (First u : topP) + diag' = Arg diagL (Both u v : diagP) + +prop_compare_with_reference :: Positive Word -> [(Int, Int)] -> Property +prop_compare_with_reference (Positive x) ixs' = + counterexample (show (as, bs, d1, d2)) $ + length (notBoth d1) === length (notBoth d2) + where + as = [0 .. max 100 x] + len = length as + ixs = filter (uncurry (/=)) $ map (\(i, j) -> (i `mod` len, j `mod` len)) $ take 100 ixs' + bs = foldl' applySwap as ixs + d1 = getDiffBy (==) as bs + d2 = naiveGetDiffBy (==) as bs + + applySwap xs (i, j) = zipWith + (\k x -> (if k == i then xs !! j else if k == j then xs !! i else x)) + [0..] + xs + + notBoth = filter $ \case + Both{} -> False + _ -> True