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(..) )
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 :: 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]
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 :: (Patchy p, NameHack p) => PatchInfo -> PatchSet p wStart wX
-> Maybe ((PatchSet p :> RL (PatchInfoAnd p)) wStart wX)
splitOnTag t (PatchSet ps ts@(Tagged hp _ _ :<: _)) | info hp == t =
Just $ PatchSet NilRL ts :> ps
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
tagAndDeps@(hp' :<: ds') :> nonDeps ->
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)
splitOnTag t (PatchSet (p :<: ps) ts) = do
ns :> x <- splitOnTag t (PatchSet ps ts)
return $ ns :> (p :<: x)
splitOnTag t0 patchset@(PatchSet NilRL (Tagged _ _ _s :<: _)) =
unwrapOneTagged patchset >>= splitOnTag t0
splitOnTag _ (PatchSet NilRL NilRL) = Nothing
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 :: 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 :: [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 :: PatchInfoAnd p wX wY
-> (PatchInfo, Maybe [PatchInfo])
infoAndExplicitDeps p
| isTag (info p) = (info p, getdeps `fmap` hopefullyM p)
| otherwise = (info p, Nothing)
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]
then PatchSet NilRL (Tagged hp Nothing ps :<: ts)
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
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
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)
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