{-# 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
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
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
| 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 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 ""