-- 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 ( 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 -- 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) | B.null x -> reverse xs
                        _ -> ls
            post = take numpost $ drop (max 0 $ l+length o-1) 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>"

-- 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.

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)
              -- 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
              | 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 -- don't know what to do here...
                           else text "!" <+> text (fn2fp f)
          summ (f,0,0,0,False,Duplicated) | f == fp2fn ""
              = if use_xml then empty -- don't know what to do here...
                           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) -- 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 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)