1----------------------------------------------------------------------------- 2-- | 3-- Module : Data.Algorithm.DiffOutput 4-- Copyright : (c) Sterling Clover 2008-2011, Kevin Charter 2011 5-- License : BSD 3 Clause 6-- Maintainer : s.clover@gmail.com 7-- Stability : experimental 8-- Portability : portable 9-- Author : Stephan Wehr (wehr@factisresearch.com) and JP Moresmau (jp@moresmau.fr) 10-- 11-- Generates a string output that is similar to diff normal mode 12----------------------------------------------------------------------------- 13module Data.Algorithm.DiffOutput where 14import Data.Algorithm.Diff 15import Text.PrettyPrint 16import Data.Char 17import Data.List 18import Data.Monoid (mappend) 19 20-- | Converts Diffs to DiffOperations 21diffToLineRanges :: [Diff [String]] -> [DiffOperation LineRange] 22diffToLineRanges = toLineRange 1 1 23 where 24 toLineRange :: Int -> Int -> [Diff [String]] -> [DiffOperation LineRange] 25 toLineRange _ _ []=[] 26 toLineRange leftLine rightLine (Both ls _:rs)= 27 let lins=length ls 28 in toLineRange (leftLine+lins) (rightLine+lins) rs 29 toLineRange leftLine rightLine (Second lsS:First lsF:rs)= 30 toChange leftLine rightLine lsF lsS rs 31 toLineRange leftLine rightLine (First lsF:Second lsS:rs)= 32 toChange leftLine rightLine lsF lsS rs 33 toLineRange leftLine rightLine (Second lsS:rs)= 34 let linesS=length lsS 35 diff=Addition (LineRange (rightLine,rightLine+linesS-1) lsS) (leftLine-1) 36 in diff : toLineRange leftLine (rightLine+linesS) rs 37 toLineRange leftLine rightLine (First lsF:rs)= 38 let linesF=length lsF 39 diff=Deletion (LineRange (leftLine,leftLine+linesF-1) lsF) (rightLine-1) 40 in diff: toLineRange(leftLine+linesF) rightLine rs 41 toChange leftLine rightLine lsF lsS rs= 42 let linesS=length lsS 43 linesF=length lsF 44 in Change (LineRange (leftLine,leftLine+linesF-1) lsF) (LineRange (rightLine,rightLine+linesS-1) lsS) 45 : toLineRange (leftLine+linesF) (rightLine+linesS) rs 46 47-- | pretty print the differences. The output is similar to the output of the diff utility 48ppDiff :: [Diff [String]] -> String 49ppDiff gdiff = 50 let diffLineRanges = diffToLineRanges gdiff 51 in 52 render (prettyDiffs diffLineRanges) ++ "\n" 53 54 55-- | pretty print of diff operations 56prettyDiffs :: [DiffOperation LineRange] -> Doc 57prettyDiffs [] = empty 58prettyDiffs (d : rest) = prettyDiff d $$ prettyDiffs rest 59 where 60 prettyDiff (Deletion inLeft lineNoRight) = 61 prettyRange (lrNumbers inLeft) `mappend` char 'd' `mappend` int lineNoRight $$ 62 prettyLines '<' (lrContents inLeft) 63 prettyDiff (Addition inRight lineNoLeft) = 64 int lineNoLeft `mappend` char 'a' `mappend` prettyRange (lrNumbers inRight) $$ 65 prettyLines '>' (lrContents inRight) 66 prettyDiff (Change inLeft inRight) = 67 prettyRange (lrNumbers inLeft) `mappend` char 'c' `mappend` prettyRange (lrNumbers inRight) $$ 68 prettyLines '<' (lrContents inLeft) $$ 69 text "---" $$ 70 prettyLines '>' (lrContents inRight) 71 prettyRange (start, end) = 72 if start == end then int start else int start `mappend` comma `mappend` int end 73 prettyLines start lins = 74 vcat (map (\l -> char start <+> text l) lins) 75 76-- | Parse pretty printed Diffs as DiffOperations 77parsePrettyDiffs :: String -> [DiffOperation LineRange] 78parsePrettyDiffs = reverse . doParse [] . lines 79 where 80 doParse diffs [] = diffs 81 doParse diffs s = 82 let (mnd,r) = parseDiff s 83 in case mnd of 84 Just nd -> doParse (nd:diffs) r 85 _ -> doParse diffs r 86 parseDiff [] = (Nothing,[]) 87 parseDiff (h:rs) = let 88 (r1,hrs1) = parseRange h 89 in case hrs1 of 90 ('d':hrs2) -> parseDel r1 hrs2 rs 91 ('a':hrs2) -> parseAdd r1 hrs2 rs 92 ('c':hrs2) -> parseChange r1 hrs2 rs 93 _ -> (Nothing,rs) 94 parseDel r1 hrs2 rs = let 95 (r2,_) = parseRange hrs2 96 (ls,rs2) = span (isPrefixOf "<") rs 97 in (Just $ Deletion (LineRange r1 (map (drop 2) ls)) (fst r2), rs2) 98 parseAdd r1 hrs2 rs = let 99 (r2,_) = parseRange hrs2 100 (ls,rs2) = span (isPrefixOf ">") rs 101 in (Just $ Addition (LineRange r2 (map (drop 2) ls)) (fst r1), rs2) 102 parseChange r1 hrs2 rs = let 103 (r2,_) = parseRange hrs2 104 (ls1,rs2) = span (isPrefixOf "<") rs 105 in case rs2 of 106 ("---":rs3) -> let 107 (ls2,rs4) = span (isPrefixOf ">") rs3 108 in (Just $ Change (LineRange r1 (map (drop 2) ls1)) (LineRange r2 (map (drop 2) ls2)), rs4) 109 _ -> (Nothing,rs2) 110 parseRange :: String -> ((LineNo, LineNo),String) 111 parseRange l = let 112 (fstLine,rs) = span isDigit l 113 (sndLine,rs3) = case rs of 114 (',':rs2) -> span isDigit rs2 115 _ -> (fstLine,rs) 116 in ((read fstLine,read sndLine),rs3) 117 118-- | Line number alias 119type LineNo = Int 120 121-- | Line Range: start, end and contents 122data LineRange = LineRange { lrNumbers :: (LineNo, LineNo) 123 , lrContents :: [String] 124 } 125 deriving (Show,Read,Eq,Ord) 126 127-- | Diff Operation representing changes to apply 128data DiffOperation a = Deletion a LineNo 129 | Addition a LineNo 130 | Change a a 131 deriving (Show,Read,Eq,Ord) 132