{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ViewPatterns #-}
module Darcs.Patch.Prim.V1.Show
    ( showHunk )
    where

import Prelude ()
import Darcs.Prelude

import Darcs.Util.ByteString ( fromPS2Hex )
import qualified Data.ByteString as B (ByteString, length, take, drop)
import qualified Data.ByteString.Char8 as BC (head)

import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.FileHunk ( FileHunk(..), showFileHunk )
import Darcs.Patch.Format ( FileNameFormat )
import Darcs.Patch.Show ( formatFileName )
import Darcs.Patch.Permutations () -- for Invert instance of FL
import Darcs.Patch.Prim.Class ( PrimShow(..) )
import Darcs.Patch.Prim.V1.Core
     ( Prim(..), FilePatchType(..), DirPatchType(..) )
import Darcs.Patch.Prim.V1.Details ()
import Darcs.Patch.Viewing ( showContextHunk )
import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(..) )

import Darcs.Util.Path ( FileName )
import Darcs.Util.Printer ( Doc, vcat,
                 text, userchunk, invisibleText, invisiblePS, blueText,
                 ($$), (<+>)
               )
import Darcs.Util.Show ( appPrec, BSWrapper(..) )
import Darcs.Util.Tree ( Tree )


instance Show (Prim wX wY) where
    showsPrec d (Move fn1 fn2) = showParen (d > appPrec) $ showString "Move " .
                                 showsPrec (appPrec + 1) fn1 . showString " " .
                                 showsPrec (appPrec + 1) fn2
    showsPrec d (DP fn dp) = showParen (d > appPrec) $ showString "DP " .
                             showsPrec (appPrec + 1) fn . showString " " .
                             showsPrec (appPrec + 1) dp
    showsPrec d (FP fn fp) = showParen (d > appPrec) $ showString "FP " .
                             showsPrec (appPrec + 1) fn . showString " " .
                             showsPrec (appPrec + 1) fp
    showsPrec d (ChangePref p f t) = showParen (d > appPrec) $ showString "ChangePref " .
                                     showsPrec (appPrec + 1) p . showString " " .
                                     showsPrec (appPrec + 1) f . showString " " .
                                     showsPrec (appPrec + 1) t

instance Show2 Prim where
   showDict2 = ShowDictClass

instance Show1 (Prim wX) where
   showDict1 = ShowDictClass

instance Show (FilePatchType wX wY) where
    showsPrec _ RmFile = showString "RmFile"
    showsPrec _ AddFile = showString "AddFile"
    showsPrec d (Hunk line old new) | all ((==1) . B.length) old && all ((==1) . B.length) new
        = showParen (d > appPrec) $ showString "Hunk " .
                                      showsPrec (appPrec + 1) line . showString " " .
                                      showsPrecC old . showString " " .
                                      showsPrecC new
       where showsPrecC [] = showString "[]"
             showsPrecC ss = showParen True $ showString "packStringLetters " . showsPrec (appPrec + 1) (map BC.head ss)
    showsPrec d (Hunk line old new) = showParen (d > appPrec) $ showString "Hunk " .
                                      showsPrec (appPrec + 1) line . showString " " .
                                      showsPrec (appPrec + 1) (map BSWrapper old) . showString " " .
                                      showsPrec (appPrec + 1) (map BSWrapper new)
    showsPrec d (TokReplace t old new) = showParen (d > appPrec) $ showString "TokReplace " .
                                         showsPrec (appPrec + 1) t . showString " " .
                                         showsPrec (appPrec + 1) old . showString " " .
                                         showsPrec (appPrec + 1) new
    -- this case may not work usefully
    showsPrec d (Binary old new) = showParen (d > appPrec) $ showString "Binary " .
                                   showsPrec (appPrec + 1) (BSWrapper old) . showString " " .
                                   showsPrec (appPrec + 1) (BSWrapper new)

instance Show (DirPatchType wX wY) where
    showsPrec _ RmDir = showString "RmDir"
    showsPrec _ AddDir = showString "AddDir"

instance ApplyState Prim ~ Tree => PrimShow Prim where
  showPrim fmt (FP f AddFile) = showAddFile fmt f
  showPrim fmt (FP f RmFile)  = showRmFile fmt f
  showPrim fmt (FP f (Hunk line old new))  = showHunk fmt f line old new
  showPrim fmt (FP f (TokReplace t old new))  = showTok fmt f t old new
  showPrim fmt (FP f (Binary old new))  = showBinary fmt f old new
  showPrim fmt (DP d AddDir) = showAddDir fmt d
  showPrim fmt (DP d RmDir)  = showRmDir fmt d
  showPrim fmt (Move f f') = showMove fmt f f'
  showPrim _ (ChangePref p f t) = showChangePref p f t
  showPrimCtx fmt (FP f (Hunk line old new)) = showContextHunk fmt (FileHunk f line old new)
  showPrimCtx fmt p = return $ showPrim fmt p

showAddFile :: FileNameFormat -> FileName -> Doc
showAddFile fmt f = blueText "addfile" <+> formatFileName fmt f

showRmFile :: FileNameFormat -> FileName -> Doc
showRmFile fmt f = blueText "rmfile" <+> formatFileName fmt f

showMove :: FileNameFormat -> FileName -> FileName -> Doc
showMove fmt d d' = blueText "move" <+> formatFileName fmt d <+> formatFileName fmt d'

showChangePref :: String -> String -> String -> Doc
showChangePref p f t = blueText "changepref" <+> text p
                    $$ userchunk f
                    $$ userchunk t

showAddDir :: FileNameFormat -> FileName -> Doc
showAddDir fmt d = blueText "adddir" <+> formatFileName fmt d

showRmDir :: FileNameFormat -> FileName -> Doc
showRmDir fmt d = blueText "rmdir" <+> formatFileName fmt d

showHunk :: FileNameFormat -> FileName -> Int -> [B.ByteString] -> [B.ByteString] -> Doc
showHunk fmt f line old new = showFileHunk fmt (FileHunk f line old new)

showTok :: FileNameFormat -> FileName -> String -> String -> String -> Doc
showTok fmt f t o n = blueText "replace" <+> formatFileName fmt f
                                     <+> text "[" <> userchunk t <> text "]"
                                     <+> userchunk o
                                     <+> userchunk n

showBinary :: FileNameFormat -> FileName -> B.ByteString -> B.ByteString -> Doc
showBinary fmt f o n =
    blueText "binary" <+> formatFileName fmt f
 $$ invisibleText "oldhex"
 $$ vcat (map makeprintable $ breakEvery 78 $ fromPS2Hex o)
 $$ invisibleText "newhex"
 $$ vcat (map makeprintable $ breakEvery 78 $ fromPS2Hex n)
     where makeprintable ps = invisibleText "*" <> invisiblePS ps

breakEvery :: Int -> B.ByteString -> [B.ByteString]
breakEvery n ps | B.length ps < n = [ps]
                 | otherwise = B.take n ps : breakEvery n (B.drop n ps)