-- Copyright (C) 2003-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. {-# LANGUAGE CPP , ScopedTypeVariables #-} module Darcs.Patch.Depends ( getUncovered , areUnrelatedRepos , findCommonAndUncommon , mergeThem , findCommonWithThem , countUsThem , removeFromPatchSet , slightlyOptimizePatchset , getPatchesBeyondTag , splitOnTag , newsetUnion , newsetIntersection , commuteToEnd , findUncommon , merge2FL ) where #include "impossible.h" import Prelude hiding ( pi ) import Data.List ( delete, intersect, (\\) ) import Data.Maybe ( fromMaybe ) import Darcs.Patch ( Patchy, getdeps, commute, commuteFLorComplain, commuteRL ) import Darcs.Patch.Info ( PatchInfo, isTag, showPatchInfoUI ) import Darcs.Patch.Merge ( Merge, mergeFL ) import Darcs.Patch.Permutations ( partitionFL, partitionRL, removeSubsequenceRL ) import Darcs.Patch.PatchInfoAnd( PatchInfoAnd, hopefully, hopefullyM, info ) import Darcs.Patch.Rebase.NameHack ( NameHack ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL, appendPSFL ) import Darcs.Patch.Progress ( progressRL ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=\/=), (=/\=) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart ) import Darcs.Patch.Witnesses.Ordered ( (:\/:)(..), (:/\:)(..), (:>)(..), Fork(..), (+>+), mapFL, RL(..), FL(..), isShorterThanRL, (+<+), reverseFL, reverseRL, mapRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FlippedSeal(..), flipSeal, seal ) import Darcs.Util.Printer ( renderString, vcat, RenderMode(..) ) {- - This module uses the following definitions: - - Explicit dependencies: the set of patches that a patch depends on "by name", - i.e. irrespective of (non-)commutation (non commuting patches are implicit - dependencies, or conflicts). In other words, the set of patch names in a tag - or patch recorded with --ask-deps. - - Covered: a patch p covers another, q, if p's explicit dependencies include - q. E.g. in a repo [a,b,t] where t is a tag and a,b have no explicit - dependencies, then t will cover a and b. - - "Clean" tag: a tag in a repository is clean if all patches prior to the tag - are (transitively-)covered by the tag. An obvious example of obtaining an - unclean tag is by pulling from one repo into another - the tag could have - been commuted past other patches. When patches are created, they are clean, - since they explicitly depend on all uncovered patches. -} {-| taggedIntersection takes two 'PatchSet's and splits them into a /common/ intersection portion and two sets of patches. The intersection, however, is only lazily determined, so there is no guarantee that all intersecting patches will be included in the intersection 'PatchSet'. This is a pretty efficient function, because it makes use of the already-broken-up nature of 'PatchSet's. Note that the first argument to taggedIntersection should be the repository that is more cheaply accessed (i.e. local), as taggedIntersection does its best to reduce the number of inventories that are accessed from its rightmost argument. -} taggedIntersection :: forall p wStart wX wY . (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> Fork (RL (Tagged p)) (RL (PatchInfoAnd p)) (RL (PatchInfoAnd p)) wStart wX wY taggedIntersection (PatchSet ps1 NilRL) s2 = Fork NilRL ps1 (newset2RL s2) taggedIntersection s1 (PatchSet ps2 NilRL) = Fork NilRL (newset2RL s1) ps2 taggedIntersection s1 (PatchSet ps2 (Tagged t _ _ :<: _)) | Just (PatchSet ps1 ts1) <- maybeSplitSetOnTag (info t) s1 = Fork ts1 ps1 (unsafeCoercePStart ps2) taggedIntersection s1 s2@(PatchSet ps2 (Tagged t _ p :<: ts2)) = case hopefullyM t of Just _ -> taggedIntersection s1 (PatchSet (ps2 +<+ t :<: p) ts2) Nothing -> case splitOnTag (info t) s1 of Just (PatchSet NilRL com :> us) -> Fork com us (unsafeCoercePStart ps2) Just _ -> impossible Nothing -> Fork NilRL (newset2RL s1) (newset2RL s2) -- |'maybeSplitSetOnTag' takes a tag's 'PatchInfo', @t0@, and a 'PatchSet' and -- attempts to find @t0@ in one of the 'Tagged's in the PatchSet. If the tag is -- found, the PatchSet is split up, on that tag, such that all later patches -- are in the "since last tag" patch list. If the tag is not found, 'Nothing' -- is returned. maybeSplitSetOnTag :: PatchInfo -> PatchSet p wStart wX -> Maybe (PatchSet p wStart wX) maybeSplitSetOnTag t0 origSet@(PatchSet ps (Tagged t _ pst :<: ts)) | t0 == info t = Just origSet | otherwise = do PatchSet ps' ts' <- maybeSplitSetOnTag t0 (PatchSet (t :<: pst) ts) Just $ PatchSet (ps +<+ ps') ts' maybeSplitSetOnTag _ _ = Nothing getPatchesBeyondTag :: (Patchy p, NameHack p) => PatchInfo -> PatchSet p wStart wX -> FlippedSeal (RL (PatchInfoAnd p)) wX getPatchesBeyondTag t (PatchSet ps (Tagged hp _ _ :<: _)) | info hp == t = flipSeal ps getPatchesBeyondTag t patchset@(PatchSet (hp :<: ps) ts) = if info hp == t then if getUncovered patchset == [info hp] -- special case to avoid looking at redundant patches then flipSeal NilRL else case splitOnTag t patchset of Just (_ :> e) -> flipSeal e _ -> impossible else case getPatchesBeyondTag t (PatchSet ps ts) of FlippedSeal xxs -> FlippedSeal (hp :<: xxs) getPatchesBeyondTag t (PatchSet NilRL NilRL) = bug $ "tag\n" ++ renderString Encode (showPatchInfoUI t) ++ "\nis not in the patchset in getPatchesBeyondTag." getPatchesBeyondTag t0 (PatchSet NilRL (Tagged t _ ps :<: ts)) = getPatchesBeyondTag t0 (PatchSet (t :<: ps) ts) -- |splitOnTag takes a tag's 'PatchInfo', and a 'PatchSet', and attempts to -- find the tag in the PatchSet, returning a pair: the clean PatchSet "up to" -- the tag, and a RL of patches after the tag; If the tag is not in the -- PatchSet, we return Nothing. splitOnTag :: (Patchy p, NameHack p) => PatchInfo -> PatchSet p wStart wX -> Maybe ((PatchSet p :> RL (PatchInfoAnd p)) wStart wX) -- If the tag we are looking for is the first Tagged tag of the patchset, just -- separate out the patchset's patches. splitOnTag t (PatchSet ps ts@(Tagged hp _ _ :<: _)) | info hp == t = Just $ PatchSet NilRL ts :> ps -- If the tag is the most recent patch in the set, we check if the patch is the -- only non-depended-on patch in the set (i.e. it is a clean tag); creating a -- new Tagged out of the patches and tag, and adding it to the patchset, if -- this is the case. Otherwise, we try to make the tag clean. splitOnTag t patchset@(PatchSet hps@(hp :<: ps) ts) | info hp == t = if getUncovered patchset == [t] then Just $ PatchSet NilRL (Tagged hp Nothing ps :<: ts) :> NilRL else case partitionRL ((`notElem` (t : ds)) . info) hps of -- Partition hps by those that are the tag and its explicit deps. tagAndDeps@(hp' :<: ds') :> nonDeps -> -- If @ds@ doesn't contain the tag of the first Tagged, that -- tag will also be returned by the call to getUncovered - so -- we need to unwrap the next Tagged in order to expose it to -- being partitioned out in the recursive call to splitOnTag. if getUncovered (PatchSet tagAndDeps ts) == [t] then let tagged = Tagged hp' Nothing ds' in return $ PatchSet NilRL (tagged :<: ts) :> nonDeps else do unfolded <- unwrapOneTagged $ PatchSet tagAndDeps ts xx :> yy <- splitOnTag t unfolded return $ xx :> (nonDeps +<+ yy) _ -> impossible where ds = getdeps (hopefully hp) -- We drop the leading patch, to try and find a non-Tagged tag. splitOnTag t (PatchSet (p :<: ps) ts) = do ns :> x <- splitOnTag t (PatchSet ps ts) return $ ns :> (p :<: x) -- If there are no patches left, we "unfold" the next Tagged, and try again. splitOnTag t0 patchset@(PatchSet NilRL (Tagged _ _ _s :<: _)) = unwrapOneTagged patchset >>= splitOnTag t0 -- If we've checked all the patches, but haven't found the tag, return Nothing. splitOnTag _ (PatchSet NilRL NilRL) = Nothing -- |'unwrapOneTagged' unfolds a single Tagged object in a PatchSet, adding the -- tag and patches to the PatchSet's patch list. unwrapOneTagged :: (Monad m) => PatchSet p wX wY -> m (PatchSet p wX wY) unwrapOneTagged (PatchSet ps (Tagged t _ tps :<: ts)) = return $ PatchSet (ps +<+ t :<: tps) ts unwrapOneTagged _ = fail "called unwrapOneTagged with no Tagged's in the set" -- | @getUncovered ps@ returns the 'PatchInfo' for all the patches in -- @ps@ that are not depended on by anything else *through explicit -- dependencies*. Tags are a likely candidate, although we may also -- find some non-tag patches in this list. -- -- Keep in mind that in a typical repository with a lot of tags, only a small -- fraction of tags would be returned as they would be at least indirectly -- depended on by the topmost ones. getUncovered :: PatchSet p wStart wX -> [PatchInfo] getUncovered patchset = case patchset of (PatchSet ps NilRL) -> findUncovered (mapRL infoAndExplicitDeps ps) (PatchSet ps (Tagged t _ _ :<: _)) -> findUncovered (mapRL infoAndExplicitDeps (ps +<+ t :<: NilRL)) where findUncovered :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo] findUncovered [] = [] findUncovered ((pi, Nothing) : rest) = pi : findUncovered rest findUncovered ((pi, Just deps) : rest) = pi : findUncovered (dropDepsIn deps rest) -- |dropDepsIn traverses the list of patches, dropping any patches that -- occur in the dependency list; when a patch is dropped, its dependencies -- are added to the dependency list used for later patches. dropDepsIn :: [PatchInfo] -> [(PatchInfo, Maybe [PatchInfo])] -> [(PatchInfo, Maybe [PatchInfo])] dropDepsIn [] pps = pps dropDepsIn _ [] = [] dropDepsIn ds (hp : pps) | fst hp `elem` ds = let extraDeps = fromMaybe [] $ snd hp in dropDepsIn (extraDeps ++ delete (fst hp) ds) pps | otherwise = hp : dropDepsIn ds pps -- |infoAndExplicitDeps returns the patch info and (for tags only) the list -- of explicit dependencies of a patch. infoAndExplicitDeps :: PatchInfoAnd p wX wY -> (PatchInfo, Maybe [PatchInfo]) infoAndExplicitDeps p | isTag (info p) = (info p, getdeps `fmap` hopefullyM p) | otherwise = (info p, Nothing) -- | @slightlyOptimizePatchset@ only works on the surface inventory -- (see 'optimizePatchset') and only optimises at most one tag in -- there, going for the most recent tag which has no non-depended -- patch after it. Older tags won't be 'clean', which means the -- PatchSet will not be in 'unclean :< clean' state. slightlyOptimizePatchset :: PatchSet p wStart wX -> PatchSet p wStart wX slightlyOptimizePatchset (PatchSet ps0 ts0) = sops $ PatchSet (prog ps0) ts0 where prog = progressRL "Optimizing inventory" sops :: PatchSet p wStart wY -> PatchSet p wStart wY sops patchset@(PatchSet NilRL _) = patchset sops patchset@(PatchSet (hp :<: ps) ts) | isTag (info hp) = if getUncovered patchset == [info hp] -- exactly one tag and it depends on everything not already -- archived then PatchSet NilRL (Tagged hp Nothing ps :<: ts) -- other tags or other top-level patches too (so move past hp) else let ps' = sops $ PatchSet (prog ps) ts in appendPSFL ps' (hp :>: NilFL) | otherwise = appendPSFL (sops $ PatchSet ps ts) (hp :>: NilFL) commuteToEnd :: forall p wStart wX wY . (Patchy p, NameHack p) => RL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY -> (PatchSet p :> RL (PatchInfoAnd p)) wStart wX commuteToEnd NilRL (PatchSet ps ts) = PatchSet NilRL ts :> ps commuteToEnd (p :<: ps) (PatchSet xs ts) | info p `elem` mapRL info xs = case fastRemoveRL p xs of Just xs' -> commuteToEnd ps (PatchSet xs' ts) Nothing -> impossible -- "Nothing is impossible" commuteToEnd ps (PatchSet xs (Tagged t _ ys :<: ts)) = commuteToEnd ps (PatchSet (xs +<+ t :<: ys) ts) commuteToEnd _ _ = impossible removeFromPatchSet :: (Patchy p, NameHack p) => FL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY -> Maybe (PatchSet p wStart wX) removeFromPatchSet bad0 = rfns (reverseFL bad0) where rfns :: (Patchy p, NameHack p) => RL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY -> Maybe (PatchSet p wStart wX) rfns bad (PatchSet ps ts) | all (`elem` mapRL info ps) (mapRL info bad) = do ps' <- removeSubsequenceRL bad ps Just $ PatchSet ps' ts rfns _ (PatchSet _ NilRL) = Nothing rfns bad (PatchSet ps (Tagged t _ tps :<: ts)) = rfns bad (PatchSet (ps +<+ t :<: tps) ts) findCommonAndUncommon :: forall p wStart wX wY . (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> Fork (PatchSet p) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wStart wX wY findCommonAndUncommon us them = case taggedIntersection us them of Fork common us' them' -> case partitionFL (infoIn them') $ reverseRL us' of _ :> bad@(_ :>: _) :> _ -> bug $ "Failed to commute common patches:\n" ++ renderString Encode (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad) (common2 :> NilFL :> only_ours) -> case partitionFL (infoIn us') $ reverseRL them' of _ :> bad@(_ :>: _) :> _ -> bug $ "Failed to commute common patches:\n" ++ renderString Encode (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad) _ :> NilFL :> only_theirs -> Fork (PatchSet (reverseFL common2) common) only_ours (unsafeCoercePStart only_theirs) where infoIn inWhat = (`elem` mapRL info inWhat) . info findCommonWithThem :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> (PatchSet p :> FL (PatchInfoAnd p)) wStart wX findCommonWithThem us them = case taggedIntersection us them of Fork common us' them' -> case partitionFL ((`elem` mapRL info them') . info) $ reverseRL us' of _ :> bad@(_ :>: _) :> _ -> bug $ "Failed to commute common patches:\n" ++ renderString Encode (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad) common2 :> _nilfl :> only_ours -> PatchSet (reverseFL common2) common :> unsafeCoerceP only_ours findUncommon :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wX wY findUncommon us them = case findCommonWithThem us them of _common :> us' -> case findCommonWithThem them us of _ :> them' -> unsafeCoercePStart us' :\/: them' countUsThem :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> (Int, Int) countUsThem us them = case taggedIntersection us them of Fork _ us' them' -> let uu = mapRL info us' tt = mapRL info them' in (length $ uu \\ tt, length $ tt \\ uu) mergeThem :: (Patchy p, Merge p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> Sealed (FL (PatchInfoAnd p) wX) mergeThem us them = case taggedIntersection us them of Fork _ us' them' -> case merge2FL (reverseRL us') (reverseRL them') of them'' :/\: _ -> Sealed them'' newsetIntersection :: (Patchy p, NameHack p) => [SealedPatchSet p wStart] -> SealedPatchSet p wStart newsetIntersection [] = seal $ PatchSet NilRL NilRL newsetIntersection [x] = x newsetIntersection (Sealed y : ys) = case newsetIntersection ys of Sealed z -> case taggedIntersection y z of Fork common a b -> case mapRL info a `intersect` mapRL info b of morecommon -> case partitionRL (\e -> info e `notElem` morecommon) a of commonps :> _ -> seal $ PatchSet commonps common newsetUnion :: (Patchy p, Merge p, NameHack p) => [SealedPatchSet p wStart] -> SealedPatchSet p wStart newsetUnion [] = seal $ PatchSet NilRL NilRL newsetUnion [x] = x newsetUnion (Sealed y@(PatchSet psy tsy) : Sealed y2 : ys) = case mergeThem y y2 of Sealed p2 -> newsetUnion $ seal (PatchSet (reverseFL p2 +<+ psy) tsy) : ys -- | Merge two FLs (say L and R), starting in a common context. The result is a -- FL starting in the original end context of L, going to a new context that is -- the result of applying all patches from R on top of patches from L. -- -- While this function is similar to 'mergeFL', there are three important -- differences to keep in mind: -- -- * 'mergeFL' does not correctly deal with duplicate patches whereas this one -- does -- (Question from Eric Kow: in what sense? Why not fix the mergeFL instance?) -- -- * The conventional order we use in this function is reversed from -- 'mergeFL' (so @mergeFL r l@ vs. @merge2FL l r@. This does not -- matter so much for the former since you get both paths. -- (Question from Eric Kow: should we flip merge2FL for more uniformity in -- the code?) merge2FL :: (Patchy p, Merge p, NameHack p) => FL (PatchInfoAnd p) wX wY -> FL (PatchInfoAnd p) wX wZ -> (FL (PatchInfoAnd p) :/\: FL (PatchInfoAnd p)) wY wZ merge2FL xs NilFL = NilFL :/\: xs merge2FL NilFL ys = ys :/\: NilFL merge2FL xs (y :>: ys) | Just xs' <- fastRemoveFL y xs = merge2FL xs' ys merge2FL (x :>: xs) ys | Just ys' <- fastRemoveFL x ys = merge2FL xs ys' | otherwise = case mergeFL (x :\/: ys) of ys' :/\: x' -> case merge2FL xs ys' of ys'' :/\: xs' -> ys'' :/\: (x' :>: xs') areUnrelatedRepos :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> Bool areUnrelatedRepos us them = case taggedIntersection us them of Fork c u t -> checkit c u t where checkit (Tagged{} :<: _) _ _ = False checkit _ u t | t `isShorterThanRL` 5 = False | u `isShorterThanRL` 5 = False | otherwise = null $ intersect (mapRL info u) (mapRL info t) -- | Remove a patch from FL, using PatchInfo equality. The result is Just -- whenever the patch has been found and removed. If the patch is not present -- in the sequence at all or any commutation fails, we get Nothing. First two -- cases are optimisations for the common cases where the head of the list is -- the patch to remove, or the patch is not there at all. fastRemoveFL :: (Patchy p, NameHack p) => PatchInfoAnd p wX wY -> FL (PatchInfoAnd p) wX wZ -> Maybe (FL (PatchInfoAnd p) wY wZ) fastRemoveFL _ NilFL = Nothing fastRemoveFL a (b :>: bs) | IsEq <- a =\/= b = Just bs | info a `notElem` mapFL info bs = Nothing fastRemoveFL a (b :>: bs) = do a' :> bs' <- pullout NilRL bs a'' :> b' <- commute (b :> a') IsEq <- return (a'' =\/= a) Just (b' :>: bs') where i = info a pullout :: (Patchy p, NameHack p) => RL (PatchInfoAnd p) wA0 wA -> FL (PatchInfoAnd p) wA wB -> Maybe ((PatchInfoAnd p :> FL (PatchInfoAnd p)) wA0 wB) pullout _ NilFL = Nothing pullout acc (x :>: xs) | info x == i = do x' :> acc' <- commuteRL (acc :> x) Just (x' :> reverseRL acc' +>+ xs) | otherwise = pullout (x :<: acc) xs fastRemoveRL :: (Patchy p, NameHack p) => PatchInfoAnd p wY wZ -> RL (PatchInfoAnd p) wX wZ -> Maybe (RL (PatchInfoAnd p) wX wY) fastRemoveRL _ NilRL = Nothing fastRemoveRL a (b :<: bs) | IsEq <- a =/\= b = Just bs | info a `notElem` mapRL info bs = Nothing fastRemoveRL a (b :<: bs) = do bs' :> a' <- pullout NilFL bs b' :> a'' <- commute (a' :> b) IsEq <- return (a'' =/\= a) Just (b' :<: bs') where i = info a pullout :: (Patchy p, NameHack p) => FL (PatchInfoAnd p) wB wC -> RL (PatchInfoAnd p) wA wB -> Maybe ((RL (PatchInfoAnd p) :> PatchInfoAnd p) wA wC) pullout _ NilRL = Nothing pullout acc (x :<: xs) | info x == i = do acc' :> x' <- either (const Nothing) Just (commuteFLorComplain (x :> acc)) Just (reverseFL acc' +<+ xs :> x') | otherwise = pullout (x :>: acc) xs