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"
readPending :: RepoPatch p => Repository rt p wR wU wT
-> IO (Sealed (FL (PrimOf p) wR))
readPending :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wR))
readPending = 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
""
readTentativePending :: RepoPatch p => Repository rt p wR wU wT
-> IO (Sealed (FL (PrimOf p) wT))
readTentativePending :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
readTentativePending = 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
readNewPending :: RepoPatch p => Repository rt p wR wU wT
-> IO (Sealed (FL (PrimOf p) wT))
readNewPending :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
readNewPending = 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
readPendingFile :: ReadPatch prim => String -> Repository rt p wR wU wT
-> IO (Sealed (FL prim wX))
readPendingFile :: 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
suffix Repository rt p wR wU wT
_ =
do
let filepath :: String
filepath = String
pendingPath forall a. [a] -> [a] -> [a]
++ String
suffix
ByteString
raw <- String -> IO ByteString
gzReadFilePS String
filepath
case forall (p :: * -> * -> *) wX.
ReadPatch p =>
ByteString -> Either String (Sealed (p wX))
readPatch ByteString
raw of
Right Sealed (FLM prim wX)
p -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall (p :: * -> * -> *) wX wY. FLM p wX wY -> FL p wX wY
unFLM Sealed (FLM prim wX)
p)
Left String
e -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"Corrupt pending patch: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
filepath, String
e]
forall a. IO a -> a -> IO a
`catchNonExistence` forall (a :: * -> *) wY. a wY -> Sealed a
Sealed forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
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 (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall (p :: * -> * -> *) wX wY. FL p wX wY -> FLM p wX wY
FLM forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> * -> *) wX.
(forall wY. Parser (Sealed (p wY)))
-> Char -> Char -> Parser (Sealed (FL p wX))
readMaybeBracketedFL 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 (p :: * -> * -> *) wA wB.
(forall wX wY. p wX wY -> Doc) -> Char -> Char -> FL p wA wB -> Doc
showMaybeBracketedFL (forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
f) Char
'{' Char
'}' forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal (forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>:forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = 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 (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]
writeTentativePending :: RepoPatch p => Repository rt p wR wU wT
-> FL (PrimOf p) wT wY -> IO ()
writeTentativePending :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
writeTentativePending = 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
writeNewPending :: RepoPatch p => Repository rt p wR wU wT
-> FL (PrimOf p) wT wP -> IO ()
writeNewPending :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
writeNewPending = 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
writePendingFile :: ShowPatchBasic prim => String -> Repository rt p wR wU wT
-> FL prim wX wY -> IO ()
writePendingFile :: 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
suffix Repository rt p wR wU wT
_ = forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
String -> p wX wY -> IO ()
writePatch String
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) wX wY. FL p wX wY -> FLM p wX wY
FLM
where
name :: String
name = String
pendingPath forall a. [a] -> [a] -> [a]
++ String
suffix
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 = forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile String
f forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForStorage p wX wY
p forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"\n"
tentativelyRemoveFromPending :: forall rt p wR wU wT wO. RepoPatch p
=> Repository rt p wR wU wT
-> FL (PrimOf p) wO wT
-> IO ()
tentativelyRemoveFromPending :: forall (rt :: RepoType) (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
r FL (PrimOf p) wO wT
ps = do
Sealed FL (PrimOf p) wO wX
pend <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
readTentativePending (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 <-
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 (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 forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
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
tentativelyRemoveFromPW :: forall rt p wR wO wT wP wU. RepoPatch p
=> Repository rt p wR wU wT
-> FL (PrimOf p) wO wT
-> FL (PrimOf p) wO wP
-> FL (PrimOf p) wP wU
-> IO ()
tentativelyRemoveFromPW :: forall (rt :: RepoType) (p :: * -> * -> *) wR wO wT wP wU.
RepoPatch p =>
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' <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
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 (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
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 :: (PrimPatch p)
=> FL p wA wB -> FL p wA wC -> FL p wC wD -> Sealed (FL p wB)
updatePending :: 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 wA wB
NilFL FL p wA wC
ys FL p wC wD
zs = forall (p :: * -> * -> *) wA wB wC.
(Commute p, Invert p, Eq2 p) =>
RL p wA wB -> FL p wB wC -> Sealed (FL p wA)
removeRLFL (forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL p wA wC
ys) FL p wC wD
zs
updatePending FL p wA wB
_ FL p wA wC
NilFL FL p wC wD
_ = forall (a :: * -> *) wY. a wY -> Sealed a
Sealed forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
updatePending FL p wA wB
xs FL p wA wC
ys FL p wC wD
NilFL = forall (a :: * -> *) wY. a wY -> Sealed a
Sealed (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL p wA wB
xs forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL p wA wC
ys)
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' <- 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 = 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
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 <- forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> (:>) (FL p) (p :> FL p) wX wY
commuteWhatWeCanFL (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert p wA wY
x 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' <- 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 (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert (p wZ wZ
ix'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 = 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 = 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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
updatePending (p wA wY
x:>:FL p wY wB
xs) FL p wA wC
ys FL p wC wD
zs =
case 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' -> 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 ->
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"cannot eliminate repo change:"
Doc -> Doc -> 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 (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL 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 (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL p wC wD
zs)
removeRLFL :: (Commute p, Invert p, Eq2 p)
=> RL p wA wB -> FL p wB wC -> Sealed (FL p wA)
removeRLFL :: 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:<:p wY wB
y) FL p wB wC
zs
| Just FL p wY wC
zs' <- forall (p :: * -> * -> *) wX wY wZ.
(Eq2 p, Commute p) =>
p wX wY -> FL p wX wZ -> Maybe (FL p wY wZ)
removeFL (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert p wY wB
y) FL p wB wC
zs = 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 forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) (RL p) p wX wY -> (:>) (RL p) (p :> RL p) wX wY
commuteWhatWeCanRL (RL p wA wY
ys 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 (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal ((RL p wA wZ
depsforall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<:p wZ wZ
y') forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> FL p wY wZ -> FL p wX wZ
+>>+) forall a b. (a -> b) -> a -> b
$ 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
_ = forall (a :: * -> *) wY. a wY -> Sealed a
Sealed forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
removeAllFL :: (Commute p, Invert p, Eq2 p)
=> FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC)
removeAllFL :: 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 (p wA wY
y:>:FL p wY wB
ys) FL p wA wC
zs
| Just FL p wY wC
zs' <- 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 = 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 = forall a. Maybe a
Nothing
removeAllFL FL p wA wB
NilFL FL p wA wC
zs = forall a. a -> Maybe a
Just FL p wA wC
zs
decoalesceAllFL :: (Commute p, Invert p, PrimCanonize p)
=> FL p wA wC -> FL p wA wB -> Maybe (FL p wB wC)
decoalesceAllFL :: 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
zs (p wA wY
y:>:FL p wY wB
ys)
| Just FL p wY wC
zs' <- 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 = 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 = forall a. Maybe a
Nothing
decoalesceAllFL FL p wA wC
zs FL p wA wB
NilFL = forall a. a -> Maybe a
Just FL p wA wC
zs
decoalesceFL :: (Commute p, Invert p, PrimCanonize p)
=> FL p wA wC -> p wA wB -> Maybe (FL p wB wC)
decoalesceFL :: 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
NilFL p wA wB
y = forall a. a -> Maybe a
Just (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert p wA wB
y forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: 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' <- 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 = forall a. a -> Maybe a
Just (p wB wY
z' 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' <- forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert p wA wB
y 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' <- 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 (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert p wZ wY
iy')
forall (m :: * -> *) a. Monad m => a -> m a
return (p wB wZ
z' forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL p wZ wC
zs')
makeNewPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> UpdatePending
-> FL (PrimOf p) wT wP
-> Tree IO
-> IO ()
makeNewPending :: 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
_ UpdatePending
NoUpdatePending FL (PrimOf p) wT wP
_ Tree 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 =
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 forall a b. (a -> b) -> a -> b
$
do let newname :: String
newname = String
pendingPath forall a. [a] -> [a] -> [a]
++ String
".new"
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Writing new pending: " forall a. [a] -> [a] -> [a]
++ String
newname
Sealed FL (PrimOf p) wT wX
sfp <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (prim :: * -> * -> *) wX wY.
PrimSift prim =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL (PrimOf p) wT wP
origp
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 <- 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
Tree IO
_ <- forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (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) forall a b. (a -> b) -> a -> b
$ \(IOException
err :: IOException) -> do
let buggyname :: String
buggyname = String
pendingPath forall a. [a] -> [a] -> [a]
++ String
"_buggy"
String -> String -> IO ()
renameFile String
newname String
buggyname
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String
"There was an attempt to write an invalid pending! " forall a. [a] -> [a] -> [a]
++ 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 forall a b. (a -> b) -> a -> b
$ String
"Finished writing new pending: " forall a. [a] -> [a] -> [a]
++ String
newname
finalizePending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> UpdatePending
-> Tree IO
-> IO ()
finalizePending :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> UpdatePending -> Tree IO -> IO ()
finalizePending Repository rt p wR wU wT
repo UpdatePending
NoUpdatePending Tree 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 forall a b. (a -> b) -> a -> b
$ 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 =
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 forall a b. (a -> b) -> a -> b
$ do
Sealed FL (PrimOf p) wT wX
tpend <- 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 <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (prim :: * -> * -> *) wX wY.
PrimSift prim =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL (PrimOf p) wT wX
tpend
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 :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> UpdatePending -> IO ()
revertPending Repository rt p wR wU wT
r UpdatePending
upe = do
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (String
pendingPath forall a. [a] -> [a] -> [a]
++ String
".tentative")
Sealed FL (PrimOf p) wR wX
x <- 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 forall a. Eq a => a -> a -> Bool
== UpdatePending
YesUpdatePending
then forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
writeTentativePending (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 forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String
pendingPath
tentativelyAddToPending :: forall rt p wR wU wT wX wY. RepoPatch p
=> Repository rt p wR wU wT
-> FL (PrimOf p) wX wY
-> IO ()
tentativelyAddToPending :: forall (rt :: RepoType) (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
repo FL (PrimOf p) wX wY
patch =
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 forall a b. (a -> b) -> a -> b
$ do
Sealed FL (PrimOf p) wT wX
pend <- 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
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 forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart FL (PrimOf p) wX wY
patch)
setTentativePending :: forall rt p wR wU wT wP. RepoPatch p
=> Repository rt p wR wU wT
-> FL (PrimOf p) wT wP
-> IO ()
setTentativePending :: forall (rt :: RepoType) (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
repo FL (PrimOf p) wT wP
patch = do
Sealed FL (PrimOf p) wT wX
prims <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (prim :: * -> * -> *) wX wY.
PrimSift prim =>
FL prim wX wY -> Sealed (FL prim wX)
siftForPending FL (PrimOf p) wT wP
patch
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 forall a b. (a -> b) -> a -> b
$ 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