{-# LANGUAGE UndecidableInstances, StandaloneDeriving #-}
module Darcs.Patch.Rebase.Container
( Suspended(..)
, countToEdit, simplifyPush, simplifyPushes
, addFixupsToSuspended, removeFixupsFromSuspended
) where
import Prelude ()
import Darcs.Prelude
import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) )
import Darcs.Patch.Effect ( Effect(..) )
import Darcs.Patch.FileHunk ( IsHunk(..) )
import Darcs.Patch.Format ( PatchListFormat(..) )
import Darcs.Patch.Invert ( invert )
import Darcs.Patch.Named ( Named )
import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Commute ( Commute(..) )
import Darcs.Patch.Inspect ( PatchInspect(..) )
import Darcs.Patch.Read ( ReadPatch(..) )
import Darcs.Patch.Show ( ShowPatch(..) )
import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim(..), FromPrim(..) )
import Darcs.Patch.Read ( bracketedFL )
import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), namedToFixups )
import Darcs.Patch.Rebase.Item ( RebaseItem(..) )
import qualified Darcs.Patch.Rebase.Item as Item ( countToEdit, simplifyPush, simplifyPushes )
import Darcs.Patch.Repair ( Check(..), Repair(..), RepairToFL(..) )
import Darcs.Patch.Show ( ShowPatchBasic(..) )
import Darcs.Patch.ReadMonads ( lexString, myLex' )
import Darcs.Patch.Witnesses.Ordered
import Darcs.Patch.Witnesses.Sealed
import Darcs.Patch.Witnesses.Show
( Show1(..), Show2(..)
, ShowDict(ShowDictClass)
)
import Darcs.Util.Printer ( vcat, text, blueText, ($$), (<+>) )
import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )
import Control.Applicative ( (<|>) )
import Control.Arrow ( (***), second )
import Control.Monad ( when )
import Data.Maybe ( catMaybes )
import qualified Data.ByteString.Char8 as BC ( pack )
data Suspended p wX wY where
Items :: FL (RebaseItem p) wX wY -> Suspended p wX wX
deriving instance (Show2 p, Show2 (PrimOf p)) => Show (Suspended p wX wY)
instance (Show2 p, Show2 (PrimOf p)) => Show1 (Suspended p wX) where
showDict1 = ShowDictClass
instance (Show2 p, Show2 (PrimOf p)) => Show2 (Suspended p) where
showDict2 = ShowDictClass
instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Suspended p) where
listTouchedFiles (Items ps) = listTouchedFiles ps
hunkMatches f (Items ps) = hunkMatches f ps
instance Effect (Suspended p) where
effect (Items _) = NilFL
instance Conflict p => Conflict (Suspended p) where
resolveConflicts _ = []
conflictedEffect _ = []
instance Apply (Suspended p) where
type ApplyState (Suspended p) = ApplyState p
apply _ = return ()
instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Suspended p) where
showPatch f (Items ps)
= blueText "rebase" <+> text "0.0" <+> blueText "{"
$$ vcat (mapFL (showPatch f) ps)
$$ blueText "}"
instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (Suspended p) where
summary (Items ps) = summaryFL ps
summaryFL ps = vcat (mapFL summary ps)
instance PrimPatchBase p => PrimPatchBase (Suspended p) where
type PrimOf (Suspended p) = PrimOf p
instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (Suspended p) where
readPatch' =
do lexString (BC.pack "rebase")
version <- myLex'
when (version /= BC.pack "0.0") $ error $ "can't handle rebase version " ++ show version
(lexString (BC.pack "{}") >> return (seal (Items NilFL)))
<|>
(unseal (Sealed . Items) <$> bracketedFL readPatch' '{' '}')
instance Check p => Check (Suspended p) where
isInconsistent (Items ps) =
case catMaybes (mapFL isInconsistent ps) of
[] -> Nothing
xs -> Just (vcat xs)
instance Repair (Suspended p) where
applyAndTryToFix (Items ps) =
return . fmap (unlines *** Items) $ repairInternal ps
instance RepairToFL (Suspended p) where
applyAndTryToFixFL s = fmap (second $ (:>: NilFL)) <$> applyAndTryToFix s
class RepairInternalFL p where
repairInternalFL :: p wX wY -> Maybe ([String], FL p wX wY)
class RepairInternal p where
repairInternal :: p wX wY -> Maybe ([String], p wX wY)
instance RepairInternalFL p => RepairInternal (FL p) where
repairInternal NilFL = Nothing
repairInternal (x :>: ys) =
case (repairInternalFL x, repairInternal ys) of
(Nothing , Nothing) -> Nothing
(Just (e, rxs), Nothing) -> Just (e , rxs +>+ ys )
(Nothing , Just (e', rys)) -> Just (e' , x :>: rys)
(Just (e, rxs), Just (e', rys)) -> Just (e ++ e', rxs +>+ rys)
instance RepairInternalFL (RebaseItem p) where
repairInternalFL (ToEdit _) = Nothing
repairInternalFL (Fixup p) = fmap (second $ mapFL_FL Fixup) $ repairInternalFL p
instance RepairInternalFL (RebaseFixup p) where
repairInternalFL (PrimFixup _) = Nothing
repairInternalFL (NameFixup _) = Nothing
countToEdit :: Suspended p wX wY -> Int
countToEdit (Items ps) = Item.countToEdit ps
onSuspended
:: (forall wZ . FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX))
-> Suspended p wY wY
-> Suspended p wX wX
onSuspended f (Items ps) = unseal Items (f ps)
addFixupsToSuspended
:: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
=> Named p wX wY
-> Suspended p wY wY
-> Suspended p wX wX
addFixupsToSuspended p = simplifyPushes D.MyersDiff (namedToFixups p)
removeFixupsFromSuspended
:: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
=> Named p wX wY
-> Suspended p wX wX
-> Suspended p wY wY
removeFixupsFromSuspended p = simplifyPushes D.MyersDiff (invert (namedToFixups p))
simplifyPush
:: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
=> D.DiffAlgorithm
-> RebaseFixup p wX wY
-> Suspended p wY wY
-> Suspended p wX wX
simplifyPush da fixups = onSuspended (Item.simplifyPush da fixups)
simplifyPushes
:: (PrimPatchBase p, Commute p, FromPrim p, Effect p)
=> D.DiffAlgorithm
-> FL (RebaseFixup p) wX wY
-> Suspended p wY wY
-> Suspended p wX wX
simplifyPushes da fixups = onSuspended (Item.simplifyPushes da fixups)