{-# LANGUAGE CPP #-}
module Darcs.Repository.State
( restrictSubpaths, restrictBoring, TreeFilter(..), restrictDarcsdir
, maybeRestrictSubpaths
, unrecordedChanges, readPending
, readRecorded, readUnrecorded, readRecordedAndPending, readWorking
, readPendingAndWorking, readUnrecordedFiltered
, readIndex, updateIndex, invalidateIndex, UseIndex(..), ScanKnown(..)
, filterOutConflicts
, addPendingDiffToPending, addToPending
) where
import Prelude ()
import Darcs.Prelude
import Control.Monad ( when, foldM, forM )
import Control.Monad.State ( StateT, runStateT, get, put, liftIO )
import Control.Exception ( catch, IOException )
import Data.Maybe ( fromJust, isJust )
import Data.Ord ( comparing )
import Data.List ( sortBy, union, delete )
import Text.Regex( matchRegex )
import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile )
import System.FilePath
( (</>)
#if mingw32_HOST_OS
, (<.>)
#endif
)
import qualified Data.ByteString as B
( ByteString, readFile, drop, writeFile, empty, concat )
import qualified Data.ByteString.Char8 as BC
( pack, unpack, split )
import qualified Data.ByteString.Lazy as BL ( toChunks )
import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL, fromPrims
, PrimPatch, maybeApplyToTree
, tokreplace, forceTokReplace, move )
import Darcs.Patch.Named.Wrapped ( anonymous )
import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnFilePaths )
import Darcs.Patch.Witnesses.Ordered ( RL(..), 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 ( selfCommuter, commuteFL )
import Darcs.Patch.CommuteFn ( commuterIdRL )
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(..)
, UpdateWorking(..), LookForMoves(..), LookForReplaces(..) )
import Darcs.Util.Global ( darcsdir )
import Darcs.Repository.InternalTypes ( Repository, repoFormat )
import Darcs.Repository.Format(formatHas, RepoProperty(NoWorkingDir))
import qualified Darcs.Repository.Pending as Pending
import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps )
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Util.Path
( AnchoredPath(..), anchorPath, floatPath, fn2fp
, SubPath, sp2fn, filterPaths, FileName
, parents, replacePrefixPath, anchoredRoot
, toFilePath, simpleSubPath, normPath, floatSubPath, makeName
)
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 Darcs.Util.Tree.Plain( readPlainTree )
import Darcs.Util.Tree.Hashed( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize )
import qualified Darcs.Util.Index as I
import qualified Darcs.Util.Tree as Tree
import Darcs.Util.Index ( listFileIDs, getFileID )
newtype TreeFilter m = TreeFilter { 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 -> [SubPath]
-> IO (TreeFilter m)
restrictSubpaths :: Repository rt p wR wU wT -> [SubPath] -> IO (TreeFilter m)
restrictSubpaths repo :: Repository rt p wR wU wT
repo subpaths :: [SubPath]
subpaths = do
Sealed pending :: FL (PrimOf p) wT wX
pending <- Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
Pending.readPending Repository rt p wR wU wT
repo
FL (PrimOf p) wT wX
-> Repository rt p wR wU wT -> [SubPath] -> IO (TreeFilter m)
forall (p :: * -> * -> *) wT wP (rt :: RepoType) wR wU
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wT wP
-> Repository rt p wR wU wT -> [SubPath] -> IO (TreeFilter m)
restrictSubpathsAfter FL (PrimOf p) wT wX
pending Repository rt p wR wU wT
repo [SubPath]
subpaths
restrictSubpathsAfter :: (RepoPatch p, ApplyState p ~ Tree)
=> FL (PrimOf p) wT wP
-> Repository rt p wR wU wT
-> [SubPath]
-> IO (TreeFilter m)
restrictSubpathsAfter :: FL (PrimOf p) wT wP
-> Repository rt p wR wU wT -> [SubPath] -> IO (TreeFilter m)
restrictSubpathsAfter pending :: FL (PrimOf p) wT wP
pending _repo :: Repository rt p wR wU wT
_repo subpaths :: [SubPath]
subpaths = do
let paths :: [FilePath]
paths = (SubPath -> FilePath) -> [SubPath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FileName -> FilePath
fn2fp (FileName -> FilePath)
-> (SubPath -> FileName) -> SubPath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPath -> FileName
sp2fn) [SubPath]
subpaths
paths' :: [FilePath]
paths' = [FilePath]
paths [FilePath] -> [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a] -> [a]
`union` FL (PrimOf p) wT wP -> [FilePath] -> [FilePath]
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [FilePath] -> [FilePath]
effectOnFilePaths FL (PrimOf p) wT wP
pending [FilePath]
paths
anchored :: [AnchoredPath]
anchored = (FilePath -> AnchoredPath) -> [FilePath] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> AnchoredPath
floatPath [FilePath]
paths'
restrictPaths :: FilterTree tree m => tree m -> tree m
restrictPaths :: 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]
anchored)
TreeFilter m -> IO (TreeFilter m)
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 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) wT wP
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (TreeFilter m)
maybeRestrictSubpaths :: FL (PrimOf p) wT wP
-> Repository rt p wR wU wT -> Maybe [SubPath] -> IO (TreeFilter m)
maybeRestrictSubpaths pending :: FL (PrimOf p) wT wP
pending repo :: Repository rt p wR wU wT
repo =
IO (TreeFilter m)
-> ([SubPath] -> IO (TreeFilter m))
-> Maybe [SubPath]
-> IO (TreeFilter m)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TreeFilter m -> IO (TreeFilter m)
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 forall a. a -> a
forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
id) (FL (PrimOf p) wT wP
-> Repository rt p wR wU wT -> [SubPath] -> IO (TreeFilter m)
forall (p :: * -> * -> *) wT wP (rt :: RepoType) wR wU
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wT wP
-> Repository rt p wR wU wT -> [SubPath] -> IO (TreeFilter m)
restrictSubpathsAfter FL (PrimOf p) wT wP
pending Repository rt p wR wU wT
repo)
inDarcsDir :: AnchoredPath -> Bool
inDarcsDir :: AnchoredPath -> Bool
inDarcsDir (AnchoredPath (x :: Name
x:_)) | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Name
makeName FilePath
darcsdir = Bool
True
inDarcsDir _ = Bool
False
restrictBoring :: Tree m -> IO (TreeFilter m)
restrictBoring :: Tree m -> IO (TreeFilter m)
restrictBoring guide :: Tree m
guide = do
[Regex]
boring <- IO [Regex]
boringRegexps
let boring' :: AnchoredPath -> Bool
boring' p :: AnchoredPath
p | AnchoredPath -> Bool
inDarcsDir AnchoredPath
p = Bool
False
boring' p :: AnchoredPath
p = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Regex -> Bool) -> [Regex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\rx :: Regex
rx -> Maybe [FilePath] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [FilePath] -> Bool) -> Maybe [FilePath] -> Bool
forall a b. (a -> b) -> a -> b
$ Regex -> FilePath -> Maybe [FilePath]
matchRegex Regex
rx FilePath
p') [Regex]
boring
where p' :: FilePath
p' = FilePath -> AnchoredPath -> FilePath
anchorPath "" AnchoredPath
p
restrictTree :: FilterTree t m => t m -> t m
restrictTree :: t m -> t 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
$ \p :: AnchoredPath
p _ -> case Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
guide AnchoredPath
p of
Nothing -> AnchoredPath -> Bool
boring' AnchoredPath
p
_ -> Bool
True
TreeFilter m -> IO (TreeFilter m)
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 forall (tr :: (* -> *) -> *). FilterTree tr m => tr m -> tr m
forall (tree :: (* -> *) -> *) (m :: * -> *).
FilterTree tree m =>
tree m -> tree m
restrictTree)
restrictDarcsdir :: TreeFilter m
restrictDarcsdir :: 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
$ \p :: AnchoredPath
p _ -> Bool -> Bool
not (AnchoredPath -> Bool
inDarcsDir AnchoredPath
p)
unrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree)
=> (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU)
unrecordedChanges :: (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wT wU)
unrecordedChanges dopts :: (UseIndex, ScanKnown, DiffAlgorithm)
dopts lfm :: LookForMoves
lfm lfr :: LookForReplaces
lfr r :: Repository rt p wR wU wT
r paths :: Maybe [SubPath]
paths = do
(pending :: FL (PrimOf p) wT wZ
pending :> working :: FL (PrimOf p) wZ wU
working) <- (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wT wU)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wT wU)
readPendingAndWorking (UseIndex, ScanKnown, DiffAlgorithm)
dopts LookForMoves
lfm LookForReplaces
lfr Repository rt p wR wU wT
r Maybe [SubPath]
paths
FL (PrimOf p) wT wU -> IO (FL (PrimOf p) wT wU)
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PrimOf p) wT wU -> IO (FL (PrimOf p) wT wU))
-> FL (PrimOf p) wT wU -> IO (FL (PrimOf p) wT wU)
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wT wU -> FL (PrimOf p) wT wU
forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
FL prim wX wY -> FL prim wX wY
sortCoalesceFL (FL (PrimOf p) wT wZ
pending FL (PrimOf p) wT wZ -> FL (PrimOf p) wZ wU -> FL (PrimOf p) wT 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 :: forall rt p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
=> (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU)
readPendingAndWorking :: (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wT wU)
readPendingAndWorking _ _ _ r :: Repository rt p wR wU wT
r _ | RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
NoWorkingDir (Repository rt p wR wU wT -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wT
r) = do
EqCheck wU wT
IsEq <- EqCheck wU wT -> IO (EqCheck wU wT)
forall (m :: * -> *) a. Monad m => a -> m a
return (EqCheck wU wT -> IO (EqCheck wU wT))
-> EqCheck wU wT -> IO (EqCheck wU wT)
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wT -> EqCheck wU wT
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> EqCheck wU wT
workDirLessRepoWitness Repository rt p wR wU wT
r
(:>) (FL (PrimOf p)) (FL (PrimOf p)) wU wU
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wU wU)
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 (useidx :: UseIndex
useidx, scan :: ScanKnown
scan, diffalg :: DiffAlgorithm
diffalg) lfm :: LookForMoves
lfm lfr :: LookForReplaces
lfr repo :: Repository rt p wR wU wT
repo mbpaths :: Maybe [SubPath]
mbpaths = do
(pending_tree :: Tree IO
pending_tree, working_tree :: Tree IO
working_tree, pending :: FL (PrimOf p) wT wU
pending) <-
Repository rt p wR wU wT
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [SubPath]
-> IO (Tree IO, Tree IO, FL (PrimOf p) wT wU)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [SubPath]
-> IO (Tree IO, Tree IO, FL (PrimOf p) wT wU)
readPendingAndMovesAndUnrecorded Repository rt p wR wU wT
repo UseIndex
useidx ScanKnown
scan LookForMoves
lfm Maybe [SubPath]
mbpaths
(pending_tree_with_replaces :: Tree IO
pending_tree_with_replaces, Sealed replaces :: FL (PrimOf p) wU wX
replaces) <-
LookForReplaces
-> DiffAlgorithm
-> Repository rt p wR wU wT
-> Tree IO
-> Tree IO
-> IO (Tree IO, Sealed (FL (PrimOf p) wU))
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 wT
repo Tree IO
pending_tree Tree IO
working_tree
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) Any)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft FreeLeft (FL (PrimOf p))
wrapped_diff of
Sealed diff :: FL (PrimOf p) Any wX
diff -> do
(:>) (FL (PrimOf p)) (FL (PrimOf p)) wT wU
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wT wU)
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PrimOf p) wT wU
pending FL (PrimOf p) wT wU -> FL (PrimOf p) wU Any -> FL (PrimOf p) wT Any
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wU wX -> FL (PrimOf p) wU Any
forall (a :: * -> * -> *) wX wY1 wY2. a wX wY1 -> a wX wY2
unsafeCoercePEnd FL (PrimOf p) wU wX
replaces FL (PrimOf p) wT Any
-> FL (PrimOf p) Any wU
-> (:>) (FL (PrimOf p)) (FL (PrimOf p)) wT wU
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimOf p) Any wX -> FL (PrimOf p) Any wU
forall (a :: * -> * -> *) wX wY1 wY2. a wX wY1 -> a wX wY2
unsafeCoercePEnd FL (PrimOf p) Any wX
diff)
readPendingAndMovesAndUnrecorded
:: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [SubPath]
-> IO ( Tree IO
, Tree IO
, FL (PrimOf p) wT wU
)
readPendingAndMovesAndUnrecorded :: Repository rt p wR wU wT
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [SubPath]
-> IO (Tree IO, Tree IO, FL (PrimOf p) wT wU)
readPendingAndMovesAndUnrecorded repo :: Repository rt p wR wU wT
repo useidx :: UseIndex
useidx scan :: ScanKnown
scan lfm :: LookForMoves
lfm mbpaths :: Maybe [SubPath]
mbpaths = do
(pending_tree :: Tree IO
pending_tree, Sealed pending :: FL (PrimOf p) wT wX
pending) <- Repository rt p wR wU wT -> IO (Tree IO, Sealed (FL (PrimOf p) wT))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO (Tree IO, Sealed (FL (PrimOf p) wT))
readPending Repository rt p wR wU wT
repo
FL (PrimOf p) wX wX
moves <- LookForMoves
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wX wX)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wB
(prim :: * -> * -> *).
(RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p) =>
LookForMoves
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL prim wB wB)
getMoves LookForMoves
lfm Repository rt p wR wU wT
repo Maybe [SubPath]
mbpaths
let pending' :: FL (PrimOf p) wT wX
pending' = FL (PrimOf p) wT wX
pending FL (PrimOf p) wT wX -> FL (PrimOf p) wX wX -> FL (PrimOf p) wT wX
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wX wX
moves
TreeFilter IO
relevant <- FL (PrimOf p) wT wX
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (TreeFilter IO)
forall (p :: * -> * -> *) wT wP (rt :: RepoType) wR wU
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wT wP
-> Repository rt p wR wU wT -> Maybe [SubPath] -> IO (TreeFilter m)
maybeRestrictSubpaths FL (PrimOf p) wT wX
pending' Repository rt p wR wU wT
repo Maybe [SubPath]
mbpaths
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
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, Monad m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree FL (PrimOf p) wX wX
moves Tree IO
pending_tree
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
index <-
FL (PrimOf p) wX wX -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, Monad m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree FL (PrimOf p) wX wX
moves (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Index -> IO (Tree IO)
I.updateIndex (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
relevant (Index -> Index) -> IO Index -> IO Index
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Repository rt p wR wU wT -> IO Index
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO Index
readIndex Repository rt p wR wU wT
repo
Tree IO
working_tree <- UseIndex
-> ScanKnown -> TreeFilter IO -> Tree IO -> Tree IO -> IO (Tree IO)
filteredWorking UseIndex
useidx' ScanKnown
scan TreeFilter IO
relevant Tree IO
index Tree IO
pending_tree'
(Tree IO, Tree IO, FL (PrimOf p) wT wU)
-> IO (Tree IO, Tree IO, FL (PrimOf p) wT wU)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
pending_tree', Tree IO
working_tree, FL (PrimOf p) wT wX -> FL (PrimOf p) wT wU
forall (a :: * -> * -> *) wX wY1 wY2. a wX wY1 -> a wX wY2
unsafeCoercePEnd FL (PrimOf p) wT wX
pending')
filteredWorking :: UseIndex
-> ScanKnown
-> TreeFilter IO
-> Tree IO
-> Tree IO
-> IO (Tree IO)
filteredWorking :: UseIndex
-> ScanKnown -> TreeFilter IO -> Tree IO -> Tree IO -> IO (Tree IO)
filteredWorking useidx :: UseIndex
useidx scan :: ScanKnown
scan relevant :: TreeFilter IO
relevant index :: Tree IO
index pending_tree :: Tree IO
pending_tree = do
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
<$> case ScanKnown
scan of
ScanKnown -> case UseIndex
useidx of
UseIndex -> Tree IO -> IO (Tree IO)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree IO
index
IgnoreIndex -> 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
-> 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
. 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
<$> FilePath -> IO (Tree IO)
readPlainTree "."
ScanAll -> do
TreeFilter IO
nonboring <- Tree IO -> IO (TreeFilter IO)
forall (m :: * -> *). Tree m -> IO (TreeFilter m)
restrictBoring Tree IO
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
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
nonboring (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)
readPlainTree "."
Tree IO -> IO (Tree IO)
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
$ case UseIndex
useidx of
UseIndex -> Tree IO
plain Tree IO -> Tree IO -> Tree IO
forall (m :: * -> *). Monad m => Tree m -> Tree m -> Tree m
`overlay` Tree IO
index
IgnoreIndex -> Tree IO
plain
ScanBoring -> do
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
relevant (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)
readPlainTree "."
Tree IO -> IO (Tree IO)
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
$ case UseIndex
useidx of
UseIndex -> Tree IO
plain Tree IO -> Tree IO -> Tree IO
forall (m :: * -> *). Monad m => Tree m -> Tree m -> Tree m
`overlay` Tree IO
index
IgnoreIndex -> Tree IO
plain
workDirLessRepoWitness :: Repository rt p wR wU wT -> EqCheck wU wT
workDirLessRepoWitness :: Repository rt p wR wU wT -> EqCheck wU wT
workDirLessRepoWitness r :: Repository rt p wR wU wT
r
| RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
NoWorkingDir (Repository rt p wR wU wT -> RepoFormat
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wT
r) = EqCheck Any Any -> EqCheck wU wT
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 wT
forall wA wB. EqCheck wA wB
NotEq
readRecorded :: Repository rt p wR wU wT -> IO (Tree IO)
readRecorded :: Repository rt p wR wU wT -> IO (Tree IO)
readRecorded _repo :: Repository rt p wR wU wT
_repo = do
let h_inventory :: FilePath
h_inventory = FilePath
darcsdir FilePath -> FilePath -> FilePath
</> "hashed_inventory"
Bool
hashed <- FilePath -> IO Bool
doesFileExist FilePath
h_inventory
if Bool
hashed
then do ByteString
inv <- FilePath -> IO ByteString
B.readFile FilePath
h_inventory
let linesInv :: [ByteString]
linesInv = Char -> ByteString -> [ByteString]
BC.split '\n' ByteString
inv
case [ByteString]
linesInv of
[] -> Tree IO -> IO (Tree IO)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree IO
forall (m :: * -> *). Tree m
emptyTree
(pris_line :: ByteString
pris_line:_) -> do
let hash :: Hash
hash = ByteString -> Hash
decodeDarcsHash (ByteString -> Hash) -> ByteString -> Hash
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop 9 ByteString
pris_line
size :: Maybe Int
size = ByteString -> Maybe Int
decodeDarcsSize (ByteString -> Maybe Int) -> ByteString -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop 9 ByteString
pris_line
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Hash
hash Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
NoHash) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Bad pristine root: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
pris_line
FilePath -> (Maybe Int, Hash) -> IO (Tree IO)
readDarcsHashed (FilePath
darcsdir FilePath -> FilePath -> FilePath
</> "pristine.hashed") (Maybe Int
size, Hash
hash)
else do Bool
have_pristine <- FilePath -> IO Bool
doesDirectoryExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
darcsdir FilePath -> FilePath -> FilePath
</> "pristine"
Bool
have_current <- FilePath -> IO Bool
doesDirectoryExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
darcsdir FilePath -> FilePath -> FilePath
</> "current"
case (Bool
have_pristine, Bool
have_current) of
(True, _) -> FilePath -> IO (Tree IO)
readPlainTree (FilePath -> IO (Tree IO)) -> FilePath -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ FilePath
darcsdir FilePath -> FilePath -> FilePath
</> "pristine"
(False, True) -> FilePath -> IO (Tree IO)
readPlainTree (FilePath -> IO (Tree IO)) -> FilePath -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ FilePath
darcsdir FilePath -> FilePath -> FilePath
</> "current"
(_, _) -> FilePath -> IO (Tree IO)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail "No pristine tree is available!"
readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT -> Maybe [SubPath] -> IO (Tree IO)
readUnrecorded :: Repository rt p wR wU wT -> Maybe [SubPath] -> IO (Tree IO)
readUnrecorded repo :: Repository rt p wR wU wT
repo mbpaths :: Maybe [SubPath]
mbpaths = do
Sealed pending :: FL (PrimOf p) wT wX
pending <- Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
Pending.readPending Repository rt p wR wU wT
repo
TreeFilter IO
relevant <- FL (PrimOf p) wT wX
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (TreeFilter IO)
forall (p :: * -> * -> *) wT wP (rt :: RepoType) wR wU
(m :: * -> *).
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PrimOf p) wT wP
-> Repository rt p wR wU wT -> Maybe [SubPath] -> IO (TreeFilter m)
maybeRestrictSubpaths FL (PrimOf p) wT wX
pending Repository rt p wR wU wT
repo Maybe [SubPath]
mbpaths
Repository rt p wR wU wT -> IO Index
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO Index
readIndex Repository rt p wR wU wT
repo IO Index -> (Index -> IO (Tree IO)) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Index -> IO (Tree IO)
I.updateIndex (Index -> IO (Tree IO))
-> (Index -> Index) -> Index -> 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
relevant
readUnrecordedFiltered :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [SubPath] -> IO (Tree IO)
readUnrecordedFiltered :: Repository rt p wR wU wT
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [SubPath]
-> IO (Tree IO)
readUnrecordedFiltered repo :: Repository rt p wR wU wT
repo useidx :: UseIndex
useidx scan :: ScanKnown
scan lfm :: LookForMoves
lfm mbpaths :: Maybe [SubPath]
mbpaths = do
(_, working_tree :: Tree IO
working_tree, _) <-
Repository rt p wR wU wT
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [SubPath]
-> IO (Tree IO, Tree IO, FL (PrimOf p) wT wU)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UseIndex
-> ScanKnown
-> LookForMoves
-> Maybe [SubPath]
-> IO (Tree IO, Tree IO, FL (PrimOf p) wT wU)
readPendingAndMovesAndUnrecorded Repository rt p wR wU wT
repo UseIndex
useidx ScanKnown
scan LookForMoves
lfm Maybe [SubPath]
mbpaths
Tree IO -> IO (Tree IO)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree IO
working_tree
readWorking :: IO (Tree IO)
readWorking :: IO (Tree IO)
readWorking = 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
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)
readPlainTree ".")
readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT -> IO (Tree IO)
readRecordedAndPending :: Repository rt p wR wU wT -> IO (Tree IO)
readRecordedAndPending repo :: Repository rt p wR wU wT
repo = (Tree IO, Sealed (FL (PrimOf p) wT)) -> Tree IO
forall a b. (a, b) -> a
fst ((Tree IO, Sealed (FL (PrimOf p) wT)) -> Tree IO)
-> IO (Tree IO, Sealed (FL (PrimOf p) wT)) -> IO (Tree IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Repository rt p wR wU wT -> IO (Tree IO, Sealed (FL (PrimOf p) wT))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO (Tree IO, Sealed (FL (PrimOf p) wT))
readPending Repository rt p wR wU wT
repo
readPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> IO (Tree IO, Sealed (FL (PrimOf p) wT))
readPending :: Repository rt p wR wU wT -> IO (Tree IO, Sealed (FL (PrimOf p) wT))
readPending repo :: Repository rt p wR wU wT
repo = do
Tree IO
pristine <- Repository rt p wR wU wT -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wT
repo
Sealed pending :: FL (PrimOf p) wT wX
pending <- Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
Pending.readPending Repository rt p wR wU wT
repo
IO (Tree IO, Sealed (FL (PrimOf p) wT))
-> (IOException -> IO (Tree IO, Sealed (FL (PrimOf p) wT)))
-> IO (Tree IO, Sealed (FL (PrimOf p) wT))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((\t :: Tree IO
t -> (Tree IO
t, FL (PrimOf p) wT wX -> Sealed (FL (PrimOf p) wT)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL (PrimOf p) wT wX
pending)) (Tree IO -> (Tree IO, Sealed (FL (PrimOf p) wT)))
-> IO (Tree IO) -> IO (Tree IO, Sealed (FL (PrimOf p) wT))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FL (PrimOf p) wT wX -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, Monad m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree FL (PrimOf p) wT wX
pending Tree IO
pristine) ((IOException -> IO (Tree IO, Sealed (FL (PrimOf p) wT)))
-> IO (Tree IO, Sealed (FL (PrimOf p) wT)))
-> (IOException -> IO (Tree IO, Sealed (FL (PrimOf p) wT)))
-> IO (Tree IO, Sealed (FL (PrimOf p) wT))
forall a b. (a -> b) -> a -> b
$
\(IOException
err :: IOException) -> do
FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Yikes, pending has conflicts! " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
forall a. Show a => a -> FilePath
show IOException
err
FilePath -> IO ()
putStrLn "Stashing the buggy pending as _darcs/patches/pending_buggy"
FilePath -> FilePath -> IO ()
renameFile (FilePath
darcsdir FilePath -> FilePath -> FilePath
</> "patches" FilePath -> FilePath -> FilePath
</> "pending")
(FilePath
darcsdir FilePath -> FilePath -> FilePath
</> "patches" FilePath -> FilePath -> FilePath
</> "pending_buggy")
(Tree IO, Sealed (FL (PrimOf p) wT))
-> IO (Tree IO, Sealed (FL (PrimOf p) wT))
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO
pristine, FL (PrimOf p) wT wT -> Sealed (FL (PrimOf p) wT)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL (PrimOf p) wT wT
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
index_file, index_invalid :: FilePath
index_file :: FilePath
index_file = FilePath
darcsdir FilePath -> FilePath -> FilePath
</> "index"
index_invalid :: FilePath
index_invalid = FilePath
darcsdir FilePath -> FilePath -> FilePath
</> "index_invalid"
invalidateIndex :: t -> IO ()
invalidateIndex :: t -> IO ()
invalidateIndex _ = FilePath -> ByteString -> IO ()
B.writeFile FilePath
index_invalid ByteString
B.empty
readIndex :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT -> IO I.Index
readIndex :: Repository rt p wR wU wT -> IO Index
readIndex repo :: Repository rt p wR wU wT
repo = do
(invalid :: Bool
invalid, exists :: Bool
exists, formatValid :: Bool
formatValid) <- IO (Bool, Bool, Bool)
checkIndex
if Bool -> Bool
not Bool
exists Bool -> Bool -> Bool
|| Bool
invalid Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
formatValid
then do Tree IO
pris <- Repository rt p wR wU wT -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO (Tree IO)
readRecordedAndPending Repository rt p wR wU wT
repo
Index
idx <- FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index
I.updateIndexFrom FilePath
index_file Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
darcsTreeHash Tree IO
pris
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
invalid (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
index_invalid
Index -> IO Index
forall (m :: * -> *) a. Monad m => a -> m a
return Index
idx
else FilePath -> (Tree IO -> Hash) -> IO Index
I.readIndex FilePath
index_file Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
darcsTreeHash
updateIndex :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT -> IO ()
updateIndex :: Repository rt p wR wU wT -> IO ()
updateIndex repo :: Repository rt p wR wU wT
repo = do
(invalid :: Bool
invalid, _, _) <- IO (Bool, Bool, Bool)
checkIndex
Tree IO
pris <- Repository rt p wR wU wT -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO (Tree IO)
readRecordedAndPending Repository rt p wR wU wT
repo
Index
_ <- FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index
I.updateIndexFrom FilePath
index_file Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
darcsTreeHash Tree IO
pris
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
invalid (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
index_invalid
checkIndex :: IO (Bool, Bool, Bool)
checkIndex :: IO (Bool, Bool, Bool)
checkIndex = do
Bool
invalid <- FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
index_invalid
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
index_file
Bool
formatValid <- if Bool
exists
then FilePath -> IO Bool
I.indexFormatValid FilePath
index_file
else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
formatValid) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
#if mingw32_HOST_OS
renameFile index_file (index_file <.> "old")
#else
FilePath -> IO ()
removeFile FilePath
index_file
#endif
(Bool, Bool, Bool) -> IO (Bool, Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
invalid, Bool
exists, Bool
formatValid)
filterOutConflicts
:: (RepoPatch p, ApplyState p ~ Tree)
=> RL (PatchInfoAnd rt p) wX wT
-> Repository rt p wR wU wT
-> FL (PatchInfoAnd rt p) wX wZ
-> IO (Bool, Sealed (FL (PatchInfoAnd rt p) wX))
filterOutConflicts :: RL (PatchInfoAnd rt p) wX wT
-> Repository rt p wR wU wT
-> FL (PatchInfoAnd rt p) wX wZ
-> IO (Bool, Sealed (FL (PatchInfoAnd rt p) wX))
filterOutConflicts us :: RL (PatchInfoAnd rt p) wX wT
us repository :: Repository rt p wR wU wT
repository them :: FL (PatchInfoAnd rt p) wX wZ
them
= do let commuter :: (:>) (PatchInfoAnd rt p) (RL (PatchInfoAnd rt p)) wX wY
-> Maybe ((:>) (RL (PatchInfoAnd rt p)) (PatchInfoAnd rt p) wX wY)
commuter = CommuteFn (PatchInfoAnd rt p) (PatchInfoAnd rt p)
-> CommuteFn (PatchInfoAnd rt p) (RL (PatchInfoAnd rt p))
forall (p1 :: * -> * -> *) (p2 :: * -> * -> *).
CommuteFn p1 p2 -> CommuteFn p1 (RL p2)
commuterIdRL CommuteFn (PatchInfoAnd rt p) (PatchInfoAnd rt p)
forall (p :: * -> * -> *). Commute p => CommuteFn p p
selfCommuter
PatchInfoAnd rt p wT wU
unrec <- (WrappedNamed rt p wT wU -> PatchInfoAnd rt p wT wU)
-> IO (WrappedNamed rt p wT wU) -> IO (PatchInfoAnd rt p wT wU)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WrappedNamed rt p wT wU -> PatchInfoAnd rt p wT wU
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY
n2pia (IO (WrappedNamed rt p wT wU) -> IO (PatchInfoAnd rt p wT wU))
-> (FL (PrimOf p) wT wU -> IO (WrappedNamed rt p wT wU))
-> FL (PrimOf p) wT wU
-> IO (PatchInfoAnd rt p wT wU)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL p wT wU -> IO (WrappedNamed rt p wT wU)
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
FL p wX wY -> IO (WrappedNamed rt p wX wY)
anonymous (FL p wT wU -> IO (WrappedNamed rt p wT wU))
-> (FL (PrimOf p) wT wU -> FL p wT wU)
-> FL (PrimOf p) wT wU
-> IO (WrappedNamed rt p wT wU)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FL (PrimOf p) wT wU -> FL p wT wU
forall (p :: * -> * -> *) wX wY.
FromPrims p =>
FL (PrimOf p) wX wY -> p wX wY
fromPrims
(FL (PrimOf p) wT wU -> IO (PatchInfoAnd rt p wT wU))
-> IO (FL (PrimOf p) wT wU) -> IO (PatchInfoAnd rt p wT wU)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wT wU)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wT wU)
unrecordedChanges (UseIndex
UseIndex, ScanKnown
ScanKnown, DiffAlgorithm
MyersDiff)
LookForMoves
NoLookForMoves LookForReplaces
NoLookForReplaces Repository rt p wR wU wT
repository Maybe [SubPath]
forall a. Maybe a
Nothing
them' :: FL (PatchInfoAnd rt p) wX wZ
them' :> rest :: FL (PatchInfoAnd rt p) wZ wZ
rest <- (:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wZ
-> IO
((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wZ)
forall (m :: * -> *) a. Monad m => a -> m a
return ((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wZ
-> IO
((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wZ))
-> (:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wZ
-> IO
((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wZ)
forall a b. (a -> b) -> a -> b
$ CommuteFn (PatchInfoAnd rt p) (RL (PatchInfoAnd rt p))
-> FL (PatchInfoAnd rt p) wX wZ
-> RL (PatchInfoAnd rt p) wX wU
-> (:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wZ
forall (p1 :: * -> * -> *) (p2 :: * -> * -> *) wX wY wZ.
(Commute p1, Invert p1) =>
CommuteFn p1 p2
-> FL p1 wX wY -> p2 wX wZ -> (:>) (FL p1) (FL p1) wX wY
partitionConflictingFL CommuteFn (PatchInfoAnd rt p) (RL (PatchInfoAnd rt p))
commuter FL (PatchInfoAnd rt p) wX wZ
them (RL (PatchInfoAnd rt p) wX wT
us RL (PatchInfoAnd rt p) wX wT
-> PatchInfoAnd rt p wT wU -> RL (PatchInfoAnd rt p) wX wU
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: PatchInfoAnd rt p wT wU
unrec)
(Bool, Sealed (FL (PatchInfoAnd rt p) wX))
-> IO (Bool, Sealed (FL (PatchInfoAnd rt p) wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PatchInfoAnd rt p) wZ wZ -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
check FL (PatchInfoAnd rt p) wZ wZ
rest, FL (PatchInfoAnd rt p) wX wZ -> Sealed (FL (PatchInfoAnd rt p) wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PatchInfoAnd rt p) wX wZ
them')
where check :: FL p wA wB -> Bool
check :: FL p wA wB -> Bool
check NilFL = Bool
False
check _ = Bool
True
getMoves :: forall rt p wR wU wT wB prim.
(RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p)
=> LookForMoves
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL prim wB wB)
getMoves :: LookForMoves
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL prim wB wB)
getMoves NoLookForMoves _ _ = FL prim wB wB -> IO (FL prim wB wB)
forall (m :: * -> *) a. Monad m => a -> m a
return FL prim wB wB
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
getMoves YesLookForMoves repository :: Repository rt p wR wU wT
repository files :: Maybe [SubPath]
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 wR wU wT
-> Maybe [SubPath] -> IO [(AnchoredPath, AnchoredPath, ItemType)]
getMovedFiles Repository rt p wR wU wT
repository Maybe [SubPath]
files
where
mkMovesFL :: [(AnchoredPath, AnchoredPath, c)] -> FL a wY wY
mkMovesFL [] = FL a wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
mkMovesFL ((a :: AnchoredPath
a,b :: AnchoredPath
b,_):xs :: [(AnchoredPath, AnchoredPath, c)]
xs) = FilePath -> FilePath -> a wY wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
FilePath -> FilePath -> prim wX wY
move (FilePath -> AnchoredPath -> FilePath
anchorPath "" AnchoredPath
a) (FilePath -> AnchoredPath -> FilePath
anchorPath "" 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 wR wU wT
-> Maybe [SubPath]
-> IO [(AnchoredPath, AnchoredPath, ItemType)]
getMovedFiles :: Repository rt p wR wU wT
-> Maybe [SubPath] -> IO [(AnchoredPath, AnchoredPath, ItemType)]
getMovedFiles repo :: Repository rt p wR wU wT
repo fs :: Maybe [SubPath]
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 wR wU wT -> IO Index
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> IO Index
readIndex Repository rt p wR wU wT
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 (\xs :: [((AnchoredPath, b), FileID)]
xs (p :: AnchoredPath
p, it :: b
it)-> do Maybe FileID
mfid <- AnchoredPath -> IO (Maybe FileID)
getFileID AnchoredPath
p
[((AnchoredPath, b), FileID)] -> IO [((AnchoredPath, b), FileID)]
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
Nothing -> [((AnchoredPath, b), FileID)]
xs
Just fid :: 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 (\(a :: AnchoredPath
a,b :: 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
<$> FilePath -> IO (Tree IO)
readPlainTree ".")
let match :: [((a, c), b)] -> [((b, c), b)] -> [(a, b, c)]
match (x :: ((a, c), b)
x:xs :: [((a, c), b)]
xs) (y :: ((b, c), b)
y:ys :: [((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 _ _ = []
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 [SubPath]
fs of
Nothing -> [(AnchoredPath, AnchoredPath, ItemType)]
movedfiles
Just subpath :: [SubPath]
subpath ->
((AnchoredPath, AnchoredPath, ItemType) -> Bool)
-> [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(f1 :: AnchoredPath
f1, f2 :: AnchoredPath
f2, _) -> (AnchoredPath -> Bool) -> [AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (AnchoredPath -> [AnchoredPath] -> 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 = (SubPath -> AnchoredPath) -> [SubPath] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> AnchoredPath
floatPath (FilePath -> AnchoredPath)
-> (SubPath -> FilePath) -> SubPath -> AnchoredPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubPath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath) [SubPath]
subpath
[(AnchoredPath, AnchoredPath, ItemType)]
-> IO [(AnchoredPath, AnchoredPath, ItemType)]
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 xs :: [(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@(start :: t
start,_,_):rest :: [(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 current :: t
current ((a' :: t
a',b' :: t
b',_):rest' :: [(t, t, c)]
rest') first :: 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 _ [] _ = Bool
False
deleteFrom :: t -> [(t, t, c)] -> [(t, t, c)] -> [(t, t, c)]
deleteFrom a :: t
a (y :: (t, t, c)
y@(a' :: t
a',b' :: t
b',_):ys :: [(t, t, c)]
ys) seen :: [(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 _ [] seen :: [(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@(_,dest :: AnchoredPath
dest,_):_) =
(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 prevDest :: AnchoredPath
prevDest (y :: (AnchoredPath, AnchoredPath, c)
y@(s :: AnchoredPath
s,d :: AnchoredPath
d,_):ys :: [(AnchoredPath, AnchoredPath, c)]
ys) currentSmallest :: (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 (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 _ [] currentSmallest :: (AnchoredPath, AnchoredPath, c)
currentSmallest = (AnchoredPath, AnchoredPath, c)
currentSmallest
fixPaths :: [(AnchoredPath, AnchoredPath, ItemType)]
-> [(AnchoredPath, AnchoredPath, ItemType)]
fixPaths [] = []
fixPaths (y :: (AnchoredPath, AnchoredPath, ItemType)
y@(f1 :: AnchoredPath
f1,f2 :: AnchoredPath
f2,t :: ItemType
t):ys :: [(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 i :: (AnchoredPath, b, c)
i@(if1 :: AnchoredPath
if1,if2 :: b
if2,it :: c
it) | AnchoredPath
nfst AnchoredPath -> AnchoredPath -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredPath
anchoredRoot = (AnchoredPath, b, c)
i
| Bool
otherwise = (AnchoredPath
nfst, b
if2, c
it)
where nfst :: AnchoredPath
nfst = AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
replacePrefixPath AnchoredPath
f1 AnchoredPath
f2 AnchoredPath
if1
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 :: LookForReplaces
-> DiffAlgorithm
-> Repository rt p wR wU wT
-> Tree IO
-> Tree IO
-> IO (Tree IO, Sealed (FL (PrimOf p) wU))
getReplaces NoLookForReplaces _ _ pending :: Tree IO
pending _ = (Tree IO, Sealed (FL (PrimOf p) wU))
-> IO (Tree IO, Sealed (FL (PrimOf p) wU))
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 YesLookForReplaces diffalg :: DiffAlgorithm
diffalg _repo :: Repository rt p wR wU wT
_repo pending :: Tree IO
pending working :: Tree IO
working = do
FilePath -> FileType
ftf <- IO (FilePath -> FileType)
filetypeFunction
Sealed changes :: 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 :: [(FileName, ByteString, ByteString)]
allModifiedTokens = [[(FileName, ByteString, ByteString)]]
-> [(FileName, ByteString, ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(FileName, ByteString, ByteString)]]
-> [(FileName, ByteString, ByteString)])
-> [[(FileName, ByteString, ByteString)]]
-> [(FileName, ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ (forall wW wZ.
PrimOf p wW wZ -> [(FileName, ByteString, ByteString)])
-> FL (PrimOf p) Any wX -> [[(FileName, ByteString, ByteString)]]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ.
PrimOf p wW wZ -> [(FileName, ByteString, ByteString)]
modifiedTokens FL (PrimOf p) Any wX
changes
replaces :: [(FileName, ByteString, ByteString)]
replaces = [(FileName, ByteString, ByteString)]
-> [(FileName, ByteString, ByteString)]
forall a a c. (Eq a, Eq a, Eq c) => [(a, a, c)] -> [(a, a, c)]
rmInvalidReplaces [(FileName, ByteString, ByteString)]
allModifiedTokens
(patches :: [FreeLeft (FL (PrimOf p))]
patches, new_pending :: 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
$
[(FileName, ByteString, ByteString)]
-> ((FileName, 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 [(FileName, ByteString, ByteString)]
replaces (((FileName, ByteString, ByteString)
-> StateT (Tree IO) IO (FreeLeft (FL (PrimOf p))))
-> StateT (Tree IO) IO [FreeLeft (FL (PrimOf p))])
-> ((FileName, 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
$ \(f :: FileName
f,a :: ByteString
a,b :: ByteString
b) ->
FilePath
-> SubPath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL (PrimOf p)))
forall (a :: * -> * -> *).
(PrimPatch a, ApplyState a ~ Tree) =>
FilePath
-> SubPath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL a))
doReplace FilePath
defaultToks
(Maybe SubPath -> SubPath
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe SubPath -> SubPath) -> Maybe SubPath -> SubPath
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe SubPath
simpleSubPath (FilePath -> Maybe SubPath) -> FilePath -> Maybe SubPath
forall a b. (a -> b) -> a -> b
$ FileName -> FilePath
fn2fp (FileName -> FilePath) -> FileName -> FilePath
forall a b. (a -> b) -> a -> b
$ FileName -> FileName
normPath FileName
f)
(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 (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 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 (PrimOf p))] -> Sealed (FL (FL (PrimOf p)) wU)
forall (a :: * -> * -> *) wX. [FreeLeft a] -> Sealed (FL a wX)
toFL [FreeLeft (FL (PrimOf p))]
patches)
where
modifiedTokens :: PrimOf p wX wY -> [(FileName, B.ByteString, B.ByteString)]
modifiedTokens :: PrimOf p wX wY -> [(FileName, ByteString, ByteString)]
modifiedTokens p :: PrimOf p wX wY
p = case PrimOf p wX wY -> Maybe (FileHunk wX wY)
forall (p :: * -> * -> *) wX wY.
IsHunk p =>
p wX wY -> Maybe (FileHunk wX wY)
isHunk PrimOf p wX wY
p of
Just (FileHunk f :: FileName
f _ old :: [ByteString]
old new :: [ByteString]
new) ->
((ByteString, ByteString) -> (FileName, ByteString, ByteString))
-> [(ByteString, ByteString)]
-> [(FileName, ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a :: ByteString
a,b :: ByteString
b) -> (FileName
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 (\(a :: [ByteString]
a,b :: [ByteString]
b) -> [ByteString] -> 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 (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))
Nothing -> []
checkModified :: ([ByteString], [ByteString]) -> [(ByteString, ByteString)]
checkModified = ((ByteString, ByteString) -> Bool)
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a :: ByteString
a,b :: 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 ((f :: a
f,old :: a
old,new :: c
new):rs :: [(a, a, c)]
rs)
| ((a, a, c) -> Bool) -> [(a, a, c)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(f' :: a
f',a :: a
a,b :: 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 (\(f'' :: a
f'',a' :: a
a',_) -> 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 (r :: (a, a, c)
r:rs :: [(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
-> SubPath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL a))
doReplace toks :: FilePath
toks f :: SubPath
f old :: FilePath
old new :: 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 (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
$ a Any Any -> Tree IO -> IO (Maybe (Tree IO))
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> Tree IO -> IO (Maybe (Tree IO))
maybeApplyToTree a Any Any
forall wX wY. a wX wY
replacePatch Tree IO
pend
case Maybe (Tree IO)
mpend' of
Nothing -> SubPath
-> FilePath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL a))
forall (prim :: * -> * -> *).
(PrimPatch prim, ApplyState prim ~ Tree) =>
SubPath
-> FilePath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL prim))
getForceReplace SubPath
f FilePath
toks FilePath
old FilePath
new
Just pend' :: Tree IO
pend' -> do
Tree IO -> StateT (Tree IO) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Tree IO
pend'
FreeLeft (FL a) -> StateT (Tree IO) IO (FreeLeft (FL a))
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeLeft (FL a) -> StateT (Tree IO) IO (FreeLeft (FL a)))
-> FreeLeft (FL a) -> StateT (Tree IO) IO (FreeLeft (FL a))
forall a b. (a -> b) -> a -> b
$ (forall wX wY wZ. a wX wY -> FL a wY wZ -> FL a wX wZ)
-> FreeLeft a -> FreeLeft (FL a) -> FreeLeft (FL a)
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 wX wY wZ. a wX wY -> FL a wY wZ -> FL a wX wZ
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
(:>:) ((forall wX wY. a wX wY) -> FreeLeft a
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX wY. p wX wY) -> w p
freeGap forall wX wY. a wX wY
replacePatch) ((forall wX. FL a wX wX) -> FreeLeft (FL a)
forall (w :: (* -> * -> *) -> *) (p :: * -> * -> *).
Gap w =>
(forall wX. p wX wX) -> w p
emptyGap forall wX. FL a wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
where
replacePatch :: a wX wY
replacePatch = FilePath -> FilePath -> FilePath -> FilePath -> a wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
FilePath -> FilePath -> FilePath -> FilePath -> prim wX wY
tokreplace (SubPath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath SubPath
f) FilePath
toks FilePath
old FilePath
new
getForceReplace :: (PrimPatch prim, ApplyState prim ~ Tree)
=> SubPath -> String -> String -> String
-> StateT (Tree IO) IO (FreeLeft (FL prim))
getForceReplace :: SubPath
-> FilePath
-> FilePath
-> FilePath
-> StateT (Tree IO) IO (FreeLeft (FL prim))
getForceReplace f :: SubPath
f toks :: FilePath
toks old :: FilePath
old new :: FilePath
new = do
let path :: AnchoredPath
path = SubPath -> AnchoredPath
floatSubPath SubPath
f
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 (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 :: Blob IO
blob -> IO ByteString -> StateT (Tree IO) IO ByteString
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
Nothing -> FilePath -> StateT (Tree IO) IO ByteString
forall a. FilePath -> a
bug (FilePath -> StateT (Tree IO) IO ByteString)
-> FilePath -> StateT (Tree IO) IO ByteString
forall a b. (a -> b) -> a -> b
$ "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 (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 (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 (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 (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 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 (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
$
FilePath -> FilePath -> FilePath -> FilePath -> prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
FilePath -> FilePath -> FilePath -> FilePath -> prim wX wY
tokreplace (SubPath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath SubPath
f) 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 ps :: FL prim Any wX
ps -> IO (Maybe (Tree IO)) -> StateT (Tree IO) IO (Maybe (Tree IO))
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 :: * -> * -> *) 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
Nothing -> FilePath -> StateT (Tree IO) IO (FreeLeft (FL prim))
forall a. FilePath -> a
bug "getForceReplace: unable to apply detected force replaces"
Just tree'' :: 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 (m :: * -> *) a. Monad m => a -> m a
return FreeLeft (FL prim)
patches
addPendingDiffToPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT -> UpdateWorking
-> FreeLeft (FL (PrimOf p)) -> IO ()
addPendingDiffToPending :: Repository rt p wR wU wT
-> UpdateWorking -> FreeLeft (FL (PrimOf p)) -> IO ()
addPendingDiffToPending _ NoUpdateWorking _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addPendingDiffToPending repo :: Repository rt p wR wU wT
repo uw :: UpdateWorking
uw@UpdateWorking
YesUpdateWorking newP :: FreeLeft (FL (PrimOf p))
newP = do
(toPend :: FL (PrimOf p) wT wZ
toPend :> _) <-
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wT wU)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wT wU)
readPendingAndWorking (UseIndex
UseIndex, ScanKnown
ScanKnown, DiffAlgorithm
MyersDiff)
LookForMoves
NoLookForMoves LookForReplaces
NoLookForReplaces Repository rt p wR wU wT
repo Maybe [SubPath]
forall a. Maybe a
Nothing
Repository rt p wR wU wT -> IO ()
forall t. t -> IO ()
invalidateIndex Repository rt p wR wU wT
repo
case FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wZ)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft FreeLeft (FL (PrimOf p))
newP of
(Sealed p :: FL (PrimOf p) wZ wX
p) -> do Tree IO
recordedState <- Repository rt p wR wU wT -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wT
repo
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wT wX -> Tree IO -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wT wY -> Tree IO -> IO ()
Pending.makeNewPending Repository rt p wR wU wT
repo UpdateWorking
uw (FL (PrimOf p) wT wZ
toPend FL (PrimOf p) wT wZ -> FL (PrimOf p) wZ wX -> FL (PrimOf p) wT wX
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wZ wX
p) Tree IO
recordedState
addToPending :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT -> UpdateWorking
-> FL (PrimOf p) wU wY -> IO ()
addToPending :: Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending _ NoUpdateWorking _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addToPending repo :: Repository rt p wR wU wT
repo uw :: UpdateWorking
uw@UpdateWorking
YesUpdateWorking p :: FL (PrimOf p) wU wY
p = do
(toPend :: FL (PrimOf p) wT wZ
toPend :> toUnrec :: FL (PrimOf p) wZ wU
toUnrec) <- (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wT wU)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wT wU)
readPendingAndWorking (UseIndex
UseIndex, ScanKnown
ScanKnown, DiffAlgorithm
MyersDiff)
LookForMoves
NoLookForMoves LookForReplaces
NoLookForReplaces Repository rt p wR wU wT
repo Maybe [SubPath]
forall a. Maybe a
Nothing
Repository rt p wR wU wT -> IO ()
forall t. t -> IO ()
invalidateIndex Repository rt p wR wU wT
repo
case (forall wA wB.
(:>) (PrimOf p) (FL (PrimOf p)) wA wB
-> Maybe ((:>) (FL (PrimOf p)) (PrimOf p) wA wB))
-> (:>) (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 =>
(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 wA wB.
(:>) (PrimOf p) (FL (PrimOf p)) wA wB
-> Maybe ((:>) (FL (PrimOf p)) (PrimOf p) wA wB)
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
(toP' :: RL (PrimOf p) wZ wZ
toP' :> p' :: FL (PrimOf p) wZ wZ
p' :> _excessUnrec :: RL (PrimOf p) wZ wY
_excessUnrec) -> do
Tree IO
recordedState <- Repository rt p wR wU wT -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wT
repo
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wT wZ -> Tree IO -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wT wY -> Tree IO -> IO ()
Pending.makeNewPending Repository rt p wR wU wT
repo UpdateWorking
uw
(FL (PrimOf p) wT wZ
toPend FL (PrimOf p) wT wZ -> FL (PrimOf p) wZ wZ -> FL (PrimOf p) wT 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') Tree IO
recordedState