{-# LANGUAGE UndecidableInstances #-}
module Darcs.Patch.Named.Wrapped
  ( WrappedNamed(..)
  , fromRebasing
  ) where

import Darcs.Prelude

import Control.Applicative ( (<|>) )
import Data.Coerce ( coerce )

import Darcs.Patch.Apply ( Apply(..) )
import Darcs.Patch.Commute ( Commute(..) )
import Darcs.Patch.Effect ( Effect(..) )
import Darcs.Patch.Ident ( Ident(..), PatchId )
import Darcs.Patch.Format ( PatchListFormat(..), ListFormat )
import Darcs.Patch.Info ( PatchInfo, showPatchInfo )
import Darcs.Patch.FromPrim ( FromPrim, PrimPatchBase(..) )
import Darcs.Patch.Named ( Named(..), patch2patchinfo )
import Darcs.Patch.Read ( ReadPatch(..) )
import Darcs.Patch.Rebase.Suspended
  ( Suspended(..)
  , addFixupsToSuspended
  , removeFixupsFromSuspended
  )
import Darcs.Patch.RepoPatch ( RepoPatch )
import Darcs.Patch.RepoType
  ( RepoType(..), IsRepoType(..), SRepoType(..)
  , RebaseType(..), SRebaseType(..)
  )
import Darcs.Patch.Show ( ShowPatchBasic(..) )

import Darcs.Patch.Witnesses.Sealed ( mapSeal )
import Darcs.Patch.Witnesses.Show ( Show1, Show2 )
import Darcs.Patch.Witnesses.Ordered
  ( FL(..), mapFL_FL, (:>)(..)
  )

-- |A patch that lives in a repository where an old-style rebase is in
-- progress. Such a repository will consist of @Normal@ patches
-- along with exactly one @Suspended@ patch.
--
-- It is here only so that we can upgrade an old-style rebase.
--
-- @NormalP@ represents a normal patch within a respository where a
-- rebase is in progress. @NormalP 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
-- @RebaseP@ patch and setting the appropriate format flag.
--
-- Note that the witnesses are such that the @RebaseP@
-- 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.
data WrappedNamed (rt :: RepoType) p wX wY where
  NormalP :: !(Named p wX wY) -> WrappedNamed rt p wX wY
  RebaseP
    :: (PrimPatchBase p, FromPrim p, Effect p)
    => !PatchInfo
    -> !(Suspended p wX wX)
    -> WrappedNamed ('RepoType 'IsRebase) p wX wX

deriving instance Show2 p => Show (WrappedNamed rt p wX wY)

instance Show2 p => Show1 (WrappedNamed rt p wX)

instance Show2 p => Show2 (WrappedNamed rt p)

fromRebasing :: WrappedNamed rt p wX wY -> Named p wX wY
fromRebasing :: WrappedNamed rt p wX wY -> Named p wX wY
fromRebasing (NormalP Named p wX wY
n) = Named p wX wY
n
fromRebasing (RebaseP {}) = String -> Named p wX wY
forall a. HasCallStack => String -> a
error String
"internal error: found rebasing internal patch"

instance PrimPatchBase p => PrimPatchBase (WrappedNamed rt p) where
  type PrimOf (WrappedNamed rt p) = PrimOf p

type instance PatchId (WrappedNamed rt p) = PatchInfo

instance Ident (WrappedNamed rt p) where
  ident :: WrappedNamed rt p wX wY -> PatchId (WrappedNamed rt p)
ident (NormalP Named p wX wY
p) = Named p wX wY -> PatchInfo
forall (p :: * -> * -> *) wX wY. Named p wX wY -> PatchInfo
patch2patchinfo Named p wX wY
p
  ident (RebaseP PatchInfo
name Suspended p wX wX
_) = PatchInfo
PatchId (WrappedNamed rt p)
name

instance PatchListFormat (WrappedNamed rt p)

instance (ShowPatchBasic p, PatchListFormat p)
  => ShowPatchBasic (WrappedNamed rt p) where

  showPatch :: ShowPatchFor -> WrappedNamed rt p wX wY -> Doc
showPatch ShowPatchFor
f (NormalP Named p wX wY
n) = ShowPatchFor -> Named p wX wY -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
f Named p wX wY
n
  showPatch ShowPatchFor
f (RebaseP PatchInfo
i Suspended p wX wX
s) = ShowPatchFor -> PatchInfo -> Doc
showPatchInfo ShowPatchFor
f PatchInfo
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ShowPatchFor -> Suspended p wX wX -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
f Suspended p wX wX
s

-- This is a local hack to maintain backwards compatibility with
-- the on-disk format for rebases. Previously the rebase container
-- was internally represented via a 'Rebasing' type that sat *inside*
-- a 'Named', and so the rebase container patch had the structure
-- 'NamedP i [] (Suspendended s :>: NilFL)'. This structure was reflected
-- in the way it was saved on disk.
-- The easiest to read this structure is to use an intermediate type
-- that reflects the old structure.
-- TODO: switch to a more natural on-disk structure that directly
-- saves/reads 'RebaseP'.
data ReadRebasing p wX wY where
  ReadNormal    :: p wX wY -> ReadRebasing p wX wY
  ReadSuspended :: Suspended p wX wX -> ReadRebasing p wX wX

instance ( ReadPatch p, PrimPatchBase p, FromPrim p, Effect p, PatchListFormat p
         , RepoPatch p, IsRepoType rt
         ) => ReadPatch (WrappedNamed rt p) where
  readPatch' :: Parser (Sealed (WrappedNamed rt p wX))
readPatch' =
    case SRepoType rt
forall (rt :: RepoType). IsRepoType rt => SRepoType rt
singletonRepoType :: SRepoType rt of
      SRepoType SRebaseType rebaseType
SIsRebase ->
        let wrapNamed :: Named (ReadRebasing p) wX wY -> WrappedNamed rt p wX wY
            wrapNamed :: Named (ReadRebasing p) wX wY -> WrappedNamed rt p wX wY
wrapNamed (NamedP PatchInfo
i [] (ReadSuspended Suspended p wX wX
s :>: FL (ReadRebasing p) wY wY
NilFL))
               = PatchInfo
-> Suspended p wX wX -> WrappedNamed ('RepoType 'IsRebase) p wX wX
forall (p :: * -> * -> *) wX.
(PrimPatchBase p, FromPrim p, Effect p) =>
PatchInfo
-> Suspended p wX wX -> WrappedNamed ('RepoType 'IsRebase) p wX wX
RebaseP PatchInfo
i Suspended p wX wX
s
            wrapNamed (NamedP PatchInfo
i [PatchInfo]
deps FL (ReadRebasing p) wX wY
ps) = Named p wX wY -> WrappedNamed rt p wX wY
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
Named p wX wY -> WrappedNamed rt p wX wY
NormalP (PatchInfo -> [PatchInfo] -> FL p wX wY -> Named p wX wY
forall (p :: * -> * -> *) wX wY.
PatchInfo -> [PatchInfo] -> FL p wX wY -> Named p wX wY
NamedP PatchInfo
i [PatchInfo]
deps ((forall wW wY. ReadRebasing p wW wY -> p wW wY)
-> FL (ReadRebasing p) wX wY -> FL p wX wY
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall wW wY. ReadRebasing p wW wY -> p wW wY
forall (p :: * -> * -> *) wX wY. ReadRebasing p wX wY -> p wX wY
unRead FL (ReadRebasing p) wX wY
ps))

            unRead :: ReadRebasing p wX wY -> p wX wY
unRead (ReadNormal p wX wY
p) = p wX wY
p
            unRead (ReadSuspended Suspended p wX wX
_) = String -> p wX wY
forall a. HasCallStack => String -> a
error String
"unexpected suspended patch"

        in (Sealed (Named (ReadRebasing p) wX)
 -> Sealed (WrappedNamed rt p wX))
-> Parser ByteString (Sealed (Named (ReadRebasing p) wX))
-> Parser (Sealed (WrappedNamed rt p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall wX.
 Named (ReadRebasing p) wX wX -> WrappedNamed rt p wX wX)
-> Sealed (Named (ReadRebasing p) wX)
-> Sealed (WrappedNamed rt p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. Named (ReadRebasing p) wX wX -> WrappedNamed rt p wX wX
forall wX wY.
Named (ReadRebasing p) wX wY -> WrappedNamed rt p wX wY
wrapNamed) Parser ByteString (Sealed (Named (ReadRebasing p) wX))
forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'

      SRepoType rt
_ -> (Sealed (Named p wX) -> Sealed (WrappedNamed rt p wX))
-> Parser ByteString (Sealed (Named p wX))
-> Parser (Sealed (WrappedNamed rt p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall wX. Named p wX wX -> WrappedNamed rt p wX wX)
-> Sealed (Named p wX) -> Sealed (WrappedNamed rt p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. Named p wX wX -> WrappedNamed rt p wX wX
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
Named p wX wY -> WrappedNamed rt p wX wY
NormalP) Parser ByteString (Sealed (Named p wX))
forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'

instance PatchListFormat p => PatchListFormat (ReadRebasing p) where
  patchListFormat :: ListFormat (ReadRebasing p)
patchListFormat = ListFormat p -> ListFormat (ReadRebasing p)
coerce (ListFormat p
forall (p :: * -> * -> *). PatchListFormat p => ListFormat p
patchListFormat :: ListFormat p)

instance (ReadPatch p, PatchListFormat p, PrimPatchBase p, RepoPatch p) => ReadPatch (ReadRebasing p) where
  readPatch' :: Parser (Sealed (ReadRebasing p wX))
readPatch' =
       (forall wX. Suspended p wX wX -> ReadRebasing p wX wX)
-> Sealed (Suspended p wX) -> Sealed (ReadRebasing p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. Suspended p wX wX -> ReadRebasing p wX wX
forall wX wY. Suspended p wX wY -> ReadRebasing p wX wY
toSuspended (Sealed (Suspended p wX) -> Sealed (ReadRebasing p wX))
-> Parser ByteString (Sealed (Suspended p wX))
-> Parser (Sealed (ReadRebasing p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Sealed (Suspended p wX))
forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'
    Parser (Sealed (ReadRebasing p wX))
-> Parser (Sealed (ReadRebasing p wX))
-> Parser (Sealed (ReadRebasing p wX))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall wX. p wX wX -> ReadRebasing p wX wX)
-> Sealed (p wX) -> Sealed (ReadRebasing p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. p wX wX -> ReadRebasing p wX wX
forall (p :: * -> * -> *) wX wY. p wX wY -> ReadRebasing p wX wY
ReadNormal (Sealed (p wX) -> Sealed (ReadRebasing p wX))
-> Parser ByteString (Sealed (p wX))
-> Parser (Sealed (ReadRebasing p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Sealed (p wX))
forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'
      where -- needed to get a suitably polymorphic type
            toSuspended :: Suspended p wX wY -> ReadRebasing p wX wY
            toSuspended :: Suspended p wX wY -> ReadRebasing p wX wY
toSuspended (Items FL (RebaseChange (PrimOf p)) wX wY
ps) = Suspended p wX wX -> ReadRebasing p wX wX
forall (p :: * -> * -> *) wX.
Suspended p wX wX -> ReadRebasing p wX wX
ReadSuspended (FL (RebaseChange (PrimOf p)) wX wY -> Suspended p wX wX
forall (p :: * -> * -> *) wX wY.
FL (RebaseChange (PrimOf p)) wX wY -> Suspended p wX wX
Items FL (RebaseChange (PrimOf p)) wX wY
ps)

instance Apply p => Apply (WrappedNamed rt p) where
  type ApplyState (WrappedNamed rt p) = ApplyState p
  apply :: WrappedNamed rt p wX wY -> m ()
apply (NormalP Named p wX wY
n) = Named p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply Named p wX wY
n
  -- the data type definition claims that a 'RebaseP' has no effect,
  -- so make sure it really doesn't have any
  apply (RebaseP PatchInfo
_ Suspended p wX wX
_) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  unapply :: WrappedNamed rt p wX wY -> m ()
unapply (NormalP Named p wX wY
n) = Named p wX wY -> m ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
unapply Named p wX wY
n
  unapply (RebaseP PatchInfo
_ Suspended p wX wX
_) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance Commute p => Commute (WrappedNamed rt p) where
  commute :: (:>) (WrappedNamed rt p) (WrappedNamed rt p) wX wY
-> Maybe ((:>) (WrappedNamed rt p) (WrappedNamed rt p) wX wY)
commute (NormalP Named p wX wZ
n1 :> NormalP Named p wZ wY
n2) = do
    Named p wX wZ
n2' :> Named p wZ wY
n1' <- (:>) (Named p) (Named p) wX wY
-> Maybe ((:>) (Named p) (Named p) wX wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (Named p wX wZ
n1 Named p wX wZ -> Named p wZ wY -> (:>) (Named p) (Named p) wX wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> Named p wZ wY
n2)
    (:>) (WrappedNamed rt p) (WrappedNamed rt p) wX wY
-> Maybe ((:>) (WrappedNamed rt p) (WrappedNamed rt p) wX wY)
forall (m :: * -> *) a. Monad m => a -> m a
return (Named p wX wZ -> WrappedNamed rt p wX wZ
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
Named p wX wY -> WrappedNamed rt p wX wY
NormalP Named p wX wZ
n2' WrappedNamed rt p wX wZ
-> WrappedNamed rt p wZ wY
-> (:>) (WrappedNamed rt p) (WrappedNamed rt p) wX wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> Named p wZ wY -> WrappedNamed rt p wZ wY
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
Named p wX wY -> WrappedNamed rt p wX wY
NormalP Named p wZ wY
n1')

  commute (RebaseP PatchInfo
i1 Suspended p wX wX
s1 :> RebaseP PatchInfo
i2 Suspended p wZ wZ
s2) =
    -- Two rebases in sequence must have the same starting context,
    -- so they should trivially commute.
    -- This case shouldn't actually happen since each repo only has
    -- a single Suspended patch.
    (:>)
  (WrappedNamed ('RepoType 'IsRebase) p)
  (WrappedNamed ('RepoType 'IsRebase) p)
  wZ
  wX
-> Maybe
     ((:>)
        (WrappedNamed ('RepoType 'IsRebase) p)
        (WrappedNamed ('RepoType 'IsRebase) p)
        wZ
        wX)
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchInfo
-> Suspended p wZ wZ -> WrappedNamed ('RepoType 'IsRebase) p wZ wZ
forall (p :: * -> * -> *) wX.
(PrimPatchBase p, FromPrim p, Effect p) =>
PatchInfo
-> Suspended p wX wX -> WrappedNamed ('RepoType 'IsRebase) p wX wX
RebaseP PatchInfo
i2 Suspended p wZ wZ
s2 WrappedNamed ('RepoType 'IsRebase) p wZ wZ
-> WrappedNamed ('RepoType 'IsRebase) p wZ wX
-> (:>)
     (WrappedNamed ('RepoType 'IsRebase) p)
     (WrappedNamed ('RepoType 'IsRebase) p)
     wZ
     wX
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> PatchInfo
-> Suspended p wX wX -> WrappedNamed ('RepoType 'IsRebase) p wX wX
forall (p :: * -> * -> *) wX.
(PrimPatchBase p, FromPrim p, Effect p) =>
PatchInfo
-> Suspended p wX wX -> WrappedNamed ('RepoType 'IsRebase) p wX wX
RebaseP PatchInfo
i1 Suspended p wX wX
s1)

  commute (NormalP Named p wX wZ
n1 :> RebaseP PatchInfo
i2 Suspended p wZ wZ
s2) =
    (:>)
  (WrappedNamed ('RepoType 'IsRebase) p) (WrappedNamed rt p) wX wZ
-> Maybe
     ((:>)
        (WrappedNamed ('RepoType 'IsRebase) p) (WrappedNamed rt p) wX wZ)
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchInfo
-> Suspended p wX wX -> WrappedNamed ('RepoType 'IsRebase) p wX wX
forall (p :: * -> * -> *) wX.
(PrimPatchBase p, FromPrim p, Effect p) =>
PatchInfo
-> Suspended p wX wX -> WrappedNamed ('RepoType 'IsRebase) p wX wX
RebaseP PatchInfo
i2 (Named p wX wZ -> Suspended p wZ wZ -> Suspended p wX wX
forall (p :: * -> * -> *) wX wY.
(PrimPatchBase p, Commute p, FromPrim p, Effect p) =>
Named p wX wY -> Suspended p wY wY -> Suspended p wX wX
addFixupsToSuspended Named p wX wZ
n1 Suspended p wZ wZ
s2) WrappedNamed ('RepoType 'IsRebase) p wX wX
-> WrappedNamed rt p wX wZ
-> (:>)
     (WrappedNamed ('RepoType 'IsRebase) p) (WrappedNamed rt p) wX wZ
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> Named p wX wZ -> WrappedNamed rt p wX wZ
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
Named p wX wY -> WrappedNamed rt p wX wY
NormalP Named p wX wZ
n1)

  commute (RebaseP PatchInfo
i1 Suspended p wX wX
s1 :> NormalP Named p wZ wY
n2) =
    (:>)
  (WrappedNamed rt p) (WrappedNamed ('RepoType 'IsRebase) p) wZ wY
-> Maybe
     ((:>)
        (WrappedNamed rt p) (WrappedNamed ('RepoType 'IsRebase) p) wZ wY)
forall (m :: * -> *) a. Monad m => a -> m a
return (Named p wZ wY -> WrappedNamed rt p wZ wY
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
Named p wX wY -> WrappedNamed rt p wX wY
NormalP Named p wZ wY
n2 WrappedNamed rt p wZ wY
-> WrappedNamed ('RepoType 'IsRebase) p wY wY
-> (:>)
     (WrappedNamed rt p) (WrappedNamed ('RepoType 'IsRebase) p) wZ wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> PatchInfo
-> Suspended p wY wY -> WrappedNamed ('RepoType 'IsRebase) p wY wY
forall (p :: * -> * -> *) wX.
(PrimPatchBase p, FromPrim p, Effect p) =>
PatchInfo
-> Suspended p wX wX -> WrappedNamed ('RepoType 'IsRebase) p wX wX
RebaseP PatchInfo
i1 (Named p wZ wY -> Suspended p wZ wZ -> Suspended p wY wY
forall (p :: * -> * -> *) wX wY.
(PrimPatchBase p, Commute p, FromPrim p, Effect p) =>
Named p wX wY -> Suspended p wX wX -> Suspended p wY wY
removeFixupsFromSuspended Named p wZ wY
n2 Suspended p wX wX
Suspended p wZ wZ
s1))