-- 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, humanFriendly )
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 _ _) = humanFriendly 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)