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