module Darcs.Patch.Viewing
( showContextHunk, showContextSeries
)
where
import Prelude hiding ( pi, readFile )
import Control.Monad.State.Strict ( gets )
import Control.Monad.Trans ( liftIO )
import Storage.Hashed.Monad( TreeIO, fileExists, readFile, tree, virtualTreeIO )
import Storage.Hashed.AnchoredPath( floatPath )
import ByteStringUtils (linesPS )
import qualified Data.ByteString as BS (null, concat)
import qualified Data.ByteString.Lazy as BL (toChunks)
import Darcs.Patch.FileName ( fn2fp )
import Printer ( Doc, empty, vcat,
text, blueText, Color(Cyan,Magenta), lineColor,
($$), (<+>),
prefix,
userchunkPS,
)
import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) )
import Darcs.Patch.FileHunk ( IsHunk(..), FileHunk(..), showFileHunk )
import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), formatFileName )
import Darcs.Patch.Apply ( Apply(..), applyToTree )
#include "gadts.h"
import Darcs.Witnesses.Ordered ( RL(..), FL(..),
mapFL, mapFL_FL, reverseRL, concatFL )
showContextSeries :: (Apply p, ShowPatch p, IsHunk p) => FL p C(x y) -> TreeIO Doc
showContextSeries patches = scs Nothing patches
where scs :: (Apply p, ShowPatch p, IsHunk p) => Maybe (FileHunk C(w x)) -> FL p C(x y) -> TreeIO Doc
scs pold (p:>:ps) = do
s' <- gets tree >>= liftIO . applyToTree p
case isHunk p of
Nothing -> do a <- showContextPatch p
b <- liftIO $ virtualTreeIO (scs Nothing ps) s'
return $ a $$ fst b
Just fh ->
case ps of
NilFL -> coolContextHunk pold fh Nothing
(p2:>:_) -> do a <- coolContextHunk pold fh (isHunk p2)
b <- liftIO $ virtualTreeIO (scs (Just fh) ps) s'
return $ a $$ fst b
scs _ NilFL = return empty
showContextHunk :: FileHunk C(x y) -> TreeIO Doc
showContextHunk h = coolContextHunk Nothing h Nothing
coolContextHunk :: Maybe (FileHunk C(a b)) -> FileHunk C(b c) -> Maybe (FileHunk C(c d)) -> TreeIO Doc
coolContextHunk prev fh@(FileHunk f l o n) next = do
let path = floatPath $ fn2fp f
have <- fileExists path
content <- if have then Just `fmap` readFile path else return Nothing
case (linesPS . BS.concat . BL.toChunks) `fmap` content of
Nothing -> return $ showFileHunk OldFormat fh
Just ls ->
let numpre = case prev of
Just (FileHunk f' 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
Just (FileHunk f' lnext _ _)
| f' == f && lnext < l+length n+4 &&
lnext > l ->
lnext (l+length n)
_ -> 3
cleanedls = case reverse ls of
(x:xs) | BS.null x -> reverse xs
_ -> ls
post = take numpost $ drop (max 0 $ l+length o1) cleanedls
in return $ 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)
instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (FL p) where
showPatch = showPatchInternal patchListFormat
where showPatchInternal :: ListFormat p -> FL p C(x y) -> Doc
showPatchInternal ListFormatV1 (p :>: NilFL) = showPatch p
showPatchInternal ListFormatV1 NilFL = blueText "{" $$ blueText "}"
showPatchInternal ListFormatV1 ps = blueText "{" $$ vcat (mapFL showPatch ps) $$ blueText "}"
showPatchInternal ListFormatV2 ps = vcat (mapFL showPatch ps)
showPatchInternal ListFormatDefault ps = vcat (mapFL showPatch ps)
instance (Apply p, IsHunk p, PatchListFormat p, ShowPatch p) => ShowPatch (FL p) where
showContextPatch = showContextPatchInternal patchListFormat
where showContextPatchInternal :: ListFormat p -> FL p C(x y) -> TreeIO Doc
showContextPatchInternal ListFormatV1 (p :>: NilFL) = showContextPatch p
showContextPatchInternal ListFormatV1 NilFL = return $ blueText "{" $$ blueText "}"
showContextPatchInternal ListFormatV1 ps = do x <- showContextSeries ps
return $ blueText "{" $$ x $$ blueText "}"
showContextPatchInternal ListFormatV2 ps = showContextSeries ps
showContextPatchInternal ListFormatDefault ps = showContextSeries ps
description = vcat . mapFL description
summary = summaryFL
summaryFL = summaryFL . concatFL
thing x = thing (helperx x) ++ "s"
where helperx :: FL a C(x y) -> a C(x y)
helperx _ = undefined
things = thing
instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RL p) where
showPatch = showPatch . reverseRL
instance (Apply p, IsHunk p, PatchListFormat p, ShowPatch p) => ShowPatch (RL p) where
showContextPatch = showContextPatch . reverseRL
description = description . reverseRL
summary = summary . reverseRL
summaryFL = summaryFL . mapFL_FL reverseRL
thing = thing . reverseRL
things = things . reverseRL