src/Darcs/Patch/Viewing.lhs

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