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