1{-# LANGUAGE UndecidableInstances #-} 2module Darcs.Patch.Rebase.Suspended 3 ( Suspended(..) 4 , countToEdit, simplifyPush, simplifyPushes 5 , addFixupsToSuspended, removeFixupsFromSuspended 6 , addToEditsToSuspended 7 ) where 8 9import Darcs.Prelude 10 11import Darcs.Patch.Effect ( Effect(..) ) 12import Darcs.Patch.Format ( PatchListFormat(..) ) 13import Darcs.Patch.Invert ( invert ) 14import Darcs.Patch.Named ( Named(..) ) 15import Darcs.Patch.Commute ( Commute(..) ) 16import Darcs.Patch.Info ( replaceJunk ) 17import Darcs.Patch.Inspect ( PatchInspect(..) ) 18import Darcs.Patch.Read ( ReadPatch(..) ) 19import Darcs.Patch.FromPrim ( PrimPatchBase(..), FromPrim(..), FromPrim(..) ) 20import Darcs.Patch.Read ( bracketedFL ) 21import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), namedToFixups ) 22import Darcs.Patch.Rebase.Name ( RebaseName(..) ) 23import Darcs.Patch.RepoPatch ( RepoPatch ) 24import qualified Darcs.Patch.Rebase.Change as Change ( simplifyPush, simplifyPushes ) 25import Darcs.Patch.Rebase.Change ( RebaseChange(..), addNamedToRebase ) 26import qualified Darcs.Patch.Rebase.Legacy.Item as Item ( toRebaseChanges, RebaseItem ) 27import Darcs.Patch.Show ( ShowPatchBasic(..) ) 28import Darcs.Util.Parser ( lexString, lexWord ) 29import Darcs.Patch.Witnesses.Ordered 30import Darcs.Patch.Witnesses.Sealed 31import Darcs.Patch.Witnesses.Show ( Show1, Show2 ) 32import Darcs.Util.Printer ( vcat, text, blueText, ($$), (<+>) ) 33import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) ) 34 35import Control.Applicative ( (<|>) ) 36import qualified Data.ByteString.Char8 as BC ( pack ) 37 38-- | A single @Suspended@ patch contains the entire rebase state, in the form 39-- of 'RebaseItem's. 40-- 41-- The witnesses are such that a @Suspended@ appears to have no effect. 42-- This behaviour is only kept so we can read old-style rebase patches, 43-- where the entire rebase state was kept in a single patch on disk. 44-- 45data Suspended p wX wY where 46 Items :: FL (RebaseChange (PrimOf p)) wX wY -> Suspended p wX wX 47 48deriving instance (Show2 p, Show2 (PrimOf p)) => Show (Suspended p wX wY) 49 50instance (Show2 p, Show2 (PrimOf p)) => Show1 (Suspended p wX) 51 52instance (Show2 p, Show2 (PrimOf p)) => Show2 (Suspended p) 53 54instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Suspended p) where 55 listTouchedFiles (Items ps) = listTouchedFiles ps 56 hunkMatches f (Items ps) = hunkMatches f ps 57 58instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Suspended p) where 59 showPatch f (Items ps) 60 = blueText "rebase" <+> text "0.2" <+> blueText "{" 61 $$ vcat (mapFL (showPatch f) ps) 62 $$ blueText "}" 63 64instance (PrimPatchBase p, PatchListFormat p, ReadPatch p, RepoPatch p) => ReadPatch (Suspended p) where 65 readPatch' = 66 do lexString (BC.pack "rebase") 67 version <- lexWord 68 case () of 69 _ | version == BC.pack "0.2" -> 70 (lexString (BC.pack "{}") >> return (seal (Items NilFL))) 71 <|> 72 (unseal (Sealed . Items) <$> bracketedFL readPatch' '{' '}') 73 -- version 0.1 was a very temporary intermediate state on the way to 0.2 74 -- and we don't offer an upgrade path for it. 75 | version == BC.pack "0.0" -> 76 -- Note that if we have an "old-style" rebase, i.e. the first rebase implementation in 77 -- darcs, characterised by the format string "rebase-in-progress", then only version 78 -- 0.0 is possible here. On the other hand, the more recent implementation could use any 79 -- version including 0.0. 80 -- Unlike version 0.2, version 0.0 rebase patches on disk can contain conflicts. These are 81 -- removed when reading by Item.toRebaseChanges, which ultimately calls 'fullUnwind', the 82 -- same machinery that is used when version 0.2 patches are created from scratch. 83 let 84 itemsToSuspended :: Sealed (FL (Item.RebaseItem p) wX) -> Sealed (Suspended p wX) 85 itemsToSuspended (Sealed ps) = 86 case Item.toRebaseChanges ps of 87 Sealed ps' -> Sealed (Items ps') 88 in 89 (lexString (BC.pack "{}") >> return (seal (Items NilFL))) 90 <|> 91 itemsToSuspended <$> bracketedFL readPatch' '{' '}' 92 | otherwise -> error $ "can't handle rebase version " ++ show version 93 94countToEdit :: Suspended p wX wY -> Int 95countToEdit (Items ps) = lengthFL ps 96 97onSuspended 98 :: (forall wZ . FL (RebaseChange (PrimOf p)) wY wZ -> Sealed (FL (RebaseChange (PrimOf p)) wX)) 99 -> Suspended p wY wY 100 -> Suspended p wX wX 101onSuspended f (Items ps) = unseal Items (f ps) 102 103-- |add fixups for the name and effect of a patch to a 'Suspended' 104addFixupsToSuspended 105 :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) 106 => Named p wX wY 107 -> Suspended p wY wY 108 -> Suspended p wX wX 109addFixupsToSuspended p = simplifyPushes D.MyersDiff (namedToFixups p) 110 111-- |remove fixups (actually, add their inverse) for the name and effect of a patch to a 'Suspended' 112removeFixupsFromSuspended 113 :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) 114 => Named p wX wY 115 -> Suspended p wX wX 116 -> Suspended p wY wY 117removeFixupsFromSuspended p = simplifyPushes D.MyersDiff (invert (namedToFixups p)) 118 119-- | Add 'Named' patches for editing to a 'Suspended'. The patches to be 120-- suspended are renamed by replacing the junk in their 'Patchinfo'. 121-- 122-- The reason we rename patches immediately when suspending them is that 123-- the user may pull an identical copy from a clone, Which means we have 124-- the same patch name twice, once in the normal repo and once suspended. 125-- Furthermore, they can again suspend that copy, leaving us with multiple 126-- copies of the same patch in the rebase state. This is bad because it 127-- invalidates most of the invariants for RebaseName fixups. See issue2445 128-- and tests/rebase-repull.sh for examples which lead to crashes when we 129-- don't do the renaming here. 130addToEditsToSuspended 131 :: RepoPatch p 132 => D.DiffAlgorithm 133 -> FL (Named p) wX wY 134 -> Suspended p wY wY 135 -> IO (Suspended p wX wX) 136addToEditsToSuspended _ NilFL items = return items 137addToEditsToSuspended da (NamedP old ds ps :>: qs) items = do 138 items' <- addToEditsToSuspended da qs items 139 new <- replaceJunk old 140 case simplifyPush da (NameFixup (Rename new old)) items' of 141 Items items'' -> 142 case addNamedToRebase da (NamedP new ds ps) items'' of 143 Sealed items''' -> return $ Items items''' 144 145simplifyPush 146 :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) 147 => D.DiffAlgorithm 148 -> RebaseFixup (PrimOf p) wX wY 149 -> Suspended p wY wY 150 -> Suspended p wX wX 151simplifyPush da fixups = onSuspended (Change.simplifyPush da fixups) 152 153simplifyPushes 154 :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) 155 => D.DiffAlgorithm 156 -> FL (RebaseFixup (PrimOf p)) wX wY 157 -> Suspended p wY wY 158 -> Suspended p wX wX 159simplifyPushes da fixups = onSuspended (Change.simplifyPushes da fixups) 160