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