-- Copyright (C) 2002-2004,2007-2008 David Roundy
-- Copyright (C) 2005 Juliusz Chroboczek
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

module Darcs.Repository.Pending
    ( readPending
    , readTentativePending
    , writeTentativePending
    , siftForPending
    , tentativelyRemoveFromPending
    , tentativelyRemoveFromPW
    , revertPending
    , finalizePending
    , makeNewPending
    , tentativelyAddToPending
    , setTentativePending
    ) where

import Darcs.Prelude

import Control.Applicative
import Control.Exception ( catch, IOException )
import System.Directory ( renameFile )

import Darcs.Patch
    ( PrimOf
    , RepoPatch
    , PrimPatch
    , applyToTree
    , readPatch
    )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Commute ( Commute(..) )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Permutations
    ( removeFL
    , commuteWhatWeCanFL
    , commuteWhatWeCanRL
    )
import Darcs.Patch.Prim
    ( PrimSift(siftForPending)
    , PrimCanonize(primDecoalesce)
    )
import Darcs.Patch.Progress (progressFL)
import Darcs.Util.Parser ( Parser )
import Darcs.Patch.Read ( ReadPatch(..), bracketedFL )
import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(ForStorage) )
import Darcs.Patch.Show ( displayPatch )
import Darcs.Patch.Witnesses.Eq ( Eq2(..) )
import Darcs.Patch.Witnesses.Ordered
    ( RL(..), FL(..), (+>+), (+>>+), (:>)(..), mapFL, reverseFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), mapSeal )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart )

import Darcs.Repository.Flags ( UpdatePending (..))
import Darcs.Repository.InternalTypes ( Repository, withRepoLocation, unsafeCoerceT )
import Darcs.Repository.Paths ( pendingPath )

import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Exception ( catchNonExistence )
import Darcs.Util.Lock  ( writeDocBinFile, removeFileMayNotExist )
import Darcs.Util.Printer ( Doc, ($$), text, vcat, (<+>), renderString )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Tree ( Tree )


newSuffix, tentativeSuffix :: String
newSuffix :: String
newSuffix = String
".new"
tentativeSuffix :: String
tentativeSuffix = String
".tentative"

-- | Read the contents of pending.
readPending :: RepoPatch p => Repository rt p wR wU wT
            -> IO (Sealed (FL (PrimOf p) wR))
readPending :: Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wR))
readPending = String
-> Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wR))
forall (prim :: * -> * -> *) (rt :: RepoType) (p :: * -> * -> *) wR
       wU wT wX.
ReadPatch prim =>
String -> Repository rt p wR wU wT -> IO (Sealed (FL prim wX))
readPendingFile String
""

-- |Read the contents of tentative pending.
readTentativePending :: RepoPatch p => Repository rt p wR wU wT
                     -> IO (Sealed (FL (PrimOf p) wT))
readTentativePending :: Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
readTentativePending = String
-> Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
forall (prim :: * -> * -> *) (rt :: RepoType) (p :: * -> * -> *) wR
       wU wT wX.
ReadPatch prim =>
String -> Repository rt p wR wU wT -> IO (Sealed (FL prim wX))
readPendingFile String
tentativeSuffix

-- |Read the contents of tentative pending.
readNewPending :: RepoPatch p => Repository rt p wR wU wT
               -> IO (Sealed (FL (PrimOf p) wT))
readNewPending :: Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
readNewPending = String
-> Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
forall (prim :: * -> * -> *) (rt :: RepoType) (p :: * -> * -> *) wR
       wU wT wX.
ReadPatch prim =>
String -> Repository rt p wR wU wT -> IO (Sealed (FL prim wX))
readPendingFile String
newSuffix

-- |Read the pending file with the given suffix. CWD should be the repository
-- directory.
readPendingFile :: ReadPatch prim => String -> Repository rt p wR wU wT
                -> IO (Sealed (FL prim wX))
readPendingFile :: String -> Repository rt p wR wU wT -> IO (Sealed (FL prim wX))
readPendingFile String
suffix Repository rt p wR wU wT
_ =
  do
    let filepath :: String
filepath = String
pendingPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix
    ByteString
raw <- String -> IO ByteString
gzReadFilePS String
filepath
    case ByteString -> Either String (Sealed (FLM prim wX))
forall (p :: * -> * -> *) wX.
ReadPatch p =>
ByteString -> Either String (Sealed (p wX))
readPatch ByteString
raw of
      Right Sealed (FLM prim wX)
p -> Sealed (FL prim wX) -> IO (Sealed (FL prim wX))
forall (m :: * -> *) a. Monad m => a -> m a
return ((forall wX. FLM prim wX wX -> FL prim wX wX)
-> Sealed (FLM prim wX) -> Sealed (FL prim wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. FLM prim wX wX -> FL prim wX wX
forall (p :: * -> * -> *) wX wY. FLM p wX wY -> FL p wX wY
unFLM Sealed (FLM prim wX)
p)
      Left String
e -> String -> IO (Sealed (FL prim wX))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Sealed (FL prim wX)))
-> String -> IO (Sealed (FL prim wX))
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"Corrupt pending patch: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
filepath, String
e]
  IO (Sealed (FL prim wX))
-> Sealed (FL prim wX) -> IO (Sealed (FL prim wX))
forall a. IO a -> a -> IO a
`catchNonExistence` FL prim wX wX -> Sealed (FL prim wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL prim wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL

-- Wrapper around FL where printed format uses { } except around singletons.
-- Now that the Show behaviour of FL p can be customised (using
-- showFLBehavior (*)), we could instead change the general behaviour of FL Prim;
-- but since the pending code can be kept nicely compartmentalised, it's nicer
-- to do it this way.
-- (*) bf: This function does not exist.
newtype FLM p wX wY = FLM { FLM p wX wY -> FL p wX wY
unFLM :: FL p wX wY }

instance ReadPatch p => ReadPatch (FLM p) where
    readPatch' :: Parser (Sealed (FLM p wX))
readPatch' = (forall wX. FL p wX wX -> FLM p wX wX)
-> Sealed (FL p wX) -> Sealed (FLM p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall wX. FL p wX wX -> FLM p wX wX
forall (p :: * -> * -> *) wX wY. FL p wX wY -> FLM p wX wY
FLM (Sealed (FL p wX) -> Sealed (FLM p wX))
-> Parser ByteString (Sealed (FL p wX))
-> Parser (Sealed (FLM p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall wY. Parser (Sealed (p wY)))
-> Char -> Char -> Parser ByteString (Sealed (FL p wX))
forall (p :: * -> * -> *) wX.
(forall wY. Parser (Sealed (p wY)))
-> Char -> Char -> Parser (Sealed (FL p wX))
readMaybeBracketedFL forall wY. Parser (Sealed (p wY))
forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch' Char
'{' Char
'}'

instance ShowPatchBasic p => ShowPatchBasic (FLM p) where
    showPatch :: ShowPatchFor -> FLM p wX wY -> Doc
showPatch ShowPatchFor
f = (forall wX wY. p wX wY -> Doc) -> Char -> Char -> FL p wX wY -> Doc
forall (p :: * -> * -> *) wA wB.
(forall wX wY. p wX wY -> Doc) -> Char -> Char -> FL p wA wB -> Doc
showMaybeBracketedFL (ShowPatchFor -> p wX wY -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
f) Char
'{' Char
'}' (FL p wX wY -> Doc)
-> (FLM p wX wY -> FL p wX wY) -> FLM p wX wY -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FLM p wX wY -> FL p wX wY
forall (p :: * -> * -> *) wX wY. FLM p wX wY -> FL p wX wY
unFLM

readMaybeBracketedFL :: (forall wY . Parser (Sealed (p wY))) -> Char -> Char
                     -> Parser (Sealed (FL p wX))
readMaybeBracketedFL :: (forall wY. Parser (Sealed (p wY)))
-> Char -> Char -> Parser (Sealed (FL p wX))
readMaybeBracketedFL forall wY. Parser (Sealed (p wY))
parser Char
pre Char
post =
    (forall wY. Parser (Sealed (p wY)))
-> Char -> Char -> Parser (Sealed (FL p wX))
forall (p :: * -> * -> *) wX.
(forall wY. Parser (Sealed (p wY)))
-> Char -> Char -> Parser (Sealed (FL p wX))
bracketedFL forall wY. Parser (Sealed (p wY))
parser Char
pre Char
post Parser (Sealed (FL p wX))
-> Parser (Sealed (FL p wX)) -> Parser (Sealed (FL p wX))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((forall wX. p wX wX -> FL p wX wX)
-> Sealed (p wX) -> Sealed (FL p wX)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal (p wX wX -> FL p wX wX -> FL p wX wX
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL p wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) (Sealed (p wX) -> Sealed (FL p wX))
-> Parser ByteString (Sealed (p wX)) -> Parser (Sealed (FL p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Sealed (p wX))
forall wY. Parser (Sealed (p wY))
parser)

showMaybeBracketedFL :: (forall wX wY . p wX wY -> Doc) -> Char -> Char
                     -> FL p wA wB -> Doc
showMaybeBracketedFL :: (forall wX wY. p wX wY -> Doc) -> Char -> Char -> FL p wA wB -> Doc
showMaybeBracketedFL forall wX wY. p wX wY -> Doc
_ Char
pre Char
post FL p wA wB
NilFL = String -> Doc
text [Char
pre] Doc -> Doc -> Doc
$$ String -> Doc
text [Char
post]
showMaybeBracketedFL forall wX wY. p wX wY -> Doc
printer Char
_ Char
_ (p wA wY
p :>: FL p wY wB
NilFL) = p wA wY -> Doc
forall wX wY. p wX wY -> Doc
printer p wA wY
p
showMaybeBracketedFL forall wX wY. p wX wY -> Doc
printer Char
pre Char
post FL p wA wB
ps = String -> Doc
text [Char
pre] Doc -> Doc -> Doc
$$
                                           [Doc] -> Doc
vcat ((forall wX wY. p wX wY -> Doc) -> FL p wA wB -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wX wY. p wX wY -> Doc
printer FL p wA wB
ps) Doc -> Doc -> Doc
$$
                                           String -> Doc
text [Char
post]

-- |Write the contents of tentative pending.
writeTentativePending :: RepoPatch p => Repository rt p wR wU wT
                      -> FL (PrimOf p) wT wY -> IO ()
writeTentativePending :: Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
writeTentativePending = String -> Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
forall (prim :: * -> * -> *) (rt :: RepoType) (p :: * -> * -> *) wR
       wU wT wX wY.
ShowPatchBasic prim =>
String -> Repository rt p wR wU wT -> FL prim wX wY -> IO ()
writePendingFile String
tentativeSuffix

-- |Write the contents of new pending. CWD should be the repository directory.
writeNewPending :: RepoPatch p => Repository rt p wR wU wT
                               -> FL (PrimOf p) wT wP -> IO ()
writeNewPending :: Repository rt p wR wU wT -> FL (PrimOf p) wT wP -> IO ()
writeNewPending = String -> Repository rt p wR wU wT -> FL (PrimOf p) wT wP -> IO ()
forall (prim :: * -> * -> *) (rt :: RepoType) (p :: * -> * -> *) wR
       wU wT wX wY.
ShowPatchBasic prim =>
String -> Repository rt p wR wU wT -> FL prim wX wY -> IO ()
writePendingFile String
newSuffix

-- Write a pending file, with the given suffix. CWD should be the repository
-- directory.
writePendingFile :: ShowPatchBasic prim => String -> Repository rt p wR wU wT
                 -> FL prim wX wY -> IO ()
writePendingFile :: String -> Repository rt p wR wU wT -> FL prim wX wY -> IO ()
writePendingFile String
suffix Repository rt p wR wU wT
_ = String -> FLM prim wX wY -> IO ()
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
String -> p wX wY -> IO ()
writePatch String
name (FLM prim wX wY -> IO ())
-> (FL prim wX wY -> FLM prim wX wY) -> FL prim wX wY -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL prim wX wY -> FLM prim wX wY
forall (p :: * -> * -> *) wX wY. FL p wX wY -> FLM p wX wY
FLM
  where
    name :: String
name = String
pendingPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix

writePatch :: ShowPatchBasic p => FilePath -> p wX wY -> IO ()
writePatch :: String -> p wX wY -> IO ()
writePatch String
f p wX wY
p = String -> Doc -> IO ()
forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile String
f (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowPatchFor -> p wX wY -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForStorage p wX wY
p Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"\n"

-- | Remove as much as possible of the given list of prim patches from the
-- pending patch. The "as much as possible" is due to --look-for-* options
-- which cause changes that normally must be explicitly done by the user (such
-- as add, move, and replace) to be inferred from the the diff between
-- pristine and working. These changes cannot be removed from pending because
-- they have never been part of it.
--
-- This function is used by Darcs whenever it adds a patch to the repository
-- (eg. with apply or record). Think of it as one part of transferring patches
-- from pending to somewhere else.
tentativelyRemoveFromPending :: forall rt p wR wU wT wO. RepoPatch p
                             => Repository rt p wR wU wT
                             -> FL (PrimOf p) wO wT
                             -> IO ()
tentativelyRemoveFromPending :: Repository rt p wR wU wT -> FL (PrimOf p) wO wT -> IO ()
tentativelyRemoveFromPending Repository rt p wR wU wT
r FL (PrimOf p) wO wT
ps = do
    Sealed FL (PrimOf p) wO wX
pend <- Repository rt p wR wU wO -> IO (Sealed (FL (PrimOf p) wO))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
readTentativePending (Repository rt p wR wU wT -> Repository rt p wR wU wO
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wT'.
Repository rt p wR wU wT -> Repository rt p wR wU wT'
unsafeCoerceT Repository rt p wR wU wT
r :: Repository rt p wR wU wO)
    Sealed FL (PrimOf p) wT wX
newpend <-
        Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT)))
-> Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT))
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wO wT
-> FL (PrimOf p) wO wX
-> FL (PrimOf p) wX wX
-> Sealed (FL (PrimOf p) wT)
forall (p :: * -> * -> *) wA wB wC wD.
PrimPatch p =>
FL p wA wB -> FL p wA wC -> FL p wC wD -> Sealed (FL p wB)
updatePending (String -> FL (PrimOf p) wO wT -> FL (PrimOf p) wO wT
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Removing from pending:" FL (PrimOf p) wO wT
ps) FL (PrimOf p) wO wX
pend FL (PrimOf p) wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
    Repository rt p wR wU wT -> FL (PrimOf p) wT wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
writeTentativePending Repository rt p wR wU wT
r FL (PrimOf p) wT wX
newpend

-- | Similar to 'tentativelyRemoveFromPending', but also takes the (old)
-- difference between pending and working into account. It is used by amend and
-- record commands to adjust the pending patch. See the docs for
-- 'updatePending' below for details.
tentativelyRemoveFromPW :: forall rt p wR wO wT wP wU. RepoPatch p
                        => Repository rt p wR wU wT
                        -> FL (PrimOf p) wO wT -- added repo changes
                        -> FL (PrimOf p) wO wP -- O = old tentative
                        -> FL (PrimOf p) wP wU -- P = (old) pending
                        -> IO ()
tentativelyRemoveFromPW :: Repository rt p wR wU wT
-> FL (PrimOf p) wO wT
-> FL (PrimOf p) wO wP
-> FL (PrimOf p) wP wU
-> IO ()
tentativelyRemoveFromPW Repository rt p wR wU wT
r FL (PrimOf p) wO wT
changes FL (PrimOf p) wO wP
pending FL (PrimOf p) wP wU
working = do
    Sealed FL (PrimOf p) wT wX
pending' <- Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT)))
-> Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT))
forall a b. (a -> b) -> a -> b
$
        FL (PrimOf p) wO wT
-> FL (PrimOf p) wO wP
-> FL (PrimOf p) wP wU
-> Sealed (FL (PrimOf p) wT)
forall (p :: * -> * -> *) wA wB wC wD.
PrimPatch p =>
FL p wA wB -> FL p wA wC -> FL p wC wD -> Sealed (FL p wB)
updatePending (String -> FL (PrimOf p) wO wT -> FL (PrimOf p) wO wT
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Removing from pending:" FL (PrimOf p) wO wT
changes) FL (PrimOf p) wO wP
pending FL (PrimOf p) wP wU
working
    Repository rt p wR wU wT -> FL (PrimOf p) wT wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
writeTentativePending Repository rt p wR wU wT
r FL (PrimOf p) wT wX
pending'

{- |
@'updatePending' changes pending working@ updates @pending@ by removing the
@changes@ we added to the repository. If primitive patches were atomic, we
could assume that @changes@ is a subset of @pending +>+ working@, but alas,
they are not: before we select changes we coalesce them; and during
selection we can again arbitrarily split them (though currently this is
limited to hunks).

The algorithm is as follows. For each @x@ in @changes@ we first try to
remove it from @pending@ as is. If this fails, we commute it past @pending@,
pushing any (reverse) dependencies with it, and check if we can remove the
result from @working@.

If prim patches were atomic this check would always succeed and we would be
done now. But due to coalescing and splitting of prims it can fail, so we
must try harder: we now try to decoalesce the commuted changes from
@working@. If that fails, too, then we know that our @x@ originated from
@pending@. So we backtrack and decoalesce @x@ from @pending@. This final
step must not fail. If it does, then we have a bug because it means we
recorded a change that cannot be removed from the net effect of @pending@
and @working@.
-}
updatePending :: (PrimPatch p)
              => FL p wA wB -> FL p wA wC -> FL p wC wD -> Sealed (FL p wB)
-- no changes to the repo => cancel patches in pending whose inverse are in working
updatePending :: FL p wA wB -> FL p wA wC -> FL p wC wD -> Sealed (FL p wB)
updatePending FL p wA wB
NilFL FL p wA wC
ys FL p wC wD
zs = RL p wA wC -> FL p wC wD -> Sealed (FL p wA)
forall (p :: * -> * -> *) wA wB wC.
(Commute p, Invert p, Eq2 p) =>
RL p wA wB -> FL p wB wC -> Sealed (FL p wA)
removeRLFL (FL p wA wC -> RL p wA wC
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL p wA wC
ys) FL p wC wD
zs
-- pending is empty => keep it that way
updatePending FL p wA wB
_ FL p wA wC
NilFL FL p wC wD
_ = FL p wB wB -> Sealed (FL p wB)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL p wB wB
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
-- no working changes =>
--  just prepend inverted repo changes and rely on sifting to clean up pending
updatePending FL p wA wB
xs FL p wA wC
ys FL p wC wD
NilFL = FL p wB wC -> Sealed (FL p wB)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (FL p wA wB -> FL p wB wA
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL p wA wB
xs FL p wB wA -> FL p wA wC -> FL p wB wC
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL p wA wC
ys)
-- x can be removed from pending => continue with the rest
updatePending (p wA wY
x:>:FL p wY wB
xs) FL p wA wC
ys FL p wC wD
zs | Just FL p wY wC
ys' <- p wA wY -> FL p wA wC -> Maybe (FL p wY wC)
forall (p :: * -> * -> *) wX wY wZ.
(Eq2 p, Commute p) =>
p wX wY -> FL p wX wZ -> Maybe (FL p wY wZ)
removeFL p wA wY
x FL p wA wC
ys = FL p wY wB -> FL p wY wC -> FL p wC wD -> Sealed (FL p wB)
forall (p :: * -> * -> *) wA wB wC wD.
PrimPatch p =>
FL p wA wB -> FL p wA wC -> FL p wC wD -> Sealed (FL p wB)
updatePending FL p wY wB
xs FL p wY wC
ys' FL p wC wD
zs
-- x and its reverse dependencies can be commuted through pending
-- *and* the result can be removed or decoalesced from working
updatePending (p wA wY
x:>:FL p wY wB
xs) FL p wA wC
ys FL p wC wD
zs
  | FL p wY wZ
ys' :> p wZ wZ
ix' :> FL p wZ wC
deps <- (:>) p (FL p) wY wC -> (:>) (FL p) (p :> FL p) wY wC
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> (:>) (FL p) (p :> FL p) wX wY
commuteWhatWeCanFL (p wA wY -> p wY wA
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert p wA wY
x p wY wA -> FL p wA wC -> (:>) p (FL p) wY wC
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wA wC
ys)
  , Just FL p wZ wD
zs' <- FL p wC wZ -> FL p wC wD -> Maybe (FL p wZ wD)
forall (p :: * -> * -> *) wA wB wC.
(Commute p, Invert p, Eq2 p, PrimCanonize p) =>
FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC)
removeFromWorking (FL p wZ wC -> FL p wC wZ
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert (p wZ wZ
ix'p wZ wZ -> FL p wZ wC -> FL p wZ wC
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL p wZ wC
deps)) FL p wC wD
zs = FL p wY wB -> FL p wY wZ -> FL p wZ wD -> Sealed (FL p wB)
forall (p :: * -> * -> *) wA wB wC wD.
PrimPatch p =>
FL p wA wB -> FL p wA wC -> FL p wC wD -> Sealed (FL p wB)
updatePending FL p wY wB
xs FL p wY wZ
ys' FL p wZ wD
zs'
  where
    removeFromWorking :: FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC)
removeFromWorking FL p wA wB
as FL p wA wC
bs = FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC)
forall (p :: * -> * -> *) wA wB wC.
(Commute p, Invert p, Eq2 p) =>
FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC)
removeAllFL FL p wA wB
as FL p wA wC
bs Maybe (FL p wB wC) -> Maybe (FL p wB wC) -> Maybe (FL p wB wC)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FL p wA wC -> FL p wA wB -> Maybe (FL p wB wC)
forall (p :: * -> * -> *) wA wC wB.
(Commute p, Invert p, PrimCanonize p) =>
FL p wA wC -> FL p wA wB -> Maybe (FL p wB wC)
decoalesceAllFL FL p wA wC
bs FL p wA wB
as
-- decoalesce x from ys and continue with the rest
updatePending (p wA wY
x:>:FL p wY wB
xs) FL p wA wC
ys FL p wC wD
zs =
  case FL p wA wC -> p wA wY -> Maybe (FL p wY wC)
forall (p :: * -> * -> *) wA wC wB.
(Commute p, Invert p, PrimCanonize p) =>
FL p wA wC -> p wA wB -> Maybe (FL p wB wC)
decoalesceFL FL p wA wC
ys p wA wY
x of
    Just FL p wY wC
ys' -> FL p wY wB -> FL p wY wC -> FL p wC wD -> Sealed (FL p wB)
forall (p :: * -> * -> *) wA wB wC wD.
PrimPatch p =>
FL p wA wB -> FL p wA wC -> FL p wC wD -> Sealed (FL p wB)
updatePending FL p wY wB
xs FL p wY wC
ys' FL p wC wD
zs
    Maybe (FL p wY wC)
Nothing ->
      String -> Sealed (FL p wB)
forall a. HasCallStack => String -> a
error (String -> Sealed (FL p wB)) -> String -> Sealed (FL p wB)
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString
        (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"cannot eliminate repo change:"
        Doc -> Doc -> Doc
$$ p wA wY -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch p wA wY
x
        Doc -> Doc -> Doc
$$ String -> Doc
text String
"from pending:"
        Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((forall wW wZ. p wW wZ -> Doc) -> FL p wA wC -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ. p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL p wA wC
ys)
        Doc -> Doc -> Doc
$$ String -> Doc
text String
"or working:"
        Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((forall wW wZ. p wW wZ -> Doc) -> FL p wC wD -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ. p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL p wC wD
zs)

-- | Remove as many patches as possible of an 'RL' from an adjacent 'FL'.
removeRLFL :: (Commute p, Invert p, Eq2 p)
           => RL p wA wB -> FL p wB wC -> Sealed (FL p wA)
removeRLFL :: RL p wA wB -> FL p wB wC -> Sealed (FL p wA)
removeRLFL (RL p wA wY
ys:<:p wY wB
y) FL p wB wC
zs
  | Just FL p wY wC
zs' <- p wB wY -> FL p wB wC -> Maybe (FL p wY wC)
forall (p :: * -> * -> *) wX wY wZ.
(Eq2 p, Commute p) =>
p wX wY -> FL p wX wZ -> Maybe (FL p wY wZ)
removeFL (p wY wB -> p wB wY
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert p wY wB
y) FL p wB wC
zs = RL p wA wY -> FL p wY wC -> Sealed (FL p wA)
forall (p :: * -> * -> *) wA wB wC.
(Commute p, Invert p, Eq2 p) =>
RL p wA wB -> FL p wB wC -> Sealed (FL p wA)
removeRLFL RL p wA wY
ys FL p wY wC
zs'
  | Bool
otherwise = case (:>) (RL p) p wA wB -> (:>) (RL p) (p :> RL p) wA wB
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) (RL p) p wX wY -> (:>) (RL p) (p :> RL p) wX wY
commuteWhatWeCanRL (RL p wA wY
ys RL p wA wY -> p wY wB -> (:>) (RL p) p wA wB
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> p wY wB
y) of
      RL p wA wZ
deps :> p wZ wZ
y' :> RL p wZ wB
ys' -> (forall wX. FL p wZ wX -> FL p wA wX)
-> Sealed (FL p wZ) -> Sealed (FL p wA)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal ((RL p wA wZ
depsRL p wA wZ -> p wZ wZ -> RL p wA wZ
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<:p wZ wZ
y') RL p wA wZ -> FL p wZ wX -> FL p wA wX
forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> FL p wY wZ -> FL p wX wZ
+>>+) (Sealed (FL p wZ) -> Sealed (FL p wA))
-> Sealed (FL p wZ) -> Sealed (FL p wA)
forall a b. (a -> b) -> a -> b
$ RL p wZ wB -> FL p wB wC -> Sealed (FL p wZ)
forall (p :: * -> * -> *) wA wB wC.
(Commute p, Invert p, Eq2 p) =>
RL p wA wB -> FL p wB wC -> Sealed (FL p wA)
removeRLFL RL p wZ wB
ys' FL p wB wC
zs
removeRLFL RL p wA wB
NilRL FL p wB wC
_ = FL p wA wA -> Sealed (FL p wA)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL p wA wA
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL

-- | Remove all patches of the first 'FL' from the second 'FL' or fail.
removeAllFL :: (Commute p, Invert p, Eq2 p)
            => FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC)
removeAllFL :: FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC)
removeAllFL (p wA wY
y:>:FL p wY wB
ys) FL p wA wC
zs
  | Just FL p wY wC
zs' <- p wA wY -> FL p wA wC -> Maybe (FL p wY wC)
forall (p :: * -> * -> *) wX wY wZ.
(Eq2 p, Commute p) =>
p wX wY -> FL p wX wZ -> Maybe (FL p wY wZ)
removeFL p wA wY
y FL p wA wC
zs = FL p wY wB -> FL p wY wC -> Maybe (FL p wB wC)
forall (p :: * -> * -> *) wA wB wC.
(Commute p, Invert p, Eq2 p) =>
FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC)
removeAllFL FL p wY wB
ys FL p wY wC
zs'
  | Bool
otherwise = Maybe (FL p wB wC)
forall a. Maybe a
Nothing
removeAllFL FL p wA wB
NilFL FL p wA wC
zs = FL p wA wC -> Maybe (FL p wA wC)
forall a. a -> Maybe a
Just FL p wA wC
zs

-- | Decoalesce all patches in the second 'FL' from the first 'FL' or fail.
decoalesceAllFL :: (Commute p, Invert p, PrimCanonize p)
                => FL p wA wC -> FL p wA wB -> Maybe (FL p wB wC)
decoalesceAllFL :: FL p wA wC -> FL p wA wB -> Maybe (FL p wB wC)
decoalesceAllFL FL p wA wC
zs (p wA wY
y:>:FL p wY wB
ys)
  | Just FL p wY wC
zs' <- FL p wA wC -> p wA wY -> Maybe (FL p wY wC)
forall (p :: * -> * -> *) wA wC wB.
(Commute p, Invert p, PrimCanonize p) =>
FL p wA wC -> p wA wB -> Maybe (FL p wB wC)
decoalesceFL FL p wA wC
zs p wA wY
y = FL p wY wC -> FL p wY wB -> Maybe (FL p wB wC)
forall (p :: * -> * -> *) wA wC wB.
(Commute p, Invert p, PrimCanonize p) =>
FL p wA wC -> FL p wA wB -> Maybe (FL p wB wC)
decoalesceAllFL FL p wY wC
zs' FL p wY wB
ys
  | Bool
otherwise = Maybe (FL p wB wC)
forall a. Maybe a
Nothing
decoalesceAllFL FL p wA wC
zs FL p wA wB
NilFL = FL p wA wC -> Maybe (FL p wA wC)
forall a. a -> Maybe a
Just FL p wA wC
zs

-- | Decoalesce (subtract) a single patch from an 'FL' by trying to
-- decoalesce it with every element until it succeeds or we cannot
-- commute it any further.
decoalesceFL :: (Commute p, Invert p, {- Eq2 p,  -}PrimCanonize p)
             => FL p wA wC -> p wA wB -> Maybe (FL p wB wC)
decoalesceFL :: FL p wA wC -> p wA wB -> Maybe (FL p wB wC)
decoalesceFL FL p wA wC
NilFL p wA wB
y = FL p wB wA -> Maybe (FL p wB wA)
forall a. a -> Maybe a
Just (p wA wB -> p wB wA
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert p wA wB
y p wB wA -> FL p wA wA -> FL p wB wA
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wA wA
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
decoalesceFL (p wA wY
z :>: FL p wY wC
zs) p wA wB
y
  | Just p wB wY
z' <- p wA wY -> p wA wB -> Maybe (p wB wY)
forall (prim :: * -> * -> *) wX wZ wY.
PrimCanonize prim =>
prim wX wZ -> prim wX wY -> Maybe (prim wY wZ)
primDecoalesce p wA wY
z p wA wB
y = FL p wB wC -> Maybe (FL p wB wC)
forall a. a -> Maybe a
Just (p wB wY
z' p wB wY -> FL p wY wC -> FL p wB wC
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wY wC
zs)
  | Bool
otherwise = do
      p wB wZ
z' :> p wZ wY
iy' <- (:>) p p wB wY -> Maybe ((:>) p p wB wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (p wA wB -> p wB wA
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert p wA wB
y p wB wA -> p wA wY -> (:>) p p wB wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> p wA wY
z)
      FL p wZ wC
zs' <- FL p wY wC -> p wY wZ -> Maybe (FL p wZ wC)
forall (p :: * -> * -> *) wA wC wB.
(Commute p, Invert p, PrimCanonize p) =>
FL p wA wC -> p wA wB -> Maybe (FL p wB wC)
decoalesceFL FL p wY wC
zs (p wZ wY -> p wY wZ
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert p wZ wY
iy')
      FL p wB wC -> Maybe (FL p wB wC)
forall (m :: * -> *) a. Monad m => a -> m a
return (p wB wZ
z' p wB wZ -> FL p wZ wC -> FL p wB wC
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wZ wC
zs')

-- | @makeNewPending repo YesUpdatePending pendPs@ verifies that the
--   @pendPs@ could be applied to pristine if we wanted to, and if so
--   writes it to disk.  If it can't be applied, @pendPs@ must
--   be somehow buggy, so we save it for forensics and crash.
makeNewPending :: (RepoPatch p, ApplyState p ~ Tree)
                 => Repository rt p wR wU wT
                 -> UpdatePending
                 -> FL (PrimOf p) wT wP
                 -> Tree IO  -- ^recorded state of the repository, to check if pending can be applied
                 -> IO ()
makeNewPending :: Repository rt p wR wU wT
-> UpdatePending -> FL (PrimOf p) wT wP -> Tree IO -> IO ()
makeNewPending Repository rt p wR wU wT
_                  UpdatePending
NoUpdatePending FL (PrimOf p) wT wP
_ Tree IO
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
makeNewPending Repository rt p wR wU wT
repo UpdatePending
YesUpdatePending FL (PrimOf p) wT wP
origp Tree IO
recordedState =
    Repository rt p wR wU wT -> IO () -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT -> IO a -> IO a
withRepoLocation Repository rt p wR wU wT
repo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    do let newname :: String
newname = String
pendingPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".new"
       String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Writing new pending:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
newname
       Sealed FL (PrimOf p) wT wX
sfp <- Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT)))
-> Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT))
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wT wP -> Sealed (FL (PrimOf p) wT)
forall (prim :: * -> * -> *) wX wY.
PrimSift prim =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL (PrimOf p) wT wP
origp
       Repository rt p wR wU wT -> FL (PrimOf p) wT wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
writeNewPending Repository rt p wR wU wT
repo FL (PrimOf p) wT wX
sfp
       Sealed FL (PrimOf p) wT wX
p <- Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
readNewPending Repository rt p wR wU wT
repo
       -- We don't ever use the resulting tree.
       Tree IO
_ <- IO (Tree IO) -> (IOException -> IO (Tree IO)) -> IO (Tree IO)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (FL (PrimOf p) wT wX -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, Monad m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree FL (PrimOf p) wT wX
p Tree IO
recordedState) ((IOException -> IO (Tree IO)) -> IO (Tree IO))
-> (IOException -> IO (Tree IO)) -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ \(IOException
err :: IOException) -> do
         let buggyname :: String
buggyname = String
pendingPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_buggy"
         String -> String -> IO ()
renameFile String
newname String
buggyname
         String -> IO (Tree IO)
forall a. HasCallStack => String -> a
error (String -> IO (Tree IO)) -> String -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString
            (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String
"There was an attempt to write an invalid pending! " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
err)
            Doc -> Doc -> Doc
$$ String -> Doc
text String
"If possible, please send the contents of" Doc -> Doc -> Doc
<+> String -> Doc
text String
buggyname
            Doc -> Doc -> Doc
$$ String -> Doc
text String
"along with a bug report."
       String -> String -> IO ()
renameFile String
newname String
pendingPath
       String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Finished writing new pending:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
newname

-- | Replace the pending patch with the tentative pending.
--   If @NoUpdatePending@, this merely deletes the tentative pending
--   without replacing the current one.
--
--   Question (Eric Kow): shouldn't this also delete the tentative
--   pending if @YesUpdatePending@?  I'm just puzzled by the seeming
--   inconsistency of the @NoUpdatePending@ doing deletion, but
--   @YesUpdatePending@ not bothering.
finalizePending :: (RepoPatch p, ApplyState p ~ Tree)
                => Repository rt p wR wU wT
                -> UpdatePending
                -> Tree IO
                -> IO ()
finalizePending :: Repository rt p wR wU wT -> UpdatePending -> Tree IO -> IO ()
finalizePending Repository rt p wR wU wT
repo UpdatePending
NoUpdatePending Tree IO
_ =
  Repository rt p wR wU wT -> IO () -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT -> IO a -> IO a
withRepoLocation Repository rt p wR wU wT
repo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String
pendingPath
finalizePending Repository rt p wR wU wT
repo upe :: UpdatePending
upe@UpdatePending
YesUpdatePending Tree IO
recordedState =
  Repository rt p wR wU wT -> IO () -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT -> IO a -> IO a
withRepoLocation Repository rt p wR wU wT
repo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Sealed FL (PrimOf p) wT wX
tpend <- Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
readTentativePending Repository rt p wR wU wT
repo
      Sealed FL (PrimOf p) wT wX
new_pending <- Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT)))
-> Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT))
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wT wX -> Sealed (FL (PrimOf p) wT)
forall (prim :: * -> * -> *) wX wY.
PrimSift prim =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL (PrimOf p) wT wX
tpend
      Repository rt p wR wU wT
-> UpdatePending -> FL (PrimOf p) wT wX -> Tree IO -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wP.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdatePending -> FL (PrimOf p) wT wP -> Tree IO -> IO ()
makeNewPending Repository rt p wR wU wT
repo UpdatePending
upe FL (PrimOf p) wT wX
new_pending Tree IO
recordedState

revertPending :: RepoPatch p
              => Repository rt p wR wU wT
              -> UpdatePending
              -> IO ()
revertPending :: Repository rt p wR wU wT -> UpdatePending -> IO ()
revertPending Repository rt p wR wU wT
r UpdatePending
upe = do
  String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (String
pendingPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".tentative")
  Sealed FL (PrimOf p) wR wX
x <- Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wR))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wR))
readPending Repository rt p wR wU wT
r
  if UpdatePending
upe UpdatePending -> UpdatePending -> Bool
forall a. Eq a => a -> a -> Bool
== UpdatePending
YesUpdatePending
    then Repository rt p wR wU wR -> FL (PrimOf p) wR wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
writeTentativePending (Repository rt p wR wU wT -> Repository rt p wR wU wR
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wT'.
Repository rt p wR wU wT -> Repository rt p wR wU wT'
unsafeCoerceT Repository rt p wR wU wT
r) FL (PrimOf p) wR wX
x
    else String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String
pendingPath

-- | @tentativelyAddToPending repo ps@ appends @ps@ to the pending patch.
--
--   This fuction is unsafe because it accepts a patch that works on the
--   tentative pending and we don't currently track the state of the
--   tentative pending.
tentativelyAddToPending :: forall rt p wR wU wT wX wY. RepoPatch p
                        => Repository rt p wR wU wT
                        -> FL (PrimOf p) wX wY
                        -> IO ()
tentativelyAddToPending :: Repository rt p wR wU wT -> FL (PrimOf p) wX wY -> IO ()
tentativelyAddToPending Repository rt p wR wU wT
repo FL (PrimOf p) wX wY
patch =
    Repository rt p wR wU wT -> IO () -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT -> IO a -> IO a
withRepoLocation Repository rt p wR wU wT
repo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Sealed FL (PrimOf p) wT wX
pend <- Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
readTentativePending Repository rt p wR wU wT
repo
        Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
writeTentativePending Repository rt p wR wU wT
repo (FL (PrimOf p) wT wX
pend FL (PrimOf p) wT wX -> FL (PrimOf p) wX wY -> FL (PrimOf p) wT wY
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wX wY -> FL (PrimOf p) wX wY
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart FL (PrimOf p) wX wY
patch)

-- | Overwrites the pending patch with a new one, starting at the tentative state.
setTentativePending :: forall rt p wR wU wT wP. RepoPatch p
                    => Repository rt p wR wU wT
                    -> FL (PrimOf p) wT wP
                    -> IO ()
setTentativePending :: Repository rt p wR wU wT -> FL (PrimOf p) wT wP -> IO ()
setTentativePending Repository rt p wR wU wT
repo FL (PrimOf p) wT wP
patch = do
    Sealed FL (PrimOf p) wT wX
prims <- Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT)))
-> Sealed (FL (PrimOf p) wT) -> IO (Sealed (FL (PrimOf p) wT))
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wT wP -> Sealed (FL (PrimOf p) wT)
forall (prim :: * -> * -> *) wX wY.
PrimSift prim =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL (PrimOf p) wT wP
patch
    Repository rt p wR wU wT -> IO () -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT -> IO a -> IO a
withRepoLocation Repository rt p wR wU wT
repo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wT -> FL (PrimOf p) wT wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
writeTentativePending Repository rt p wR wU wT
repo FL (PrimOf p) wT wX
prims