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