1 -- Copyright (C) 2002-2004 David Roundy 2 -- 3 -- This program is free software; you can redistribute it and/or modify 4 -- it under the terms of the GNU General Public License as published by 5 -- the Free Software Foundation; either version 2, or (at your option) 6 -- any later version. 7 -- 8 -- This program is distributed in the hope that it will be useful, 9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 -- GNU General Public License for more details. 12 -- 13 -- You should have received a copy of the GNU General Public License 14 -- along with this program; see the file COPYING. If not, write to 15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 -- Boston, MA 02110-1301, USA. 17 18 {-# OPTIONS_GHC -cpp -fno-warn-orphans #-} 19 {-# LANGUAGE CPP #-} 20 21 module Darcs.Patch.Viewing ( xml_summary, summarize ) 22 where 23 24 import Prelude hiding ( pi ) 25 import Control.Monad ( liftM ) 26 import Data.List ( sort ) 27 28 import Darcs.SlurpDirectory ( Slurpy, get_slurp, get_filecontents ) 29 import ByteStringUtils (linesPS ) 30 import qualified Data.ByteString as B (null) 31 import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp ) 32 import Printer ( Doc, empty, vcat, 33 text, blueText, Color(Cyan,Magenta), lineColor, 34 minus, plus, ($$), (<+>), (<>), 35 prefix, renderString, 36 userchunkPS, 37 ) 38 import Darcs.Patch.Core ( Patch(..), Named(..), 39 patchcontents ) 40 import Darcs.Patch.Prim ( Prim(..), is_hunk, isHunk, formatFileName, showPrim, FileNameFormat(..), Conflict(..), 41 Effect, IsConflictedPrim(IsC), ConflictState(..), 42 DirPatchType(..), FilePatchType(..) ) 43 import Darcs.Patch.Patchy ( Patchy, Apply, ShowPatch(..), identity ) 44 import Darcs.Patch.Show ( showPatch_, showNamedPrefix ) 45 import Darcs.Patch.Info ( showPatchInfo, human_friendly ) 46 import Darcs.Patch.Apply ( apply_to_slurpy ) 47 #include "impossible.h" 48 #include "gadts.h" 49 import Darcs.Ordered ( RL(..), FL(..), 50 mapFL, mapFL_FL, reverseRL ) 51 52 instance ShowPatch Prim where 53 showPatch = showPrim OldFormat 54 showContextPatch s p@(FP _ (Hunk _ _ _)) = showContextHunk s (PP p) 55 showContextPatch s (Split ps) = 56 blueText "(" $$ showContextSeries s (mapFL_FL PP ps) 57 <> blueText ")" 58 showContextPatch _ p = showPatch p 59 summary = gen_summary False . (:[]) . IsC Okay 60 thing _ = "change" 61 62 summarize :: (Conflict e, Effect e) => e C(x y) -> Doc 63 summarize = gen_summary False . conflictedEffect 64 65 instance ShowPatch Patch where 66 showPatch = showPatch_ 67 showContextPatch s (PP x) | is_hunk x = showContextHunk s (PP x) 68 showContextPatch _ (ComP NilFL) = blueText "{" $$ blueText "}" 69 showContextPatch s (ComP ps) = blueText "{" $$ showContextSeries s ps 70 $$ blueText "}" 71 showContextPatch _ p = showPatch p 72 summary = summarize 73 thing _ = "change" 74 75 showContextSeries :: (Apply p, ShowPatch p, Effect p) => Slurpy -> FL p C(x y) -> Doc 76 showContextSeries slur patches = scs slur identity patches 77 where scs :: (Apply p, ShowPatch p, Effect p) => Slurpy -> Prim C(w x) -> FL p C(x y) -> Doc 78 scs s pold (p:>:ps) = 79 case isHunk p of 80 Nothing -> showContextPatch s p $$ scs s' identity ps 81 Just hp -> 82 case ps of 83 NilFL -> coolContextHunk s pold hp identity 84 (p2:>:_) -> 85 case isHunk p2 of 86 Nothing -> coolContextHunk s pold hp identity $$ scs s' hp ps 87 Just hp2 -> coolContextHunk s pold hp hp2 $$ 88 scs s' hp ps 89 where s' = 90 fromJust $ apply_to_slurpy p s 91 scs _ _ NilFL = empty 92 93 showContextHunk :: (Apply p, ShowPatch p, Effect p) => Slurpy -> p C(x y) -> Doc 94 showContextHunk s p = case isHunk p of 95 Just h -> coolContextHunk s identity h identity 96 Nothing -> showPatch p 97 98 coolContextHunk :: Slurpy -> Prim C(a b) -> Prim C(b c) 99 -> Prim C(c d) -> Doc 100 coolContextHunk s prev p@(FP f (Hunk l o n)) next = 101 case (linesPS . get_filecontents) `liftM` get_slurp f s of 102 Nothing -> showPatch p -- This is a weird error... 103 Just ls -> 104 let numpre = case prev of 105 (FP f' (Hunk lprev _ nprev)) 106 | f' == f && 107 l - (lprev + length nprev + 3) < 3 && 108 lprev < l -> 109 max 0 $ l - (lprev + length nprev + 3) 110 _ -> if l >= 4 then 3 else l - 1 111 pre = take numpre $ drop (l - numpre - 1) ls 112 numpost = case next of 113 (FP f' (Hunk lnext _ _)) 114 | f' == f && lnext < l+length n+4 && 115 lnext > l -> 116 lnext - (l+length n) 117 _ -> 3 118 cleanedls = case reverse ls of 119 (x:xs) | B.null x -> reverse xs 120 _ -> ls 121 post = take numpost $ drop (max 0 $ l+length o-1) cleanedls 122 in blueText "hunk" <+> formatFileName OldFormat f <+> text (show l) 123 $$ prefix " " (vcat $ map userchunkPS pre) 124 $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS o)) 125 $$ lineColor Cyan (prefix "+" (vcat $ map userchunkPS n)) 126 $$ prefix " " (vcat $ map userchunkPS post) 127 coolContextHunk _ _ _ _ = impossible 128 129 xml_summary :: (Effect p, Patchy p, Conflict p) => Named p C(x y) -> Doc 130 xml_summary p = text "<summary>" 131 $$ gen_summary True (conflictedEffect $ patchcontents p) 132 $$ text "</summary>" 133 134 -- Yuck duplicated code below... 135 escapeXML :: String -> Doc 136 escapeXML = text . strReplace '\'' "'" . strReplace '"' """ . 137 strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&" 138 139 strReplace :: Char -> String -> String -> String 140 strReplace _ _ [] = [] 141 strReplace x y (z:zs) 142 | x == z = y ++ (strReplace x y zs) 143 | otherwise = z : (strReplace x y zs) 144 -- end yuck duplicated code. 145 146 gen_summary :: Bool -> [IsConflictedPrim] -> Doc 147 gen_summary use_xml p 148 = vcat themoves 149 $$ vcat themods 150 where themods = map summ $ combine $ sort $ concatMap s2 p 151 s2 :: IsConflictedPrim -> [(FileName, Int, Int, Int, Bool, ConflictState)] 152 s2 (IsC c x) = map (append56 c) $ s x 153 s :: Prim C(x y) -> [(FileName, Int, Int, Int, Bool)] 154 s (FP f (Hunk _ o n)) = [(f, length o, length n, 0, False)] 155 s (FP f (Binary _ _)) = [(f, 0, 0, 0, False)] 156 s (FP f AddFile) = [(f, -1, 0, 0, False)] 157 s (FP f RmFile) = [(f, 0, -1, 0, False)] 158 s (FP f (TokReplace _ _ _)) = [(f, 0, 0, 1, False)] 159 s (DP d AddDir) = [(d, -1, 0, 0, True)] 160 s (DP d RmDir) = [(d, 0, -1, 0, True)] 161 s (Split xs) = concat $ mapFL s xs 162 s (Move _ _) = [(fp2fn "", 0, 0, 0, False)] 163 s (ChangePref _ _ _) = [(fp2fn "", 0, 0, 0, False)] 164 s Identity = [(fp2fn "", 0, 0, 0, False)] 165 append56 f (a,b,c,d,e) = (a,b,c,d,e,f) 166 (-1) .+ _ = -1 167 _ .+ (-1) = -1 168 a .+ b = a + b 169 combine ((f,a,b,r,isd,c):(f',a',b',r',_,c'):ss) 170 -- Don't combine AddFile and RmFile: (maybe an old revision of) darcs 171 -- allows a single patch to add and remove the same file, see issue 185 172 | f == f' && (a /= -1 || b' /= -1) && (a' /= -1 || b /= -1) = 173 combine ((f,a.+a',b.+b',r+r',isd,combineConflitStates c c'):ss) 174 combine ((f,a,b,r,isd,c):ss) = (f,a,b,r,isd,c) : combine ss 175 combine [] = [] 176 combineConflitStates Conflicted _ = Conflicted 177 combineConflitStates _ Conflicted = Conflicted 178 combineConflitStates Duplicated _ = Duplicated 179 combineConflitStates _ Duplicated = Duplicated 180 combineConflitStates Okay Okay = Okay 181 182 summ (f,_,-1,_,False,Okay) 183 = if use_xml then text "<remove_file>" 184 $$ escapeXML (drop_dotslash $ fn2fp f) 185 $$ text "</remove_file>" 186 else text "R" <+> text (fn2fp f) 187 summ (f,_,-1,_,False,Conflicted) 188 = if use_xml then text "<remove_file conflict='true'>" 189 $$ escapeXML (drop_dotslash $ fn2fp f) 190 $$ text "</remove_file>" 191 else text "R!" <+> text (fn2fp f) 192 summ (f,_,-1,_,False,Duplicated) 193 = if use_xml then text "<remove_file duplicate='true'>" 194 $$ escapeXML (drop_dotslash $ fn2fp f) 195 $$ text "</remove_file>" 196 else text "R" <+> text (fn2fp f) <+> text "(duplicate)" 197 summ (f,-1,_,_,False,Okay) 198 = if use_xml then text "<add_file>" 199 $$ escapeXML (drop_dotslash $ fn2fp f) 200 $$ text "</add_file>" 201 else text "A" <+> text (fn2fp f) 202 summ (f,-1,_,_,False,Conflicted) 203 = if use_xml then text "<add_file conflict='true'>" 204 $$ escapeXML (drop_dotslash $ fn2fp f) 205 $$ text "</add_file>" 206 else text "A!" <+> text (fn2fp f) 207 summ (f,-1,_,_,False,Duplicated) 208 = if use_xml then text "<add_file duplicate='true'>" 209 $$ escapeXML (drop_dotslash $ fn2fp f) 210 $$ text "</add_file>" 211 else text "A" <+> text (fn2fp f) <+> text "(duplicate)" 212 summ (f,0,0,0,False,Okay) | f == fp2fn "" = empty 213 summ (f,0,0,0,False,Conflicted) | f == fp2fn "" 214 = if use_xml then empty -- don't know what to do here... 215 else text "!" <+> text (fn2fp f) 216 summ (f,0,0,0,False,Duplicated) | f == fp2fn "" 217 = if use_xml then empty -- don't know what to do here... 218 else text (fn2fp f) <+> text "(duplicate)" 219 summ (f,a,b,r,False,Okay) 220 = if use_xml then text "<modify_file>" 221 $$ escapeXML (drop_dotslash $ fn2fp f) 222 <> xrm a <> xad b <> xrp r 223 $$ text "</modify_file>" 224 else text "M" <+> text (fn2fp f) 225 <+> rm a <+> ad b <+> rp r 226 summ (f,a,b,r,False,Conflicted) 227 = if use_xml then text "<modify_file conflict='true'>" 228 $$ escapeXML (drop_dotslash $ fn2fp f) 229 <> xrm a <> xad b <> xrp r 230 $$ text "</modify_file>" 231 else text "M!" <+> text (fn2fp f) 232 <+> rm a <+> ad b <+> rp r 233 summ (f,a,b,r,False,Duplicated) 234 = if use_xml then text "<modify_file duplicate='true'>" 235 $$ escapeXML (drop_dotslash $ fn2fp f) 236 <> xrm a <> xad b <> xrp r 237 $$ text "</modify_file>" 238 else text "M" <+> text (fn2fp f) 239 <+> rm a <+> ad b <+> rp r <+> text "(duplicate)" 240 summ (f,_,-1,_,True,Okay) 241 = if use_xml then text "<remove_directory>" 242 $$ escapeXML (drop_dotslash $ fn2fp f) 243 $$ text "</remove_directory>" 244 else text "R" <+> text (fn2fp f) <> text "/" 245 summ (f,_,-1,_,True,Conflicted) 246 = if use_xml then text "<remove_directory conflict='true'>" 247 $$ escapeXML (drop_dotslash $ fn2fp f) 248 $$ text "</remove_directory>" 249 else text "R!" <+> text (fn2fp f) <> text "/" 250 summ (f,_,-1,_,True,Duplicated) 251 = if use_xml then text "<remove_directory duplicate='true'>" 252 $$ escapeXML (drop_dotslash $ fn2fp f) 253 $$ text "</remove_directory>" 254 else text "R" <+> text (fn2fp f) <> text "/ (duplicate)" 255 summ (f,-1,_,_,True,Okay) 256 = if use_xml then text "<add_directory>" 257 $$ escapeXML (drop_dotslash $ fn2fp f) 258 $$ text "</add_directory>" 259 else text "A" <+> text (fn2fp f) <> text "/" 260 summ (f,-1,_,_,True,Conflicted) 261 = if use_xml then text "<add_directory conflict='true'>" 262 $$ escapeXML (drop_dotslash $ fn2fp f) 263 $$ text "</add_directory>" 264 else text "A!" <+> text (fn2fp f) <> text "/" 265 summ (f,-1,_,_,True,Duplicated) 266 = if use_xml then text "<add_directory duplicate='true'>" 267 $$ escapeXML (drop_dotslash $ fn2fp f) 268 $$ text "</add_directory>" 269 else text "A!" <+> text (fn2fp f) <> text "/ (duplicate)" 270 summ _ = empty 271 ad 0 = empty 272 ad a = plus <> text (show a) 273 xad 0 = empty 274 xad a = text "<added_lines num='" <> text (show a) <> text "'/>" 275 rm 0 = empty 276 rm a = minus <> text (show a) 277 xrm 0 = empty 278 xrm a = text "<removed_lines num='" <> text (show a) <> text "'/>" 279 rp 0 = empty 280 rp a = text "r" <> text (show a) 281 xrp 0 = empty 282 xrp a = text "<replaced_tokens num='" <> text (show a) <> text "'/>" 283 drop_dotslash ('.':'/':str) = drop_dotslash str 284 drop_dotslash str = str 285 themoves :: [Doc] 286 themoves = map showmoves p 287 showmoves :: IsConflictedPrim -> Doc 288 showmoves (IsC _ (Move a b)) 289 = if use_xml 290 then text "<move from=\"" 291 <> escapeXML (drop_dotslash $ fn2fp a) <> text "\" to=\"" 292 <> escapeXML (drop_dotslash $ fn2fp b) <> text"\"/>" 293 else text " " <> text (fn2fp a) 294 <> text " -> " <> text (fn2fp b) 295 showmoves _ = empty 296 297 instance (Conflict p, ShowPatch p) => ShowPatch (Named p) where 298 showPatch (NamedP n [] p) = showPatchInfo n <> showPatch p 299 showPatch (NamedP n d p) = showNamedPrefix n d <+> showPatch p 300 showContextPatch s (NamedP n [] p) = showPatchInfo n <> showContextPatch s p 301 showContextPatch s (NamedP n d p) = showNamedPrefix n d <+> showContextPatch s p 302 description (NamedP n _ _) = human_friendly n 303 summary p = description p $$ text "" $$ 304 prefix " " (summarize p) -- this isn't summary because summary does the 305 -- wrong thing with (Named (FL p)) so that it can 306 -- get the summary of a sequence of named patches 307 -- right. 308 showNicely p@(NamedP _ _ pt) = description p $$ 309 prefix " " (showNicely pt) 310 311 instance (Conflict p, ShowPatch p) => Show (Named p C(x y)) where 312 show = renderString . showPatch 313 314 instance (Conflict p, Apply p, Effect p, ShowPatch p) => ShowPatch (FL p) where 315 showPatch xs = vcat (mapFL showPatch xs) 316 showContextPatch = showContextSeries 317 description = vcat . mapFL description 318 summary = vcat . mapFL summary 319 thing x = thing (helperx x) ++ "s" 320 where helperx :: FL a C(x y) -> a C(x y) 321 helperx _ = undefined 322 things = thing 323 324 instance (Conflict p, Apply p, ShowPatch p) => ShowPatch (RL p) where 325 showPatch = showPatch . reverseRL 326 showContextPatch s = showContextPatch s . reverseRL 327 description = description . reverseRL 328 summary = summary . reverseRL 329 thing = thing . reverseRL 330 things = things . reverseRL 331 332 instance (Conflict p, Patchy p) => Patchy (FL p) 333 instance (Conflict p, Patchy p) => Patchy (RL p)