module Darcs.Patch.Viewing ( xml_summary, summarize )
where
import Prelude hiding ( pi )
import Control.Monad ( liftM )
import Data.List ( sort )
import Darcs.SlurpDirectory ( Slurpy, get_slurp, get_filecontents )
import ByteStringUtils (linesPS )
import qualified Data.ByteString as B (null)
import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp )
import Printer ( Doc, empty, vcat,
text, blueText, Color(Cyan,Magenta), lineColor,
minus, plus, ($$), (<+>), (<>),
prefix, renderString,
userchunkPS,
)
import Darcs.Patch.Core ( Patch(..), Named(..),
patchcontents )
import Darcs.Patch.Prim ( Prim(..), is_hunk, isHunk, formatFileName, showPrim, FileNameFormat(..), Conflict(..),
Effect, IsConflictedPrim(IsC), ConflictState(..),
DirPatchType(..), FilePatchType(..) )
import Darcs.Patch.Patchy ( Patchy, Apply, ShowPatch(..), identity )
import Darcs.Patch.Show ( showPatch_, showNamedPrefix )
import Darcs.Patch.Info ( showPatchInfo, human_friendly )
import Darcs.Patch.Apply ( apply_to_slurpy )
#include "impossible.h"
#include "gadts.h"
import Darcs.Ordered ( RL(..), FL(..),
mapFL, mapFL_FL, reverseRL )
instance ShowPatch Prim where
showPatch = showPrim OldFormat
showContextPatch s p@(FP _ (Hunk _ _ _)) = showContextHunk s (PP p)
showContextPatch s (Split ps) =
blueText "(" $$ showContextSeries s (mapFL_FL PP ps)
<> blueText ")"
showContextPatch _ p = showPatch p
summary = gen_summary False . (:[]) . IsC Okay
thing _ = "change"
summarize :: (Conflict e, Effect e) => e C(x y) -> Doc
summarize = gen_summary False . conflictedEffect
instance ShowPatch Patch where
showPatch = showPatch_
showContextPatch s (PP x) | is_hunk x = showContextHunk s (PP x)
showContextPatch _ (ComP NilFL) = blueText "{" $$ blueText "}"
showContextPatch s (ComP ps) = blueText "{" $$ showContextSeries s ps
$$ blueText "}"
showContextPatch _ p = showPatch p
summary = summarize
thing _ = "change"
showContextSeries :: (Apply p, ShowPatch p, Effect p) => Slurpy -> FL p C(x y) -> Doc
showContextSeries slur patches = scs slur identity patches
where scs :: (Apply p, ShowPatch p, Effect p) => Slurpy -> Prim C(w x) -> FL p C(x y) -> Doc
scs s pold (p:>:ps) =
case isHunk p of
Nothing -> showContextPatch s p $$ scs s' identity ps
Just hp ->
case ps of
NilFL -> coolContextHunk s pold hp identity
(p2:>:_) ->
case isHunk p2 of
Nothing -> coolContextHunk s pold hp identity $$ scs s' hp ps
Just hp2 -> coolContextHunk s pold hp hp2 $$
scs s' hp ps
where s' =
fromJust $ apply_to_slurpy p s
scs _ _ NilFL = empty
showContextHunk :: (Apply p, ShowPatch p, Effect p) => Slurpy -> p C(x y) -> Doc
showContextHunk s p = case isHunk p of
Just h -> coolContextHunk s identity h identity
Nothing -> showPatch p
coolContextHunk :: Slurpy -> Prim C(a b) -> Prim C(b c)
-> Prim C(c d) -> Doc
coolContextHunk s prev p@(FP f (Hunk l o n)) next =
case (linesPS . get_filecontents) `liftM` get_slurp f s of
Nothing -> showPatch p
Just ls ->
let numpre = case prev of
(FP f' (Hunk lprev _ nprev))
| f' == f &&
l (lprev + length nprev + 3) < 3 &&
lprev < l ->
max 0 $ l (lprev + length nprev + 3)
_ -> if l >= 4 then 3 else l 1
pre = take numpre $ drop (l numpre 1) ls
numpost = case next of
(FP f' (Hunk lnext _ _))
| f' == f && lnext < l+length n+4 &&
lnext > l ->
lnext (l+length n)
_ -> 3
cleanedls = case reverse ls of
(x:xs) | B.null x -> reverse xs
_ -> ls
post = take numpost $ drop (max 0 $ l+length o1) cleanedls
in blueText "hunk" <+> formatFileName OldFormat f <+> text (show l)
$$ prefix " " (vcat $ map userchunkPS pre)
$$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS o))
$$ lineColor Cyan (prefix "+" (vcat $ map userchunkPS n))
$$ prefix " " (vcat $ map userchunkPS post)
coolContextHunk _ _ _ _ = impossible
xml_summary :: (Effect p, Patchy p, Conflict p) => Named p C(x y) -> Doc
xml_summary p = text "<summary>"
$$ gen_summary True (conflictedEffect $ patchcontents p)
$$ text "</summary>"
escapeXML :: String -> Doc
escapeXML = text . strReplace '\'' "'" . strReplace '"' """ .
strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&"
strReplace :: Char -> String -> String -> String
strReplace _ _ [] = []
strReplace x y (z:zs)
| x == z = y ++ (strReplace x y zs)
| otherwise = z : (strReplace x y zs)
gen_summary :: Bool -> [IsConflictedPrim] -> Doc
gen_summary use_xml p
= vcat themoves
$$ vcat themods
where themods = map summ $ combine $ sort $ concatMap s2 p
s2 :: IsConflictedPrim -> [(FileName, Int, Int, Int, Bool, ConflictState)]
s2 (IsC c x) = map (append56 c) $ s x
s :: Prim C(x y) -> [(FileName, Int, Int, Int, Bool)]
s (FP f (Hunk _ o n)) = [(f, length o, length n, 0, False)]
s (FP f (Binary _ _)) = [(f, 0, 0, 0, False)]
s (FP f AddFile) = [(f, 1, 0, 0, False)]
s (FP f RmFile) = [(f, 0, 1, 0, False)]
s (FP f (TokReplace _ _ _)) = [(f, 0, 0, 1, False)]
s (DP d AddDir) = [(d, 1, 0, 0, True)]
s (DP d RmDir) = [(d, 0, 1, 0, True)]
s (Split xs) = concat $ mapFL s xs
s (Move _ _) = [(fp2fn "", 0, 0, 0, False)]
s (ChangePref _ _ _) = [(fp2fn "", 0, 0, 0, False)]
s Identity = [(fp2fn "", 0, 0, 0, False)]
append56 f (a,b,c,d,e) = (a,b,c,d,e,f)
(1) .+ _ = 1
_ .+ (1) = 1
a .+ b = a + b
combine ((f,a,b,r,isd,c):(f',a',b',r',_,c'):ss)
| f == f' && (a /= 1 || b' /= 1) && (a' /= 1 || b /= 1) =
combine ((f,a.+a',b.+b',r+r',isd,combineConflitStates c c'):ss)
combine ((f,a,b,r,isd,c):ss) = (f,a,b,r,isd,c) : combine ss
combine [] = []
combineConflitStates Conflicted _ = Conflicted
combineConflitStates _ Conflicted = Conflicted
combineConflitStates Duplicated _ = Duplicated
combineConflitStates _ Duplicated = Duplicated
combineConflitStates Okay Okay = Okay
summ (f,_,1,_,False,Okay)
= if use_xml then text "<remove_file>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</remove_file>"
else text "R" <+> text (fn2fp f)
summ (f,_,1,_,False,Conflicted)
= if use_xml then text "<remove_file conflict='true'>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</remove_file>"
else text "R!" <+> text (fn2fp f)
summ (f,_,1,_,False,Duplicated)
= if use_xml then text "<remove_file duplicate='true'>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</remove_file>"
else text "R" <+> text (fn2fp f) <+> text "(duplicate)"
summ (f,1,_,_,False,Okay)
= if use_xml then text "<add_file>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</add_file>"
else text "A" <+> text (fn2fp f)
summ (f,1,_,_,False,Conflicted)
= if use_xml then text "<add_file conflict='true'>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</add_file>"
else text "A!" <+> text (fn2fp f)
summ (f,1,_,_,False,Duplicated)
= if use_xml then text "<add_file duplicate='true'>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</add_file>"
else text "A" <+> text (fn2fp f) <+> text "(duplicate)"
summ (f,0,0,0,False,Okay) | f == fp2fn "" = empty
summ (f,0,0,0,False,Conflicted) | f == fp2fn ""
= if use_xml then empty
else text "!" <+> text (fn2fp f)
summ (f,0,0,0,False,Duplicated) | f == fp2fn ""
= if use_xml then empty
else text (fn2fp f) <+> text "(duplicate)"
summ (f,a,b,r,False,Okay)
= if use_xml then text "<modify_file>"
$$ escapeXML (drop_dotslash $ fn2fp f)
<> xrm a <> xad b <> xrp r
$$ text "</modify_file>"
else text "M" <+> text (fn2fp f)
<+> rm a <+> ad b <+> rp r
summ (f,a,b,r,False,Conflicted)
= if use_xml then text "<modify_file conflict='true'>"
$$ escapeXML (drop_dotslash $ fn2fp f)
<> xrm a <> xad b <> xrp r
$$ text "</modify_file>"
else text "M!" <+> text (fn2fp f)
<+> rm a <+> ad b <+> rp r
summ (f,a,b,r,False,Duplicated)
= if use_xml then text "<modify_file duplicate='true'>"
$$ escapeXML (drop_dotslash $ fn2fp f)
<> xrm a <> xad b <> xrp r
$$ text "</modify_file>"
else text "M" <+> text (fn2fp f)
<+> rm a <+> ad b <+> rp r <+> text "(duplicate)"
summ (f,_,1,_,True,Okay)
= if use_xml then text "<remove_directory>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</remove_directory>"
else text "R" <+> text (fn2fp f) <> text "/"
summ (f,_,1,_,True,Conflicted)
= if use_xml then text "<remove_directory conflict='true'>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</remove_directory>"
else text "R!" <+> text (fn2fp f) <> text "/"
summ (f,_,1,_,True,Duplicated)
= if use_xml then text "<remove_directory duplicate='true'>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</remove_directory>"
else text "R" <+> text (fn2fp f) <> text "/ (duplicate)"
summ (f,1,_,_,True,Okay)
= if use_xml then text "<add_directory>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</add_directory>"
else text "A" <+> text (fn2fp f) <> text "/"
summ (f,1,_,_,True,Conflicted)
= if use_xml then text "<add_directory conflict='true'>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</add_directory>"
else text "A!" <+> text (fn2fp f) <> text "/"
summ (f,1,_,_,True,Duplicated)
= if use_xml then text "<add_directory duplicate='true'>"
$$ escapeXML (drop_dotslash $ fn2fp f)
$$ text "</add_directory>"
else text "A!" <+> text (fn2fp f) <> text "/ (duplicate)"
summ _ = empty
ad 0 = empty
ad a = plus <> text (show a)
xad 0 = empty
xad a = text "<added_lines num='" <> text (show a) <> text "'/>"
rm 0 = empty
rm a = minus <> text (show a)
xrm 0 = empty
xrm a = text "<removed_lines num='" <> text (show a) <> text "'/>"
rp 0 = empty
rp a = text "r" <> text (show a)
xrp 0 = empty
xrp a = text "<replaced_tokens num='" <> text (show a) <> text "'/>"
drop_dotslash ('.':'/':str) = drop_dotslash str
drop_dotslash str = str
themoves :: [Doc]
themoves = map showmoves p
showmoves :: IsConflictedPrim -> Doc
showmoves (IsC _ (Move a b))
= if use_xml
then text "<move from=\""
<> escapeXML (drop_dotslash $ fn2fp a) <> text "\" to=\""
<> escapeXML (drop_dotslash $ fn2fp b) <> text"\"/>"
else text " " <> text (fn2fp a)
<> text " -> " <> text (fn2fp b)
showmoves _ = empty
instance (Conflict p, ShowPatch p) => ShowPatch (Named p) where
showPatch (NamedP n [] p) = showPatchInfo n <> showPatch p
showPatch (NamedP n d p) = showNamedPrefix n d <+> showPatch p
showContextPatch s (NamedP n [] p) = showPatchInfo n <> showContextPatch s p
showContextPatch s (NamedP n d p) = showNamedPrefix n d <+> showContextPatch s p
description (NamedP n _ _) = human_friendly n
summary p = description p $$ text "" $$
prefix " " (summarize p)
showNicely p@(NamedP _ _ pt) = description p $$
prefix " " (showNicely pt)
instance (Conflict p, ShowPatch p) => Show (Named p C(x y)) where
show = renderString . showPatch
instance (Conflict p, Apply p, Effect p, ShowPatch p) => ShowPatch (FL p) where
showPatch xs = vcat (mapFL showPatch xs)
showContextPatch = showContextSeries
description = vcat . mapFL description
summary = vcat . mapFL summary
thing x = thing (helperx x) ++ "s"
where helperx :: FL a C(x y) -> a C(x y)
helperx _ = undefined
things = thing
instance (Conflict p, Apply p, ShowPatch p) => ShowPatch (RL p) where
showPatch = showPatch . reverseRL
showContextPatch s = showContextPatch s . reverseRL
description = description . reverseRL
summary = summary . reverseRL
thing = thing . reverseRL
things = things . reverseRL
instance (Conflict p, Patchy p) => Patchy (FL p)
instance (Conflict p, Patchy p) => Patchy (RL p)