{-# LANGUAGE CPP #-}
module Darcs.Repository.State
( restrictSubpaths, restrictBoring, TreeFilter(..), restrictDarcsdir
, unrecordedChanges
, readRecorded, readUnrecorded, readRecordedAndPending, readWorking
, readPendingAndWorking, readUnrecordedFiltered
, readIndex, updateIndex, invalidateIndex, UseIndex(..), ScanKnown(..)
, filterOutConflicts
, addPendingDiffToPending, 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, doesDirectoryExist, renameFile )
import System.FilePath ( (<.>), (</>) )
import System.IO ( hPutStrLn, stderr )
import System.IO.Error ( catchIOError )
import qualified Data.ByteString as B
( ByteString, readFile, writeFile, empty, concat )
import qualified Data.ByteString.Char8 as BC
( pack, unpack )
import qualified Data.ByteString.Lazy as BL ( toChunks )
import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL
, PrimPatch, maybeApplyToTree
, tokreplace, forceTokReplace, move )
import Darcs.Patch.Named ( anonymous )
import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnPaths )
import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+)
, (:>)(..), reverseRL, reverseFL
, mapFL, concatFL, toFL, 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 ( UseIndex(..), ScanKnown(..), DiffAlgorithm(..)
, UpdatePending(..), LookForMoves(..), LookForReplaces(..) )
import Darcs.Repository.InternalTypes ( 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.Diff ( treeDiff )
import Darcs.Repository.Inventory ( peekPristineHash, getValidHash )
import Darcs.Repository.Paths
( pristineDirPath
, hashedInventoryPath
, oldPristineDirPath
, oldCurrentDirPath
, patchesDirPath
, 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.Hash( Hash( NoHash ) )
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.Tree.Hashed
( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize )
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 )
#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 wR wU wT -> [AnchoredPath]
-> IO (TreeFilter m)
restrictSubpaths :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT (m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> [AnchoredPath] -> IO (TreeFilter m)
restrictSubpaths Repository rt p wR wU wT
repo [AnchoredPath]
paths = do
Sealed FL (PrimOf p) wR wX
pending <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wR))
Pending.readPending Repository rt p wR wU wT
repo
forall (p :: * -> * -> *) wR wP (rt :: RepoType) wU wT
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wR wP
-> Repository rt p wR wU wT -> [AnchoredPath] -> IO (TreeFilter m)
restrictSubpathsAfter FL (PrimOf p) wR wX
pending Repository rt p wR wU wT
repo [AnchoredPath]
paths
restrictSubpathsAfter :: (RepoPatch p, ApplyState p ~ Tree)
=> FL (PrimOf p) wR wP
-> Repository rt p wR wU wT
-> [AnchoredPath]
-> IO (TreeFilter m)
restrictSubpathsAfter :: forall (p :: * -> * -> *) wR wP (rt :: RepoType) wU wT
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wR wP
-> Repository rt p wR wU wT -> [AnchoredPath] -> IO (TreeFilter m)
restrictSubpathsAfter FL (PrimOf p) wR wP
pending Repository rt p wR wU wT
_repo [AnchoredPath]
paths = do
let paths' :: [AnchoredPath]
paths' = [AnchoredPath]
paths forall a. Eq a => [a] -> [a] -> [a]
`union` 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 = forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
Tree.filter (forall t. [AnchoredPath] -> AnchoredPath -> t -> Bool
filterPaths [AnchoredPath]
paths')
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter 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 wR wU wT
-> Maybe [AnchoredPath]
-> IO (TreeFilter m)
maybeRestrictSubpaths :: forall (p :: * -> * -> *) wR wP (rt :: RepoType) wU wT
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wR wP
-> Repository rt p wR wU wT
-> Maybe [AnchoredPath]
-> IO (TreeFilter m)
maybeRestrictSubpaths FL (PrimOf p) wR wP
pending Repository rt p wR wU wT
repo =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter forall a. a -> a
id) (forall (p :: * -> * -> *) wR wP (rt :: RepoType) wU wT
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wR wP
-> Repository rt p wR wU wT -> [AnchoredPath] -> IO (TreeFilter m)
restrictSubpathsAfter FL (PrimOf p) wR wP
pending Repository rt p wR wU wT
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 -> Bool
exclude AnchoredPath
p = AnchoredPath -> Bool
inDarcsdir AnchoredPath
p Bool -> Bool -> Bool
|| FilePath -> Bool
boring (AnchoredPath -> FilePath
realPath AnchoredPath
p)
restrictTree :: FilterTree t m => t m -> t m
restrictTree :: forall (tree :: (* -> *) -> *) (m :: * -> *).
FilterTree tree m =>
tree m -> tree m
restrictTree =
forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
Tree.filter forall a b. (a -> b) -> a -> b
$ \AnchoredPath
p TreeItem m
_ ->
case forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
guide AnchoredPath
p of
Maybe (TreeItem m)
Nothing -> Bool -> Bool
not (AnchoredPath -> Bool
exclude AnchoredPath
p)
Maybe (TreeItem m)
_ -> Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter forall (tree :: (* -> *) -> *) (m :: * -> *).
FilterTree tree m =>
tree m -> tree m
restrictTree)
restrictDarcsdir :: TreeFilter m
restrictDarcsdir :: forall (m :: * -> *). TreeFilter m
restrictDarcsdir = forall (m :: * -> *).
(forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m)
-> TreeFilter m
TreeFilter forall a b. (a -> b) -> a -> b
$ forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
Tree.filter 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)
=> (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath] -> IO (FL (PrimOf p) wR wU)
unrecordedChanges :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges (UseIndex, ScanKnown, DiffAlgorithm)
dopts LookForMoves
lfm LookForReplaces
lfr Repository rt p wR wU wR
r Maybe [AnchoredPath]
paths = do
(FL (PrimOf p) wR wZ
pending :> FL (PrimOf p) wZ wU
working) <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
readPendingAndWorking (UseIndex, ScanKnown, DiffAlgorithm)
dopts LookForMoves
lfm LookForReplaces
lfr Repository rt p wR wU wR
r Maybe [AnchoredPath]
paths
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
FL prim wX wY -> FL prim wX wY
sortCoalesceFL (FL (PrimOf p) wR wZ
pending 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)
=> (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO ((FL (PrimOf p) :> FL (PrimOf p)) wR wU)
readPendingAndWorking :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
readPendingAndWorking (UseIndex, ScanKnown, DiffAlgorithm)
_ LookForMoves
_ LookForReplaces
_ Repository rt p wR wU wR
r Maybe [AnchoredPath]
_ | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
NoWorkingDir (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wR
r) = do
EqCheck wU wR
IsEq <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> EqCheck wU wT
workDirLessRepoWitness Repository rt p wR wU wR
r
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (a :: * -> * -> *) wX. FL a wX wX
NilFL forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
readPendingAndWorking (UseIndex
useidx, ScanKnown
scan, DiffAlgorithm
diffalg) LookForMoves
lfm LookForReplaces
lfr Repository rt p wR 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)) <-
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO
(Tree IO, Tree IO, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
readPendingAndMovesAndUnrecorded Repository rt p wR wU wR
repo UseIndex
useidx ScanKnown
scan LookForMoves
lfm Maybe [AnchoredPath]
mbpaths
FilePath -> IO ()
debugMessage FilePath
"readPendingAndWorking: after readPendingAndMovesAndUnrecorded"
(Tree IO
pending_tree_with_replaces, Sealed FL (PrimOf p) wU wX
replaces) <-
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
LookForReplaces
-> DiffAlgorithm
-> Repository rt p wR wU wT
-> Tree IO
-> Tree IO
-> IO (Tree IO, Sealed (FL (PrimOf p) wU))
getReplaces LookForReplaces
lfr DiffAlgorithm
diffalg Repository rt p wR 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 <- 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 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"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX wY1 wY2. a wX wY1 -> a wX wY2
unsafeCoercePEnd forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wR wZ
pending forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> (FL (PrimOf p) wZ wU
moves forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wU wX
replaces 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 wR wU wR
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO ( Tree IO
, Tree IO
, (FL (PrimOf p) :> FL (PrimOf p)) wR wU
)
readPendingAndMovesAndUnrecorded :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO
(Tree IO, Tree IO, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
readPendingAndMovesAndUnrecorded Repository rt p wR wU wR
repo UseIndex
useidx ScanKnown
scan LookForMoves
lfm Maybe [AnchoredPath]
mbpaths = do
FilePath -> IO ()
debugMessage FilePath
"readPendingAndMovesAndUnrecorded: start"
(Tree IO
pending_tree, Sealed FL (PrimOf p) wR wX
pending) <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
readPending Repository rt p wR wU wR
repo
FL (PrimOf p) wX wX
moves <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wB
(prim :: * -> * -> *).
(RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p) =>
LookForMoves
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO (FL prim wB wB)
getMoves LookForMoves
lfm Repository rt p wR wU wR
repo Maybe [AnchoredPath]
mbpaths
TreeFilter IO
relevant <- forall (p :: * -> * -> *) wR wP (rt :: RepoType) wU wT
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wR wP
-> Repository rt p wR wU wT
-> Maybe [AnchoredPath]
-> IO (TreeFilter m)
maybeRestrictSubpaths (FL (PrimOf p) wR wX
pending 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 wR wU wR
repo Maybe [AnchoredPath]
mbpaths
Tree IO
pending_tree_with_moves <-
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
relevant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, Monad 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 <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wR
-> UseIndex -> TreeFilter IO -> Tree IO -> IO (Tree IO)
readIndexOrPlainTree Repository rt p wR 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 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 <-
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
Repository rt p wR wU wR
-> UseIndex
-> ScanKnown
-> TreeFilter IO
-> Tree IO
-> Tree IO
-> IO (Tree IO)
filteredWorking Repository rt p wR wU wR
repo UseIndex
useidx' ScanKnown
scan TreeFilter IO
relevant Tree IO
index Tree IO
pending_tree_with_moves
FilePath -> IO ()
debugMessage FilePath
"readPendingAndMovesAndUnrecorded: done"
forall (m :: * -> *) a. Monad m => a -> m a
return
(Tree IO
pending_tree_with_moves, Tree IO
working_tree, forall (a :: * -> * -> *) wX wY1 wY2. a wX wY1 -> a wX wY2
unsafeCoercePEnd (FL (PrimOf p) wR wX
pending 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 wR wU wR
-> UseIndex
-> ScanKnown
-> TreeFilter IO
-> Tree IO
-> Tree IO
-> IO (Tree IO)
filteredWorking :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
Repository rt p wR wU wR
-> UseIndex
-> ScanKnown
-> TreeFilter IO
-> Tree IO
-> Tree IO
-> IO (Tree IO)
filteredWorking Repository rt p wR wU wR
repo UseIndex
useidx ScanKnown
scan TreeFilter IO
relevant Tree IO
index Tree IO
pending_tree =
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter forall (m :: * -> *). TreeFilter m
restrictDarcsdir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
relevant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
case UseIndex
useidx of
UseIndex
UseIndex ->
case ScanKnown
scan of
ScanKnown
ScanKnown -> forall (m :: * -> *) a. Monad m => a -> m a
return Tree IO
index
ScanKnown
ScanAll -> do
TreeFilter IO
nonboring <- forall (m :: * -> *). Tree m -> IO (TreeFilter m)
restrictBoring Tree IO
index
Tree IO
plain <- forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
nonboring forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readPlainTree Repository rt p wR wU wR
repo
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Tree IO
plain forall (m :: * -> *). Monad m => Tree m -> Tree m -> Tree m
`overlay` Tree IO
index
ScanKnown
ScanBoring -> do
Tree IO
plain <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readPlainTree Repository rt p wR wU wR
repo
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Tree IO
plain forall (m :: * -> *). Monad m => Tree m -> Tree m -> Tree m
`overlay` Tree IO
index
UseIndex
IgnoreIndex ->
case ScanKnown
scan of
ScanKnown
ScanKnown -> do
Tree IO
guide <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree IO
pending_tree
forall (t :: (* -> *) -> *) (m :: * -> *) (n :: * -> *).
FilterTree t m =>
Tree n -> t m -> t m
restrict Tree IO
guide forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readPlainTree Repository rt p wR wU wR
repo
ScanKnown
ScanAll -> do
Tree IO
guide <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree IO
pending_tree
TreeFilter IO
nonboring <- forall (m :: * -> *). Tree m -> IO (TreeFilter m)
restrictBoring Tree IO
guide
forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
nonboring forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readPlainTree Repository rt p wR wU wR
repo
ScanKnown
ScanBoring -> forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readPlainTree Repository rt p wR wU wR
repo
workDirLessRepoWitness :: Repository rt p wR wU wT -> EqCheck wU wT
workDirLessRepoWitness :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> EqCheck wU wT
workDirLessRepoWitness Repository rt p wR wU wT
r
| RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
NoWorkingDir (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wT
r) = forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP forall wA. EqCheck wA wA
IsEq
| Bool
otherwise = forall wA wB. EqCheck wA wB
NotEq
readRecorded :: Repository rt p wR wU wT -> IO (Tree IO)
readRecorded :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wT
_repo = do
Bool
hashed <- FilePath -> IO Bool
doesFileExist FilePath
hashedInventoryPath
if Bool
hashed
then do ByteString
inv <- FilePath -> IO ByteString
B.readFile FilePath
hashedInventoryPath
let pris :: PristineHash
pris = ByteString -> PristineHash
peekPristineHash ByteString
inv
hash :: Hash
hash = ByteString -> Hash
decodeDarcsHash forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
BC.pack forall a b. (a -> b) -> a -> b
$ forall a. ValidHash a => a -> FilePath
getValidHash PristineHash
pris
size :: Maybe Int
size = ByteString -> Maybe Int
decodeDarcsSize forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
BC.pack forall a b. (a -> b) -> a -> b
$ forall a. ValidHash a => a -> FilePath
getValidHash PristineHash
pris
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Hash
hash forall a. Eq a => a -> a -> Bool
== Hash
NoHash) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
"Bad pristine root: " forall a. [a] -> [a] -> [a]
++ forall a. ValidHash a => a -> FilePath
getValidHash PristineHash
pris
FilePath -> (Maybe Int, Hash) -> IO (Tree IO)
readDarcsHashed FilePath
pristineDirPath (Maybe Int
size, Hash
hash)
else do Bool
have_pristine <- FilePath -> IO Bool
doesDirectoryExist forall a b. (a -> b) -> a -> b
$ FilePath
oldPristineDirPath
Bool
have_current <- FilePath -> IO Bool
doesDirectoryExist forall a b. (a -> b) -> a -> b
$ FilePath
oldCurrentDirPath
case (Bool
have_pristine, Bool
have_current) of
(Bool
True, Bool
_) -> FilePath -> IO (Tree IO)
PlainTree.readPlainTree forall a b. (a -> b) -> a -> b
$ FilePath
oldPristineDirPath
(Bool
False, Bool
True) -> FilePath -> IO (Tree IO)
PlainTree.readPlainTree forall a b. (a -> b) -> a -> b
$ FilePath
oldCurrentDirPath
(Bool
_, Bool
_) -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"No pristine tree is available!"
readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR
-> UseIndex
-> Maybe [AnchoredPath]
-> IO (Tree IO)
readUnrecorded :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
readUnrecorded Repository rt p wR wU wR
repo UseIndex
useidx Maybe [AnchoredPath]
mbpaths = do
#if TEST_INDEX
t1 <- expand =<< readUnrecordedFiltered repo useidx ScanKnown 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
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
readUnrecordedFiltered Repository rt p wR wU wR
repo UseIndex
useidx ScanKnown
ScanKnown 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 wR 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 :: RepoType) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wR
-> UseIndex -> TreeFilter IO -> Tree IO -> IO (Tree IO)
readIndexOrPlainTree Repository rt p wR wU wR
repo UseIndex
UseIndex TreeFilter IO
treeFilter Tree IO
pending_tree =
(Index -> IO (Tree IO)
treeFromIndex forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
treeFilter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO Index
readIndex Repository rt p wR wU wR
repo)
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" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show IOError
e)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wR
-> UseIndex -> TreeFilter IO -> Tree IO -> IO (Tree IO)
readIndexOrPlainTree Repository rt p wR wU wR
repo UseIndex
IgnoreIndex TreeFilter IO
treeFilter Tree IO
pending_tree
readIndexOrPlainTree Repository rt p wR wU wR
repo UseIndex
IgnoreIndex TreeFilter IO
treeFilter Tree IO
pending_tree = do
Tree IO
guide <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree IO
pending_tree
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
treeFilter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> *) (m :: * -> *) (n :: * -> *).
FilterTree t m =>
Tree n -> t m -> t m
restrict Tree IO
guide forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readPlainTree Repository rt p wR wU wR
repo
#endif
readUnrecordedFiltered :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [AnchoredPath] -> IO (Tree IO)
readUnrecordedFiltered :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO (Tree IO)
readUnrecordedFiltered Repository rt p wR wU wR
repo UseIndex
useidx ScanKnown
scan LookForMoves
lfm Maybe [AnchoredPath]
mbpaths = do
(Tree IO
_, Tree IO
working_tree, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU
_) <-
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [AnchoredPath]
-> IO
(Tree IO, Tree IO, (:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
readPendingAndMovesAndUnrecorded Repository rt p wR wU wR
repo UseIndex
useidx ScanKnown
scan LookForMoves
lfm Maybe [AnchoredPath]
mbpaths
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 =
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
relevant forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter forall (m :: * -> *). TreeFilter m
restrictDarcsdir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
FilePath -> IO (Tree IO)
PlainTree.readPlainTree FilePath
".")
readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR -> IO (Tree IO)
readRecordedAndPending :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (Tree IO)
readRecordedAndPending Repository rt p wR wU wR
repo = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
readPending Repository rt p wR wU wR
repo
readPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR
-> IO (Tree IO, Sealed (FL (PrimOf p) wR))
readPending :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
readPending Repository rt p wR wU wR
repo = do
Tree IO
pristine <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wR
repo
Sealed FL (PrimOf p) wR wX
pending <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wR))
Pending.readPending Repository rt p wR wU wR
repo
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((\Tree IO
t -> (Tree IO
t, forall (a :: * -> *) wX. a wX -> Sealed a
seal FL (PrimOf p) wR wX
pending)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, Monad m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree FL (PrimOf p) wR wX
pending Tree IO
pristine) forall a b. (a -> b) -> a -> b
$
\(IOError
err :: IOException) -> do
FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"Yikes, pending has conflicts! " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show IOError
err
FilePath -> IO ()
putStrLn FilePath
"Stashing the buggy pending as _darcs/patches/pending_buggy"
FilePath -> FilePath -> IO ()
renameFile (FilePath
patchesDirPath FilePath -> FilePath -> FilePath
</> FilePath
"pending")
(FilePath
patchesDirPath FilePath -> FilePath -> FilePath
</> FilePath
"pending_buggy")
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
pristine, forall (a :: * -> *) wX. a wX -> Sealed a
seal forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
invalidateIndex :: t -> IO ()
invalidateIndex :: forall t. t -> IO ()
invalidateIndex t
_ = FilePath -> ByteString -> IO ()
B.writeFile FilePath
indexInvalidPath ByteString
B.empty
readIndex :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR -> IO Index
readIndex :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO Index
readIndex Repository rt p wR wU wR
repo = do
Bool
okay <- IO Bool
checkIndex
if Bool -> Bool
not Bool
okay
then forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO Index
internalUpdateIndex Repository rt p wR wU wR
repo
else FilePath -> (Tree IO -> Hash) -> IO Index
openIndex FilePath
indexPath forall (m :: * -> *). Tree m -> Hash
darcsTreeHash
internalUpdateIndex :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR -> IO Index
internalUpdateIndex :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO Index
internalUpdateIndex Repository rt p wR wU wR
repo = do
Tree IO
pris <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (Tree IO)
readRecordedAndPending Repository rt p wR wU wR
repo
Index
idx <- FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index
updateIndexFrom FilePath
indexPath forall (m :: * -> *). Tree m -> Hash
darcsTreeHash Tree IO
pris
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist FilePath
indexInvalidPath
forall (m :: * -> *) a. Monad m => a -> m a
return Index
idx
updateIndex :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR -> IO ()
updateIndex :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ()
updateIndex Repository rt p wR wU wR
repo = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Bool
checkIndex
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO Index
internalUpdateIndex Repository rt p wR wU wR
repo
checkIndex :: IO Bool
checkIndex :: IO Bool
checkIndex = do
Bool
invalid <- FilePath -> IO Bool
doesFileExist 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exist Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
formatValid) forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
renameFile FilePath
indexPath (FilePath
indexPath FilePath -> FilePath -> FilePath
<.> FilePath
"old")
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 wR wU wR
-> FL (PatchInfoAnd rt p) wX wR
-> FL (PatchInfoAnd rt p) wX wZ
-> IO (Bool, Sealed (FL (PatchInfoAnd rt p) wX))
filterOutConflicts :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU wX wZ.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> FL (PatchInfoAnd rt p) wX wR
-> FL (PatchInfoAnd rt p) wX wZ
-> IO (Bool, Sealed (FL (PatchInfoAnd rt p) wX))
filterOutConflicts Repository rt p wR wU wR
repository FL (PatchInfoAnd rt p) wX wR
us FL (PatchInfoAnd rt p) wX wZ
them
= do
PatchInfoAndG rt (Named p) wR wU
unrec <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (p :: * -> * -> *) wX wY (rt :: RepoType).
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG rt p wX wY
n2pia forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) wX wY.
FromPrim p =>
FL (PrimOf p) wX wY -> IO (Named p wX wY)
anonymous
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges (UseIndex
UseIndex, ScanKnown
ScanKnown, DiffAlgorithm
MyersDiff)
LookForMoves
NoLookForMoves LookForReplaces
NoLookForReplaces Repository rt p wR wU wR
repository forall a. Maybe a
Nothing
FL (PatchInfoAnd rt p) wX wZ
them' :> FL (PatchInfoAnd rt p) wZ wZ
rest <-
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 rt p) wX wZ
them (FL (PatchInfoAnd rt p) wX wR
us forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ PatchInfoAndG rt (Named p) wR wU
unrec 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 (m :: * -> *) a. Monad m => a -> m a
return (forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
check FL (PatchInfoAnd rt p) wZ wZ
rest, forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PatchInfoAnd rt 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 wR wU wB prim.
(RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p)
=> LookForMoves
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO (FL prim wB wB)
getMoves :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wB
(prim :: * -> * -> *).
(RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p) =>
LookForMoves
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO (FL prim wB wB)
getMoves LookForMoves
NoLookForMoves Repository rt p wR wU wR
_ Maybe [AnchoredPath]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
getMoves LookForMoves
YesLookForMoves Repository rt p wR wU wR
repository Maybe [AnchoredPath]
files =
forall {a :: * -> * -> *} {c} {wY}.
PrimConstruct a =>
[(AnchoredPath, AnchoredPath, c)] -> FL a wY wY
mkMovesFL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO [(AnchoredPath, AnchoredPath, ItemType)]
getMovedFiles Repository rt p wR wU wR
repository Maybe [AnchoredPath]
files
where
mkMovesFL :: [(AnchoredPath, AnchoredPath, c)] -> FL a wY wY
mkMovesFL [] = forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
mkMovesFL ((AnchoredPath
a,AnchoredPath
b,c
_):[(AnchoredPath, AnchoredPath, c)]
xs) = forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> AnchoredPath -> prim wX wY
move AnchoredPath
a AnchoredPath
b 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 wR wU wR
-> Maybe [AnchoredPath]
-> IO [(AnchoredPath, AnchoredPath, ItemType)]
getMovedFiles :: Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO [(AnchoredPath, AnchoredPath, ItemType)]
getMovedFiles Repository rt p wR wU wR
repo Maybe [AnchoredPath]
fs = do
[((AnchoredPath, ItemType), FileID)]
old <- forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Index -> IO [((AnchoredPath, ItemType), FileID)]
listFileIDs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO Index
readIndex Repository rt p wR wU wR
repo)
TreeFilter IO
nonboring <- forall (m :: * -> *). Tree m -> IO (TreeFilter m)
restrictBoring forall (m :: * -> *). Tree m
emptyTree
let addIDs :: [(AnchoredPath, b)] -> IO [((AnchoredPath, b), FileID)]
addIDs = 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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)forall a. a -> [a] -> [a]
:[((AnchoredPath, b), FileID)]
xs) []
[((AnchoredPath, ItemType), FileID)]
new <- forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(forall {b}. [(AnchoredPath, b)] -> IO [((AnchoredPath, b), FileID)]
addIDs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(AnchoredPath
a,TreeItem IO
b) -> (AnchoredPath
a, forall (m :: * -> *). TreeItem m -> ItemType
itemType TreeItem IO
b)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
Tree.list forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
TreeFilter m
-> forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
applyTreeFilter TreeFilter IO
nonboring forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readPlainTree Repository rt p wR 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)
| forall a b. (a, b) -> b
snd ((a, c), b)
x forall a. Ord a => a -> a -> Bool
> forall a b. (a, b) -> b
snd ((b, c), b)
y = [((a, c), b)] -> [((b, c), b)] -> [(a, b, c)]
match (((a, c), b)
xforall a. a -> [a] -> [a]
:[((a, c), b)]
xs) [((b, c), b)]
ys
| forall a b. (a, b) -> b
snd ((a, c), b)
x forall a. Ord a => a -> a -> Bool
< 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)
yforall a. a -> [a] -> [a]
:[((b, c), b)]
ys)
| forall a b. (a, b) -> b
snd (forall a b. (a, b) -> a
fst ((a, c), b)
x) forall a. Eq a => a -> a -> Bool
/= forall a b. (a, b) -> b
snd (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 = (forall a b. (a, b) -> a
fst (forall a b. (a, b) -> a
fst ((a, c), b)
x), forall a b. (a, b) -> a
fst (forall a b. (a, b) -> a
fst ((b, c), b)
y), forall a b. (a, b) -> b
snd (forall a b. (a, b) -> a
fst ((a, c), b)
x))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 = 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 ->
forall a. (a -> Bool) -> [a] -> [a]
filter (\(AnchoredPath
f1, AnchoredPath
f2, ItemType
_) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (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
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 forall a b. (a -> b) -> a -> b
$ forall {c}.
Eq c =>
[(AnchoredPath, AnchoredPath, c)]
-> [(AnchoredPath, AnchoredPath, c)]
sortMoves forall a b. (a -> b) -> a -> b
$ 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 (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)
xforall 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' forall a. Eq a => a -> a -> Bool
== t
current = t
b' 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 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)]
seenforall 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)
yforall 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)
smallestforall a. a -> [a] -> [a]
:[(AnchoredPath, AnchoredPath, c)]
-> [(AnchoredPath, AnchoredPath, c)]
sortMoves (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 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 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 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)
yforall a. a -> [a] -> [a]
:[(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
fixPaths (forall a b. (a -> b) -> [a] -> [b]
map forall {b} {c}. (AnchoredPath, b, c) -> (AnchoredPath, b, c)
replacepp [(AnchoredPath, AnchoredPath, ItemType)]
ys)
| Bool
otherwise = (AnchoredPath, AnchoredPath, ItemType)
yforall 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 wR wU wT
. (RepoPatch p, ApplyState p ~ Tree)
=> LookForReplaces
-> DiffAlgorithm
-> Repository rt p wR wU wT
-> Tree IO
-> Tree IO
-> IO (Tree IO,
Sealed (FL (PrimOf p) wU))
getReplaces :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
LookForReplaces
-> DiffAlgorithm
-> Repository rt p wR wU wT
-> Tree IO
-> Tree IO
-> IO (Tree IO, Sealed (FL (PrimOf p) wU))
getReplaces LookForReplaces
NoLookForReplaces DiffAlgorithm
_ Repository rt p wR wU wT
_ Tree IO
pending Tree IO
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
pending, forall (a :: * -> *) wX. a wX -> Sealed a
Sealed forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
getReplaces LookForReplaces
YesLookForReplaces DiffAlgorithm
diffalg Repository rt p wR wU wT
_repo Tree IO
pending Tree IO
working = do
FilePath -> FileType
ftf <- IO (FilePath -> FileType)
filetypeFunction
Sealed FL (PrimOf p) Any wX
changes <- forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wX wY.
PrimOf p wX wY -> [(AnchoredPath, ByteString, ByteString)]
modifiedTokens FL (PrimOf p) Any wX
changes
replaces :: [(AnchoredPath, ByteString, ByteString)]
replaces = 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) <-
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Tree IO
pending forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(AnchoredPath, ByteString, ByteString)]
replaces forall a b. (a -> b) -> a -> b
$ \(AnchoredPath
path, ByteString
a, ByteString
b) ->
forall {prim :: * -> * -> *}.
(ApplyState prim ~ Tree, CleanMerge prim, Commute prim,
Invert prim, Eq2 prim, IsHunk prim, PatchInspect prim,
RepairToFL prim, Show2 prim, PrimCanonize prim, PrimClassify 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)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
new_pending, forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX. [FreeLeft a] -> Sealed (FL a wX)
toFL [FreeLeft (FL (PrimOf p))]
patches)
where
modifiedTokens :: PrimOf p wX wY -> [(AnchoredPath, B.ByteString, B.ByteString)]
modifiedTokens :: forall wX wY.
PrimOf p wX wY -> [(AnchoredPath, ByteString, ByteString)]
modifiedTokens PrimOf p wX wY
p = case forall (p :: * -> * -> *) wX wY.
IsHunk p =>
p wX wY -> Maybe (FileHunk wX wY)
isHunk PrimOf p wX wY
p of
Just (FileHunk AnchoredPath
f Int
_ [ByteString]
old [ByteString]
new) ->
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
a,ByteString
b) -> (AnchoredPath
f, ByteString
a, ByteString
b)) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([ByteString], [ByteString]) -> [(ByteString, ByteString)]
checkModified forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter (\([ByteString]
a,[ByteString]
b) -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
a forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
b)
forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [ByteString]
breakToTokens [ByteString]
old) (forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [ByteString]
breakToTokens [ByteString]
new))
Maybe (FileHunk wX wY)
Nothing -> []
checkModified :: ([ByteString], [ByteString]) -> [(ByteString, ByteString)]
checkModified = forall a. (a -> Bool) -> [a] -> [a]
filter (\(ByteString
a,ByteString
b) -> ByteString
aforall a. Eq a => a -> a -> Bool
/=ByteString
b) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry 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)
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(a
f',a
a,c
b) -> a
f' forall a. Eq a => a -> a -> Bool
== a
f Bool -> Bool -> Bool
&& a
old forall a. Eq a => a -> a -> Bool
== a
a Bool -> Bool -> Bool
&& c
b forall a. Eq a => a -> a -> Bool
/= c
new) [(a, a, c)]
rs =
[(a, a, c)] -> [(a, a, c)]
rmInvalidReplaces forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
f'',a
a',c
_) -> a
f'' forall a. Eq a => a -> a -> Bool
/= a
f Bool -> Bool -> Bool
|| a
a' 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)
rforall a. a -> [a] -> [a]
:[(a, a, c)] -> [(a, a, c)]
rmInvalidReplaces (forall a. (a -> Bool) -> [a] -> [a]
filter (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 <- forall s (m :: * -> *). MonadState s m => m s
get
Maybe (Tree IO)
mpend' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> Tree IO -> IO (Maybe (Tree IO))
maybeApplyToTree forall {wX} {wY}. prim wX wY
replacePatch Tree IO
pend
case Maybe (Tree IO)
mpend' of
Maybe (Tree IO)
Nothing -> 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
forall s (m :: * -> *). MonadState s m => s -> m ()
put Tree IO
pend'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
(:>:) (forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap forall {wX} {wY}. prim wX wY
replacePatch) (forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
where
replacePatch :: prim wX wY
replacePatch = 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 <- forall s (m :: * -> *). MonadState s m => m s
get
Tree IO
expandedTree <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> m (Tree m)
expandPath Tree IO
tree AnchoredPath
path
ByteString
content <- case forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Blob m)
findFile Tree IO
expandedTree AnchoredPath
path of
Just Blob IO
blob -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob IO
blob
Maybe (Blob IO)
Nothing -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"getForceReplace: not in tree: " forall a. [a] -> [a] -> [a]
++ 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 forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BL.toChunks ByteString
content)
tree' :: Tree IO
tree' = forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree Tree IO
expandedTree AnchoredPath
path forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Blob m -> TreeItem m
File forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => ByteString -> Blob m
makeBlobBS ByteString
newcontent
FilePath -> FileType
ftf <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO (FilePath -> FileType)
filetypeFunction
FreeLeft (FL prim)
normaliseNewTokPatch <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
(+>+) FreeLeft (FL prim)
normaliseNewTokPatch forall a b. (a -> b) -> a -> b
$ forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap forall a b. (a -> b) -> a -> b
$
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
AnchoredPath -> FilePath -> FilePath -> FilePath -> prim wX wY
tokreplace AnchoredPath
path FilePath
toks FilePath
old FilePath
new forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
Maybe (Tree IO)
mtree'' <- case forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft FreeLeft (FL prim)
patches of
Sealed FL prim Any wX
ps -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> Tree IO -> IO (Maybe (Tree IO))
maybeApplyToTree FL prim Any wX
ps Tree IO
tree
case Maybe (Tree IO)
mtree'' of
Maybe (Tree IO)
Nothing -> forall a. HasCallStack => FilePath -> a
error FilePath
"getForceReplace: unable to apply detected force replaces"
Just Tree IO
tree'' -> do
forall s (m :: * -> *). MonadState s m => s -> m ()
put Tree IO
tree''
forall (m :: * -> *) a. Monad m => a -> m a
return FreeLeft (FL prim)
patches
addPendingDiffToPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR
-> FreeLeft (FL (PrimOf p)) -> IO ()
addPendingDiffToPending :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> FreeLeft (FL (PrimOf p)) -> IO ()
addPendingDiffToPending Repository rt p wR wU wR
repo FreeLeft (FL (PrimOf p))
newP = do
(Tree IO
_, Sealed FL (PrimOf p) wR wX
toPend) <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (Tree IO, Sealed (FL (PrimOf p) wR))
readPending Repository rt p wR wU wR
repo
forall t. t -> IO ()
invalidateIndex Repository rt p wR wU wR
repo
case forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft FreeLeft (FL (PrimOf p))
newP of
(Sealed FL (PrimOf p) wX wX
p) -> do
Tree IO
recordedState <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wR
repo
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 ()
Pending.makeNewPending Repository rt p wR wU wR
repo UpdatePending
YesUpdatePending (FL (PrimOf p) wR wX
toPend forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wX wX
p) Tree IO
recordedState
addToPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR
-> UseIndex -> FL (PrimOf p) wU wY -> IO ()
addToPending :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wU wR
repo UseIndex
useidx FL (PrimOf p) wU wY
p = do
(FL (PrimOf p) wR wZ
toPend :> FL (PrimOf p) wZ wU
toUnrec) <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wR wU)
readPendingAndWorking (UseIndex
useidx, ScanKnown
ScanKnown, DiffAlgorithm
MyersDiff)
LookForMoves
NoLookForMoves LookForReplaces
NoLookForReplaces Repository rt p wR wU wR
repo forall a. Maybe a
Nothing
forall t. t -> IO ()
invalidateIndex Repository rt p wR wU wR
repo
case forall (p :: * -> * -> *) (q :: * -> * -> *) wX wY.
Commute p =>
(forall wA wB. (:>) p q wA wB -> Maybe ((:>) q p wA wB))
-> (:>) (RL p) q wX wY -> (:>) (RL p) (q :> RL p) wX wY
genCommuteWhatWeCanRL forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PrimOf p) wZ wU
toUnrec 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
Tree IO
recordedState <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wR
repo
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 ()
Pending.makeNewPending Repository rt p wR wU wR
repo UpdatePending
YesUpdatePending
(FL (PrimOf p) wR wZ
toPend forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PrimOf p) wZ wZ
toP' forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wZ wZ
p') Tree IO
recordedState
readPlainTree :: Repository rt p wR wU wT -> IO (Tree IO)
readPlainTree :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readPlainTree Repository rt p wR wU wT
repo = FilePath -> IO (Tree IO)
PlainTree.readPlainTree (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> FilePath
repoLocation Repository rt p wR wU wT
repo)