#include "gadts.h"
module Darcs.Patch.Depends ( get_common_and_uncommon, get_tags_right,
get_common_and_uncommon_or_missing,
optimize_patchset, deep_optimize_patchset,
slightly_optimize_patchset,
get_patches_beyond_tag, get_patches_in_tag,
patchset_union, patchset_intersection,
commute_to_end,
) where
import Data.List ( delete, intersect )
import Control.Monad ( liftM2 )
import Control.Monad.Error ( Error(..) )
import Darcs.Patch ( RepoPatch, Named, getdeps, commute,
commuteFL,
patch2patchinfo, merge )
import Darcs.Witnesses.Ordered ( (:\/:)(..), (:<)(..), (:/\:)(..), (:>)(..),
RL(..), FL(..),
(+<+),
reverseFL, mapFL_FL, mapFL, concatReverseFL,
lengthRL, concatRL, reverseRL, mapRL,
unsafeCoerceP, EqCheck(..) )
import Darcs.Patch.Permutations ( partitionRL )
import Darcs.Patch.Info ( PatchInfo, human_friendly, is_tag )
import Darcs.Patch.Set ( PatchSet, SealedPatchSet )
import Darcs.Patch.Patchy ( sloppyIdentity )
import Darcs.Hopefully ( PatchInfoAnd, piap, info, n2pia,
hopefully, conscientiously, hopefullyM )
import Darcs.ProgressPatches ( progressRL )
import Darcs.Witnesses.Sealed (Sealed(..), FlippedSeal(..), Sealed2(..)
, flipSeal, seal, unseal, mapFlipped )
import Printer ( errorDoc, renderString, ($$), text )
#include "impossible.h"
get_common_and_uncommon :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->
([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y))
get_common_and_uncommon_or_missing :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->
Either PatchInfo ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y))
get_common_and_uncommon =
either missingPatchError id . get_common_and_uncommon_err
get_common_and_uncommon_or_missing =
either (\(MissingPatch x _) -> Left x) Right . get_common_and_uncommon_err
get_common_and_uncommon_err :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->
Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y))
get_common_and_uncommon_err (ps1,ps2) = gcau (optimize_patchset ps1) ps2
with_partial_intersection :: forall a p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y)
-> (FORALL(z) PatchSet p C(z) -> RL (PatchInfoAnd p) C(z x)
-> RL (PatchInfoAnd p) C(z y) -> a)
-> a
with_partial_intersection NilRL ps2 j = j (NilRL:<:NilRL) NilRL (concatRL ps2)
with_partial_intersection ps1 NilRL j = j (NilRL:<:NilRL) (concatRL ps1) NilRL
with_partial_intersection (NilRL:<:ps1) ps2 j =
with_partial_intersection ps1 ps2 j
with_partial_intersection ps1 (NilRL:<:ps2) j =
with_partial_intersection ps1 ps2 j
with_partial_intersection ((pi1:<:NilRL):<:common) ((pi2:<:NilRL):<:_) j
| info pi1 == info pi2
, IsEq <- sloppyIdentity pi1
, IsEq <- sloppyIdentity pi2 = j common NilRL (unsafeCoerceP NilRL)
with_partial_intersection (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s) j
= f (lengthRL orig_ps1) (last $ mapRL info orig_ps1) (orig_ps1:>:NilFL) orig_ps1s
(lengthRL orig_ps2) (last $ mapRL info orig_ps2) (orig_ps2:>:NilFL) orig_ps2s
where
f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r)
-> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u)
-> a
f _n1 l1 ps1 ps1s _n2 l2 ps2 _ps2s
| l1 == l2 = j ps1s (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2))
f n1 l1 ps1 ps1s n2 l2 ps2 ps2s
= case compare n1 n2 of
GT -> case dropWhileNilRL ps2s of
ps2':<:ps2s' ->
f n1 l1 ps1 ps1s
(n2 + lengthRL ps2') (last $ mapRL info ps2') (ps2':>:ps2) ps2s'
NilRL ->
case dropWhileNilRL ps1s of
ps1':<:ps1s' ->
f (n1 + lengthRL ps1') (last $ mapRL info ps1')
(ps1':>:ps1) ps1s'
n2 l2 ps2 ps2s
NilRL -> j (NilRL:<:NilRL) (concatReverseFL ps1) (concatReverseFL ps2)
_ -> case dropWhileNilRL ps1s of
ps1':<:ps1s' ->
f (n1 + lengthRL ps1') (last $ mapRL info ps1') (ps1':>:ps1) ps1s'
n2 l2 ps2 ps2s
NilRL ->
case dropWhileNilRL ps2s of
ps2':<:ps2s' ->
f n1 l1 ps1 NilRL
(n2 + lengthRL ps2') (last $ mapRL info ps2')
(ps2':>:ps2) ps2s'
NilRL -> j (NilRL:<:NilRL) (concatReverseFL ps1) (concatReverseFL ps2)
gcau :: forall p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y)
-> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y))
gcau NilRL ps2 = return ([], NilRL :\/: concatRL ps2)
gcau ps1 NilRL = return ([], concatRL ps1 :\/: NilRL)
gcau (NilRL:<:ps1) ps2 = gcau ps1 ps2
gcau ps1 (NilRL:<:ps2) = gcau ps1 ps2
gcau ((pi1:<:NilRL):<:_) ((pi2:<:NilRL):<:_)
| info pi1 == info pi2
, IsEq <- sloppyIdentity pi1
, IsEq <- sloppyIdentity pi2 = return ([info pi1], NilRL :\/: unsafeCoerceP NilRL)
gcau (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s)
= f (lengthRL orig_ps1) (unseal info $ lastRL orig_ps1) (orig_ps1:>:NilFL) orig_ps1s
(lengthRL orig_ps2) (unseal info $ lastRL orig_ps2) (orig_ps2:>:NilFL) orig_ps2s
where
f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r)
-> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u)
-> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y))
f _n1 l1 ps1 _ps1s _n2 l2 ps2 _ps2s
| l1 == l2 = gcau_simple (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2))
f n1 l1 ps1 ps1s n2 l2 ps2 ps2s
= case n1 `compare` n2 of
GT -> case dropWhileNilRL ps2s of
ps2':<:ps2s' ->
f n1 l1 ps1 ps1s
(n2 + lengthRL ps2') (unseal info $ lastRL ps2') (ps2':>:ps2) ps2s'
NilRL ->
case dropWhileNilRL ps1s of
ps1':<:ps1s' ->
f (n1 + lengthRL ps1') (unseal info $ lastRL ps1')
(ps1':>:ps1) ps1s'
n2 l2 ps2 ps2s
NilRL -> gcau_simple (concatReverseFL ps1) (concatReverseFL ps2)
_ -> case dropWhileNilRL ps1s of
ps1':<:ps1s' ->
f (n1 + lengthRL ps1') (unseal info $ lastRL ps1') (ps1':>:ps1) ps1s'
n2 l2 ps2 ps2s
NilRL ->
case dropWhileNilRL ps2s of
ps2':<:ps2s' ->
f n1 l1 ps1 NilRL
(n2 + lengthRL ps2') (unseal info $ lastRL ps2')
(ps2':>:ps2) ps2s'
NilRL -> gcau_simple (concatReverseFL ps1) (concatReverseFL ps2)
lastRL :: RL a C(x y) -> Sealed (a C(x))
lastRL (a:<:NilRL) = seal a
lastRL (_:<:as) = lastRL as
lastRL NilRL = bug "lastRL on empty list"
dropWhileNilRL :: PatchSet p C(x) -> PatchSet p C(x)
dropWhileNilRL (NilRL:<:xs) = dropWhileNilRL xs
dropWhileNilRL xs = xs
gcau_simple :: RepoPatch p => RL (PatchInfoAnd p) C(x y)
-> RL (PatchInfoAnd p) C(u v)
-> Either MissingPatch ([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(y v))
gcau_simple ps1 ps2 = do
FlippedSeal ex1 <- get_extra common ps1
FlippedSeal ex2 <- get_extra common ps2
let ps1' = filter (`elem` common) $ ps1_info
return (ps1', (unsafeCoerceP ex1 :\/: ex2))
where common = ps1_info `intersect` mapRL info ps2
ps1_info = mapRL info ps1
data MissingPatch = MissingPatch !PatchInfo !String
instance Error MissingPatch where
noMsg = bug "MissingPatch doesn't define noMsg."
get_extra :: RepoPatch p => [PatchInfo]
-> RL (PatchInfoAnd p) C(u x)
-> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y))
get_extra = get_extra_aux (return $ unsafeCoerceP NilFL)
where
get_extra_aux :: RepoPatch p => Either MissingPatch (FL (Named p) C(x y))
-> [PatchInfo]
-> RL (PatchInfoAnd p) C(u x)
-> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y))
get_extra_aux _ _ NilRL = return (flipSeal NilRL)
get_extra_aux skipped common (hp:<:pps) =
if info hp `elem` common && is_tag (info hp)
then case getdeps `fmap` hopefullyM hp of
Just ds -> get_extra_aux (liftM2 (:>:) ep skipped) (ds++delete (info hp) common) pps
Nothing -> get_extra_aux (liftM2 (:>:) ep skipped) (delete (info hp) common) pps
else if info hp `elem` common
then get_extra_aux (liftM2 (:>:) ep skipped) (delete (info hp) common) pps
else do
p <- ep
skpd <- skipped
case commuteFL (p :> skpd) of
Right (skipped_patch' :> p') -> do
FlippedSeal x <- get_extra_aux (return skipped_patch') common pps
return $ flipSeal (info hp `piap` p' :<: x)
Left (Sealed2 hpc) -> errorDoc $ text "bug in get_extra commuting patches:"
$$ text "First patch is:"
$$ human_friendly (info hp)
$$ text "Second patch is:"
$$ human_friendly (info $ n2pia hpc)
where ep = case hopefullyM hp of
Right p' -> return p'
Left e -> Left (MissingPatch (info hp) e)
missingPatchError :: MissingPatch -> a
missingPatchError (MissingPatch pinfo e) =
errorDoc
( text "failed to read patch in get_extra:"
$$ human_friendly pinfo $$ text e
$$ text "Perhaps this is a 'partial' repository?" )
get_extra_old :: RepoPatch p => [PatchInfo]
-> RL (PatchInfoAnd p) C(u x)
-> FlippedSeal (RL (PatchInfoAnd p)) C(y)
get_extra_old common pps =
either missingPatchError id (get_extra common pps)
get_patches_beyond_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> FlippedSeal (RL (PatchInfoAnd p)) C(x)
get_patches_beyond_tag t ((hp:<:NilRL):<:_) | info hp == t = flipSeal NilRL
get_patches_beyond_tag t patchset@((hp:<:ps):<:pps) =
if info hp == t
then if get_tags_right patchset == [info hp]
then flipSeal NilRL
else get_extra_old [t] (concatRL patchset)
else mapFlipped (hp:<:) $ get_patches_beyond_tag t (ps:<:pps)
get_patches_beyond_tag t (NilRL:<:pps) = get_patches_beyond_tag t pps
get_patches_beyond_tag t NilRL = bug $ "tag\n" ++
renderString (human_friendly t) ++
"\nis not in the patchset in get_patches_beyond_tag."
get_patches_in_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> SealedPatchSet p
get_patches_in_tag t pps@((hp:<:NilRL):<:xs)
| info hp == t = seal pps
| otherwise = get_patches_in_tag t xs
get_patches_in_tag t ((hp:<:ps):<:xs)
| info hp /= t = get_patches_in_tag t (ps:<:xs)
get_patches_in_tag t ((pa:<:ps):<:xs) = gpit thepis (pa:>:NilFL) (ps:<:xs)
where thepis = getdeps $ conscientiously
(\e -> text "Couldn't read tag"
$$ human_friendly t
$$ text ""
$$ e) pa
gpit :: RepoPatch p => [PatchInfo] -> (FL (PatchInfoAnd p)) C(x y) -> PatchSet p C(x) -> SealedPatchSet p
gpit _ sofar NilRL = seal $ reverseFL sofar :<: NilRL
gpit deps sofar ((hp:<:NilRL):<:xs')
| info hp `elem` deps
, IsEq <- sloppyIdentity hp = seal $ (reverseFL $ hp :>: sofar) :<: xs'
| IsEq <- sloppyIdentity hp = gpit deps sofar xs'
gpit deps sofar (NilRL:<:xs') = gpit deps sofar xs'
gpit deps sofar ((hp:<:ps'):<:xs')
| info hp `elem` deps
= let odeps = filter (/=info hp) deps
alldeps = if is_tag $ info hp
then odeps ++ getdeps (hopefully hp)
else odeps
in gpit alldeps (hp:>:sofar) (ps':<:xs')
| otherwise
= gpit deps (commute_by sofar $ hopefully hp) (ps':<:xs')
commute_by :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> (Named p) C(w x)
-> FL (PatchInfoAnd p) C(w z)
commute_by NilFL _ = unsafeCoerceP NilFL
commute_by (hpa:>:xs') p =
case commute (p :> hopefully hpa) of
Nothing -> bug "Failure commuting patches in commute_by called by gpit!"
Just (a' :> p') -> (info hpa `piap` a') :>: commute_by xs' p'
get_patches_in_tag t _ = errorDoc $ text "Couldn't read tag"
$$ human_friendly t
get_tags_right :: RL (RL (PatchInfoAnd p)) C(x y) -> [PatchInfo]
get_tags_right NilRL = []
get_tags_right (ps:<:_) = get_tags_r (mapRL info_and_deps ps)
where
get_tags_r :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo]
get_tags_r [] = []
get_tags_r (hp:pps) = case snd hp of
Just ds -> fst hp : get_tags_r (drop_tags_r ds pps)
Nothing -> fst hp : get_tags_r pps
drop_tags_r :: [PatchInfo]
-> [(PatchInfo, Maybe [PatchInfo])] -> [(PatchInfo, Maybe [PatchInfo])]
drop_tags_r [] pps = pps
drop_tags_r _ [] = []
drop_tags_r ds (hp:pps)
| fst hp `elem` ds = case snd hp of
Just ds' -> drop_tags_r (ds'++delete (fst hp) ds) pps
Nothing -> drop_tags_r (delete (fst hp) ds) pps
| otherwise = hp : drop_tags_r ds pps
info_and_deps :: PatchInfoAnd p C(x y) -> (PatchInfo, Maybe [PatchInfo])
info_and_deps p
| is_tag (info p) = (info p, getdeps `fmap` hopefullyM p)
| otherwise = (info p, Nothing)
deep_optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x)
deep_optimize_patchset pss = optimize_patchset (concatRL pss :<: NilRL)
optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x)
optimize_patchset NilRL = NilRL
optimize_patchset (ps:<:pss) = opsp ps +<+ pss
where
opsp :: RL (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(x y)
opsp NilRL = NilRL
opsp (hp:<:pps)
| is_tag (info hp) && get_tags_right ((hp:<:pps):<:NilRL) == [info hp]
= (hp:<:NilRL) :<: opsp pps
| otherwise = hp -:- opsp pps
(-:-) :: (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(a x) -> RL (RL (PatchInfoAnd p)) C(a y)
pp -:- NilRL = (pp:<:NilRL) :<: NilRL
pp -:- (p:<:ps) = ((pp:<:p) :<: ps)
slightly_optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x)
slightly_optimize_patchset NilRL = NilRL
slightly_optimize_patchset (ps:<:pss) = sops (progressRL "Optimizing inventory" ps) +<+ pss
where sops :: RL (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(x y)
sops NilRL = NilRL
sops (pinfomp :<: NilRL) = (pinfomp :<: NilRL) :<: NilRL
sops (hp:<:pps) | is_tag (info hp) = if get_tags_right ((hp:<:pps):<:NilRL) == [info hp]
then (hp:<:NilRL) :<: (pps:<: NilRL)
else hp -:- sops (progressRL "Optimizing inventory" pps)
| otherwise = hp -:- sops pps
commute_to_end :: forall p C(x y). RepoPatch p => FL (Named p) C(x y) -> PatchSet p C(y)
-> (FL (Named p) :< RL (RL (PatchInfoAnd p))) C(() x)
commute_to_end select from = ctt (mapFL patch2patchinfo select) from NilFL
where
ctt :: [PatchInfo] -> PatchSet p C(v) -> FL (Named p) C(v u)
-> (FL (Named p) :< RL (RL (PatchInfoAnd p))) C(() x)
ctt [] ps acc = (unsafeCoerceP acc) :< ps
ctt sel (NilRL:<:ps) acc = ctt sel ps acc
ctt sel ((hp:<:hps):<:ps) acc
| info hp `elem` sel
= case commuteFL (hopefully hp :> acc) of
Left _ -> bug "patches to commute_to_end does not commutex (1)"
Right (acc' :> _) -> ctt (delete (info hp) sel) (hps:<:ps) acc'
| otherwise
= ctt sel (hps:<:ps) (hopefully hp:>:acc)
ctt _ _ _ = bug "patches to commute_to_end does not commutex (2)"
patchset_intersection :: RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p
patchset_intersection [] = seal (NilRL :<: NilRL)
patchset_intersection [x] = x
patchset_intersection (Sealed y:ys) =
case patchset_intersection ys of
Sealed ys' -> with_partial_intersection y ys' $
\common a b ->
case mapRL info a `intersect` mapRL info b of
morecommon ->
case partitionRL (\e -> info e `notElem` morecommon) a of
commonps :> _ -> seal $ commonps :<: common
patchset_union :: forall p. RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p
patchset_union [] = seal (NilRL :<: NilRL)
patchset_union [x] = x
patchset_union (Sealed y:ys) =
case patchset_union ys of
Sealed ys' -> with_partial_intersection y ys' f
where
f :: FORALL(z x y) PatchSet p C(z)
-> RL (PatchInfoAnd p) C(z x)
-> RL (PatchInfoAnd p) C(z y)
-> SealedPatchSet p
f common a b = g_s $ gcau_simple a b
where
g_s :: Either MissingPatch
([PatchInfo],(RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y))
-> SealedPatchSet p
g_s (Left e) = missingPatchError e
g_s (Right (_, a' :\/: b')) =
case (merge_sets (a' :\/: b')) of
Sealed a'b' -> seal $ (a'b' +<+ b) :<: common
merge_sets :: RepoPatch p => (RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y) -> Sealed (RL (PatchInfoAnd p) C(y))
merge_sets (l :\/: r) =
let pl = mapFL_FL hopefully $ reverseRL l
pr = mapFL_FL hopefully $ reverseRL r
p2pimp p = patch2patchinfo p `piap` p
in case merge (pl:\/: pr) of
(_:/\:pl') -> seal $ reverseFL $ mapFL_FL p2pimp pl'