-- 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
    , tentativelyRemoveFromPW
    , revertPending
    , finalizePending
    , setTentativePending
    ) where

import Darcs.Prelude

import Control.Applicative
import System.Directory ( copyFile, renameFile )

import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch, commuteFL, readPatch )
import Darcs.Patch.Commute ( Commute(..) )
import Darcs.Patch.Invert ( invertFL )
import Darcs.Patch.Permutations ( partitionFL )
import Darcs.Patch.Prim
    ( PrimCoalesce(tryToShrink)
    , PrimSift(primIsSiftable)
    , coalesce
    )
import Darcs.Patch.Progress ( progressFL )
import Darcs.Patch.Read ( ReadPatch(..), bracketedFL )
import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(ForStorage) )
import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..)
    , RL(..)
    , mapFL
    , (+>+)
    , (:>)(..)
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, unseal )

import Darcs.Repository.InternalTypes
    ( AccessType(..)
    , Repository
    , SAccessType(..)
    , repoAccessType
    , unsafeStartTransaction
    , withRepoDir
    )
import Darcs.Repository.Paths ( pendingPath, tentativePendingPath )

import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Exception ( catchDoesNotExistError, ifDoesNotExistError )
import Darcs.Util.Lock ( writeDocBinFile )
import Darcs.Util.Parser ( Parser )
import Darcs.Util.Printer ( Doc, text, vcat, ($$) )


tentativeSuffix :: String
tentativeSuffix :: String
tentativeSuffix = String
".tentative"

-- | Read the contents of pending.
readPending :: RepoPatch p => Repository rt p wU wR
            -> IO (Sealed (FL (PrimOf p) wR))
readPending :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (Sealed (FL (PrimOf p) wR))
readPending Repository rt p wU wR
repo =
  case Repository rt p wU wR -> SAccessType rt
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> SAccessType rt
repoAccessType Repository rt p wU wR
repo of
    SAccessType rt
SRO -> String -> Repository rt p wU wR -> IO (Sealed (FL (PrimOf p) wR))
forall (prim :: * -> * -> *) (rt :: AccessType) (p :: * -> * -> *)
       wU wR wX.
ReadPatch prim =>
String -> Repository rt p wU wR -> IO (Sealed (FL prim wX))
readPendingFile String
"" Repository rt p wU wR
repo
    SAccessType rt
SRW -> String -> Repository rt p wU wR -> IO (Sealed (FL (PrimOf p) wR))
forall (prim :: * -> * -> *) (rt :: AccessType) (p :: * -> * -> *)
       wU wR wX.
ReadPatch prim =>
String -> Repository rt p wU wR -> IO (Sealed (FL prim wX))
readPendingFile String
tentativeSuffix Repository rt p wU wR
repo

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

-- |Read the pending file with the given suffix. CWD should be the repository
-- directory. Unsafe!
readPendingFile :: ReadPatch prim => String -> Repository rt p wU wR
                -> IO (Sealed (FL prim wX))
readPendingFile :: forall (prim :: * -> * -> *) (rt :: AccessType) (p :: * -> * -> *)
       wU wR wX.
ReadPatch prim =>
String -> Repository rt p wU wR -> IO (Sealed (FL prim wX))
readPendingFile String
suffix Repository rt p wU wR
_ =
  Sealed (FL prim wX)
-> IO (Sealed (FL prim wX)) -> IO (Sealed (FL prim wX))
forall a. a -> IO a -> IO a
ifDoesNotExistError (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) (IO (Sealed (FL prim wX)) -> IO (Sealed (FL prim wX)))
-> IO (Sealed (FL prim wX)) -> IO (Sealed (FL prim wX))
forall a b. (a -> b) -> a -> b
$ 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 a. a -> IO a
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 FLM prim wX wX -> FL prim wX wX
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 a. String -> IO a
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]

-- 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 { forall (p :: * -> * -> *) wX wY. FLM p wX wY -> FL p wX wY
unFLM :: FL p wX wY }

instance ReadPatch p => ReadPatch (FLM p) where
    readPatch' :: forall wX. 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 FL p wX wX -> FLM p wX wX
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 ByteString (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 Parser (Sealed (p wY))
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 :: forall wX wY. 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 wX wY. 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 (p :: * -> * -> *) wX.
(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 Parser (Sealed (p wY))
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 a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
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 (p :: * -> * -> *) wA wB.
(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 p wW wZ -> Doc
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 'RW p wU wR
                      -> FL (PrimOf p) wR wP -> IO ()
writeTentativePending :: forall (p :: * -> * -> *) wU wR wP.
RepoPatch p =>
Repository 'RW p wU wR -> FL (PrimOf p) wR wP -> IO ()
writeTentativePending Repository 'RW p wU wR
_ FL (PrimOf p) wR wP
ps =
    (forall wX. FL (PrimOf p) wR wX -> IO ())
-> Sealed (FL (PrimOf p) wR) -> IO ()
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal (String -> FLM (PrimOf p) wR wX -> IO ()
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
String -> p wX wY -> IO ()
writePatch String
name (FLM (PrimOf p) wR wX -> IO ())
-> (FL (PrimOf p) wR wX -> FLM (PrimOf p) wR wX)
-> FL (PrimOf p) wR wX
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL (PrimOf p) wR wX -> FLM (PrimOf p) wR wX
forall (p :: * -> * -> *) wX wY. FL p wX wY -> FLM p wX wY
FLM) (FL (PrimOf p) wR wP -> Sealed (FL (PrimOf p) wR)
forall (prim :: * -> * -> *) wX wY.
(PrimCoalesce prim, PrimSift prim) =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL (PrimOf p) wR wP
ps)
  where
    name :: String
name = String
pendingPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tentativeSuffix

writePatch :: ShowPatchBasic p => FilePath -> p wX wY -> IO ()
writePatch :: forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
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 wX wY. 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. It is used by record and amend to update pending.
--
-- 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.
-- Also, before we present prims to the user to select for recording, we
-- coalesce prims from pending and working, which is reason we have to use
-- decoalescing.
tentativelyRemoveFromPW :: forall p wR wO wP wU. RepoPatch p
                        => Repository 'RW p wU wR
                        -> FL (PrimOf p) wO wR -- added repo changes
                        -> FL (PrimOf p) wO wP -- O = old recorded state
                        -> FL (PrimOf p) wP wU -- P = (old) pending state
                        -> IO ()
tentativelyRemoveFromPW :: forall (p :: * -> * -> *) wR wO wP wU.
RepoPatch p =>
Repository 'RW p wU wR
-> FL (PrimOf p) wO wR
-> FL (PrimOf p) wO wP
-> FL (PrimOf p) wP wU
-> IO ()
tentativelyRemoveFromPW Repository 'RW p wU wR
r FL (PrimOf p) wO wR
changes FL (PrimOf p) wO wP
pending FL (PrimOf p) wP wU
_working = do
  let inverted_changes :: RL (PrimOf p) wR wO
inverted_changes = FL (PrimOf p) wO wR -> RL (PrimOf p) wR wO
forall (p :: * -> * -> *) wX wY.
Invert p =>
FL p wX wY -> RL p wY wX
invertFL (String -> FL (PrimOf p) wO wR -> FL (PrimOf p) wO wR
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Removing from pending:" FL (PrimOf p) wO wR
changes)
  (forall wX. FL (PrimOf p) wR wX -> IO ())
-> Sealed (FL (PrimOf p) wR) -> IO ()
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal (Repository 'RW p wU wR -> FL (PrimOf p) wR wX -> IO ()
forall (p :: * -> * -> *) wU wR wP.
RepoPatch p =>
Repository 'RW p wU wR -> FL (PrimOf p) wR wP -> IO ()
writeTentativePending Repository 'RW p wU wR
r) (RL (PrimOf p) wR wO
-> FL (PrimOf p) wO wP -> Sealed (FL (PrimOf p) wR)
forall (p :: * -> * -> *) wR wO wP.
PrimPatch p =>
RL p wR wO -> FL p wO wP -> Sealed (FL p wR)
updatePendingRL RL (PrimOf p) wR wO
inverted_changes FL (PrimOf p) wO wP
pending)

-- | Iterate 'updatePending' for all recorded changes.
updatePendingRL :: PrimPatch p => RL p wR wO -> FL p wO wP -> Sealed (FL p wR)
updatePendingRL :: forall (p :: * -> * -> *) wR wO wP.
PrimPatch p =>
RL p wR wO -> FL p wO wP -> Sealed (FL p wR)
updatePendingRL RL p wR wO
NilRL FL p wO wP
ys = FL p wR wP -> Sealed (FL p wR)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL p wR wP
FL p wO wP
ys
updatePendingRL (RL p wR wY
xs :<: p wY wO
x) FL p wO wP
ys = (forall wX. FL p wY wX -> Sealed (FL p wR))
-> Sealed (FL p wY) -> Sealed (FL p wR)
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal (RL p wR wY -> FL p wY wX -> Sealed (FL p wR)
forall (p :: * -> * -> *) wR wO wP.
PrimPatch p =>
RL p wR wO -> FL p wO wP -> Sealed (FL p wR)
updatePendingRL RL p wR wY
xs) (p wY wO -> FL p wO wP -> Sealed (FL p wY)
forall (p :: * -> * -> *) wR wO wP.
PrimCoalesce p =>
p wR wO -> FL p wO wP -> Sealed (FL p wR)
updatePending p wY wO
x FL p wO wP
ys)

{- | Given an (inverted) single recorded change @x@ and the old pending
@ys@, for each prim @y@ in pending either cancel @x@ against @y@, or
coalesce them. If they coalesce, either commute the result past pending, or
continue with the rest of pending. If coalescing fails, commute @x@ forward
and try again with the next prim from pending. Repeat until we reach the end
of pending or @x@ becomes stuck, in which case we keep it there.

The idea of this algorithm is best explained in terms of an analogy with
arithmetic, where coalescing is addition. Let's say we start out with @a@ in
pending and @b@ in working and record the coalesced @a+b@. We now want to
remove (only) the @a@ from pending. To do that we coalesce @-(a+b)+a@ and
the result (if successful) is @-b@. If this can be commuted past pending, we
are done: the part that came from pending (@a@) is removed and the other
part cancels against what remains in working.

However, we should also guard against the possibility that we recorded a
change that was coalesced from more than one prim in pending. For instance,
suppose we recorded @a+b+c@, where @a@ and @b@ are both from pending and @c@
is form working; after coalescing with @a@ we would be left with
@-(a+b+c)+a=-(b+c)@ which would then be stuck against the remaining @b@.
This is why we continue coalescing, giving us @-(b+c)+b=-c@ which we again
try to commute out etc.

Finally, note that a change can legitimately be stuck in pending i.e. it can
neither be coalesced nor commuted further. For instance, if we have a hunk
in pending and some other prim that depends on it, such as a replace, and
the user records (only) a split-off version of the hunk but not the replace.
This will coalesce with the remaining hunk but then be stuck at the replace.
This is how it should be and thus keeping it there is the correct behavior.
-}

updatePending :: PrimCoalesce p => p wR wO -> FL p wO wP -> Sealed (FL p wR)
updatePending :: forall (p :: * -> * -> *) wR wO wP.
PrimCoalesce p =>
p wR wO -> FL p wO wP -> Sealed (FL p wR)
updatePending p wR wO
_ FL p wO wP
NilFL = FL p wR wR -> Sealed (FL p wR)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL p wR wR
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
updatePending p wR wO
x (p wO wY
y :>: FL p wY wP
ys) =
  case (:>) p p wR wY -> Maybe (Maybe2 p wR wY)
forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
(:>) prim prim wX wY -> Maybe (Maybe2 prim wX wY)
coalesce (p wR wO
x p wR wO -> p wO wY -> (:>) p p wR wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> p wO wY
y) of
    Just Maybe2 p wR wY
Nothing2 -> FL p wR wP -> Sealed (FL p wR)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL p wR wP
FL p wY wP
ys -- cancelled out
    Just (Just2 p wR wY
y') ->
      case (:>) p (FL p) wR wP -> Maybe ((:>) (FL p) p wR wP)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (p wR wY
y' p wR wY -> FL p wY wP -> (:>) p (FL p) wR wP
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL p wY wP
ys) of
        Just (FL p wR wZ
ys' :> p wZ wP
_) -> FL p wR wZ -> Sealed (FL p wR)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL p wR wZ
ys' -- drop result if we can commute it past
        Maybe ((:>) (FL p) p wR wP)
Nothing -> p wR wY -> FL p wY wP -> Sealed (FL p wR)
forall (p :: * -> * -> *) wR wO wP.
PrimCoalesce p =>
p wR wO -> FL p wO wP -> Sealed (FL p wR)
updatePending p wR wY
y' FL p wY wP
ys -- continue coalescing with with y'
    Maybe (Maybe2 p wR wY)
Nothing ->
      case (:>) p p wR wY -> Maybe ((:>) p p wR wY)
forall wX wY. (:>) p p wX wY -> Maybe ((:>) p p wX wY)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (p wR wO
x p wR wO -> p wO wY -> (:>) p p wR wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> p wO wY
y) of
        Just (p wR wZ
y' :> p wZ wY
x') -> (forall wX. FL p wZ wX -> FL p wR wX)
-> Sealed (FL p wZ) -> Sealed (FL p wR)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal (p wR wZ
y' p wR wZ -> FL p wZ wX -> FL p wR wX
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:) (p wZ wY -> FL p wY wP -> Sealed (FL p wZ)
forall (p :: * -> * -> *) wR wO wP.
PrimCoalesce p =>
p wR wO -> FL p wO wP -> Sealed (FL p wR)
updatePending p wZ wY
x' FL p wY wP
ys)
        Maybe ((:>) p p wR wY)
Nothing -> FL p wR wP -> Sealed (FL p wR)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (p wR wO
x p wR wO -> FL p wO wP -> FL p wR wP
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: p wO wY
y p wO wY -> FL p wY wP -> FL p wO wP
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wY wP
ys) -- x is stuck, keep it there

-- | Replace the pending patch with the tentative pending
finalizePending :: Repository 'RW p wU wR -> IO ()
finalizePending :: forall (p :: * -> * -> *) wU wR. Repository 'RW p wU wR -> IO ()
finalizePending Repository 'RW p wU wR
_ = String -> String -> IO ()
renameFile String
tentativePendingPath String
pendingPath

-- | Copy the pending patch to the tentative pending, or write a new empty
-- tentative pending if regular pending does not exist.
revertPending :: RepoPatch p => Repository 'RO p wU wR -> IO ()
revertPending :: forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RO p wU wR -> IO ()
revertPending Repository 'RO p wU wR
r =
  String -> String -> IO ()
copyFile String
pendingPath String
tentativePendingPath IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchDoesNotExistError`
    (Repository 'RO p wU wR -> IO (Sealed (FL (PrimOf p) wR))
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (Sealed (FL (PrimOf p) wR))
readPending Repository 'RO p wU wR
r IO (Sealed (FL (PrimOf p) wR))
-> (Sealed (FL (PrimOf p) wR) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall wX. FL (PrimOf p) wR wX -> IO ())
-> Sealed (FL (PrimOf p) wR) -> IO ()
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal (Repository 'RW p wU wR -> FL (PrimOf p) wR wX -> IO ()
forall (p :: * -> * -> *) wU wR wP.
RepoPatch p =>
Repository 'RW p wU wR -> FL (PrimOf p) wR wP -> IO ()
writeTentativePending (Repository 'RO p wU wR -> Repository 'RW p wU wR
forall (p :: * -> * -> *) wU wR.
Repository 'RO p wU wR -> Repository 'RW p wU wR
unsafeStartTransaction Repository 'RO p wU wR
r)))

-- | Overwrites the pending patch with a new one, starting at the tentative state.
setTentativePending :: forall p wU wR wP. RepoPatch p
                    => Repository 'RW p wU wR
                    -> FL (PrimOf p) wR wP
                    -> IO ()
setTentativePending :: forall (p :: * -> * -> *) wU wR wP.
RepoPatch p =>
Repository 'RW p wU wR -> FL (PrimOf p) wR wP -> IO ()
setTentativePending Repository 'RW p wU wR
repo FL (PrimOf p) wR wP
ps = do
    Repository 'RW p wU wR -> IO () -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR a.
Repository rt p wU wR -> IO a -> IO a
withRepoDir Repository 'RW p wU wR
repo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository 'RW p wU wR -> FL (PrimOf p) wR wP -> IO ()
forall (p :: * -> * -> *) wU wR wP.
RepoPatch p =>
Repository 'RW p wU wR -> FL (PrimOf p) wR wP -> IO ()
writeTentativePending Repository 'RW p wU wR
repo FL (PrimOf p) wR wP
ps

-- | Simplify the candidate pending patch through a combination of looking
-- for self-cancellations (sequences of patches followed by their inverses),
-- coalescing, and getting rid of any hunk or binary patches we can commute
-- out the back.
--
-- More abstractly, for an argument @p@, pristine state @R@, and working
-- state @U@, define
--
-- > unrecorded p = p +>+ diff (pureApply p R) U
--
-- Then the resulting sequence @p'@ must maintain that equality, i.e.
--
-- > unrecorded p = unrecorded (siftForPending p)
--
-- while trying to "minimize" @p@.
siftForPending
  :: (PrimCoalesce prim, PrimSift prim) => FL prim wX wY -> Sealed (FL prim wX)
siftForPending :: forall (prim :: * -> * -> *) wX wY.
(PrimCoalesce prim, PrimSift prim) =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL prim wX wY
ps =
  -- Alternately 'sift' and 'tryToShrink' until shrinking no longer reduces
  -- the length of the sequence. Here, 'sift' means to commute siftable
  -- patches to the end of the sequence and then drop them.
  case FL prim wX wY -> Sealed (FL prim wX)
forall {p :: * -> * -> *} {wX} {wY}.
(Commute p, PrimSift p) =>
FL p wX wY -> Sealed (FL p wX)
sift FL prim wX wY
ps of
    Sealed FL prim wX wX
sifted ->
      case FL prim wX wX -> Maybe (FL prim wX wX)
forall wX wY. FL prim wX wY -> Maybe (FL prim wX wY)
forall (prim :: * -> * -> *) wX wY.
PrimCoalesce prim =>
FL prim wX wY -> Maybe (FL prim wX wY)
tryToShrink FL prim wX wX
sifted of
        Maybe (FL prim wX wX)
Nothing -> FL prim wX wX -> Sealed (FL prim wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL prim wX wX
sifted
        Just FL prim wX wX
shrunk -> FL prim wX wX -> Sealed (FL prim wX)
forall (prim :: * -> * -> *) wX wY.
(PrimCoalesce prim, PrimSift prim) =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL prim wX wX
shrunk
  where
    sift :: FL p wX wY -> Sealed (FL p wX)
sift FL p wX wY
xs =
      case (forall wU wV. p wU wV -> Bool)
-> FL p wX wY -> (:>) (FL p) (FL p :> FL p) wX wY
forall (p :: * -> * -> *) wX wY.
Commute p =>
(forall wU wV. p wU wV -> Bool)
-> FL p wX wY -> (:>) (FL p) (FL p :> FL p) wX wY
partitionFL (Bool -> Bool
not (Bool -> Bool) -> (p wU wV -> Bool) -> p wU wV -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p wU wV -> Bool
forall wU wV. p wU wV -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimSift prim =>
prim wX wY -> Bool
primIsSiftable) FL p wX wY
xs of
        (FL p wX wZ
not_siftable :> FL p wZ wZ
deps :> FL p wZ wY
_) -> FL p wX wZ -> Sealed (FL p wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (FL p wX wZ
not_siftable FL p wX wZ -> FL p wZ wZ -> FL p wX wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL p wZ wZ
deps)