src/Darcs/Patch/Depends.lhs

   1 %  Copyright (C) 2003-2004 David Roundy
   2 %
   3 %  This program is free software; you can redistribute it and/or modify
   4 %  it under the terms of the GNU General Public License as published by
   5 %  the Free Software Foundation; either version 2, or (at your option)
   6 %  any later version.
   7 %
   8 %  This program is distributed in the hope that it will be useful,
   9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 %  GNU General Public License for more details.
  12 %
  13 %  You should have received a copy of the GNU General Public License
  14 %  along with this program; see the file COPYING.  If not, write to
  15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 %  Boston, MA 02110-1301, USA.
  17
  18 \section{Dependencies}
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
  21 {-# LANGUAGE CPP #-}
  22 -- , ScopedTypeVariables, TypeOperators #-}
  23
  24 #include "gadts.h"
  25
  26 module Darcs.Patch.Depends ( get_common_and_uncommon, get_tags_right,
  27                  get_common_and_uncommon_or_missing,
  28                  optimize_patchset, deep_optimize_patchset,
  29                  slightly_optimize_patchset,
  30                  get_patches_beyond_tag, get_patches_in_tag,
  31                  is_tag,
  32                  patchset_union, patchset_intersection,
  33                  commute_to_end,
  34                ) where
  35 import Data.List ( delete, intersect )
  36 import Control.Monad ( liftM2 )
  37 import Control.Monad.Error (Error(..), MonadError(..))
  38
  39 import Darcs.Patch ( RepoPatch, Named, getdeps, commutex,
  40                      commuteFL,
  41                      patch2patchinfo, merge )
  42 import Darcs.Ordered ( (:\/:)(..), (:<)(..), (:/\:)(..), (:>)(..),
  43                              RL(..), FL(..),
  44                              (+<+),
  45                              reverseFL, mapFL_FL, mapFL, concatReverseFL,
  46                              lengthRL, concatRL, reverseRL, mapRL,
  47                              unsafeCoerceP, EqCheck(..) )
  48 import Darcs.Patch.Permutations ( partitionRL )
  49 import Darcs.Patch.Info ( PatchInfo, just_name, human_friendly )
  50 import Darcs.Patch.Set ( PatchSet, SealedPatchSet )
  51 import Darcs.Patch.Patchy ( sloppyIdentity )
  52 import Darcs.Hopefully ( PatchInfoAnd, piap, info, n2pia,
  53                          hopefully, conscientiously, hopefullyM )
  54 import Darcs.Progress ( progressRL )
  55 import Darcs.Sealed (Sealed(..), FlippedSeal(..), Sealed2(..)
  56                     , flipSeal, seal, unseal )
  57 import Printer ( errorDoc, renderString, ($$), text )
  58 #include "impossible.h"
  59 \end{code}
  60
  61 \begin{code}
  62 get_common_and_uncommon :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->
  63                            ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))
  64 get_common_and_uncommon_or_missing :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->
  65                                       Either PatchInfo ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))
  66 \end{code}
  67
  68 \begin{code}
  69 get_common_and_uncommon =
  70     either missingPatchError id . get_common_and_uncommon_err
  71
  72 get_common_and_uncommon_or_missing =
  73     either (\(MissingPatch x _) -> Left x) Right . get_common_and_uncommon_err
  74
  75 get_common_and_uncommon_err :: RepoPatch p => (PatchSet p C(x),PatchSet p C(y)) ->
  76                                Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))
  77 get_common_and_uncommon_err (ps1,ps2) = gcau (optimize_patchset ps1) ps2
  78
  79 {-|
  80 with_partial_intersection takes two 'PatchSet's and splits them into a /common/
  81 intersection portion and two sets of patches.  The intersection, however,
  82 is only lazily determined, so there is no guarantee that all intersecting
  83 patches will be included in the intersection 'PatchSet'.  This is a pretty
  84 efficient function, because it makes use of the already-broken-up nature of
  85 'PatchSet's.
  86
  87 'PatchSet's have the property that if
  88 @
  89 (info $ last $ head a) == (info $ last $ head b)
  90 @
  91 then @(tail a)@ and @(tail b)@ are identical repositories, and we want to take
  92 advantage of this if possible, to avoid reading too many inventories.  In
  93 the case of --partial repositories or patch bundles, it is crucial that we
  94 don't need to read the whole history, since it isn't available.
  95
  96 TODO:
  97
  98 The length equalising isn't necessarily right. We probably also be
  99 thinking about not going past the end of a partial repository, or favour
 100 local repository stuff over remote repository stuff.
 101
 102 Also, when comparing l1 to l2, we should really be comparing the
 103 newly discovered one to /all/ the lasts in the other patch set
 104 that we've got so far.
 105 -}
 106 with_partial_intersection :: forall a p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y)
 107                           -> (FORALL(z) PatchSet p C(z) -> RL (PatchInfoAnd p) C(z x)
 108                                                         -> RL (PatchInfoAnd p) C(z y) -> a)
 109                           -> a
 110 with_partial_intersection NilRL ps2 j = j (NilRL:<:NilRL) NilRL (concatRL ps2)
 111 with_partial_intersection ps1 NilRL j = j (NilRL:<:NilRL) (concatRL ps1) NilRL
 112 with_partial_intersection (NilRL:<:ps1) ps2 j =
 113     with_partial_intersection ps1 ps2 j
 114 with_partial_intersection ps1 (NilRL:<:ps2) j =
 115     with_partial_intersection ps1 ps2 j
 116 -- NOTE: symmetry is broken here, so we want the PatchSet with more history
 117 -- first!
 118 with_partial_intersection ((pi1:<:NilRL):<:common) ((pi2:<:NilRL):<:_) j
 119 -- NOTE: Since the patchsets have the same starting but different ending
 120 -- we can coerce them.  The type system is not aware of our invariant on tags,
 121 -- but both pi1 and pi2 should be tags, thus we check they are both identity
 122 -- patches.
 123     | info pi1 == info pi2
 124     , IsEq <- sloppyIdentity pi1
 125     , IsEq <- sloppyIdentity pi2 = j common NilRL (unsafeCoerceP NilRL)
 126 with_partial_intersection (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s) j
 127  = f (lengthRL orig_ps1) (last $ mapRL info orig_ps1) (orig_ps1:>:NilFL) orig_ps1s
 128      (lengthRL orig_ps2) (last $ mapRL info orig_ps2) (orig_ps2:>:NilFL) orig_ps2s
 129     where {- Invariants: nx = length $ concatReverseFL psx
 130                          lx = last $ concatReverseFL psx   -}
 131           f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r)
 132             -> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u)
 133             -> a
 134           f _n1 l1 ps1 ps1s _n2 l2 ps2 _ps2s
 135            | l1 == l2 = j ps1s (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2))
 136           f n1 l1 ps1 ps1s n2 l2 ps2 ps2s
 137            = case compare n1 n2 of
 138              GT -> case dropWhileNilRL ps2s of
 139                    ps2':<:ps2s' ->
 140                        f n1 l1 ps1 ps1s
 141                          (n2 + lengthRL ps2') (last $ mapRL info ps2') (ps2':>:ps2) ps2s'
 142                    NilRL -> -- We keep going round f so the l1 == l2 case
 143                             -- has a chance to kick in
 144                          case dropWhileNilRL ps1s of
 145                          ps1':<:ps1s' ->
 146                              f (n1 + lengthRL ps1') (last $ mapRL info ps1')
 147                                (ps1':>:ps1) ps1s'
 148                                n2 l2 ps2 ps2s
 149                          NilRL -> j (NilRL:<:NilRL) (concatReverseFL ps1) (concatReverseFL ps2)
 150              _  -> case dropWhileNilRL ps1s of
 151                    ps1':<:ps1s' ->
 152                        f (n1 + lengthRL ps1') (last $ mapRL info ps1') (ps1':>:ps1) ps1s'
 153                          n2 l2 ps2 ps2s
 154                    NilRL -> -- We keep going round f so the l1 == l2 case
 155                             -- has a chance to kick in
 156                          case dropWhileNilRL ps2s of
 157                          ps2':<:ps2s' ->
 158                              f n1 l1 ps1 NilRL
 159                                (n2 + lengthRL ps2') (last $ mapRL info ps2')
 160                                (ps2':>:ps2) ps2s'
 161                          NilRL -> j (NilRL:<:NilRL) (concatReverseFL ps1) (concatReverseFL ps2)
 162
 163 {-|
 164 'gcau' determines a list of /common/ patches and patches unique to each of
 165 the two 'PatchSet's.  The list of /common/ patches only needs to include all
 166 patches that are not interspersed with the /unique/ patches, but including
 167 more patches in the list of /common/ patches doesn't really hurt, except
 168 for efficiency considerations.  Mostly, we want to access as few elements
 169 as possible of the 'PatchSet' list, since those can be expensive (or
 170 unavailable).  In other words, the /common/ patches need not be minimal,
 171 whereas the 'PatchSet's should be minimal for performance reasons.
 172
 173 'PatchSet's have the property that if
 174 @
 175 (info $ last $ head a) == (info $ last $ head b)
 176 @
 177 then @(tail a)@ and @(tail b)@ are identical repositories, and we want to take
 178 advantage of this if possible, to avoid reading too many inventories.  In
 179 the case of --partial repositories or patch bundles, it is crucial that we
 180 don't need to read the whole history, since it isn't available.
 181
 182 TODO:
 183
 184 The length equalising isn't necessarily right. We probably also be
 185 thinking about not going past the end of a partial repository, or favour
 186 local repository stuff over remote repo stuff.
 187
 188 Also, when comparing l1 to l2, we should really be comparing the
 189 newly discovered one to /all/ the lasts in the other patch set
 190 that we've got so far.
 191 -}
 192
 193 gcau :: forall p C(x y). RepoPatch p => PatchSet p C(x) -> PatchSet p C(y)
 194      -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))
 195 gcau NilRL ps2 = return ([], NilRL:<:NilRL :\/: concatRL ps2 :<: NilRL)
 196 gcau ps1 NilRL = return ([], concatRL ps1 :<: NilRL :\/: NilRL:<:NilRL)
 197 gcau (NilRL:<:ps1) ps2 = gcau ps1 ps2
 198 gcau ps1 (NilRL:<:ps2) = gcau ps1 ps2
 199 gcau ((pi1:<:NilRL):<:_) ((pi2:<:NilRL):<:_)
 200  | info pi1 == info pi2
 201  , IsEq <- sloppyIdentity pi1
 202  , IsEq <- sloppyIdentity pi2 = return ([info pi1], NilRL:<:NilRL :\/: unsafeCoerceP (NilRL:<:NilRL))
 203 gcau (orig_ps1:<:orig_ps1s) (orig_ps2:<:orig_ps2s)
 204  = f (lengthRL orig_ps1) (unseal info $ lastRL orig_ps1) (orig_ps1:>:NilFL) orig_ps1s
 205      (lengthRL orig_ps2) (unseal info $ lastRL orig_ps2) (orig_ps2:>:NilFL) orig_ps2s
 206     where {- Invariants: nx = lengthRL $ concatReverseFL psx
 207                          lx = last $ concatReverseFL psx   -}
 208           f :: Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(r x) -> PatchSet p C(r)
 209             -> Int -> PatchInfo -> FL (RL (PatchInfoAnd p)) C(u y) -> PatchSet p C(u)
 210             -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(x y))
 211           f _n1 l1 ps1 _ps1s _n2 l2 ps2 _ps2s
 212            | l1 == l2 = gcau_simple (unsafeCoerceP (concatReverseFL ps1)) (unsafeCoerceP (concatReverseFL ps2))
 213           f n1 l1 ps1 ps1s n2 l2 ps2 ps2s
 214            = case n1 `compare` n2 of
 215              GT -> case dropWhileNilRL ps2s of
 216                    ps2':<:ps2s' ->
 217                        f n1 l1 ps1 ps1s
 218                          (n2 + lengthRL ps2') (unseal info $ lastRL ps2') (ps2':>:ps2) ps2s'
 219                    NilRL -> -- We keep going round f so the l1 == l2 case
 220                             -- has a chance to kick in
 221                          case dropWhileNilRL ps1s of
 222                          ps1':<:ps1s' ->
 223                              f (n1 + lengthRL ps1') (unseal info $ lastRL ps1')
 224                                (ps1':>:ps1) ps1s'
 225                                n2 l2 ps2 ps2s
 226                          NilRL -> gcau_simple (concatReverseFL ps1) (concatReverseFL ps2)
 227              _  -> case dropWhileNilRL ps1s of
 228                    ps1':<:ps1s' ->
 229                        f (n1 + lengthRL ps1') (unseal info $ lastRL ps1') (ps1':>:ps1) ps1s'
 230                          n2 l2 ps2 ps2s
 231                    NilRL -> -- We keep going round f so the l1 == l2 case
 232                             -- has a chance to kick in
 233                          case dropWhileNilRL ps2s of
 234                          ps2':<:ps2s' ->
 235                              f n1 l1 ps1 NilRL
 236                                (n2 + lengthRL ps2') (unseal info $ lastRL ps2')
 237                                (ps2':>:ps2) ps2s'
 238                          NilRL -> gcau_simple (concatReverseFL ps1) (concatReverseFL ps2)
 239
 240 lastRL :: RL a C(x y) -> Sealed (a C(x))
 241 lastRL (a:<:NilRL) = seal a
 242 lastRL (_:<:as) = lastRL as
 243 lastRL NilRL = bug "lastRL on empty list"
 244
 245 dropWhileNilRL :: PatchSet p C(x) -> PatchSet p C(x)
 246 dropWhileNilRL (NilRL:<:xs) = dropWhileNilRL xs
 247 dropWhileNilRL xs = xs
 248
 249 -- | Filters the common elements from @ps1@ and @ps2@ and returns the simplified sequences.
 250 gcau_simple :: RepoPatch p => RL (PatchInfoAnd p) C(x y) -- ^ @ps1@
 251             -> RL (PatchInfoAnd p) C(u v) -- ^ @ps2@
 252             -> Either MissingPatch ([PatchInfo],(RL (RL (PatchInfoAnd p)) :\/: RL (RL (PatchInfoAnd p))) C(y v))
 253 gcau_simple ps1 ps2 = do
 254  FlippedSeal ex1 <- get_extra common ps1
 255  FlippedSeal ex2 <- get_extra common ps2
 256  let ps1' = filter (`elem` common) $ ps1_info
 257  return (ps1', (unsafeCoerceP ex1 :<: NilRL) :\/: ex2 :<: NilRL)
 258   where common   = ps1_info `intersect` mapRL info ps2
 259         ps1_info = mapRL info ps1
 260
 261 data MissingPatch = MissingPatch !PatchInfo !String
 262
 263 instance Error MissingPatch where
 264     -- we don't really need those methods
 265     noMsg = bug "MissingPatch doesn't define noMsg."
 266
 267 -- | Returns a sub-sequence from @patches@, where all the elements of @common@ have
 268 -- been removed by commuting them out.
 269 get_extra :: RepoPatch p => [PatchInfo] -- ^ @common@
 270           -> RL (PatchInfoAnd p) C(u x) -- ^ @patches@
 271           -> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y))
 272 get_extra = get_extra_aux (return $ unsafeCoerceP NilFL)
 273   where
 274   get_extra_aux :: RepoPatch p => Either MissingPatch (FL (Named p) C(x y))
 275                 -> [PatchInfo]
 276                 -> RL (PatchInfoAnd p) C(u x)
 277                 -> Either MissingPatch (FlippedSeal (RL (PatchInfoAnd p)) C(y))
 278   get_extra_aux _ _ NilRL = return (flipSeal NilRL)
 279   get_extra_aux skipped common (hp:<:pps) =
 280       if info hp `elem` common && is_tag (info hp)
 281       then case getdeps `fmap` hopefullyM hp of
 282            Just ds -> get_extra_aux (liftM2 (:>:) ep skipped) (ds++delete (info hp) common) pps
 283            Nothing -> get_extra_aux (liftM2 (:>:) ep skipped) (delete (info hp) common) pps
 284       else if info hp `elem` common
 285            then get_extra_aux (liftM2 (:>:) ep skipped) (delete (info hp) common) pps
 286            else do
 287               p <- ep
 288               skpd <- skipped
 289               case commuteFL (p :> skpd) of
 290                 Right (skipped_patch' :> p') -> do
 291                     FlippedSeal x <- get_extra_aux (return skipped_patch') common pps
 292                     return $ flipSeal (info hp `piap` p' :<: x)
 293                 -- Failure to commute indicates a bug because it means
 294                 -- that a patch was interspersed between the common
 295                 -- patches.  This should only happen if that patch was
 296                 -- commuted there.  This uses 2 properties:
 297                 -- 1) commute is its own inverse
 298                 -- 2) if patches commute in one adjacent context then
 299                 --    they commute in any context where they are
 300                 --    adjacent
 301                 Left (Sealed2 hpc) -> errorDoc $ text "bug in get_extra commuting patches:"
 302                          $$ text "First patch is:"
 303                          $$ human_friendly (info hp)
 304                          $$ text "Second patch is:"
 305                          $$ human_friendly (info $ n2pia hpc)
 306       where ep = case hopefullyM hp of
 307                  Right p' -> return p'
 308                  Left e -> throwError (MissingPatch (info hp) e)
 309
 310 missingPatchError :: MissingPatch -> a
 311 missingPatchError (MissingPatch pinfo e) =
 312     errorDoc
 313         ( text "failed to read patch in get_extra:"
 314           $$ human_friendly pinfo $$ text e
 315           $$ text "Perhaps this is a 'partial' repository?" )
 316
 317 get_extra_old :: RepoPatch p => [PatchInfo]
 318               -> RL (PatchInfoAnd p) C(u x)
 319               -> FlippedSeal (RL (PatchInfoAnd p)) C(y)
 320 get_extra_old common pps =
 321     either missingPatchError id (get_extra common pps)
 322
 323 \end{code}
 324
 325 \begin{code}
 326 get_patches_beyond_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(x)
 327 get_patches_beyond_tag t ((hp:<:NilRL):<:_) | info hp == t = flipSeal $ NilRL :<: NilRL
 328 get_patches_beyond_tag t patchset@((hp:<:ps):<:pps) =
 329     if info hp == t
 330     then if get_tags_right patchset == [info hp]
 331          then flipSeal $ NilRL :<: NilRL -- special case to avoid looking at redundant patches
 332          else case get_extra_old [t] (concatRL patchset) of
 333               FlippedSeal x -> flipSeal $ x :<: NilRL
 334     else hp `prepend` get_patches_beyond_tag t (ps:<:pps)
 335  where
 336  prepend :: (PatchInfoAnd p) C(x y) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(x) -> FlippedSeal (RL (RL (PatchInfoAnd p))) C(y)
 337  prepend pp (FlippedSeal NilRL)     = flipSeal $ (pp:<:NilRL) :<: NilRL
 338  prepend pp (FlippedSeal (p:<:ps')) = flipSeal $ (pp:<:p)     :<: ps'
 339 get_patches_beyond_tag t (NilRL:<:pps) = get_patches_beyond_tag t pps
 340 get_patches_beyond_tag t NilRL = bug $ "tag\n" ++
 341                                  renderString (human_friendly t) ++
 342                                  "\nis not in the patchset in get_patches_beyond_tag."
 343
 344 -- | @get_patches_in_tag t ps@ returns a 'SealedPatchSet' of all
 345 -- patches in @ps@ which are contained in @t@.
 346 get_patches_in_tag :: RepoPatch p => PatchInfo -> PatchSet p C(x) -> SealedPatchSet p
 347 get_patches_in_tag t pps@((hp:<:NilRL):<:xs)
 348     | info hp == t = seal pps
 349     | otherwise = get_patches_in_tag t xs
 350
 351 get_patches_in_tag t ((hp:<:ps):<:xs)
 352     | info hp /= t = get_patches_in_tag t (ps:<:xs)
 353
 354 get_patches_in_tag t ((pa:<:ps):<:xs) = gpit thepis (pa:>:NilFL) (ps:<:xs)
 355     where thepis = getdeps $ conscientiously
 356                    (\e -> text "Couldn't read tag"
 357                           $$ human_friendly t
 358                           $$ text ""
 359                           $$ e) pa
 360           gpit :: RepoPatch p => [PatchInfo] -> (FL (PatchInfoAnd p)) C(x y) -> PatchSet p C(x) -> SealedPatchSet p
 361           gpit _ sofar NilRL = seal $ reverseFL sofar :<: NilRL
 362           gpit deps sofar ((hp:<:NilRL):<:xs')
 363               | info hp `elem` deps
 364               , IsEq <- sloppyIdentity hp = seal $ (reverseFL $ hp :>: sofar) :<: xs'
 365               | IsEq <- sloppyIdentity hp = gpit deps sofar xs'
 366           gpit deps sofar (NilRL:<:xs') = gpit deps sofar xs'
 367           gpit deps sofar ((hp:<:ps'):<:xs')
 368               | info hp `elem` deps
 369                   = let odeps = filter (/=info hp) deps
 370                         alldeps = if is_tag $ info hp
 371                                   then odeps ++ getdeps (hopefully hp)
 372                                   else odeps
 373                     in gpit alldeps (hp:>:sofar) (ps':<:xs')
 374               | otherwise
 375                   = gpit deps (commute_by sofar $ hopefully hp) (ps':<:xs')
 376           commute_by :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> (Named p) C(w x)
 377                      -> FL (PatchInfoAnd p) C(w z)
 378           commute_by NilFL _ = unsafeCoerceP NilFL
 379           commute_by (hpa:>:xs') p =
 380               case commutex (hopefully hpa :< p) of
 381                 Nothing -> bug "Failure commuting patches in commute_by called by gpit!"
 382                 Just (p':<a') -> (info hpa `piap` a') :>: commute_by xs' p'
 383
 384 get_patches_in_tag t _ = errorDoc $ text "Couldn't read tag"
 385                                  $$ human_friendly t
 386 \end{code}
 387
 388 \begin{code}
 389 is_tag :: PatchInfo -> Bool
 390 is_tag pinfo = take 4 (just_name pinfo) == "TAG "
 391
 392 get_tags_right :: RL (RL (PatchInfoAnd p)) C(x y) -> [PatchInfo]
 393 get_tags_right NilRL = []
 394 get_tags_right (ps:<:_) = get_tags_r (mapRL info_and_deps ps)
 395     where
 396     get_tags_r :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo]
 397     get_tags_r [] = []
 398     get_tags_r (hp:pps) = case snd hp of
 399                           Just ds -> fst hp : get_tags_r (drop_tags_r ds pps)
 400                           Nothing -> fst hp : get_tags_r pps
 401
 402     drop_tags_r :: [PatchInfo]
 403                 -> [(PatchInfo, Maybe [PatchInfo])] -> [(PatchInfo, Maybe [PatchInfo])]
 404     drop_tags_r [] pps = pps
 405     drop_tags_r _  []  = []
 406     drop_tags_r ds (hp:pps)
 407         | fst hp `elem` ds = case snd hp of
 408                              Just ds' -> drop_tags_r (ds'++delete (fst hp) ds) pps
 409                              Nothing -> drop_tags_r (delete (fst hp) ds) pps
 410         | otherwise = hp : drop_tags_r ds pps
 411
 412     info_and_deps :: PatchInfoAnd p C(x y) -> (PatchInfo, Maybe [PatchInfo])
 413     info_and_deps p
 414         | is_tag (info p) = (info p, getdeps `fmap` hopefullyM p)
 415         | otherwise = (info p, Nothing)
 416 \end{code}
 417
 418 \begin{code}
 419 deep_optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x)
 420 deep_optimize_patchset pss = optimize_patchset (concatRL pss :<: NilRL)
 421
 422 optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x)
 423 optimize_patchset NilRL = NilRL
 424 optimize_patchset (ps:<:pss) = opsp ps +<+ pss
 425   where
 426         opsp :: RL (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(x y)
 427         opsp NilRL = NilRL
 428         opsp (hp:<:pps)
 429              | is_tag (info hp) && get_tags_right ((hp:<:pps):<:NilRL) == [info hp]
 430                  = (hp:<:NilRL) :<: opsp pps
 431              | otherwise = hp -:- opsp pps
 432
 433 (-:-) :: (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(a x) -> RL (RL (PatchInfoAnd p)) C(a y)
 434 pp -:- NilRL = (pp:<:NilRL) :<: NilRL
 435 pp -:- (p:<:ps) = ((pp:<:p) :<: ps)
 436
 437 slightly_optimize_patchset :: PatchSet p C(x) -> PatchSet p C(x)
 438 slightly_optimize_patchset NilRL = NilRL
 439 slightly_optimize_patchset (ps:<:pss) = sops (progressRL "Optimizing inventory" ps) +<+ pss
 440     where sops :: RL (PatchInfoAnd p) C(x y) -> RL (RL (PatchInfoAnd p)) C(x y)
 441           sops NilRL = NilRL
 442           sops (pinfomp :<: NilRL) = (pinfomp :<: NilRL) :<: NilRL
 443           sops (hp:<:pps) | is_tag (info hp) = if get_tags_right ((hp:<:pps):<:NilRL) == [info hp]
 444                                                then (hp:<:NilRL) :<: (pps:<: NilRL)
 445                                                else hp -:- sops (progressRL "Optimizing inventory" pps)
 446                           | otherwise = hp -:- sops pps
 447 \end{code}
 448
 449 \begin{code}
 450 commute_to_end :: forall p C(x y). RepoPatch p => FL (Named p) C(x y) -> PatchSet p C(y)
 451                -> (FL (Named p) :< RL (RL (PatchInfoAnd p))) C(() x)
 452 commute_to_end select from = ctt (mapFL patch2patchinfo select) from NilFL
 453    where
 454 -- In order to preserve the structure of the original PatchSet, we commute
 455 -- the patches we are going to throw away past the patches we plan to keep.
 456 -- This puts them at the end of the PatchSet where it is safe to discard them.
 457 -- We return all the patches in the PatchSet which have been commuted.
 458       ctt :: [PatchInfo] -> PatchSet p C(v) -> FL (Named p) C(v u)
 459           -> (FL (Named p) :< RL (RL (PatchInfoAnd p))) C(() x)
 460       -- This unsafeCoerceP should be fine, because if we run out of
 461       -- patches in the selection the ending context of the second param
 462       -- should be x (because we have commute all of the selected sequence,
 463       -- with context C(x y), past the elements of the second parameter.
 464       -- Unfortunately this is hard to express in the type system while
 465       -- using an accumulator to build up the return value.
 466       ctt [] ps acc = (unsafeCoerceP acc) :< ps
 467       ctt sel (NilRL:<:ps) acc = ctt sel ps acc
 468       ctt sel ((hp:<:hps):<:ps) acc
 469          | info hp `elem` sel
 470             = case commuteFL (hopefully hp :> acc) of
 471               Left _ -> bug "patches to commute_to_end does not commutex (1)"
 472               Right (acc' :> _) -> ctt (delete (info hp) sel) (hps:<:ps) acc'
 473          | otherwise
 474             = ctt sel (hps:<:ps) (hopefully hp:>:acc)
 475       ctt _ _ _ = bug "patches to commute_to_end does not commutex (2)"
 476 \end{code}
 477
 478 \begin{code}
 479 patchset_intersection :: RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p
 480 patchset_intersection [] = seal (NilRL :<: NilRL)
 481 patchset_intersection [x] = x
 482 patchset_intersection (Sealed y:ys) =
 483     case patchset_intersection ys of
 484     Sealed ys' -> with_partial_intersection y ys' $
 485       \common a b ->
 486           case mapRL info a `intersect` mapRL info b of
 487           morecommon ->
 488               case partitionRL (\e -> info e `notElem` morecommon) a of
 489                 commonps :> _ -> seal $ commonps :<: common
 490
 491 patchset_union :: RepoPatch p => [SealedPatchSet p] -> SealedPatchSet p
 492 patchset_union [] = seal (NilRL :<: NilRL)
 493 patchset_union [x] = x
 494 patchset_union (Sealed y:ys) =
 495     case patchset_union ys of
 496     Sealed ys' -> with_partial_intersection y ys' $
 497       \common a b ->
 498         case gcau_simple a b of
 499         Left e -> missingPatchError e
 500         Right (_, (a' :<: NilRL) :\/: (b' :<: NilRL)) ->
 501           case (merge_sets (a' :\/: b')) of
 502           Sealed a'b' -> seal $ (a'b' +<+ b) :<: common
 503         _ -> impossible
 504
 505 merge_sets :: RepoPatch p => (RL (PatchInfoAnd p) :\/: RL (PatchInfoAnd p)) C(x y) -> Sealed (RL (PatchInfoAnd p) C(y))
 506 merge_sets (l :\/: r) =
 507     let pl = mapFL_FL hopefully $ reverseRL l
 508         pr = mapFL_FL hopefully $ reverseRL r
 509         p2pimp p = patch2patchinfo p `piap` p
 510     in case merge (pl:\/: pr) of
 511        (_:/\:pl') -> seal $ reverseFL $ mapFL_FL p2pimp pl'
 512 \end{code}