Container.hs

{-# 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 )


-- TODO: move some of the docs of types to individual constructors
-- once http://trac.haskell.org/haddock/ticket/43 is fixed.

-- |A patch that lives in a repository where a rebase is in
-- progress. Such a repository will consist of @Normal@ patches
-- along with exactly one @Suspended@ patch.
--
-- Most rebase operations will require the @Suspended@ patch
-- to be at the end of the repository.
--
-- @Normal@ represents a normal patch within a respository where a
-- rebase is in progress. @Normal p@ is given the same on-disk
-- representation as @p@, so a repository can be switched into
-- and out of rebasing mode simply by adding or removing a
-- @Suspended@ patch and setting the appropriate format flag.
--
-- The single @Suspended@ patch contains the entire rebase
-- state, in the form of 'RebaseItem's.
--
-- Note that the witnesses are such that the @Suspended@
-- patch has no effect on the context of the rest of the
-- repository; in a sense the patches within it are
-- dangling off to one side from the main repository.
--
-- See Note [Rebase representation] in the 'Darcs.Patch.Rebase' for
-- a discussion of the design choice to embed the rebase state in a
-- single patch.
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) =
   -- TODO: ideally we would apply ps in a sandbox to check the individual patches
   -- are consistent with each other.
       return . fmap (unlines *** Items) $ repairInternal ps

instance RepairToFL (Suspended p) where
   applyAndTryToFixFL s = fmap (second $ (:>: NilFL)) <$> applyAndTryToFix s

-- Just repair the internals of the patch, without applying it to anything
-- or checking against an external context.
-- Included for the internal implementation of applyAndTryToFixFL for Rebasing,
-- consider either generalising it for use everywhere, or removing once
-- the implementation works in a sandbox and thus can use the "full" Repair on the
-- contained patches.
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)

-- |add fixups for the name and effect of a patch to a 'Suspended'
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)

-- |remove fixups (actually, add their inverse) for the name and effect of a patch to a 'Suspended'
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)