-- 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
    , siftForPending
    , tentativelyRemoveFromPending
    , finalizePending
    , makeNewPending
    , tentativelyAddToPending
    , setTentativePending
    , prepend
    -- deprecated interface:
    , pendingName
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Applicative
import qualified Data.ByteString as B ( empty )

import Control.Exception ( catch, IOException )
import Data.Maybe ( fromJust, fromMaybe )

import Darcs.Util.Printer ( errorDoc )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Lock
    ( writeDocBinFile
    , removeFileMayNotExist
    )
import Darcs.Repository.InternalTypes ( Repository, withRepoLocation )
import Darcs.Repository.Flags
    ( UpdateWorking (..))
import Darcs.Patch
    ( readPatch, RepoPatch, PrimOf, tryToShrink
    , primIsHunk, primIsBinary, commute, invert
    , primIsAddfile, primIsAdddir, commuteFLorComplain
    , effect, primIsSetpref, applyToTree )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )
import Darcs.Patch.Progress (progressFL)
import Darcs.Patch.Permutations ( commuteWhatWeCanFL
                                , removeFL
                                )

import Darcs.Patch.Prim ( tryShrinkingInverse
                        , PrimPatch
                        )
import Darcs.Patch.Read ( ReadPatch(..), bracketedFL )
import Darcs.Patch.ReadMonads ( ParserM )
import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(ForStorage) )
import Darcs.Patch.Apply ( ApplyState )

import Darcs.Util.Tree ( Tree )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.Workaround ( renameFile )
import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Sealed
    ( Sealed(Sealed), mapSeal, seal
    , FlippedSeal(FlippedSeal)
    , flipSeal
    )
import Darcs.Patch.Witnesses.Unsafe
    ( unsafeCoerceP, unsafeCoercePStart )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), RL(..), (:>)(..), (+>+)
    , lengthFL, allFL, filterOutFLFL
    , reverseFL, mapFL )
import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Printer ( Doc, ($$), text, vcat, (<+>) )
import Darcs.Util.Progress ( debugMessage )

pendingName :: String
pendingName :: String
pendingName = String
darcsdir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/patches/pending"

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

-- | Read the contents of pending.
-- The return type is currently incorrect as it refers to the tentative
-- state rather than the recorded state.
readPending :: RepoPatch p => Repository rt p wR wU wT
            -> IO (Sealed (FL (PrimOf p) wT))
readPending :: Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
readPending = 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 ""

-- |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 suffix :: String
suffix _ = do
    ByteString
pend <- String -> IO ByteString
gzReadFilePS (String
pendingName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix) IO ByteString -> IO ByteString -> IO ByteString
forall a. IO a -> IO a -> IO a
`catchall` ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
    Sealed (FL prim wX) -> IO (Sealed (FL prim wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL prim wX) -> IO (Sealed (FL prim wX)))
-> (ByteString -> Sealed (FL prim wX))
-> ByteString
-> IO (Sealed (FL prim wX))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sealed (FL prim wX)
-> (Sealed (FLM prim wX) -> Sealed (FL prim wX))
-> Maybe (Sealed (FLM prim wX))
-> Sealed (FL prim wX)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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) ((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) (Maybe (Sealed (FLM prim wX)) -> Sealed (FL prim wX))
-> (ByteString -> Maybe (Sealed (FLM prim wX)))
-> ByteString
-> Sealed (FL prim wX)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Sealed (FLM prim wX))
forall (p :: * -> * -> *) wX.
ReadPatch p =>
ByteString -> Maybe (Sealed (p wX))
readPatch (ByteString -> IO (Sealed (FL prim wX)))
-> ByteString -> IO (Sealed (FL prim wX))
forall a b. (a -> b) -> a -> b
$ ByteString
pend

-- 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' :: m (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))
-> m (Sealed (FL p wX)) -> m (Sealed (FLM p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall wY. m (Sealed (p wY)))
-> Char -> Char -> m (Sealed (FL p wX))
forall (m :: * -> *) (p :: * -> * -> *) wX.
ParserM m =>
(forall wY. m (Sealed (p wY)))
-> Char -> Char -> m (Sealed (FL p wX))
readMaybeBracketedFL forall wY. m (Sealed (p wY))
forall (p :: * -> * -> *) (m :: * -> *) wX.
(ReadPatch p, ParserM m) =>
m (Sealed (p wX))
readPatch' '{' '}'

instance ShowPatchBasic p => ShowPatchBasic (FLM p) where
    showPatch :: ShowPatchFor -> FLM p wX wY -> Doc
showPatch f :: 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) '{' '}' (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 m p wX . ParserM m
                     => (forall wY . m (Sealed (p wY))) -> Char -> Char
                     -> m (Sealed (FL p wX))
readMaybeBracketedFL :: (forall wY. m (Sealed (p wY)))
-> Char -> Char -> m (Sealed (FL p wX))
readMaybeBracketedFL parser :: forall wY. m (Sealed (p wY))
parser pre :: Char
pre post :: Char
post =
    (forall wY. m (Sealed (p wY)))
-> Char -> Char -> m (Sealed (FL p wX))
forall (p :: * -> * -> *) (m :: * -> *) wX.
ParserM m =>
(forall wY. m (Sealed (p wY)))
-> Char -> Char -> m (Sealed (FL p wX))
bracketedFL forall wY. m (Sealed (p wY))
parser Char
pre Char
post m (Sealed (FL p wX))
-> m (Sealed (FL p wX)) -> m (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))
-> m (Sealed (p wX)) -> m (Sealed (FL p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Sealed (p wX))
forall wY. m (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 _ pre :: Char
pre post :: Char
post NilFL = String -> Doc
text [Char
pre] Doc -> Doc -> Doc
$$ String -> Doc
text [Char
post]
showMaybeBracketedFL printer :: forall wX wY. p wX wY -> Doc
printer _ _ (p :: p wA wY
p :>: NilFL) = p wA wY -> Doc
forall wX wY. p wX wY -> Doc
printer p wA wY
p
showMaybeBracketedFL printer :: forall wX wY. p wX wY -> Doc
printer pre :: Char
pre post :: Char
post ps :: 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 wY -> IO ()
writeNewPending :: Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
writeNewPending = 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
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 suffix :: String
suffix _ = 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
pendingName 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 f :: String
f p :: 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 "\n"

-- | @siftForPending ps@ simplifies the candidate pending patch @ps@
--   through a combination of looking for self-cancellations
--   (sequences of patches followed by their inverses), coalescing,
--   and getting rid of any hunk/binary patches we can commute out
--   the back
--
--   The visual image of sifting can be quite helpful here.  We are
--   repeatedly tapping (shrinking) the patch sequence and
--   shaking it (sift). Whatever falls out is the pending we want
--   to keep. We do this until the sequence looks about as clean as
--   we can get it
siftForPending :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> Sealed (FL prim wX)
siftForPending :: FL prim wX wY -> Sealed (FL prim wX)
siftForPending simple_ps :: FL prim wX wY
simple_ps =
    if (forall wX wY. prim wX wY -> Bool) -> FL prim wX wY -> Bool
forall (a :: * -> * -> *) wW wZ.
(forall wX wY. a wX wY -> Bool) -> FL a wW wZ -> Bool
allFL (\p :: prim wX wY
p -> prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsAddfile prim wX wY
p Bool -> Bool -> Bool
|| prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsAdddir prim wX wY
p) FL prim wX wY
oldps
       then FL prim wX wY -> Sealed (FL prim wX)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL prim wX wY
oldps
       else Maybe (Sealed (FL prim wX)) -> Sealed (FL prim wX)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Sealed (FL prim wX)) -> Sealed (FL prim wX))
-> Maybe (Sealed (FL prim wX)) -> Sealed (FL prim wX)
forall a b. (a -> b) -> a -> b
$ do
           Sealed x :: FL prim wX wX
x <- Sealed (FL prim wX) -> Maybe (Sealed (FL prim wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL prim wX) -> Maybe (Sealed (FL prim wX)))
-> Sealed (FL prim wX) -> Maybe (Sealed (FL prim wX))
forall a b. (a -> b) -> a -> b
$ FL prim wY wY -> RL prim wX wY -> Sealed (FL prim wX)
forall wA wB wC.
FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC)
sift FL prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL (RL prim wX wY -> Sealed (FL prim wX))
-> RL prim wX wY -> Sealed (FL prim wX)
forall a b. (a -> b) -> a -> b
$ FL prim wX wY -> RL prim wX wY
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL prim wX wY
oldps
           Sealed (FL prim wX) -> Maybe (Sealed (FL prim wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL prim wX) -> Maybe (Sealed (FL prim wX)))
-> Sealed (FL prim wX) -> Maybe (Sealed (FL prim wX))
forall a b. (a -> b) -> a -> b
$ case FL prim wX wX -> FL prim wX wX
forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
FL prim wX wY -> FL prim wX wY
tryToShrink FL prim wX wX
x of
               ps :: FL prim wX wX
ps | FL prim wX wX -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL prim wX wX
ps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< FL prim wX wY -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL prim wX wY
oldps -> FL prim wX wX -> Sealed (FL prim wX)
forall (prim :: * -> * -> *) wX wY.
PrimPatch prim =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL prim wX wX
ps
                  | Bool
otherwise -> FL prim wX wX -> Sealed (FL prim wX)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL prim wX wX
ps
  where
    oldps :: FL prim wX wY
oldps = FL prim wX wY -> Maybe (FL prim wX wY) -> FL prim wX wY
forall a. a -> Maybe a -> a
fromMaybe FL prim wX wY
simple_ps (Maybe (FL prim wX wY) -> FL prim wX wY)
-> Maybe (FL prim wX wY) -> FL prim wX wY
forall a b. (a -> b) -> a -> b
$ FL prim wX wY -> Maybe (FL prim wX wY)
forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
FL prim wX wY -> Maybe (FL prim wX wY)
tryShrinkingInverse (FL prim wX wY -> Maybe (FL prim wX wY))
-> FL prim wX wY -> Maybe (FL prim wX wY)
forall a b. (a -> b) -> a -> b
$ FL prim wX wY -> FL prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimPatch prim =>
FL prim wX wY -> FL prim wX wY
crudeSift FL prim wX wY
simple_ps
    -- get rid of any hunk/binary patches that we can commute out the
    -- back (ie. we work our way backwards, pushing the patches down
    -- to the very end and popping them off; so in (addfile f :> hunk)
    -- we can nuke the hunk, but not so in (hunk :> replace)
    sift :: FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC)
    sift :: FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC)
sift sofar :: FL prim wA wB
sofar NilRL = FL prim wA wB -> Sealed (FL prim wA)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL prim wA wB
sofar
    sift sofar :: FL prim wA wB
sofar (ps :: RL prim wC wY
ps:<:p :: prim wY wA
p) | prim wY wA -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsHunk prim wY wA
p Bool -> Bool -> Bool
|| prim wY wA -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsBinary prim wY wA
p =
        case (:>) prim (FL prim) wY wB
-> Either (Sealed2 prim) ((:>) (FL prim) prim wY wB)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Either (Sealed2 p) ((:>) (FL p) p wX wY)
commuteFLorComplain (prim wY wA
p prim wY wA -> FL prim wA wB -> (:>) prim (FL prim) wY wB
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL prim wA wB
sofar) of
            Right (sofar' :: FL prim wY wZ
sofar' :> _) -> FL prim wY wZ -> RL prim wC wY -> Sealed (FL prim wC)
forall wA wB wC.
FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC)
sift FL prim wY wZ
sofar'      RL prim wC wY
ps
            Left _              -> FL prim wY wB -> RL prim wC wY -> Sealed (FL prim wC)
forall wA wB wC.
FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC)
sift (prim wY wA
pprim wY wA -> FL prim wA wB -> FL prim wY wB
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL prim wA wB
sofar) RL prim wC wY
ps
    sift sofar :: FL prim wA wB
sofar (ps :: RL prim wC wY
ps:<:p :: prim wY wA
p) = FL prim wY wB -> RL prim wC wY -> Sealed (FL prim wC)
forall wA wB wC.
FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC)
sift (prim wY wA
pprim wY wA -> FL prim wA wB -> FL prim wY wB
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL prim wA wB
sofar) RL prim wC wY
ps

-- | 'crudeSift' can be seen as a first pass approximation of 'siftForPending'
--    that works without having to do any commutation.  It either returns a
--    sifted pending (if the input is simple enough for this crude approach)
--    or has no effect.
crudeSift :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> FL prim wX wY
crudeSift :: FL prim wX wY -> FL prim wX wY
crudeSift xs :: FL prim wX wY
xs =
    if FL prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimPatch prim =>
FL prim wX wY -> Bool
isSimple FL prim wX wY
xs then (forall wX wY. prim wX wY -> EqCheck wX wY)
-> FL prim wX wY -> FL prim wX wY
forall (p :: * -> * -> *) wW wZ.
(forall wX wY. p wX wY -> EqCheck wX wY)
-> FL p wW wZ -> FL p wW wZ
filterOutFLFL forall wX wY. prim wX wY -> EqCheck wX wY
ishunkbinary FL prim wX wY
xs else FL prim wX wY
xs
  where
    ishunkbinary :: prim wA wB -> EqCheck wA wB
    ishunkbinary :: prim wA wB -> EqCheck wA wB
ishunkbinary x :: prim wA wB
x | prim wA wB -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsHunk prim wA wB
x Bool -> Bool -> Bool
|| prim wA wB -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsBinary prim wA wB
x = EqCheck Any Any -> EqCheck wA wB
forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP EqCheck Any Any
forall wA. EqCheck wA wA
IsEq
                   | Bool
otherwise = EqCheck wA wB
forall wA wB. EqCheck wA wB
NotEq

-- | @tentativelyRemoveFromPending p@ 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.
--
--   Question (Eric Kow): how do we detect patch equivalence?
tentativelyRemoveFromPending :: forall rt p wR wU wT wX wY. (RepoPatch p)
                 => Repository rt p wR wU wT
                 -> UpdateWorking
                 -> PatchInfoAnd rt p wX wY
                 -> IO ()
tentativelyRemoveFromPending :: Repository rt p wR wU wT
-> UpdateWorking -> PatchInfoAnd rt p wX wY -> IO ()
tentativelyRemoveFromPending _    NoUpdateWorking  _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tentativelyRemoveFromPending repo :: Repository rt p wR wU wT
repo YesUpdateWorking p :: PatchInfoAnd rt p wX wY
p = do
    Sealed pend :: 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
    -- Question (Eric Kow): why does pending being all simple matter for
    -- changepref patches in p? isSimple includes changepref, so what do
    -- adddir/etc have to do with it?  Why don't we we systematically
    -- crudeSift/not?
    let effectp :: FL (PrimOf p) wX wY
effectp = if FL (PrimOf p) wT wX -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimPatch prim =>
FL prim wX wY -> Bool
isSimple FL (PrimOf p) wT wX
pend
                     then FL (PrimOf p) wX wY -> FL (PrimOf p) wX wY
forall (prim :: * -> * -> *) wX wY.
PrimPatch prim =>
FL prim wX wY -> FL prim wX wY
crudeSift (FL (PrimOf p) wX wY -> FL (PrimOf p) wX wY)
-> FL (PrimOf p) wX wY -> FL (PrimOf p) wX wY
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p wX wY -> FL (PrimOf (PatchInfoAnd rt p)) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect PatchInfoAnd rt p wX wY
p
                     else PatchInfoAnd rt p wX wY -> FL (PrimOf (PatchInfoAnd rt p)) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect PatchInfoAnd rt p wX wY
p
    Sealed newpend :: FL (PrimOf p) wY wX
newpend <- Sealed (FL (PrimOf p) wY) -> IO (Sealed (FL (PrimOf p) wY))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wY) -> IO (Sealed (FL (PrimOf p) wY)))
-> Sealed (FL (PrimOf p) wY) -> IO (Sealed (FL (PrimOf p) wY))
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wX wY
-> FL (PrimOf p) wX wX -> Sealed (FL (PrimOf p) wY)
forall wA wB wC.
FL (PrimOf p) wA wB
-> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB)
rmpend (String -> FL (PrimOf p) wX wY -> FL (PrimOf p) wX wY
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL "Removing from pending:" FL (PrimOf p) wX wY
effectp)
                               (FL (PrimOf p) wT wX -> FL (PrimOf p) wX wX
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart FL (PrimOf p) wT wX
pend)
    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) wY wX -> FL (PrimOf p) wT wX
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart FL (PrimOf p) wY wX
newpend)
  where
    -- @rmpend effect pending@ removes as much of @effect@ from @pending@
    -- as possible
    --
    -- Note that @effect@ and @pending@ must start from the same context
    -- This is not a bad thing to assume because @effect@ is a patch we want to
    -- add to the repository anyway so it'd kind of have to start from wR anyway
    --
    -- Question (Eric Kow), ok then why not
    -- @PatchInfoAnd p wR wY@ in the type signature above?
    rmpend :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB)
    rmpend :: FL (PrimOf p) wA wB
-> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB)
rmpend NilFL x :: FL (PrimOf p) wA wC
x = FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wA)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PrimOf p) wA wC
x
    rmpend _ NilFL = FL (PrimOf p) wB wB -> Sealed (FL (PrimOf p) wB)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PrimOf p) wB wB
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
    rmpend (x :: PrimOf p wA wY
x:>:xs :: FL (PrimOf p) wY wB
xs) xys :: FL (PrimOf p) wA wC
xys | Just ys :: FL (PrimOf p) wY wC
ys <- PrimOf p wA wY
-> FL (PrimOf p) wA wC -> Maybe (FL (PrimOf 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 PrimOf p wA wY
x FL (PrimOf p) wA wC
xys = FL (PrimOf p) wY wB
-> FL (PrimOf p) wY wC -> Sealed (FL (PrimOf p) wB)
forall wA wB wC.
FL (PrimOf p) wA wB
-> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB)
rmpend FL (PrimOf p) wY wB
xs FL (PrimOf p) wY wC
ys
    rmpend (x :: PrimOf p wA wY
x:>:xs :: FL (PrimOf p) wY wB
xs) ys :: FL (PrimOf p) wA wC
ys =
        case (:>) (PrimOf p) (FL (PrimOf p)) wA wB
-> (:>) (FL (PrimOf p)) (PrimOf p :> FL (PrimOf p)) wA wB
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> (:>) (FL p) (p :> FL p) wX wY
commuteWhatWeCanFL (PrimOf p wA wY
xPrimOf p wA wY
-> FL (PrimOf p) wY wB -> (:>) (PrimOf p) (FL (PrimOf p)) wA wB
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:>FL (PrimOf p) wY wB
xs) of
            a :: FL (PrimOf p) wA wZ
a:>x' :: PrimOf p wZ wZ
x':>b :: FL (PrimOf p) wZ wB
b -> case FL (PrimOf p) wA wZ
-> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wZ)
forall wA wB wC.
FL (PrimOf p) wA wB
-> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB)
rmpend FL (PrimOf p) wA wZ
a FL (PrimOf p) wA wC
ys of
                Sealed ys' :: FL (PrimOf p) wZ wX
ys' -> case (:>) (FL (PrimOf p)) (FL (PrimOf p)) wB wX
-> Maybe ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wB wX)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (FL (PrimOf p) wZ wB -> FL (PrimOf p) wB wZ
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert (PrimOf p wZ wZ
x'PrimOf p wZ wZ -> FL (PrimOf p) wZ wB -> FL (PrimOf p) wZ wB
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL (PrimOf p) wZ wB
b) FL (PrimOf p) wB wZ
-> FL (PrimOf p) wZ wX
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wB wX
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimOf p) wZ wX
ys') of
                    Just (ys'' :: FL (PrimOf p) wB wZ
ys'' :> _) -> FL (PrimOf p) wB wZ -> Sealed (FL (PrimOf p) wB)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL (PrimOf p) wB wZ
ys''
                    Nothing          -> FL (PrimOf p) wB wX -> Sealed (FL (PrimOf p) wB)
forall (a :: * -> *) wX. a wX -> Sealed a
seal (FL (PrimOf p) wB wX -> Sealed (FL (PrimOf p) wB))
-> FL (PrimOf p) wB wX -> Sealed (FL (PrimOf p) wB)
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wZ wB -> FL (PrimOf p) wB wZ
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert (PrimOf p wZ wZ
x'PrimOf p wZ wZ -> FL (PrimOf p) wZ wB -> FL (PrimOf p) wZ wB
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:FL (PrimOf p) wZ wB
b)FL (PrimOf p) wB wZ -> FL (PrimOf p) wZ wX -> FL (PrimOf p) wB wX
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+FL (PrimOf p) wZ wX
ys'
                    -- DJR: I don't think this last case should be
                    -- reached, but it also shouldn't lead to corruption.

-- | A sequence of primitive patches (candidates for the pending patch)
--   is considered simple if we can reason about their continued status as
--   pending patches solely on the basis of them being hunk/binary patches.
--
--   Simple here seems to mean that all patches are either hunk/binary
--   patches, or patches that cannot (indirectly) depend on hunk/binary
--   patches.  For now, the only other kinds of patches in this category
--   are changepref patches.
--
--   It might be tempting to add, say, adddir patches but it's probably not a
--   good idea because Darcs also inverts patches a lot in its reasoning so an
--   innocent addir may be inverted to a rmdir which in turn may depend on
--   a rmfile, which in turn depends on a hunk/binary. Likewise, we would
--   not want to add move patches to this category for similar reasons of
--   a potential dependency chain forming.
isSimple :: PrimPatch prim => FL prim wX wY -> Bool
isSimple :: FL prim wX wY -> Bool
isSimple =
    (forall wX wY. prim wX wY -> Bool) -> FL prim wX wY -> Bool
forall (a :: * -> * -> *) wW wZ.
(forall wX wY. a wX wY -> Bool) -> FL a wW wZ -> Bool
allFL forall wX wY. prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
isSimp
  where
    isSimp :: prim wX wY -> Bool
isSimp x :: prim wX wY
x = prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsHunk prim wX wY
x Bool -> Bool -> Bool
|| prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsBinary prim wX wY
x Bool -> Bool -> Bool
|| prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsSetpref prim wX wY
x

-- | @makeNewPending repo YesUpdateWorking 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
                 -> UpdateWorking
                 -> FL (PrimOf p) wT wY
                 -> Tree IO  -- ^recorded state of the repository, to check if pending can be applied
                 -> IO ()
makeNewPending :: Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wT wY -> Tree IO -> IO ()
makeNewPending _                  NoUpdateWorking _ _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
makeNewPending repo :: Repository rt p wR wU wT
repo YesUpdateWorking origp :: FL (PrimOf p) wT wY
origp recordedState :: 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
pendingName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".new"
       String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Writing new pending:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
newname
       Sealed sfp :: 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 wY -> Sealed (FL (PrimOf p) wT)
forall (prim :: * -> * -> *) wX wY.
PrimPatch prim =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL (PrimOf p) wT wY
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 p :: 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
pendingName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_buggy"
         String -> String -> IO ()
renameFile String
newname String
buggyname
         Doc -> IO (Tree IO)
forall a. Doc -> a
errorDoc (Doc -> IO (Tree IO)) -> Doc -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ String -> Doc
text ("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 "If possible, please send the contents of"
                    Doc -> Doc -> Doc
<+> String -> Doc
text String
buggyname
                    Doc -> Doc -> Doc
$$ String -> Doc
text "along with a bug report."
       String -> String -> IO ()
renameFile String
newname String
pendingName
       String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Finished writing new pending:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
newname

-- | Replace the pending patch with the tentative pending.
--   If @NoUpdateWorking@, this merely deletes the tentative pending
--   without replacing the current one.
--
--   Question (Eric Kow): shouldn't this also delete the tentative
--   pending if @YesUpdateWorking@?  I'm just puzzled by the seeming
--   inconsistency of the @NoUpdateWorking@ doing deletion, but
--   @YesUpdateWorking@ not bothering.
finalizePending :: (RepoPatch p, ApplyState p ~ Tree)
                => Repository rt p wR wU wT
                -> UpdateWorking
                -> Tree IO
                -> IO ()
finalizePending :: Repository rt p wR wU wT -> UpdateWorking -> Tree IO -> IO ()
finalizePending repo :: Repository rt p wR wU wT
repo NoUpdateWorking _ =
  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
pendingName
finalizePending repo :: Repository rt p wR wU wT
repo updateWorking :: UpdateWorking
updateWorking@UpdateWorking
YesUpdateWorking recordedState :: 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 tpend :: 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 new_pending :: 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.
PrimPatch prim =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL (PrimOf p) wT wX
tpend
      Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wT wX -> Tree IO -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wT wY -> Tree IO -> IO ()
makeNewPending Repository rt p wR wU wT
repo UpdateWorking
updateWorking FL (PrimOf p) wT wX
new_pending Tree IO
recordedState

-- | @tentativelyAddToPending repo NoDryRun YesUpdateWorking pend ps@
--   appends @ps@ to the pending patch.
--
--   It has no effect with @NoUpdateWorking@.
--
--   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
                        -> UpdateWorking
                        -> FL (PrimOf p) wX wY
                        -> IO ()
tentativelyAddToPending :: Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wX wY -> IO ()
tentativelyAddToPending _                   NoUpdateWorking  _     = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tentativelyAddToPending repo :: Repository rt p wR wU wT
repo YesUpdateWorking patch :: 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 pend :: 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
        FlippedSeal newpend_ :: FL (PrimOf p) wX wY
newpend_ <- FlippedSeal (FL (PrimOf p)) wY
-> IO (FlippedSeal (FL (PrimOf p)) wY)
forall (m :: * -> *) a. Monad m => a -> m a
return (FlippedSeal (FL (PrimOf p)) wY
 -> IO (FlippedSeal (FL (PrimOf p)) wY))
-> FlippedSeal (FL (PrimOf p)) wY
-> IO (FlippedSeal (FL (PrimOf p)) wY)
forall a b. (a -> b) -> a -> b
$
            FL (PrimOf p) Any wX
-> FL (PrimOf p) wX wY -> FlippedSeal (FL (PrimOf p)) wY
forall (prim :: * -> * -> *) wA wB wC.
FL prim wA wB -> FL prim wB wC -> FlippedSeal (FL prim) wC
newpend (FL (PrimOf p) wT wX -> FL (PrimOf p) wA wX
forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP FL (PrimOf p) wT wX
pend :: FL (PrimOf p) wA wX) FL (PrimOf p) wX wY
patch
        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) wX wY -> FL (PrimOf p) wT wY
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart FL (PrimOf p) wX wY
newpend_)
  where
    newpend :: FL prim wA wB -> FL prim wB wC -> FlippedSeal (FL prim) wC
    newpend :: FL prim wA wB -> FL prim wB wC -> FlippedSeal (FL prim) wC
newpend NilFL patch_ :: FL prim wB wC
patch_ = FL prim wB wC -> FlippedSeal (FL prim) wC
forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL prim wB wC
patch_
    newpend p :: FL prim wA wB
p     patch_ :: FL prim wB wC
patch_ = FL prim wA wC -> FlippedSeal (FL prim) wC
forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal (FL prim wA wC -> FlippedSeal (FL prim) wC)
-> FL prim wA wC -> FlippedSeal (FL prim) wC
forall a b. (a -> b) -> a -> b
$ FL prim wA wB
p FL prim wA wB -> FL prim wB wC -> FL prim wA wC
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL prim wB wC
patch_

-- | setTentativePending is basically unsafe.  It overwrites the pending
--   state with a new one, not related to the repository state.
setTentativePending :: forall rt p wR wU wT wX wY. RepoPatch p
                    => Repository rt p wR wU wT
                    -> UpdateWorking
                    -> FL (PrimOf p) wX wY
                    -> IO ()
setTentativePending :: Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wX wY -> IO ()
setTentativePending _                   NoUpdateWorking  _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setTentativePending repo :: Repository rt p wR wU wT
repo YesUpdateWorking patch :: FL (PrimOf p) wX wY
patch = do
    Sealed prims :: FL (PrimOf p) wX wX
prims <- Sealed (FL (PrimOf p) wX) -> IO (Sealed (FL (PrimOf p) wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wX) -> IO (Sealed (FL (PrimOf p) wX)))
-> Sealed (FL (PrimOf p) wX) -> IO (Sealed (FL (PrimOf p) wX))
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wX wY -> Sealed (FL (PrimOf p) wX)
forall (prim :: * -> * -> *) wX wY.
PrimPatch prim =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending 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
$ 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) wX wX -> FL (PrimOf p) wT wX
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart FL (PrimOf p) wX wX
prims)

-- | @prepend repo YesUpdateWorking ps@ prepends @ps@ to the pending patch
--   It's used right before removing @ps@ from the repo.  This ensures that
--   the pending patch can still be applied on top of the recorded state.
--
--   This function is basically unsafe.  It overwrites the pending state
--   with a new one, not related to the repository state.
prepend :: forall rt p wR wU wT wX wY. RepoPatch p
        => Repository rt p wR wU wT
        -> UpdateWorking
        -> FL (PrimOf p) wX wY
        -> IO ()
prepend :: Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wX wY -> IO ()
prepend _    NoUpdateWorking  _     = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
prepend repo :: Repository rt p wR wU wT
repo YesUpdateWorking patch :: FL (PrimOf p) wX wY
patch = do
    Sealed pend :: 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
    Sealed newpend_ :: FL (PrimOf p) wX wX
newpend_ <- Sealed (FL (PrimOf p) wX) -> IO (Sealed (FL (PrimOf p) wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wX) -> IO (Sealed (FL (PrimOf p) wX)))
-> Sealed (FL (PrimOf p) wX) -> IO (Sealed (FL (PrimOf p) wX))
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wY Any
-> FL (PrimOf p) wX wY -> Sealed (FL (PrimOf p) wX)
forall (prim :: * -> * -> *) wB wC wA.
FL prim wB wC -> FL prim wA wB -> Sealed (FL prim wA)
newpend (FL (PrimOf p) wT wX -> FL (PrimOf p) wY Any
forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP FL (PrimOf p) wT wX
pend) FL (PrimOf p) wX wY
patch
    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) wX wX -> FL (PrimOf p) wT wX
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart (FL (PrimOf p) wX wX -> FL (PrimOf p) wT wX)
-> FL (PrimOf p) wX wX -> FL (PrimOf p) wT wX
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wX wX -> FL (PrimOf p) wX wX
forall (prim :: * -> * -> *) wX wY.
PrimPatch prim =>
FL prim wX wY -> FL prim wX wY
crudeSift FL (PrimOf p) wX wX
newpend_)
  where
    newpend :: FL prim wB wC -> FL prim wA wB -> Sealed (FL prim wA)
    newpend :: FL prim wB wC -> FL prim wA wB -> Sealed (FL prim wA)
newpend NilFL patch_ :: FL prim wA wB
patch_ = FL prim wA wB -> Sealed (FL prim wA)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL prim wA wB
patch_
    newpend p :: FL prim wB wC
p     patch_ :: FL prim wA wB
patch_ = FL prim wA wC -> Sealed (FL prim wA)
forall (a :: * -> *) wX. a wX -> Sealed a
seal (FL prim wA wC -> Sealed (FL prim wA))
-> FL prim wA wC -> Sealed (FL prim wA)
forall a b. (a -> b) -> a -> b
$ FL prim wA wB
patch_ FL prim wA wB -> FL prim wB wC -> FL prim wA wC
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL prim wB wC
p