    -- Copyright (C) 2002-2004 David Roundy
    --
    -- This program is free software; you can redistribute it and/or modify
    -- it under the terms of the GNU General Public License as published by
    -- the Free Software Foundation; either version 2, or (at your option)
    -- any later version.
    --
    -- This program is distributed in the hope that it will be useful,
    -- but WITHOUT ANY WARRANTY; without even the implied warranty of
    -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    -- GNU General Public License for more details.
    --
    -- You should have received a copy of the GNU General Public License
    -- along with this program; see the file COPYING.  If not, write to
    -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
    -- Boston, MA 02110-1301, USA.

    {-# OPTIONS_GHC -cpp -fno-warn-orphans #-}
    {-# LANGUAGE CPP #-}

    module Darcs.Patch.Viewing ( xmlSummary, plainSummary )
                 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 ( FileName, 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(..), primIsHunk, 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 ( applyToTree )
    #include "impossible.h"
    #include "gadts.h"
    import Darcs.Witnesses.Ordered ( RL(..), FL(..),
                                 mapFL, mapFL_FL, reverseRL )

    instance ShowPatch Prim where
        showPatch = showPrim OldFormat
        showContextPatch p@(FP _ (Hunk _ _ _)) = showContextHunk (PP p)
        showContextPatch (Split ps) =
            do x <- showContextSeries (mapFL_FL PP ps)
               return $ blueText "(" $$ x <> blueText ")"
        showContextPatch p = return $ showPatch p
        summary = vcat . map summChunkToLine . genSummary . (:[]) . IsC Okay
        thing _ = "change"

    plainSummary :: (Conflict e, Effect e) => e C(x y) -> Doc
    plainSummary = vcat . map summChunkToLine . genSummary . conflictedEffect

    instance ShowPatch Patch where
        showPatch = showPatch_
        showContextPatch (PP x) | primIsHunk x = showContextHunk (PP x)
        showContextPatch (ComP NilFL) = return $ blueText "{" $$ blueText "}"
        showContextPatch (ComP ps) =
            do x <- showContextSeries ps
               return $ blueText "{" $$ x $$ blueText "}"
        showContextPatch p = return $ showPatch p
        summary = plainSummary
        thing _ = "change"

    showContextSeries :: (Apply p, ShowPatch p, Effect p) => FL p C(x y) -> TreeIO Doc
    showContextSeries patches = scs identity patches
        where scs :: (Apply p, ShowPatch p, Effect p) => Prim 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 identity ps) s'
                                return $ a $$ fst b
                  Just hp ->
                      case ps of
                      NilFL -> coolContextHunk pold hp identity
                      (p2:>:_) ->
                          case isHunk p2 of
                          Nothing -> do a <- coolContextHunk pold hp identity
                                        b <- liftIO $ virtualTreeIO (scs hp ps) s'
                                        return $ a $$ fst b
                          Just hp2 -> do a <- coolContextHunk pold hp hp2
                                         b <- liftIO $ virtualTreeIO (scs hp ps) s'
                                         return $ a $$ fst b
              scs _ NilFL = return empty

    showContextHunk :: (Apply p, ShowPatch p, Effect p) => p C(x y) -> TreeIO Doc
    showContextHunk p = case isHunk p of
                          Just h -> coolContextHunk identity h identity
                          Nothing -> return $ showPatch p

    coolContextHunk :: Prim C(a b) -> Prim C(b c) -> Prim C(c d) -> TreeIO Doc
    coolContextHunk prev p@(FP f (Hunk 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 -- sigh
        Nothing -> return $ showPatch p -- This is a weird error...
        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) | BS.null x -> reverse xs
                            _ -> ls
                post = take numpost $ drop (max 0 $ l+length o-1) 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)
    coolContextHunk _ _ _ = impossible

    xmlSummary :: (Effect p, Patchy p, Conflict p) => Named p C(x y) -> Doc
    xmlSummary p = text "<summary>"
                 $$ (vcat . map summChunkToXML . genSummary . conflictedEffect . patchcontents $ p)
                 $$ text "</summary>"

    -- Yuck duplicated code below...
    escapeXML :: String -> Doc
    escapeXML = text . strReplace '\'' "&apos;" . strReplace '"' "&quot;" .
      strReplace '>' "&gt;" . strReplace '<' "&lt;" . strReplace '&' "&amp;"

    strReplace :: Char -> String -> String -> String
    strReplace _ _ [] = []
    strReplace x y (z:zs)
      | x == z    = y ++ (strReplace x y zs)
      | otherwise = z : (strReplace x y zs)
    -- end yuck duplicated code.

    -- | High-level representation of a piece of patch summary
    data SummChunk = SummChunk SummDetail ConflictState
       deriving (Ord, Eq)

    data SummDetail = SummAddDir FileName
                    | SummRmDir  FileName
                    | SummFile SummOp FileName Int Int Int
                    | SummMv   FileName FileName
                    | SummNone
      deriving (Ord, Eq)

    data SummOp = SummAdd | SummRm | SummMod deriving (Ord, Eq)

    genSummary :: [IsConflictedPrim] -> [SummChunk]
    genSummary p
        = combine $ concatMap s2 p
        where s2 :: IsConflictedPrim -> [SummChunk]
              s2 (IsC c x) = map (\d -> SummChunk d c) $ s x
              s :: Prim C(x y) -> [SummDetail]
              s (FP f (Hunk _ o n)) = [SummFile SummMod f (length o) (length n) 0]
              s (FP f (Binary _ _)) = [SummFile SummMod f 0 0 0]
              s (FP f AddFile) = [SummFile SummAdd f 0 0 0]
              s (FP f RmFile) = [SummFile SummRm f 0 0 0]
              s (FP f (TokReplace _ _ _)) = [SummFile SummMod f 0 0 1]
              s (DP d AddDir) = [SummAddDir d]
              s (DP d RmDir) = [SummRmDir d]
              s (Split xs) = concat $ mapFL s xs
              s (Move f1 f2) = [SummMv f1 f2]
              s (ChangePref _ _ _) = [SummNone]
              s Identity = [SummNone]
              combine (x1@(SummChunk d1 c1) : x2@(SummChunk d2 c2) : ss)
                  = case combineDetail d1 d2 of
                      Nothing -> x1 : combine (x2:ss)
                      Just d3 -> combine $ SummChunk d3 (combineConflitStates c1 c2) : ss
              combine (x:ss) = x  : combine ss
              combine [] = []
              --
              combineDetail (SummFile o1 f1 r1 a1 x1) (SummFile o2 f2 r2 a2 x2) | f1 == f2 =
                do o3 <- combineOp o1 o2
                   return $ SummFile o3 f1 (r1 + r2) (a1 + a2) (x1 + x2)
              combineDetail _ _ = Nothing
              --
              combineConflitStates Conflicted _ = Conflicted
              combineConflitStates _ Conflicted = Conflicted
              combineConflitStates Duplicated _ = Duplicated
              combineConflitStates _ Duplicated = Duplicated
              combineConflitStates Okay Okay = Okay
              -- Don't combine AddFile and RmFile: (maybe an old revision of) darcs
              -- allows a single patch to add and remove the same file, see issue 185
              combineOp SummAdd SummRm  = Nothing
              combineOp SummRm  SummAdd = Nothing
              combineOp SummAdd _ = Just SummAdd
              combineOp _ SummAdd = Just SummAdd
              combineOp SummRm  _ = Just SummRm
              combineOp _ SummRm  = Just SummRm
              combineOp SummMod SummMod = Just SummMod

    summChunkToXML :: SummChunk -> Doc
    summChunkToXML (SummChunk detail c) =
     case detail of
       SummRmDir f  -> xconf c "remove_directory" (xfn f)
       SummAddDir f -> xconf c "add_directory"    (xfn f)
       SummFile SummRm  f _ _ _ -> xconf c "remove_file" (xfn f)
       SummFile SummAdd f _ _ _ -> xconf c "add_file"    (xfn f)
       SummFile SummMod f r a x -> xconf c "modify_file" $ xfn f <> xrm r <> xad a <> xrp x
       SummMv f1 f2  -> text "<move from=\"" <> xfn f1
                          <> text "\" to=\"" <> xfn f2 <> text"\"/>"
       SummNone      -> empty
     where
       xconf Okay t x       = text ('<':t++">") $$ x $$ text ("</"++t++">")
       xconf Conflicted t x = text ('<':t++" conflict='true'>") $$ x $$ text ("</"++t++">")
       xconf Duplicated t x = text ('<':t++" duplicate='true'>") $$ x $$ text ("</"++t++">")
       xfn = escapeXML . dropDotSlash .fn2fp
       --
       xad 0 = empty
       xad a = text "<added_lines num='" <> text (show a) <> text "'/>"
       xrm 0 = empty
       xrm a = text "<removed_lines num='" <> text (show a) <> text "'/>"
       xrp 0 = empty
       xrp a = text "<replaced_tokens num='" <> text (show a) <> text "'/>"

    summChunkToLine :: SummChunk -> Doc
    summChunkToLine (SummChunk detail c) =
      case detail of
       SummRmDir f   -> lconf c "R" $ text (fn2fp f) <> text "/"
       SummAddDir f  -> lconf c "A" $ text (fn2fp f) <> text "/"
       SummFile SummRm  f _ _ _ -> lconf c "R" $ text (fn2fp f)
       SummFile SummAdd f _ _ _ -> lconf c "A" $ text (fn2fp f)
       SummFile SummMod f r a x -> lconf c "M" $ text (fn2fp f) <+> rm r <+> ad a <+> rp x
       SummMv f1 f2 -> text " "    <> text (fn2fp f1)
                    <> text " -> " <> text (fn2fp f2)
       SummNone -> case c of
                   Okay -> empty
                   _    -> lconf c ""  empty
      where
       lconf Okay       t x = text t <+> x
       lconf Conflicted t x = text (t ++ "!") <+> x
       lconf Duplicated t x = text t <+> x <+> text "duplicate"
       --
       ad 0 = empty
       ad a = plus <> text (show a)
       rm 0 = empty
       rm a = minus <> text (show a)
       rp 0 = empty
       rp a = text "r" <> text (show a)

    dropDotSlash :: FilePath -> FilePath
    dropDotSlash ('.':'/':str) = dropDotSlash str
    dropDotSlash str = str

    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 (NamedP n [] p) = showContextPatch p >>= return . (showPatchInfo n <>)
        showContextPatch (NamedP n d p) = showContextPatch p >>= return . (showNamedPrefix n d <+>)
        description (NamedP n _ _) = human_friendly n
        summary p = description p $$ text "" $$
                    prefix "    " (plainSummary p) -- this isn't summary because summary does the
                                                -- wrong thing with (Named (FL p)) so that it can
                                                -- get the summary of a sequence of named patches
                                                -- right.
        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 = showContextPatch . 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)