module Darcs.Patch.Viewing
( showContextHunk, showContextSeries
)
where
import Prelude hiding ( pi, readFile )
import Control.Applicative( (<$>) )
import Storage.Hashed.Monad( TreeIO, fileExists, readFile, tree, virtualTreeMonad )
import Storage.Hashed.Tree( Tree )
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(..), applyToState )
import Darcs.Patch.ApplyMonad ( ApplyMonadTrans, runApplyMonad, getApplyState
, ApplyMonadOver, ApplyMonad(..), toTree )
#include "gadts.h"
import Darcs.Witnesses.Ordered ( RL(..), FL(..),
mapFL, mapFL_FL, reverseRL, concatFL )
showContextSeries :: forall p m x y. (Apply p, ShowPatch p, IsHunk p,
ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p))
=> FL p C(x y) -> m Doc
showContextSeries patches = scs Nothing patches
where scs :: forall m' ww xx yy.
(ApplyMonadTrans m' (ApplyState p), ApplyMonad m' (ApplyState p), ApplyMonadBase m ~ ApplyMonadBase m')
=> Maybe (FileHunk C(ww xx)) -> FL p C(xx yy) -> m' Doc
scs pold (p:>:ps) = do
(_, s') <- nestedApply (apply p) =<< getApplyState
case isHunk p of
Nothing -> do a <- showContextPatch p
b <- nestedApply (scs Nothing ps) s'
return $ a $$ fst b
Just fh ->
case ps of
NilFL -> fst <$> liftApply (cool pold fh Nothing) s'
(p2:>:_) -> do a <- fst <$> liftApply (cool pold fh (isHunk p2)) s'
b <- nestedApply (scs (Just fh) ps) s'
return $ a $$ fst b
scs _ NilFL = return empty
cool :: Maybe (FileHunk C(a b))
-> FileHunk C(b c)
-> Maybe (FileHunk C(c d))
-> (ApplyState p) (ApplyMonadBase m)
-> (ApplyMonadBase m) Doc
cool pold fh ps s = fst <$> virtualTreeMonad (coolContextHunk pold fh ps) (toTree s)
showContextHunk :: (ApplyMonad m Tree) => FileHunk C(x y) -> m Doc
showContextHunk h = coolContextHunk Nothing h Nothing
coolContextHunk :: (ApplyMonad m Tree, ApplyMonadTrans m Tree)
=> Maybe (FileHunk C(a b)) -> FileHunk C(b c) -> Maybe (FileHunk C(c d)) -> m Doc
coolContextHunk prev fh@(FileHunk f l o n) next = do
have <- mDoesFileExist f
content <- if have then Just `fmap` mReadFilePS f else return Nothing
case linesPS `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 :: (ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState (FL p)))
=> ListFormat p -> FL p C(x y) -> m 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