--  Copyright (C) 2002-2003 David Roundy, 2010 Ganesh Sittampalam
{-# LANGUAGE ViewPatterns #-}
module Darcs.Patch.Conflict
    ( Conflict(..), CommuteNoConflicts(..), listConflictedFiles
    , IsConflictedPrim(..), ConflictState(..)
    , mangleUnravelled
    ) where

import Prelude ()
import Darcs.Prelude

import qualified Data.ByteString.Char8 as BC (pack, last)
import qualified Data.ByteString       as B (null, ByteString)
import Data.Maybe ( isJust )
import Data.List ( sort, intercalate )
import Data.List.Ordered ( nubSort )

import Darcs.Patch.Effect ( Effect(..) )
import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk, isHunk )
import Darcs.Patch.Inspect ( PatchInspect(..) )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Permutations ()
import Darcs.Patch.Prim ( PrimPatch, is_filepatch, primIsHunk, primFromHunk )
import Darcs.Patch.Prim.Class ( PrimOf )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), RL(..), (:>)(..)
    , mapFL, reverseFL, mapRL, reverseRL
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, mapSeal )
import Darcs.Patch.Witnesses.Show ( Show2, showsPrec2 )
import Darcs.Util.Path ( FileName, fn2fp, fp2fn )
import Darcs.Util.Show ( appPrec )

listConflictedFiles :: Conflict p => p wX wY -> [FilePath]
listConflictedFiles p =
    nubSort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p

class (Effect p, PatchInspect (PrimOf p)) => Conflict p where
    resolveConflicts :: p wX wY -> [[Sealed (FL (PrimOf p) wY)]]

    conflictedEffect :: p wX wY -> [IsConflictedPrim (PrimOf p)]

class CommuteNoConflicts p where
    -- | If 'commuteNoConflicts' @x :> y@ succeeds, we know that that @x@ commutes
    --   past @y@ without any conflicts.   This function is useful for patch types
    --   for which 'commute' is defined to always succeed; so we need some way to
    --   pick out the specific cases where commutation succeeds without any conflicts.
    commuteNoConflicts :: (p :> p) wX wY -> Maybe ((p :> p) wX wY)

instance (CommuteNoConflicts p, Conflict p) => Conflict (FL p) where
    resolveConflicts NilFL = []
    resolveConflicts x = resolveConflicts $ reverseFL x
    conflictedEffect = concat . mapFL conflictedEffect

instance CommuteNoConflicts p => CommuteNoConflicts (FL p) where
    commuteNoConflicts (NilFL :> x) = Just (x :> NilFL)
    commuteNoConflicts (x :> NilFL) = Just (NilFL :> x)
    commuteNoConflicts (xs :> ys) =   do ys' :> rxs' <- commuteNoConflictsRLFL (reverseFL xs :> ys)
                                         return $ ys' :> reverseRL rxs'

instance (CommuteNoConflicts p, Conflict p) => Conflict (RL p) where
    -- By definition, a conflicting (primitive) patch is resolved if
    -- another (primitive) patch depends on the conflict.
    -- 
    -- So, when looking for conflicts in a list of patches, we go
    -- through the whole list looking for individual patches that are
    -- in conflict. But then we try to commute them past all the
    -- patches we've already seen. If we fail, i.e. there's something
    -- that depends on the conflict, then we forget about the conflict;
    -- this is the Nothing case of the 'commuteNoConflictsFL' call.
    --
    -- Note that 'primitive' does not mean Prim (this is a case of bad
    -- naming) but rather a RepoPatchV1 or RepoPatchV2. Prim patches
    -- are merely a 'base class' containing everything common to V1 and
    -- V2 primitive patches.
    resolveConflicts x = rcs x NilFL
      where
        rcs :: RL p wX wY -> FL p wY wW -> [[Sealed (FL (PrimOf p) wW)]]
        rcs NilRL _ = []
        rcs (ps :<: p) passedby
          | null (resolveConflicts p) = seq passedby rest -- TODO why seq here?
          | otherwise =
            case commuteNoConflictsFL (p :> passedby) of
              Just (_ :> p') -> resolveConflicts p' ++ rest
              Nothing -> rest
          where
            rest = rcs ps (p :>: passedby)
    conflictedEffect = concat . reverse . mapRL conflictedEffect

instance CommuteNoConflicts p => CommuteNoConflicts (RL p) where
    commuteNoConflicts (NilRL :> x) = Just (x :> NilRL)
    commuteNoConflicts (x :> NilRL) = Just (NilRL :> x)
    commuteNoConflicts (xs :> ys) =   do ys' :> rxs' <- commuteNoConflictsRLFL (xs :> reverseRL ys)
                                         return $ reverseFL ys' :> rxs'

data IsConflictedPrim prim where
    IsC :: !ConflictState -> !(prim wX wY) -> IsConflictedPrim prim
data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read)

instance Show2 prim => Show (IsConflictedPrim prim) where
    showsPrec d (IsC cs prim) =
        showParen (d > appPrec) $
            showString "IsC " . showsPrec (appPrec + 1) cs .
            showString " " . showsPrec2 (appPrec + 1) prim

commuteNoConflictsFL :: CommuteNoConflicts p => (p :> FL p) wX wY -> Maybe ((FL p :> p) wX wY)
commuteNoConflictsFL (p :> NilFL) = Just (NilFL :> p)
commuteNoConflictsFL (q :> p :>: ps) =   do p' :> q' <- commuteNoConflicts (q :> p)
                                            ps' :> q'' <- commuteNoConflictsFL (q' :> ps)
                                            return (p' :>: ps' :> q'')

commuteNoConflictsRL :: CommuteNoConflicts p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY)
commuteNoConflictsRL (NilRL :> p) = Just (p :> NilRL)
commuteNoConflictsRL (ps :<: p :> q) =   do q' :> p' <- commuteNoConflicts (p :> q)
                                            q'' :> ps' <- commuteNoConflictsRL (ps :> q')
                                            return (q'' :> ps' :<: p')

commuteNoConflictsRLFL :: CommuteNoConflicts p => (RL p :> FL p) wX wY -> Maybe ((FL p :> RL p) wX wY)
commuteNoConflictsRLFL (NilRL :> ys) = Just (ys :> NilRL)
commuteNoConflictsRLFL (xs :> NilFL) = Just (NilFL :> xs)
commuteNoConflictsRLFL (xs :> y :>: ys) =   do y' :> xs' <- commuteNoConflictsRL (xs :> y)
                                               ys' :> xs'' <- commuteNoConflictsRLFL (xs' :> ys)
                                               return (y' :>: ys' :> xs'')


applyHunks :: IsHunk prim => [Maybe B.ByteString] -> FL prim wX wY -> [Maybe B.ByteString]
applyHunks ms ((isHunk -> Just (FileHunk _ l o n)):>:ps) = applyHunks (rls l ms) ps
    where rls k _ | k <=0 = bug $ "bad hunk: start position <=0 (" ++ show k ++ ")"
          rls 1 mls = map Just n ++ drop (length o) mls
          rls i (ml:mls) = ml : rls (i-1) mls
          rls _ [] = bug "rls in applyHunks"
applyHunks ms NilFL = ms
applyHunks _ (_:>:_) = impossible

getAFilename :: PrimPatch prim => [Sealed (FL prim wX)] -> FileName
getAFilename (Sealed ((is_filepatch -> Just f):>:_):_) = f
getAFilename _ = fp2fn ""

getOld :: PrimPatch prim => [Maybe B.ByteString] -> [Sealed (FL prim wX)] -> [Maybe B.ByteString]
getOld = foldl getHunksOld

getHunksOld :: PrimPatch prim => [Maybe B.ByteString] -> Sealed (FL prim wX)
              -> [Maybe B.ByteString]
getHunksOld mls (Sealed ps) =
    applyHunks (applyHunks mls ps) (invert ps)

getHunksNew :: IsHunk prim => [Maybe B.ByteString] -> Sealed (FL prim wX)
              -> [Maybe B.ByteString]
getHunksNew mls (Sealed ps) = applyHunks mls ps

getHunkline :: [[Maybe B.ByteString]] -> Int
getHunkline = ghl 1
    where ghl :: Int -> [[Maybe B.ByteString]] -> Int
          ghl n pps =
            if any (isJust . head) pps
            then n
            else ghl (n+1) $ map tail pps

makeChunk :: Int -> [Maybe B.ByteString] -> [B.ByteString]
makeChunk n mls = pull_chunk $ drop (n-1) mls
    where pull_chunk (Just l:mls') = l : pull_chunk mls'
          pull_chunk (Nothing:_) = []
          pull_chunk [] = bug "should this be [] in pull_chunk?"


mangleUnravelled :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (FL prim wX)
mangleUnravelled pss = if onlyHunks pss
                        then (:>: NilFL) `mapSeal` mangleUnravelledHunks pss
                        else head pss

onlyHunks :: forall prim wX . PrimPatch prim => [Sealed (FL prim wX)] -> Bool
onlyHunks [] = False
onlyHunks pss = fn2fp f /= "" && all oh pss
    where f = getAFilename pss
          oh :: Sealed (FL prim wY) -> Bool
          oh (Sealed (p:>:ps)) = primIsHunk p &&
                                 [fn2fp f] == listTouchedFiles p &&
                                 oh (Sealed ps)
          oh (Sealed NilFL) = True

mangleUnravelledHunks :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (prim wX)
--mangleUnravelledHunks [[h1],[h2]] = Deal with simple cases handily?
mangleUnravelledHunks pss =
        if null nchs then bug "mangleUnravelledHunks"
                     else Sealed (primFromHunk (FileHunk filename l old new))
    where oldf = getOld (repeat Nothing) pss
          newfs = map (getHunksNew oldf) pss
          l = getHunkline $ oldf : newfs
          nchs = sort $ map (makeChunk l) newfs
          filename = getAFilename pss
          old = makeChunk l oldf
          new = [top] ++ old ++ [initial] ++ intercalate [middle] nchs ++ [bottom]
          top    = BC.pack $ "v v v v v v v" ++ eol_c
          initial= BC.pack $ "=============" ++ eol_c
          middle = BC.pack $ "*************" ++ eol_c
          bottom = BC.pack $ "^ ^ ^ ^ ^ ^ ^" ++ eol_c
          eol_c  = if any (\ps -> not (B.null ps) && BC.last ps == '\r') old
                   then "\r"
                   else ""