{-# LANGUAGE CPP #-}
module Darcs.Repository.State
( restrictSubpaths, restrictBoring, TreeFilter(..), restrictDarcsdir
, unrecordedChanges
, readPristine, readUnrecorded, readPristineAndPending, readWorking
, readPendingAndWorking, readUnrecordedFiltered
, readIndex, updateIndex
, filterOutConflicts
, unsafeAddToPending, addToPending
) where
import Darcs.Prelude
import Control.Monad ( when, foldM, forM, void )
import Control.Monad.State ( StateT, runStateT, get, put, liftIO )
import Control.Exception ( catch, IOException )
import Data.Ord ( comparing )
import Data.List ( sortBy, union, delete )
import System.Directory( doesFileExist, renameFile )
import System.FilePath ( (<.>) )
import qualified Data.ByteString as B ( ByteString, concat )
import qualified Data.ByteString.Char8 as BC ( pack, unpack )
import qualified Data.ByteString.Lazy as BL ( toChunks )
import Darcs.Patch ( RepoPatch, PrimOf, canonizeFL
, PrimPatch, maybeApplyToTree
, tokreplace, forceTokReplace, move )
import Darcs.Patch.Named ( anonymous )
import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnPaths )
import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), consGapFL
, (:>)(..), reverseRL, reverseFL
, mapFL, concatFL, joinGapsFL, nullFL )
import Darcs.Patch.Witnesses.Eq ( EqCheck(IsEq, NotEq) )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal
, freeGap, emptyGap, joinGap, FreeLeft, Gap(..) )
import Darcs.Patch.Commute ( commuteFL )
import Darcs.Patch.Permutations ( partitionConflictingFL, genCommuteWhatWeCanRL )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )
import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) )
import Darcs.Patch.TokenReplace ( breakToTokens, defaultToks )
import Darcs.Repository.Flags
( DiffAlgorithm(..)
, LookForMoves(..)
, LookForReplaces(..)
, LookForAdds(..)
, UseIndex(..)
, DiffOpts(..)
)
import Darcs.Repository.InternalTypes
( AccessType(..)
, Repository
, repoFormat
, repoLocation
)
import Darcs.Repository.Format(formatHas, RepoProperty(NoWorkingDir))
import qualified Darcs.Repository.Pending as Pending
import Darcs.Repository.Prefs ( filetypeFunction, isBoring )
import Darcs.Repository.Pristine ( readPristine )
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Repository.Paths
( indexPath
, indexInvalidPath
)
import Darcs.Util.File ( removeFileMayNotExist )
import Darcs.Util.Global ( debugMessage )
import Darcs.Util.Path
( AnchoredPath
, realPath
, filterPaths
, inDarcsdir
, parents
, movedirfilename
)
import Darcs.Util.Tree( Tree, restrict, FilterTree, expand, emptyTree, overlay, find
, ItemType(..), itemType, readBlob, modifyTree, findFile, TreeItem(..)
, makeBlobBS, expandPath )
import qualified Darcs.Util.Tree.Plain as PlainTree ( readPlainTree )
import Darcs.Util.Index
( Index
, indexFormatValid
, openIndex
, treeFromIndex
, updateIndexFrom
)
import qualified Darcs.Util.Tree as Tree
import Darcs.Util.Index ( listFileIDs, getFileID )
#define TEST_INDEX 0
#if TEST_INDEX
import Control.Monad ( unless )
import Darcs.Util.Path ( displayPath )
import Darcs.Util.Tree ( list )
#else
import System.IO ( hPutStrLn, stderr )
import System.IO.Error ( catchIOError )
#endif
newtype TreeFilter m = TreeFilter { forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter :: forall tr . FilterTree tr m => tr m -> tr m }
restrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wU wR -> [AnchoredPath]
-> IO (TreeFilter m)
restrictSubpaths :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR (m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> [AnchoredPath] -> IO (TreeFilter m)
restrictSubpaths Repository rt p wU wR
repo [AnchoredPath]
paths = do
Sealed FL (PrimOf p) wR wX
pending <- Repository rt 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))
Pending.readPending Repository rt p wU wR
repo
FL (PrimOf p) wR wX
-> Repository rt p wU wR -> [AnchoredPath] -> IO (TreeFilter m)
forall (p :: * -> * -> *) wR wP (rt :: AccessType) wU
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wR wP
-> Repository rt p wU wR -> [AnchoredPath] -> IO (TreeFilter m)
restrictSubpathsAfter FL (PrimOf p) wR wX
pending Repository rt p wU wR
repo [AnchoredPath]
paths
restrictSubpathsAfter :: (RepoPatch p, ApplyState p ~ Tree)
=> FL (PrimOf p) wR wP
-> Repository rt p wU wR
-> [AnchoredPath]
-> IO (TreeFilter m)
restrictSubpathsAfter :: forall (p :: * -> * -> *) wR wP (rt :: AccessType) wU
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wR wP
-> Repository rt p wU wR -> [AnchoredPath] -> IO (TreeFilter m)
restrictSubpathsAfter FL (PrimOf p) wR wP
pending Repository rt p wU wR
_repo [AnchoredPath]
paths = do
let paths' :: [AnchoredPath]
paths' = [AnchoredPath]
paths [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
forall a. Eq a => [a] -> [a] -> [a]
`union` FL (PrimOf p) wR wP -> [AnchoredPath] -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [AnchoredPath] -> [AnchoredPath]
effectOnPaths FL (PrimOf p) wR wP
pending [AnchoredPath]
paths
restrictPaths :: FilterTree tree m => tree m -> tree m
restrictPaths :: forall (tree :: (* -> *) -> *) (m :: * -> *).
FilterTree tree m =>
tree m -> tree m
restrictPaths = (AnchoredPath -> TreeItem m -> Bool) -> tree m -> tree m
forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
Tree.filter ([AnchoredPath] -> AnchoredPath -> TreeItem m -> Bool
forall t. [AnchoredPath] -> AnchoredPath -> t -> Bool
filterPaths [AnchoredPath]
paths')
TreeFilter m -> IO (TreeFilter m)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter tr m -> tr m
forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
forall (tree :: (* -> *) -> *) (m :: * -> *).
FilterTree tree m =>
tree m -> tree m
restrictPaths)
maybeRestrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree)
=> FL (PrimOf p) wR wP
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (TreeFilter m)
maybeRestrictSubpaths :: forall (p :: * -> * -> *) wR wP (rt :: AccessType) wU
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wR wP
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (TreeFilter m)
maybeRestrictSubpaths FL (PrimOf p) wR wP
pending Repository rt p wU wR
repo =
IO (TreeFilter m)
-> ([AnchoredPath] -> IO (TreeFilter m))
-> Maybe [AnchoredPath]
-> IO (TreeFilter m)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TreeFilter m -> IO (TreeFilter m)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeFilter m -> IO (TreeFilter m))
-> TreeFilter m -> IO (TreeFilter m)
forall a b. (a -> b) -> a -> b
$ (forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter tr m -> tr m
forall a. a -> a
forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
id) (FL (PrimOf p) wR wP
-> Repository rt p wU wR -> [AnchoredPath] -> IO (TreeFilter m)
forall (p :: * -> * -> *) wR wP (rt :: AccessType) wU
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wR wP
-> Repository rt p wU wR -> [AnchoredPath] -> IO (TreeFilter m)
restrictSubpathsAfter FL (PrimOf p) wR wP
pending Repository rt p wU wR
repo)
restrictBoring :: Tree m -> IO (TreeFilter m)
restrictBoring :: forall (m :: * -> *). Tree m -> IO (TreeFilter m)
restrictBoring Tree m
guide = do
FilePath -> Bool
boring <- IO (FilePath -> Bool)
isBoring
let exclude :: AnchoredPath -> ItemType -> Bool
exclude AnchoredPath
p ItemType
t = AnchoredPath -> Bool
inDarcsdir AnchoredPath
p Bool -> Bool -> Bool
|| FilePath -> Bool
boring (ItemType -> FilePath -> FilePath
appendSlash ItemType
t (AnchoredPath -> FilePath
realPath AnchoredPath
p))
appendSlash :: ItemType -> FilePath -> FilePath
appendSlash ItemType
TreeType FilePath
fp = FilePath
fp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/"
appendSlash ItemType
BlobType FilePath
fp = FilePath
fp
restrictTree :: FilterTree t m => t m -> t m
restrictTree :: forall (tree :: (* -> *) -> *) (m :: * -> *).
FilterTree tree m =>
tree m -> tree m
restrictTree =
(AnchoredPath -> TreeItem m -> Bool) -> t m -> t m
forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
Tree.filter ((AnchoredPath -> TreeItem m -> Bool) -> t m -> t m)
-> (AnchoredPath -> TreeItem m -> Bool) -> t m -> t m
forall a b. (a -> b) -> a -> b
$ \AnchoredPath
p TreeItem m
i ->
case Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
guide AnchoredPath
p of
Maybe (TreeItem m)
Nothing -> Bool -> Bool
not (AnchoredPath -> ItemType -> Bool
exclude AnchoredPath
p (TreeItem m -> ItemType
forall (m :: * -> *). TreeItem m -> ItemType
itemType TreeItem m
i))
Maybe (TreeItem m)
_ -> Bool
True
TreeFilter m -> IO (TreeFilter m)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter tr m -> tr m
forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
forall (tree :: (* -> *) -> *) (m :: * -> *).
FilterTree tree m =>
tree m -> tree m
restrictTree)
restrictDarcsdir :: TreeFilter m
restrictDarcsdir :: forall (m :: * -> *). TreeFilter m
restrictDarcsdir = (forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter ((forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m)
-> (forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> TreeItem m -> Bool) -> tr m -> tr m
forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
Tree.filter ((AnchoredPath -> TreeItem m -> Bool) -> tr m -> tr m)
-> (AnchoredPath -> TreeItem m -> Bool) -> tr m -> tr m
forall a b. (a -> b) -> a -> b
$ \AnchoredPath
p TreeItem m
_ -> Bool -> Bool
not (AnchoredPath -> Bool
inDarcsdir AnchoredPath
p)
unrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree)
=> DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath] -> IO (FL (PrimOf p) wR wU)
unrecordedChanges :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges dopts :: DiffOpts
dopts@DiffOpts{DiffAlgorithm
UseIndex
LookForMoves
LookForReplaces
LookForAdds
withIndex :: UseIndex
lookForAdds :: LookForAdds
lookForReplaces :: LookForReplaces
lookForMoves :: LookForMoves
diffAlg :: DiffAlgorithm
withIndex :: DiffOpts -> UseIndex
lookForAdds :: DiffOpts -> LookForAdds
lookForReplaces :: DiffOpts -> LookForReplaces
lookForMoves :: DiffOpts -> LookForMoves
diffAlg :: DiffOpts -> DiffAlgorithm
..} Repository rt p wU wR
r Maybe [AnchoredPath]
paths = do
(FL (PrimOf p) wR wZ
pending :> FL (PrimOf p) wZ wU
working) <- DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
readPendingAndWorking DiffOpts
dopts Repository rt p wU wR
r Maybe [AnchoredPath]
paths
FL (PrimOf p) wR wU -> IO (FL (PrimOf p) wR wU)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PrimOf p) wR wU -> IO (FL (PrimOf p) wR wU))
-> FL (PrimOf p) wR wU -> IO (FL (PrimOf p) wR wU)
forall a b. (a -> b) -> a -> b
$ DiffAlgorithm -> FL (PrimOf p) wR wU -> FL (PrimOf p) wR wU
forall (prim :: * -> * -> *) wX wY.
(IsHunk prim, PrimCoalesce prim, PrimConstruct prim) =>
DiffAlgorithm -> FL prim wX wY -> FL prim wX wY
canonizeFL DiffAlgorithm
diffAlg (FL (PrimOf p) wR wZ
pending FL (PrimOf p) wR wZ -> FL (PrimOf p) wZ wU -> FL (PrimOf p) wR wU
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wZ wU
working)
readPendingAndWorking :: (RepoPatch p, ApplyState p ~ Tree)
=> DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO ((FL (PrimOf p) :> FL (PrimOf p)) wR wU)
readPendingAndWorking :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
readPendingAndWorking DiffOpts
_ Repository rt p wU wR
r Maybe [AnchoredPath]
_ | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
NoWorkingDir (Repository rt p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository rt p wU wR
r) = do
EqCheck wU wR
IsEq <- EqCheck wU wR -> IO (EqCheck wU wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EqCheck wU wR -> IO (EqCheck wU wR))
-> EqCheck wU wR -> IO (EqCheck wU wR)
forall a b. (a -> b) -> a -> b
$ Repository rt p wU wR -> EqCheck wU wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> EqCheck wU wR
workDirLessRepoWitness Repository rt p wU wR
r
(:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PrimOf p) wU wU
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL FL (PrimOf p) wU wU
-> FL (PrimOf p) wU wU
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wU wU
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimOf p) wU wU
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
readPendingAndWorking DiffOpts{DiffAlgorithm
UseIndex
LookForMoves
LookForReplaces
LookForAdds
withIndex :: DiffOpts -> UseIndex
lookForAdds :: DiffOpts -> LookForAdds
lookForReplaces :: DiffOpts -> LookForReplaces
lookForMoves :: DiffOpts -> LookForMoves
diffAlg :: DiffOpts -> DiffAlgorithm
withIndex :: UseIndex
lookForAdds :: LookForAdds
lookForReplaces :: LookForReplaces
lookForMoves :: LookForMoves
diffAlg :: DiffAlgorithm
..} Repository rt p wU wR
repo Maybe [AnchoredPath]
mbpaths = do
FilePath -> IO ()
debugMessage FilePath
"readPendingAndWorking: start"
(Tree IO
pending_tree, Tree IO
working_tree, (FL (PrimOf p) wR wZ
pending :> FL (PrimOf p) wZ wU
moves)) <-
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO
(Tree IO, Tree IO, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wM.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO
(Tree IO, Tree IO, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wM)
readPendingAndMovesAndUnrecorded Repository rt p wU wR
repo UseIndex
withIndex LookForAdds
lookForAdds LookForMoves
lookForMoves Maybe [AnchoredPath]
mbpaths
FilePath -> IO ()
debugMessage FilePath
"readPendingAndWorking: after readPendingAndMovesAndUnrecorded"
(Tree IO
pending_tree_with_replaces, Sealed FL (PrimOf p) wU wX
replaces) <-
LookForReplaces
-> DiffAlgorithm
-> Repository rt p wU wR
-> Tree IO
-> Tree IO
-> IO (Tree IO, Sealed (FL (PrimOf p) wU))
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
LookForReplaces
-> DiffAlgorithm
-> Repository rt p wU wR
-> Tree IO
-> Tree IO
-> IO (Tree IO, Sealed (FL (PrimOf p) wU))
getReplaces LookForReplaces
lookForReplaces DiffAlgorithm
diffAlg Repository rt p wU wR
repo Tree IO
pending_tree Tree IO
working_tree
FilePath -> IO ()
debugMessage FilePath
"readPendingAndWorking: after getReplaces"
FilePath -> FileType
ft <- IO (FilePath -> FileType)
filetypeFunction
FreeLeft (FL (PrimOf p))
wrapped_diff <- DiffAlgorithm
-> (FilePath -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL (PrimOf p)))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
(prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> (FilePath -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
diffAlg FilePath -> FileType
ft Tree IO
pending_tree_with_replaces Tree IO
working_tree
case FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wX)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft FreeLeft (FL (PrimOf p))
wrapped_diff of
Sealed FL (PrimOf p) wX wX
diff -> do
FilePath -> IO ()
debugMessage FilePath
"readPendingAndWorking: done"
(:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU))
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
forall a b. (a -> b) -> a -> b
$ (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wX
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU
forall (a :: * -> * -> *) wX wY1 wY2. a wX wY1 -> a wX wY2
unsafeCoercePEnd ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wX
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wX
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wR wZ
pending FL (PrimOf p) wR wZ
-> FL (PrimOf p) wZ wX
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wX
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> (FL (PrimOf p) wZ wU
moves FL (PrimOf p) wZ wU -> FL (PrimOf p) wU wX -> FL (PrimOf p) wZ wX
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wU wX
replaces FL (PrimOf p) wU wX -> FL (PrimOf p) wX wX -> FL (PrimOf p) wU wX
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wX wX
diff)
readPendingAndMovesAndUnrecorded
:: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO ( Tree IO
, Tree IO
, (FL (PrimOf p) :> FL (PrimOf p)) wR wM
)
readPendingAndMovesAndUnrecorded :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR wM.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO
(Tree IO, Tree IO, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wM)
readPendingAndMovesAndUnrecorded Repository rt p wU wR
repo UseIndex
useidx LookForAdds
scan LookForMoves
lfm Maybe [AnchoredPath]
mbpaths = do
FilePath -> IO ()
debugMessage FilePath
"readPendingAndMovesAndUnrecorded: start"
(Tree IO
pending_tree, Sealed FL (PrimOf p) wR wX
pending) <- Repository rt p wU wR -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
readPending Repository rt p wU wR
repo
FL (PrimOf p) wX wX
moves <- LookForMoves
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wX wX)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR wB
(prim :: * -> * -> *).
(RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p) =>
LookForMoves
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL prim wB wB)
getMoves LookForMoves
lfm Repository rt p wU wR
repo Maybe [AnchoredPath]
mbpaths
TreeFilter IO
relevant <- FL (PrimOf p) wR wX
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (TreeFilter IO)
forall (p :: * -> * -> *) wR wP (rt :: AccessType) wU
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wR wP
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (TreeFilter m)
maybeRestrictSubpaths (FL (PrimOf p) wR wX
pending FL (PrimOf p) wR wX -> FL (PrimOf p) wX wX -> FL (PrimOf p) wR wX
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wX wX
moves) Repository rt p wU wR
repo Maybe [AnchoredPath]
mbpaths
Tree IO
pending_tree_with_moves <-
TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
relevant (Tree IO -> Tree IO) -> IO (Tree IO) -> IO (Tree IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FL (PrimOf p) wX wX -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, MonadThrow m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree FL (PrimOf p) wX wX
moves Tree IO
pending_tree
FilePath -> IO ()
debugMessage FilePath
"readPendingAndMovesAndUnrecorded: before readIndexOrPlainTree"
Tree IO
index <- Repository rt p wU wR
-> UseIndex -> TreeFilter IO -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wU wR
-> UseIndex -> TreeFilter IO -> Tree IO -> IO (Tree IO)
readIndexOrPlainTree Repository rt p wU wR
repo UseIndex
useidx TreeFilter IO
relevant Tree IO
pending_tree_with_moves
FilePath -> IO ()
debugMessage FilePath
"readPendingAndMovesAndUnrecorded: before filteredWorking"
let useidx' :: UseIndex
useidx' = if FL (PrimOf p) wX wX -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PrimOf p) wX wX
moves then UseIndex
useidx else UseIndex
IgnoreIndex
Tree IO
working_tree <-
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> TreeFilter IO
-> Tree IO
-> Tree IO
-> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> TreeFilter IO
-> Tree IO
-> Tree IO
-> IO (Tree IO)
filteredWorking Repository rt p wU wR
repo UseIndex
useidx' LookForAdds
scan TreeFilter IO
relevant Tree IO
index Tree IO
pending_tree_with_moves
FilePath -> IO ()
debugMessage FilePath
"readPendingAndMovesAndUnrecorded: done"
(Tree IO, Tree IO, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wM)
-> IO
(Tree IO, Tree IO, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wM)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
(Tree IO
pending_tree_with_moves, Tree IO
working_tree, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wX
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wM
forall (a :: * -> * -> *) wX wY1 wY2. a wX wY1 -> a wX wY2
unsafeCoercePEnd (FL (PrimOf p) wR wX
pending FL (PrimOf p) wR wX
-> FL (PrimOf p) wX wX
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wX
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimOf p) wX wX
moves))
filteredWorking :: Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> TreeFilter IO
-> Tree IO
-> Tree IO
-> IO (Tree IO)
filteredWorking :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> TreeFilter IO
-> Tree IO
-> Tree IO
-> IO (Tree IO)
filteredWorking Repository rt p wU wR
repo UseIndex
useidx LookForAdds
scan TreeFilter IO
relevant Tree IO
from_index Tree IO
pending_tree =
TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
forall (m :: * -> *). TreeFilter m
restrictDarcsdir (Tree IO -> Tree IO) -> (Tree IO -> Tree IO) -> Tree IO -> Tree IO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
relevant (Tree IO -> Tree IO) -> IO (Tree IO) -> IO (Tree IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
case UseIndex
useidx of
UseIndex
UseIndex ->
case LookForAdds
scan of
LookForAdds
NoLookForAdds -> Tree IO -> IO (Tree IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Tree IO
from_index
LookForAdds
YesLookForAdds -> do
TreeFilter IO
nonboring <- Tree IO -> IO (TreeFilter IO)
forall (m :: * -> *). Tree m -> IO (TreeFilter m)
restrictBoring Tree IO
from_index
Tree IO
plain <- TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
nonboring (Tree IO -> Tree IO) -> IO (Tree IO) -> IO (Tree IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository rt p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPlainTree Repository rt p wU wR
repo
Tree IO -> IO (Tree IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO -> IO (Tree IO)) -> Tree IO -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ Tree IO
plain Tree IO -> Tree IO -> Tree IO
forall (m :: * -> *). Applicative m => Tree m -> Tree m -> Tree m
`overlay` Tree IO
from_index
LookForAdds
EvenLookForBoring -> do
Tree IO
plain <- Repository rt p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPlainTree Repository rt p wU wR
repo
Tree IO -> IO (Tree IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO -> IO (Tree IO)) -> Tree IO -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ Tree IO
plain Tree IO -> Tree IO -> Tree IO
forall (m :: * -> *). Applicative m => Tree m -> Tree m -> Tree m
`overlay` Tree IO
from_index
UseIndex
IgnoreIndex -> do
Tree IO
working <- Repository rt p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPlainTree Repository rt p wU wR
repo
case LookForAdds
scan of
LookForAdds
NoLookForAdds -> do
Tree IO
guide <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree IO
pending_tree
Tree IO -> IO (Tree IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO -> IO (Tree IO)) -> Tree IO -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ Tree IO -> Tree IO -> Tree IO
forall (t :: (* -> *) -> *) (m :: * -> *) (n :: * -> *).
FilterTree t m =>
Tree n -> t m -> t m
restrict Tree IO
guide Tree IO
working
LookForAdds
YesLookForAdds -> do
Tree IO
guide <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree IO
pending_tree
TreeFilter IO
nonboring <- Tree IO -> IO (TreeFilter IO)
forall (m :: * -> *). Tree m -> IO (TreeFilter m)
restrictBoring Tree IO
guide
Tree IO -> IO (Tree IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO -> IO (Tree IO)) -> Tree IO -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
nonboring Tree IO
working
LookForAdds
EvenLookForBoring -> Tree IO -> IO (Tree IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Tree IO
working
workDirLessRepoWitness :: Repository rt p wU wR -> EqCheck wU wR
workDirLessRepoWitness :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> EqCheck wU wR
workDirLessRepoWitness Repository rt p wU wR
r
| RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
NoWorkingDir (Repository rt p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository rt p wU wR
r) = EqCheck Any Any -> EqCheck wU wR
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 wU wR
forall wA wB. EqCheck wA wB
NotEq
readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wU wR
-> UseIndex
-> Maybe [AnchoredPath]
-> IO (Tree IO)
readUnrecorded :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
readUnrecorded Repository rt p wU wR
repo UseIndex
useidx Maybe [AnchoredPath]
mbpaths = do
#if TEST_INDEX
t1 <- expand =<< readUnrecordedFiltered repo useidx NoLookForAdds NoLookForMoves mbpaths
(pending_tree, Sealed pending) <- readPending repo
relevant <- maybeRestrictSubpaths pending repo mbpaths
t2 <- readIndexOrPlainTree repo useidx relevant pending_tree
assertEqualTrees "indirect" t1 "direct" t2
return t1
#else
Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
readUnrecordedFiltered Repository rt p wU wR
repo UseIndex
useidx LookForAdds
NoLookForAdds LookForMoves
NoLookForMoves Maybe [AnchoredPath]
mbpaths
#endif
#if TEST_INDEX
assertEqualTrees :: String -> Tree m -> String -> Tree m -> IO ()
assertEqualTrees n1 t1 n2 t2 =
unless (t1 `eqTree` t2) $
fail $ "Trees are not equal!\n" ++ showTree n1 t1 ++ showTree n2 t2
eqTree :: Tree m -> Tree m -> Bool
eqTree t1 t2 = map fst (list t1) == map fst (list t2)
showTree :: String -> Tree m -> String
showTree name tree = unlines (name : map ((" "++) . displayPath . fst) (list tree))
#endif
readIndexOrPlainTree :: (ApplyState p ~ Tree, RepoPatch p)
=> Repository rt p wU wR
-> UseIndex
-> TreeFilter IO
-> Tree IO
-> IO (Tree IO)
#if TEST_INDEX
readIndexOrPlainTree repo useidx treeFilter pending_tree = do
indexTree <-
treeFromIndex =<< applyTreeFilter treeFilter <$> readIndex repo
plainTree <- do
guide <- expand pending_tree
expand =<< applyTreeFilter treeFilter . restrict guide <$> readPlainTree repo
assertEqualTrees "index tree" indexTree "plain tree" plainTree
return $
case useidx of
UseIndex -> indexTree
IgnoreIndex -> plainTree
#else
readIndexOrPlainTree :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wU wR
-> UseIndex -> TreeFilter IO -> Tree IO -> IO (Tree IO)
readIndexOrPlainTree Repository rt p wU wR
repo UseIndex
UseIndex TreeFilter IO
treeFilter Tree IO
pending_tree =
(Index -> IO (Tree IO)
treeFromIndex (Index -> IO (Tree IO)) -> IO Index -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
treeFilter (Index -> Index) -> IO Index -> IO Index
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository rt p wU wR -> IO Index
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO Index
readIndex Repository rt p wU wR
repo)
IO (Tree IO) -> (IOError -> IO (Tree IO)) -> IO (Tree IO)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
e -> do
Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"Warning, cannot access the index:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
e)
Repository rt p wU wR
-> UseIndex -> TreeFilter IO -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wU wR
-> UseIndex -> TreeFilter IO -> Tree IO -> IO (Tree IO)
readIndexOrPlainTree Repository rt p wU wR
repo UseIndex
IgnoreIndex TreeFilter IO
treeFilter Tree IO
pending_tree
readIndexOrPlainTree Repository rt p wU wR
repo UseIndex
IgnoreIndex TreeFilter IO
treeFilter Tree IO
pending_tree = do
Tree IO
guide <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree IO
pending_tree
Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
treeFilter (Tree IO -> Tree IO) -> (Tree IO -> Tree IO) -> Tree IO -> Tree IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree IO -> Tree IO -> Tree IO
forall (t :: (* -> *) -> *) (m :: * -> *) (n :: * -> *).
FilterTree t m =>
Tree n -> t m -> t m
restrict Tree IO
guide (Tree IO -> Tree IO) -> IO (Tree IO) -> IO (Tree IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository rt p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPlainTree Repository rt p wU wR
repo
#endif
readUnrecordedFiltered :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath] -> IO (Tree IO)
readUnrecordedFiltered :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
readUnrecordedFiltered Repository rt p wU wR
repo UseIndex
useidx LookForAdds
scan LookForMoves
lfm Maybe [AnchoredPath]
mbpaths = do
(Tree IO
_, Tree IO
working_tree, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR Any
_) <-
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO
(Tree IO, Tree IO, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR Any)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wM.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex
-> LookForAdds
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO
(Tree IO, Tree IO, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wM)
readPendingAndMovesAndUnrecorded Repository rt p wU wR
repo UseIndex
useidx LookForAdds
scan LookForMoves
lfm Maybe [AnchoredPath]
mbpaths
Tree IO -> IO (Tree IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Tree IO
working_tree
readWorking :: TreeFilter IO -> IO (Tree IO)
readWorking :: TreeFilter IO -> IO (Tree IO)
readWorking TreeFilter IO
relevant =
Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
relevant (Tree IO -> Tree IO) -> (Tree IO -> Tree IO) -> Tree IO -> Tree IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
forall (m :: * -> *). TreeFilter m
restrictDarcsdir (Tree IO -> Tree IO) -> IO (Tree IO) -> IO (Tree IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
FilePath -> IO (Tree IO)
PlainTree.readPlainTree FilePath
".")
readPristineAndPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wU wR -> IO (Tree IO)
readPristineAndPending :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO (Tree IO)
readPristineAndPending Repository rt p wU wR
repo = (Tree IO, Sealed (FL (PrimOf p) wR)) -> Tree IO
forall a b. (a, b) -> a
fst ((Tree IO, Sealed (FL (PrimOf p) wR)) -> Tree IO)
-> IO (Tree IO, Sealed (FL (PrimOf p) wR)) -> IO (Tree IO)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Repository rt p wU wR -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
readPending Repository rt p wU wR
repo
readPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wU wR
-> IO (Tree IO, Sealed (FL (PrimOf p) wR))
readPending :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
readPending Repository rt p wU wR
repo = do
Tree IO
pristine <- Repository rt p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository rt p wU wR
repo
Sealed FL (PrimOf p) wR wX
pending <- Repository rt 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))
Pending.readPending Repository rt p wU wR
repo
IO (Tree IO, Sealed (FL (PrimOf p) wR))
-> (IOError -> IO (Tree IO, Sealed (FL (PrimOf p) wR)))
-> IO (Tree IO, Sealed (FL (PrimOf p) wR))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((\Tree IO
t -> (Tree IO
t, FL (PrimOf p) wR wX -> Sealed (FL (PrimOf p) wR)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL (PrimOf p) wR wX
pending)) (Tree IO -> (Tree IO, Sealed (FL (PrimOf p) wR)))
-> IO (Tree IO) -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FL (PrimOf p) wR wX -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, MonadThrow m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree FL (PrimOf p) wR wX
pending Tree IO
pristine) ((IOError -> IO (Tree IO, Sealed (FL (PrimOf p) wR)))
-> IO (Tree IO, Sealed (FL (PrimOf p) wR)))
-> (IOError -> IO (Tree IO, Sealed (FL (PrimOf p) wR)))
-> IO (Tree IO, Sealed (FL (PrimOf p) wR))
forall a b. (a -> b) -> a -> b
$ \(IOError
e::IOException) -> do
FilePath -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO (Tree IO, Sealed (FL (PrimOf p) wR)))
-> FilePath -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
forall a b. (a -> b) -> a -> b
$
FilePath
"Cannot apply pending patch, please run `darcs repair`\n"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
e
readIndex :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wU wR -> IO Index
readIndex :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO Index
readIndex Repository rt p wU wR
repo = do
Bool
okay <- IO Bool
checkIndex
if Bool -> Bool
not Bool
okay
then Repository rt p wU wR -> IO Index
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO Index
internalUpdateIndex Repository rt p wU wR
repo
else FilePath -> IO Index
openIndex FilePath
indexPath
internalUpdateIndex :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wU wR -> IO Index
internalUpdateIndex :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO Index
internalUpdateIndex Repository rt p wU wR
repo = do
Tree IO
pris <-
Repository rt p wU wR -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO (Tree IO)
readPristineAndPending Repository rt p wU wR
repo
IO (Tree IO) -> (IOError -> IO (Tree IO)) -> IO (Tree IO)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOError
_::IOException) -> Repository rt p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository rt p wU wR
repo
Index
idx <- FilePath -> Tree IO -> IO Index
updateIndexFrom FilePath
indexPath Tree IO
pris
FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist FilePath
indexInvalidPath
Index -> IO Index
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Index
idx
updateIndex :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wU wR -> IO ()
updateIndex :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO ()
updateIndex Repository rt p wU wR
repo = do
IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Bool
checkIndex
IO Index -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Index -> IO ()) -> IO Index -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository rt p wU wR -> IO Index
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO Index
internalUpdateIndex Repository rt p wU wR
repo
checkIndex :: IO Bool
checkIndex :: IO Bool
checkIndex = do
Bool
invalid <- FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
indexInvalidPath
Bool
formatValid <- FilePath -> IO Bool
indexFormatValid FilePath
indexPath
Bool
exist <- FilePath -> IO Bool
doesFileExist FilePath
indexPath
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exist Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
formatValid) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
renameFile FilePath
indexPath (FilePath
indexPath FilePath -> FilePath -> FilePath
<.> FilePath
"old")
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
invalid Bool -> Bool -> Bool
&& Bool
formatValid)
filterOutConflicts
:: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wU wR
-> UseIndex
-> FL (PatchInfoAnd p) wX wR
-> FL (PatchInfoAnd p) wX wZ
-> IO (Bool, Sealed (FL (PatchInfoAnd p) wX))
filterOutConflicts :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR wX wZ.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex
-> FL (PatchInfoAnd p) wX wR
-> FL (PatchInfoAnd p) wX wZ
-> IO (Bool, Sealed (FL (PatchInfoAnd p) wX))
filterOutConflicts Repository rt p wU wR
repository UseIndex
useidx FL (PatchInfoAnd p) wX wR
us FL (PatchInfoAnd p) wX wZ
them
= do
PatchInfoAndG (Named p) wR wU
unrec <- (Named p wR wU -> PatchInfoAndG (Named p) wR wU)
-> IO (Named p wR wU) -> IO (PatchInfoAndG (Named p) wR wU)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Named p wR wU -> PatchInfoAndG (Named p) wR wU
forall (p :: * -> * -> *) wX wY.
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG p wX wY
n2pia (IO (Named p wR wU) -> IO (PatchInfoAndG (Named p) wR wU))
-> (FL (PrimOf p) wR wU -> IO (Named p wR wU))
-> FL (PrimOf p) wR wU
-> IO (PatchInfoAndG (Named p) wR wU)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL (PrimOf p) wR wU -> IO (Named p wR wU)
forall (p :: * -> * -> *) wX wY.
FromPrim p =>
FL (PrimOf p) wX wY -> IO (Named p wX wY)
anonymous
(FL (PrimOf p) wR wU -> IO (PatchInfoAndG (Named p) wR wU))
-> IO (FL (PrimOf p) wR wU) -> IO (PatchInfoAndG (Named p) wR wU)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges
(UseIndex
-> LookForAdds
-> LookForReplaces
-> LookForMoves
-> DiffAlgorithm
-> DiffOpts
DiffOpts UseIndex
useidx LookForAdds
NoLookForAdds LookForReplaces
NoLookForReplaces
LookForMoves
NoLookForMoves DiffAlgorithm
MyersDiff) Repository rt p wU wR
repository Maybe [AnchoredPath]
forall a. Maybe a
Nothing
FL (PatchInfoAnd p) wX wZ
them' :> FL (PatchInfoAnd p) wZ wZ
rest <-
(:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wZ
-> IO ((:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wZ)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wZ
-> IO ((:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wZ))
-> (:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wZ
-> IO ((:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wZ)
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd p) wX wZ
-> FL (PatchInfoAnd p) wX wU
-> (:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wZ
forall (p :: * -> * -> *) wX wY wZ.
(Commute p, CleanMerge p) =>
FL p wX wY -> FL p wX wZ -> (:>) (FL p) (FL p) wX wY
partitionConflictingFL FL (PatchInfoAnd p) wX wZ
them (FL (PatchInfoAnd p) wX wR
us FL (PatchInfoAnd p) wX wR
-> FL (PatchInfoAnd p) wR wU -> FL (PatchInfoAnd p) wX wU
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ PatchInfoAndG (Named p) wR wU
unrec PatchInfoAndG (Named p) wR wU
-> FL (PatchInfoAnd p) wU wU -> FL (PatchInfoAnd p) wR wU
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd p) wU wU
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
(Bool, Sealed (FL (PatchInfoAnd p) wX))
-> IO (Bool, Sealed (FL (PatchInfoAnd p) wX))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PatchInfoAnd p) wZ wZ -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
check FL (PatchInfoAnd p) wZ wZ
rest, FL (PatchInfoAnd p) wX wZ -> Sealed (FL (PatchInfoAnd p) wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PatchInfoAnd p) wX wZ
them')
where check :: FL p wA wB -> Bool
check :: forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
check FL p wA wB
NilFL = Bool
False
check FL p wA wB
_ = Bool
True
getMoves :: forall rt p wU wR wB prim.
(RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p)
=> LookForMoves
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL prim wB wB)
getMoves :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR wB
(prim :: * -> * -> *).
(RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p) =>
LookForMoves
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL prim wB wB)
getMoves LookForMoves
NoLookForMoves Repository rt p wU wR
_ Maybe [AnchoredPath]
_ = FL prim wB wB -> IO (FL prim wB wB)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FL prim wB wB
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
getMoves LookForMoves
YesLookForMoves Repository rt p wU wR
repository Maybe [AnchoredPath]
files =
[(AnchoredPath, AnchoredPath, ItemType)] -> FL prim wB wB
forall {a :: * -> * -> *} {c} {wY}.
PrimConstruct a =>
[(AnchoredPath, AnchoredPath, c)] -> FL a wY wY
mkMovesFL ([(AnchoredPath, AnchoredPath, ItemType)] -> FL prim wB wB)
-> IO [(AnchoredPath, AnchoredPath, ItemType)]
-> IO (FL prim wB wB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO [(AnchoredPath, AnchoredPath, ItemType)]
getMovedFiles Repository rt p wU wR
repository Maybe [AnchoredPath]
files
where
mkMovesFL :: [(AnchoredPath, AnchoredPath, c)] -> FL a wY wY
mkMovesFL [] = FL a wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
mkMovesFL ((AnchoredPath
a,AnchoredPath
b,c
_):[(AnchoredPath, AnchoredPath, c)]
xs) = AnchoredPath -> AnchoredPath -> a wY wY
forall wX wY. AnchoredPath -> AnchoredPath -> a wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> AnchoredPath -> prim wX wY
move AnchoredPath
a AnchoredPath
b a wY wY -> FL a wY wY -> FL a wY wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: [(AnchoredPath, AnchoredPath, c)] -> FL a wY wY
mkMovesFL [(AnchoredPath, AnchoredPath, c)]
xs
getMovedFiles :: Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO [(AnchoredPath, AnchoredPath, ItemType)]
getMovedFiles :: Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO [(AnchoredPath, AnchoredPath, ItemType)]
getMovedFiles Repository rt p wU wR
repo Maybe [AnchoredPath]
fs = do
[((AnchoredPath, ItemType), FileID)]
old <- (((AnchoredPath, ItemType), FileID)
-> ((AnchoredPath, ItemType), FileID) -> Ordering)
-> [((AnchoredPath, ItemType), FileID)]
-> [((AnchoredPath, ItemType), FileID)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((((AnchoredPath, ItemType), FileID) -> FileID)
-> ((AnchoredPath, ItemType), FileID)
-> ((AnchoredPath, ItemType), FileID)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((AnchoredPath, ItemType), FileID) -> FileID
forall a b. (a, b) -> b
snd) ([((AnchoredPath, ItemType), FileID)]
-> [((AnchoredPath, ItemType), FileID)])
-> IO [((AnchoredPath, ItemType), FileID)]
-> IO [((AnchoredPath, ItemType), FileID)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Index -> IO [((AnchoredPath, ItemType), FileID)]
listFileIDs (Index -> IO [((AnchoredPath, ItemType), FileID)])
-> IO Index -> IO [((AnchoredPath, ItemType), FileID)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Repository rt p wU wR -> IO Index
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO Index
readIndex Repository rt p wU wR
repo)
TreeFilter IO
nonboring <- Tree IO -> IO (TreeFilter IO)
forall (m :: * -> *). Tree m -> IO (TreeFilter m)
restrictBoring Tree IO
forall (m :: * -> *). Tree m
emptyTree
let addIDs :: [(AnchoredPath, b)] -> IO [((AnchoredPath, b), FileID)]
addIDs = ([((AnchoredPath, b), FileID)]
-> (AnchoredPath, b) -> IO [((AnchoredPath, b), FileID)])
-> [((AnchoredPath, b), FileID)]
-> [(AnchoredPath, b)]
-> IO [((AnchoredPath, b), FileID)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[((AnchoredPath, b), FileID)]
xs (AnchoredPath
p, b
it)-> do Maybe FileID
mfid <- AnchoredPath -> IO (Maybe FileID)
getFileID AnchoredPath
p
[((AnchoredPath, b), FileID)] -> IO [((AnchoredPath, b), FileID)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([((AnchoredPath, b), FileID)] -> IO [((AnchoredPath, b), FileID)])
-> [((AnchoredPath, b), FileID)]
-> IO [((AnchoredPath, b), FileID)]
forall a b. (a -> b) -> a -> b
$ case Maybe FileID
mfid of
Maybe FileID
Nothing -> [((AnchoredPath, b), FileID)]
xs
Just FileID
fid -> ((AnchoredPath
p, b
it), FileID
fid)((AnchoredPath, b), FileID)
-> [((AnchoredPath, b), FileID)] -> [((AnchoredPath, b), FileID)]
forall a. a -> [a] -> [a]
:[((AnchoredPath, b), FileID)]
xs) []
[((AnchoredPath, ItemType), FileID)]
new <- (((AnchoredPath, ItemType), FileID)
-> ((AnchoredPath, ItemType), FileID) -> Ordering)
-> [((AnchoredPath, ItemType), FileID)]
-> [((AnchoredPath, ItemType), FileID)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((((AnchoredPath, ItemType), FileID) -> FileID)
-> ((AnchoredPath, ItemType), FileID)
-> ((AnchoredPath, ItemType), FileID)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((AnchoredPath, ItemType), FileID) -> FileID
forall a b. (a, b) -> b
snd) ([((AnchoredPath, ItemType), FileID)]
-> [((AnchoredPath, ItemType), FileID)])
-> IO [((AnchoredPath, ItemType), FileID)]
-> IO [((AnchoredPath, ItemType), FileID)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
([(AnchoredPath, ItemType)]
-> IO [((AnchoredPath, ItemType), FileID)]
forall {b}. [(AnchoredPath, b)] -> IO [((AnchoredPath, b), FileID)]
addIDs ([(AnchoredPath, ItemType)]
-> IO [((AnchoredPath, ItemType), FileID)])
-> (Tree IO -> [(AnchoredPath, ItemType)])
-> Tree IO
-> IO [((AnchoredPath, ItemType), FileID)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AnchoredPath, TreeItem IO) -> (AnchoredPath, ItemType))
-> [(AnchoredPath, TreeItem IO)] -> [(AnchoredPath, ItemType)]
forall a b. (a -> b) -> [a] -> [b]
map (\(AnchoredPath
a,TreeItem IO
b) -> (AnchoredPath
a, TreeItem IO -> ItemType
forall (m :: * -> *). TreeItem m -> ItemType
itemType TreeItem IO
b)) ([(AnchoredPath, TreeItem IO)] -> [(AnchoredPath, ItemType)])
-> (Tree IO -> [(AnchoredPath, TreeItem IO)])
-> Tree IO
-> [(AnchoredPath, ItemType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
Tree.list (Tree IO -> IO [((AnchoredPath, ItemType), FileID)])
-> IO (Tree IO) -> IO [((AnchoredPath, ItemType), FileID)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TreeFilter IO
-> forall (tr :: (* -> *) -> *). FilterTree tr IO => tr IO -> tr IO
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
nonboring (Tree IO -> Tree IO) -> IO (Tree IO) -> IO (Tree IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository rt p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPlainTree Repository rt p wU wR
repository)
let match :: [((a, c), b)] -> [((b, c), b)] -> [(a, b, c)]
match (((a, c), b)
x:[((a, c), b)]
xs) (((b, c), b)
y:[((b, c), b)]
ys)
| ((a, c), b) -> b
forall a b. (a, b) -> b
snd ((a, c), b)
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
> ((b, c), b) -> b
forall a b. (a, b) -> b
snd ((b, c), b)
y = [((a, c), b)] -> [((b, c), b)] -> [(a, b, c)]
match (((a, c), b)
x((a, c), b) -> [((a, c), b)] -> [((a, c), b)]
forall a. a -> [a] -> [a]
:[((a, c), b)]
xs) [((b, c), b)]
ys
| ((a, c), b) -> b
forall a b. (a, b) -> b
snd ((a, c), b)
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< ((b, c), b) -> b
forall a b. (a, b) -> b
snd ((b, c), b)
y = [((a, c), b)] -> [((b, c), b)] -> [(a, b, c)]
match [((a, c), b)]
xs (((b, c), b)
y((b, c), b) -> [((b, c), b)] -> [((b, c), b)]
forall a. a -> [a] -> [a]
:[((b, c), b)]
ys)
| (a, c) -> c
forall a b. (a, b) -> b
snd (((a, c), b) -> (a, c)
forall a b. (a, b) -> a
fst ((a, c), b)
x) c -> c -> Bool
forall a. Eq a => a -> a -> Bool
/= (b, c) -> c
forall a b. (a, b) -> b
snd (((b, c), b) -> (b, c)
forall a b. (a, b) -> a
fst ((b, c), b)
y) = [((a, c), b)] -> [((b, c), b)] -> [(a, b, c)]
match [((a, c), b)]
xs [((b, c), b)]
ys
| Bool
otherwise = ((a, c) -> a
forall a b. (a, b) -> a
fst (((a, c), b) -> (a, c)
forall a b. (a, b) -> a
fst ((a, c), b)
x), (b, c) -> b
forall a b. (a, b) -> a
fst (((b, c), b) -> (b, c)
forall a b. (a, b) -> a
fst ((b, c), b)
y), (a, c) -> c
forall a b. (a, b) -> b
snd (((a, c), b) -> (a, c)
forall a b. (a, b) -> a
fst ((a, c), b)
x))(a, b, c) -> [(a, b, c)] -> [(a, b, c)]
forall a. a -> [a] -> [a]
:[((a, c), b)] -> [((b, c), b)] -> [(a, b, c)]
match [((a, c), b)]
xs [((b, c), b)]
ys
match [((a, c), b)]
_ [((b, c), b)]
_ = []
movedfiles :: [(AnchoredPath, AnchoredPath, ItemType)]
movedfiles = [((AnchoredPath, ItemType), FileID)]
-> [((AnchoredPath, ItemType), FileID)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
forall {b} {c} {a} {b}.
(Ord b, Eq c) =>
[((a, c), b)] -> [((b, c), b)] -> [(a, b, c)]
match [((AnchoredPath, ItemType), FileID)]
old [((AnchoredPath, ItemType), FileID)]
new
fmovedfiles :: [(AnchoredPath, AnchoredPath, ItemType)]
fmovedfiles =
case Maybe [AnchoredPath]
fs of
Maybe [AnchoredPath]
Nothing -> [(AnchoredPath, AnchoredPath, ItemType)]
movedfiles
Just [AnchoredPath]
paths ->
((AnchoredPath, AnchoredPath, ItemType) -> Bool)
-> [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(AnchoredPath
f1, AnchoredPath
f2, ItemType
_) -> (AnchoredPath -> Bool) -> [AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (AnchoredPath -> [AnchoredPath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AnchoredPath]
selfiles) [AnchoredPath
f1, AnchoredPath
f2]) [(AnchoredPath, AnchoredPath, ItemType)]
movedfiles
where selfiles :: [AnchoredPath]
selfiles = [AnchoredPath]
paths
[(AnchoredPath, AnchoredPath, ItemType)]
-> IO [(AnchoredPath, AnchoredPath, ItemType)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
resolve [(AnchoredPath, AnchoredPath, ItemType)]
fmovedfiles)
resolve :: [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
resolve :: [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
resolve [(AnchoredPath, AnchoredPath, ItemType)]
xs = [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
fixPaths ([(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)])
-> [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
forall a b. (a -> b) -> a -> b
$ [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
forall {c}.
Eq c =>
[(AnchoredPath, AnchoredPath, c)]
-> [(AnchoredPath, AnchoredPath, c)]
sortMoves ([(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)])
-> [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
forall a b. (a -> b) -> a -> b
$ [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
forall {t} {c}. Eq t => [(t, t, c)] -> [(t, t, c)]
deleteCycles [(AnchoredPath, AnchoredPath, ItemType)]
xs
where
deleteCycles :: [(t, t, c)] -> [(t, t, c)]
deleteCycles [] = []
deleteCycles whole :: [(t, t, c)]
whole@( x :: (t, t, c)
x@(t
start,t
_,c
_):[(t, t, c)]
rest)
= if t -> [(t, t, c)] -> t -> Bool
hasCycle t
start [(t, t, c)]
whole t
start
then [(t, t, c)] -> [(t, t, c)]
deleteCycles (t -> [(t, t, c)] -> [(t, t, c)] -> [(t, t, c)]
forall {t} {c}.
Eq t =>
t -> [(t, t, c)] -> [(t, t, c)] -> [(t, t, c)]
deleteFrom t
start [(t, t, c)]
whole [])
else (t, t, c)
x(t, t, c) -> [(t, t, c)] -> [(t, t, c)]
forall a. a -> [a] -> [a]
:[(t, t, c)] -> [(t, t, c)]
deleteCycles [(t, t, c)]
rest
where hasCycle :: t -> [(t, t, c)] -> t -> Bool
hasCycle t
current ((t
a',t
b',c
_):[(t, t, c)]
rest') t
first
| t
a' t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
current = t
b' t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
first Bool -> Bool -> Bool
|| t -> [(t, t, c)] -> t -> Bool
hasCycle t
b' [(t, t, c)]
whole t
first
| Bool
otherwise = t -> [(t, t, c)] -> t -> Bool
hasCycle t
current [(t, t, c)]
rest' t
first
hasCycle t
_ [] t
_ = Bool
False
deleteFrom :: t -> [(t, t, c)] -> [(t, t, c)] -> [(t, t, c)]
deleteFrom t
a (y :: (t, t, c)
y@(t
a',t
b',c
_):[(t, t, c)]
ys) [(t, t, c)]
seen
| t
a t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
a' = t -> [(t, t, c)] -> [(t, t, c)] -> [(t, t, c)]
deleteFrom t
b' ([(t, t, c)]
seen[(t, t, c)] -> [(t, t, c)] -> [(t, t, c)]
forall a. [a] -> [a] -> [a]
++[(t, t, c)]
ys) []
| Bool
otherwise = t -> [(t, t, c)] -> [(t, t, c)] -> [(t, t, c)]
deleteFrom t
a [(t, t, c)]
ys ((t, t, c)
y(t, t, c) -> [(t, t, c)] -> [(t, t, c)]
forall a. a -> [a] -> [a]
:[(t, t, c)]
seen)
deleteFrom t
_ [] [(t, t, c)]
seen = [(t, t, c)]
seen
sortMoves :: [(AnchoredPath, AnchoredPath, c)]
-> [(AnchoredPath, AnchoredPath, c)]
sortMoves [] = []
sortMoves whole :: [(AnchoredPath, AnchoredPath, c)]
whole@(current :: (AnchoredPath, AnchoredPath, c)
current@(AnchoredPath
_,AnchoredPath
dest,c
_):[(AnchoredPath, AnchoredPath, c)]
_) =
(AnchoredPath, AnchoredPath, c)
smallest(AnchoredPath, AnchoredPath, c)
-> [(AnchoredPath, AnchoredPath, c)]
-> [(AnchoredPath, AnchoredPath, c)]
forall a. a -> [a] -> [a]
:[(AnchoredPath, AnchoredPath, c)]
-> [(AnchoredPath, AnchoredPath, c)]
sortMoves ((AnchoredPath, AnchoredPath, c)
-> [(AnchoredPath, AnchoredPath, c)]
-> [(AnchoredPath, AnchoredPath, c)]
forall a. Eq a => a -> [a] -> [a]
delete (AnchoredPath, AnchoredPath, c)
smallest [(AnchoredPath, AnchoredPath, c)]
whole)
where
smallest :: (AnchoredPath, AnchoredPath, c)
smallest = AnchoredPath
-> [(AnchoredPath, AnchoredPath, c)]
-> (AnchoredPath, AnchoredPath, c)
-> (AnchoredPath, AnchoredPath, c)
follow AnchoredPath
dest [(AnchoredPath, AnchoredPath, c)]
whole (AnchoredPath, AnchoredPath, c)
current
follow :: AnchoredPath
-> [(AnchoredPath, AnchoredPath, c)]
-> (AnchoredPath, AnchoredPath, c)
-> (AnchoredPath, AnchoredPath, c)
follow AnchoredPath
prevDest (y :: (AnchoredPath, AnchoredPath, c)
y@(AnchoredPath
s,AnchoredPath
d,c
_):[(AnchoredPath, AnchoredPath, c)]
ys) (AnchoredPath, AnchoredPath, c)
currentSmallest
| AnchoredPath
prevDest AnchoredPath -> AnchoredPath -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredPath
s = AnchoredPath
-> [(AnchoredPath, AnchoredPath, c)]
-> (AnchoredPath, AnchoredPath, c)
-> (AnchoredPath, AnchoredPath, c)
follow AnchoredPath
d [(AnchoredPath, AnchoredPath, c)]
whole (AnchoredPath, AnchoredPath, c)
y
| AnchoredPath
d AnchoredPath -> [AnchoredPath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` AnchoredPath -> [AnchoredPath]
parents AnchoredPath
prevDest = AnchoredPath
-> [(AnchoredPath, AnchoredPath, c)]
-> (AnchoredPath, AnchoredPath, c)
-> (AnchoredPath, AnchoredPath, c)
follow AnchoredPath
d [(AnchoredPath, AnchoredPath, c)]
whole (AnchoredPath, AnchoredPath, c)
y
| Bool
otherwise = AnchoredPath
-> [(AnchoredPath, AnchoredPath, c)]
-> (AnchoredPath, AnchoredPath, c)
-> (AnchoredPath, AnchoredPath, c)
follow AnchoredPath
prevDest [(AnchoredPath, AnchoredPath, c)]
ys (AnchoredPath, AnchoredPath, c)
currentSmallest
follow AnchoredPath
_ [] (AnchoredPath, AnchoredPath, c)
currentSmallest = (AnchoredPath, AnchoredPath, c)
currentSmallest
fixPaths :: [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
fixPaths [] = []
fixPaths (y :: (AnchoredPath, AnchoredPath, ItemType)
y@(AnchoredPath
f1,AnchoredPath
f2,ItemType
t):[(AnchoredPath, AnchoredPath, ItemType)]
ys)
| AnchoredPath
f1 AnchoredPath -> AnchoredPath -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredPath
f2 = [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
fixPaths [(AnchoredPath, AnchoredPath, ItemType)]
ys
| ItemType
TreeType <- ItemType
t = (AnchoredPath, AnchoredPath, ItemType)
y(AnchoredPath, AnchoredPath, ItemType)
-> [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
forall a. a -> [a] -> [a]
:[(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
fixPaths (((AnchoredPath, AnchoredPath, ItemType)
-> (AnchoredPath, AnchoredPath, ItemType))
-> [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath, AnchoredPath, ItemType)
-> (AnchoredPath, AnchoredPath, ItemType)
forall {b} {c}. (AnchoredPath, b, c) -> (AnchoredPath, b, c)
replacepp [(AnchoredPath, AnchoredPath, ItemType)]
ys)
| Bool
otherwise = (AnchoredPath, AnchoredPath, ItemType)
y(AnchoredPath, AnchoredPath, ItemType)
-> [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
forall a. a -> [a] -> [a]
:[(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
fixPaths [(AnchoredPath, AnchoredPath, ItemType)]
ys
where replacepp :: (AnchoredPath, b, c) -> (AnchoredPath, b, c)
replacepp (AnchoredPath
if1,b
if2,c
it) = (AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
movedirfilename AnchoredPath
f1 AnchoredPath
f2 AnchoredPath
if1, b
if2, c
it)
getReplaces :: forall rt p wU wR
. (RepoPatch p, ApplyState p ~ Tree)
=> LookForReplaces
-> DiffAlgorithm
-> Repository rt p wU wR
-> Tree IO
-> Tree IO
-> IO (Tree IO,
Sealed (FL (PrimOf p) wU))
getReplaces :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
LookForReplaces
-> DiffAlgorithm
-> Repository rt p wU wR
-> Tree IO
-> Tree IO
-> IO (Tree IO, Sealed (FL (PrimOf p) wU))
getReplaces LookForReplaces
NoLookForReplaces DiffAlgorithm
_ Repository rt p wU wR
_ Tree IO
pending Tree IO
_ = (Tree IO, Sealed (FL (PrimOf p) wU))
-> IO (Tree IO, Sealed (FL (PrimOf p) wU))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
pending, FL (PrimOf p) wU wU -> Sealed (FL (PrimOf p) wU)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PrimOf p) wU wU
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
getReplaces LookForReplaces
YesLookForReplaces DiffAlgorithm
diffalg Repository rt p wU wR
_repo Tree IO
pending Tree IO
working = do
FilePath -> FileType
ftf <- IO (FilePath -> FileType)
filetypeFunction
Sealed FL (PrimOf p) Any wX
changes <- FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) Any)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft (FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) Any))
-> IO (FreeLeft (FL (PrimOf p))) -> IO (Sealed (FL (PrimOf p) Any))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiffAlgorithm
-> (FilePath -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL (PrimOf p)))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
(prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> (FilePath -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
diffalg FilePath -> FileType
ftf Tree IO
pending Tree IO
working
let allModifiedTokens :: [(AnchoredPath, ByteString, ByteString)]
allModifiedTokens = [[(AnchoredPath, ByteString, ByteString)]]
-> [(AnchoredPath, ByteString, ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(AnchoredPath, ByteString, ByteString)]]
-> [(AnchoredPath, ByteString, ByteString)])
-> [[(AnchoredPath, ByteString, ByteString)]]
-> [(AnchoredPath, ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ (forall wW wZ.
PrimOf p wW wZ -> [(AnchoredPath, ByteString, ByteString)])
-> FL (PrimOf p) Any wX
-> [[(AnchoredPath, ByteString, ByteString)]]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL PrimOf p wW wZ -> [(AnchoredPath, ByteString, ByteString)]
forall wW wZ.
PrimOf p wW wZ -> [(AnchoredPath, ByteString, ByteString)]
modifiedTokens FL (PrimOf p) Any wX
changes
replaces :: [(AnchoredPath, ByteString, ByteString)]
replaces = [(AnchoredPath, ByteString, ByteString)]
-> [(AnchoredPath, ByteString, ByteString)]
forall {a} {a} {c}.
(Eq a, Eq a, Eq c) =>
[(a, a, c)] -> [(a, a, c)]
rmInvalidReplaces [(AnchoredPath, ByteString, ByteString)]
allModifiedTokens
([FreeLeft (FL (PrimOf p))]
patches, Tree IO
new_pending) <-
(StateT (Tree IO) IO [FreeLeft (FL (PrimOf p))]
-> Tree IO -> IO ([FreeLeft (FL (PrimOf p))], Tree IO))
-> Tree IO
-> StateT (Tree IO) IO [FreeLeft (FL (PrimOf p))]
-> IO ([FreeLeft (FL (PrimOf p))], Tree IO)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Tree IO) IO [FreeLeft (FL (PrimOf p))]
-> Tree IO -> IO ([FreeLeft (FL (PrimOf p))], Tree IO)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Tree IO
pending (StateT (Tree IO) IO [FreeLeft (FL (PrimOf p))]
-> IO ([FreeLeft (FL (PrimOf p))], Tree IO))
-> StateT (Tree IO) IO [FreeLeft (FL (PrimOf p))]
-> IO ([FreeLeft (FL (PrimOf p))], Tree IO)
forall a b. (a -> b) -> a -> b
$
[(AnchoredPath, ByteString, ByteString)]
-> ((AnchoredPath, ByteString, ByteString)
-> StateT (Tree IO) IO (FreeLeft (FL (PrimOf p))))
-> StateT (Tree IO) IO [FreeLeft (FL (PrimOf p))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(AnchoredPath, ByteString, ByteString)]
replaces (((AnchoredPath, ByteString, ByteString)
-> StateT (Tree IO) IO (FreeLeft (FL (PrimOf p))))
-> StateT (Tree IO) IO [FreeLeft (FL (PrimOf p))])
-> ((AnchoredPath, ByteString, ByteString)
-> StateT (Tree IO) IO (FreeLeft (FL (PrimOf p))))
-> StateT (Tree IO) IO [FreeLeft (FL (PrimOf p))]
forall a b. (a -> b) -> a -> b
$ \(AnchoredPath
path, ByteString
a, ByteString
b) ->
FilePath
-> AnchoredPath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL (PrimOf p)))
forall {prim :: * -> * -> *}.
(ApplyState prim ~ Tree, Annotate prim, CleanMerge prim,
IsHunk prim, PatchInspect prim, RepairToFL prim, Show2 prim,
PrimCoalesce prim, PrimDetails prim, PrimApply prim, PrimSift prim,
PrimMangleUnravelled prim, ReadPatch prim, ShowPatch prim,
ShowContextPatch prim, PatchListFormat prim, PrimConstruct prim) =>
FilePath
-> AnchoredPath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL prim))
doReplace FilePath
defaultToks AnchoredPath
path (ByteString -> FilePath
BC.unpack ByteString
a) (ByteString -> FilePath
BC.unpack ByteString
b)
(Tree IO, Sealed (FL (PrimOf p) wU))
-> IO (Tree IO, Sealed (FL (PrimOf p) wU))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
new_pending, (forall wX. FL (FL (PrimOf p)) wU wX -> FL (PrimOf p) wU wX)
-> Sealed (FL (FL (PrimOf p)) wU) -> Sealed (FL (PrimOf p) wU)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal FL (FL (PrimOf p)) wU wX -> FL (PrimOf p) wU wX
forall wX. FL (FL (PrimOf p)) wU wX -> FL (PrimOf p) wU wX
forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL (Sealed (FL (FL (PrimOf p)) wU) -> Sealed (FL (PrimOf p) wU))
-> Sealed (FL (FL (PrimOf p)) wU) -> Sealed (FL (PrimOf p) wU)
forall a b. (a -> b) -> a -> b
$ FreeLeft (FL (FL (PrimOf p))) -> Sealed (FL (FL (PrimOf p)) wU)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft (FreeLeft (FL (FL (PrimOf p))) -> Sealed (FL (FL (PrimOf p)) wU))
-> FreeLeft (FL (FL (PrimOf p))) -> Sealed (FL (FL (PrimOf p)) wU)
forall a b. (a -> b) -> a -> b
$ [FreeLeft (FL (PrimOf p))] -> FreeLeft (FL (FL (PrimOf p)))
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
[w p] -> w (FL p)
joinGapsFL [FreeLeft (FL (PrimOf p))]
patches)
where
modifiedTokens :: PrimOf p wX wY -> [(AnchoredPath, B.ByteString, B.ByteString)]
modifiedTokens :: forall wW wZ.
PrimOf p wW wZ -> [(AnchoredPath, ByteString, ByteString)]
modifiedTokens PrimOf p wX wY
p = case PrimOf p wX wY
-> Maybe (FileHunk (ObjectIdOfPatch (PrimOf p)) wX wY)
forall wX wY.
PrimOf p wX wY
-> Maybe (FileHunk (ObjectIdOfPatch (PrimOf p)) wX wY)
forall (p :: * -> * -> *) wX wY.
IsHunk p =>
p wX wY -> Maybe (FileHunk (ObjectIdOfPatch p) wX wY)
isHunk PrimOf p wX wY
p of
Just (FileHunk ObjectIdOfPatch (PrimOf p)
f Int
_ [ByteString]
old [ByteString]
new) ->
((ByteString, ByteString)
-> (AnchoredPath, ByteString, ByteString))
-> [(ByteString, ByteString)]
-> [(AnchoredPath, ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
a,ByteString
b) -> (AnchoredPath
ObjectIdOfPatch (PrimOf p)
f, ByteString
a, ByteString
b)) ((([ByteString], [ByteString]) -> [(ByteString, ByteString)])
-> [([ByteString], [ByteString])] -> [(ByteString, ByteString)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([ByteString], [ByteString]) -> [(ByteString, ByteString)]
checkModified ([([ByteString], [ByteString])] -> [(ByteString, ByteString)])
-> [([ByteString], [ByteString])] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$
(([ByteString], [ByteString]) -> Bool)
-> [([ByteString], [ByteString])] -> [([ByteString], [ByteString])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\([ByteString]
a,[ByteString]
b) -> [ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
b)
([([ByteString], [ByteString])] -> [([ByteString], [ByteString])])
-> [([ByteString], [ByteString])] -> [([ByteString], [ByteString])]
forall a b. (a -> b) -> a -> b
$ [[ByteString]] -> [[ByteString]] -> [([ByteString], [ByteString])]
forall a b. [a] -> [b] -> [(a, b)]
zip ((ByteString -> [ByteString]) -> [ByteString] -> [[ByteString]]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [ByteString]
breakToTokens [ByteString]
old) ((ByteString -> [ByteString]) -> [ByteString] -> [[ByteString]]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [ByteString]
breakToTokens [ByteString]
new))
Maybe (FileHunk (ObjectIdOfPatch (PrimOf p)) wX wY)
Nothing -> []
checkModified :: ([ByteString], [ByteString]) -> [(ByteString, ByteString)]
checkModified = ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ByteString
a,ByteString
b) -> ByteString
aByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/=ByteString
b) ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> (([ByteString], [ByteString]) -> [(ByteString, ByteString)])
-> ([ByteString], [ByteString])
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ByteString] -> [ByteString] -> [(ByteString, ByteString)])
-> ([ByteString], [ByteString]) -> [(ByteString, ByteString)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [ByteString] -> [ByteString] -> [(ByteString, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip
rmInvalidReplaces :: [(a, a, c)] -> [(a, a, c)]
rmInvalidReplaces [] = []
rmInvalidReplaces ((a
f,a
old,c
new):[(a, a, c)]
rs)
| ((a, a, c) -> Bool) -> [(a, a, c)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(a
f',a
a,c
b) -> a
f' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
f Bool -> Bool -> Bool
&& a
old a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a Bool -> Bool -> Bool
&& c
b c -> c -> Bool
forall a. Eq a => a -> a -> Bool
/= c
new) [(a, a, c)]
rs =
[(a, a, c)] -> [(a, a, c)]
rmInvalidReplaces ([(a, a, c)] -> [(a, a, c)]) -> [(a, a, c)] -> [(a, a, c)]
forall a b. (a -> b) -> a -> b
$ ((a, a, c) -> Bool) -> [(a, a, c)] -> [(a, a, c)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
f'',a
a',c
_) -> a
f'' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
f Bool -> Bool -> Bool
|| a
a' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
old) [(a, a, c)]
rs
rmInvalidReplaces ((a, a, c)
r:[(a, a, c)]
rs) = (a, a, c)
r(a, a, c) -> [(a, a, c)] -> [(a, a, c)]
forall a. a -> [a] -> [a]
:[(a, a, c)] -> [(a, a, c)]
rmInvalidReplaces (((a, a, c) -> Bool) -> [(a, a, c)] -> [(a, a, c)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a, a, c) -> (a, a, c) -> Bool
forall a. Eq a => a -> a -> Bool
/=(a, a, c)
r) [(a, a, c)]
rs)
doReplace :: FilePath
-> AnchoredPath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL prim))
doReplace FilePath
toks AnchoredPath
path FilePath
old FilePath
new = do
Tree IO
pend <- StateT (Tree IO) IO (Tree IO)
forall s (m :: * -> *). MonadState s m => m s
get
Maybe (Tree IO)
mpend' <- IO (Maybe (Tree IO)) -> StateT (Tree IO) IO (Maybe (Tree IO))
forall a. IO a -> StateT (Tree IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Tree IO)) -> StateT (Tree IO) IO (Maybe (Tree IO)))
-> IO (Maybe (Tree IO)) -> StateT (Tree IO) IO (Maybe (Tree IO))
forall a b. (a -> b) -> a -> b
$ prim Any Any -> Tree IO -> IO (Maybe (Tree IO))
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyState p ~ Tree, MonadCatch m) =>
p wX wY -> Tree m -> m (Maybe (Tree m))
maybeApplyToTree prim Any Any
forall {wX} {wY}. prim wX wY
replacePatch Tree IO
pend
case Maybe (Tree IO)
mpend' of
Maybe (Tree IO)
Nothing -> AnchoredPath
-> FilePath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL prim))
forall (prim :: * -> * -> *).
(PrimPatch prim, ApplyState prim ~ Tree) =>
AnchoredPath
-> FilePath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL prim))
getForceReplace AnchoredPath
path FilePath
toks FilePath
old FilePath
new
Just Tree IO
pend' -> do
Tree IO -> StateT (Tree IO) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Tree IO
pend'
FreeLeft (FL prim) -> StateT (Tree IO) IO (FreeLeft (FL prim))
forall a. a -> StateT (Tree IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeLeft (FL prim) -> StateT (Tree IO) IO (FreeLeft (FL prim)))
-> FreeLeft (FL prim) -> StateT (Tree IO) IO (FreeLeft (FL prim))
forall a b. (a -> b) -> a -> b
$ (forall {wX} {wY}. prim wX wY)
-> FreeLeft (FL prim) -> FreeLeft (FL prim)
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w (FL p) -> w (FL p)
consGapFL prim wX wY
forall {wX} {wY}. prim wX wY
replacePatch ((forall wX. FL prim wX wX) -> FreeLeft (FL prim)
forall (p :: * -> * -> *). (forall wX. p wX wX) -> FreeLeft p
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap FL prim wX wX
forall wX. FL prim wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
where
replacePatch :: prim wX wY
replacePatch = AnchoredPath -> FilePath -> FilePath -> FilePath -> prim wX wY
forall wX wY.
AnchoredPath -> FilePath -> FilePath -> FilePath -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> FilePath -> FilePath -> FilePath -> prim wX wY
tokreplace AnchoredPath
path FilePath
toks FilePath
old FilePath
new
getForceReplace :: (PrimPatch prim, ApplyState prim ~ Tree)
=> AnchoredPath -> String -> String -> String
-> StateT (Tree IO) IO (FreeLeft (FL prim))
getForceReplace :: forall (prim :: * -> * -> *).
(PrimPatch prim, ApplyState prim ~ Tree) =>
AnchoredPath
-> FilePath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL prim))
getForceReplace AnchoredPath
path FilePath
toks FilePath
old FilePath
new = do
Tree IO
tree <- StateT (Tree IO) IO (Tree IO)
forall s (m :: * -> *). MonadState s m => m s
get
Tree IO
expandedTree <- IO (Tree IO) -> StateT (Tree IO) IO (Tree IO)
forall a. IO a -> StateT (Tree IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree IO) -> StateT (Tree IO) IO (Tree IO))
-> IO (Tree IO) -> StateT (Tree IO) IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ Tree IO -> AnchoredPath -> IO (Tree IO)
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> m (Tree m)
expandPath Tree IO
tree AnchoredPath
path
ByteString
content <- case Tree IO -> AnchoredPath -> Maybe (Blob IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Blob m)
findFile Tree IO
expandedTree AnchoredPath
path of
Just Blob IO
blob -> IO ByteString -> StateT (Tree IO) IO ByteString
forall a. IO a -> StateT (Tree IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> StateT (Tree IO) IO ByteString)
-> IO ByteString -> StateT (Tree IO) IO ByteString
forall a b. (a -> b) -> a -> b
$ Blob IO -> IO ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob IO
blob
Maybe (Blob IO)
Nothing -> FilePath -> StateT (Tree IO) IO ByteString
forall a. HasCallStack => FilePath -> a
error (FilePath -> StateT (Tree IO) IO ByteString)
-> FilePath -> StateT (Tree IO) IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"getForceReplace: not in tree: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
forall a. Show a => a -> FilePath
show AnchoredPath
path
let newcontent :: ByteString
newcontent = FilePath -> ByteString -> ByteString -> ByteString -> ByteString
forceTokReplace FilePath
toks (FilePath -> ByteString
BC.pack FilePath
new) (FilePath -> ByteString
BC.pack FilePath
old)
([ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.toChunks ByteString
content)
tree' :: Tree IO
tree' = Tree IO -> AnchoredPath -> Maybe (TreeItem IO) -> Tree IO
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree Tree IO
expandedTree AnchoredPath
path (Maybe (TreeItem IO) -> Tree IO)
-> (Blob IO -> Maybe (TreeItem IO)) -> Blob IO -> Tree IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeItem IO -> Maybe (TreeItem IO)
forall a. a -> Maybe a
Just (TreeItem IO -> Maybe (TreeItem IO))
-> (Blob IO -> TreeItem IO) -> Blob IO -> Maybe (TreeItem IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blob IO -> TreeItem IO
forall (m :: * -> *). Blob m -> TreeItem m
File (Blob IO -> Tree IO) -> Blob IO -> Tree IO
forall a b. (a -> b) -> a -> b
$ ByteString -> Blob IO
forall (m :: * -> *). Monad m => ByteString -> Blob m
makeBlobBS ByteString
newcontent
FilePath -> FileType
ftf <- IO (FilePath -> FileType)
-> StateT (Tree IO) IO (FilePath -> FileType)
forall a. IO a -> StateT (Tree IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FilePath -> FileType)
-> StateT (Tree IO) IO (FilePath -> FileType))
-> IO (FilePath -> FileType)
-> StateT (Tree IO) IO (FilePath -> FileType)
forall a b. (a -> b) -> a -> b
$ IO (FilePath -> FileType)
filetypeFunction
FreeLeft (FL prim)
normaliseNewTokPatch <- IO (FreeLeft (FL prim)) -> StateT (Tree IO) IO (FreeLeft (FL prim))
forall a. IO a -> StateT (Tree IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (FreeLeft (FL prim))
-> StateT (Tree IO) IO (FreeLeft (FL prim)))
-> IO (FreeLeft (FL prim))
-> StateT (Tree IO) IO (FreeLeft (FL prim))
forall a b. (a -> b) -> a -> b
$ DiffAlgorithm
-> (FilePath -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL prim))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
(prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> (FilePath -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
diffalg FilePath -> FileType
ftf Tree IO
expandedTree Tree IO
tree'
FreeLeft (FL prim)
patches <- FreeLeft (FL prim) -> StateT (Tree IO) IO (FreeLeft (FL prim))
forall a. a -> StateT (Tree IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeLeft (FL prim) -> StateT (Tree IO) IO (FreeLeft (FL prim)))
-> FreeLeft (FL prim) -> StateT (Tree IO) IO (FreeLeft (FL prim))
forall a b. (a -> b) -> a -> b
$ (forall wX wY wZ. FL prim wX wY -> FL prim wY wZ -> FL prim wX wZ)
-> FreeLeft (FL prim) -> FreeLeft (FL prim) -> FreeLeft (FL prim)
forall (p :: * -> * -> *) (q :: * -> * -> *) (r :: * -> * -> *).
(forall wX wY wZ. p wX wY -> q wY wZ -> r wX wZ)
-> FreeLeft p -> FreeLeft q -> FreeLeft r
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *)
(q :: * -> * -> *) (r :: * -> * -> *).
Gap w =>
(forall wX wY wZ. p wX wY -> q wY wZ -> r wX wZ)
-> w p -> w q -> w r
joinGap FL prim wX wY -> FL prim wY wZ -> FL prim wX wZ
forall wX wY wZ. FL prim wX wY -> FL prim wY wZ -> FL prim wX wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
(+>+) FreeLeft (FL prim)
normaliseNewTokPatch (FreeLeft (FL prim) -> FreeLeft (FL prim))
-> FreeLeft (FL prim) -> FreeLeft (FL prim)
forall a b. (a -> b) -> a -> b
$ (forall wX wY. FL prim wX wY) -> FreeLeft (FL prim)
forall (p :: * -> * -> *). (forall wX wY. p wX wY) -> FreeLeft p
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap ((forall wX wY. FL prim wX wY) -> FreeLeft (FL prim))
-> (forall wX wY. FL prim wX wY) -> FreeLeft (FL prim)
forall a b. (a -> b) -> a -> b
$
AnchoredPath -> FilePath -> FilePath -> FilePath -> prim wX wY
forall wX wY.
AnchoredPath -> FilePath -> FilePath -> FilePath -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> FilePath -> FilePath -> FilePath -> prim wX wY
tokreplace AnchoredPath
path FilePath
toks FilePath
old FilePath
new prim wX wY -> FL prim wY wY -> FL prim wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
Maybe (Tree IO)
mtree'' <- case FreeLeft (FL prim) -> Sealed (FL prim Any)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft FreeLeft (FL prim)
patches of
Sealed FL prim Any wX
ps -> IO (Maybe (Tree IO)) -> StateT (Tree IO) IO (Maybe (Tree IO))
forall a. IO a -> StateT (Tree IO) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Tree IO)) -> StateT (Tree IO) IO (Maybe (Tree IO)))
-> IO (Maybe (Tree IO)) -> StateT (Tree IO) IO (Maybe (Tree IO))
forall a b. (a -> b) -> a -> b
$ FL prim Any wX -> Tree IO -> IO (Maybe (Tree IO))
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyState p ~ Tree, MonadCatch m) =>
p wX wY -> Tree m -> m (Maybe (Tree m))
maybeApplyToTree FL prim Any wX
ps Tree IO
tree
case Maybe (Tree IO)
mtree'' of
Maybe (Tree IO)
Nothing -> FilePath -> StateT (Tree IO) IO (FreeLeft (FL prim))
forall a. HasCallStack => FilePath -> a
error FilePath
"getForceReplace: unable to apply detected force replaces"
Just Tree IO
tree'' -> do
Tree IO -> StateT (Tree IO) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Tree IO
tree''
FreeLeft (FL prim) -> StateT (Tree IO) IO (FreeLeft (FL prim))
forall a. a -> StateT (Tree IO) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FreeLeft (FL prim)
patches
unsafeAddToPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository 'RW p wU wR
-> FreeLeft (FL (PrimOf p)) -> IO ()
unsafeAddToPending :: forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> FreeLeft (FL (PrimOf p)) -> IO ()
unsafeAddToPending Repository 'RW p wU wR
repo FreeLeft (FL (PrimOf p))
newP = do
(Tree IO
_, Sealed FL (PrimOf p) wR wX
toPend) <- Repository 'RW p wU wR -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
readPending Repository 'RW p wU wR
repo
case FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wX)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft FreeLeft (FL (PrimOf p))
newP of
(Sealed FL (PrimOf p) wX wX
p) -> do
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 ()
Pending.writeTentativePending Repository 'RW p wU wR
repo (FL (PrimOf p) wR wX
toPend FL (PrimOf p) wR wX -> FL (PrimOf p) wX wX -> FL (PrimOf p) wR wX
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wX wX
p)
addToPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository 'RW p wU wR
-> DiffOpts
-> FL (PrimOf p) wU wY -> IO ()
addToPending :: forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DiffOpts -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository 'RW p wU wR
repo DiffOpts
dopts FL (PrimOf p) wU wY
p = do
(FL (PrimOf p) wR wZ
toPend :> FL (PrimOf p) wZ wU
toUnrec) <-
DiffOpts
-> Repository 'RW p wU wR
-> Maybe [AnchoredPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
readPendingAndWorking DiffOpts
dopts Repository 'RW p wU wR
repo Maybe [AnchoredPath]
forall a. Maybe a
Nothing
case CommuteFn (PrimOf p) (FL (PrimOf p))
-> (:>) (RL (PrimOf p)) (FL (PrimOf p)) wZ wY
-> (:>) (RL (PrimOf p)) (FL (PrimOf p) :> RL (PrimOf p)) wZ wY
forall (p :: * -> * -> *) (q :: * -> * -> *) wX wY.
Commute p =>
CommuteFn p q
-> (:>) (RL p) q wX wY -> (:>) (RL p) (q :> RL p) wX wY
genCommuteWhatWeCanRL (:>) (PrimOf p) (FL (PrimOf p)) wX wY
-> Maybe ((:>) (FL (PrimOf p)) (PrimOf p) wX wY)
CommuteFn (PrimOf p) (FL (PrimOf p))
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (FL (PrimOf p) wZ wU -> RL (PrimOf p) wZ wU
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PrimOf p) wZ wU
toUnrec RL (PrimOf p) wZ wU
-> FL (PrimOf p) wU wY
-> (:>) (RL (PrimOf p)) (FL (PrimOf p)) wZ wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimOf p) wU wY
p) of
(RL (PrimOf p) wZ wZ
toP' :> FL (PrimOf p) wZ wZ
p' :> RL (PrimOf p) wZ wY
_excessUnrec) -> do
Repository 'RW p wU wR -> FL (PrimOf p) wR wZ -> IO ()
forall (p :: * -> * -> *) wU wR wP.
RepoPatch p =>
Repository 'RW p wU wR -> FL (PrimOf p) wR wP -> IO ()
Pending.writeTentativePending Repository 'RW p wU wR
repo (FL (PrimOf p) wR wZ
toPend FL (PrimOf p) wR wZ -> FL (PrimOf p) wZ wZ -> FL (PrimOf p) wR wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ RL (PrimOf p) wZ wZ -> FL (PrimOf p) wZ wZ
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PrimOf p) wZ wZ
toP' FL (PrimOf p) wZ wZ -> FL (PrimOf p) wZ wZ -> FL (PrimOf p) wZ wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wZ wZ
p')
readPlainTree :: Repository rt p wU wR -> IO (Tree IO)
readPlainTree :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPlainTree Repository rt p wU wR
repo = FilePath -> IO (Tree IO)
PlainTree.readPlainTree (Repository rt p wU wR -> FilePath
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> FilePath
repoLocation Repository rt p wU wR
repo)