{-# LANGUAGE CPP #-}
-- Copyright (C) 2009 Petr Rockai
--           (C) 2012 José Neder
--
-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use, copy,
-- modify, merge, publish, distribute, sublicense, and/or sell copies
-- of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:
--
-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.

module Darcs.Repository.State
    ( restrictSubpaths, restrictBoring, TreeFilter(..), restrictDarcsdir
    -- * Diffs
    , unrecordedChanges
    -- * Trees
    , readRecorded, readUnrecorded, readRecordedAndPending, readWorking
    , readPendingAndWorking, readUnrecordedFiltered
    -- * Index
    , readIndex, updateIndex, invalidateIndex, UseIndex(..), ScanKnown(..)
    -- * Utilities
    , filterOutConflicts
    -- * Pending-related functions that depend on repo state
    , 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 }

-- | From a repository and a list of AnchoredPath's, construct a filter that can be
-- used on a Tree (recorded or unrecorded state) of this repository. This
-- constructed filter will take pending into account, so the subpaths will be
-- translated correctly relative to pending move patches.
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

-- | Like 'restrictSubpaths' but with the pending patch passed as a parameter.
-- The 'Repository' parameter is not used, we need it only to avoid
-- abiguous typing of @p@.
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)

-- note we assume pending starts at the recorded state
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)

-- | Construct a 'TreeFilter' that removes any boring files that are not also
-- contained in the argument 'Tree'.
--
-- The standard use case is for the argument to be the recorded state, possibly
-- with further patches applied, so as not to discard any files already known
-- to darcs. The result is usually applied to the full working state.
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)

-- | Construct a Tree filter that removes any darcs metadata files the
-- Tree might have contained.
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)

{- |
For a repository and an optional list of paths (when 'Nothing', take
everything) compute a (forward) list of prims (i.e. a patch) going from the
recorded state of the repository (pristine) to the unrecorded state of the
repository (the working tree + pending). When a list of paths is given, at
least the files that live under any of these paths in either recorded or
unrecorded will be included in the resulting patch. NB. More patches may be
included in this list, eg. the full contents of the pending patch. This is
usually not a problem, since selectChanges will properly filter the results
anyway.

This also depends on the options given:

--look-for-moves: Detect pending file moves using the index. The resulting
  patches are added to pending and taken into consideration, when filtering
  the tree according to the given path list.

--look-for-adds: Include files in the working state that do not exist in the
  recorded + pending state.

--include-boring: Include even boring files.

--look-for-replaces: Detect pending replace patches. Like detected moves,
  these are added to the pending patch. Note that, like detected moves,
  these are mere proposals for the user to consider or reject.

--ignore-times: Disables index usage completely -- for each file, we read
  both the unrecorded and the recorded copy and run a diff on them. This is
  very inefficient, although in extremely rare cases, the index could go out
  of sync (file is modified, index is updated and file is modified again
  within a single second).

  Note that use of the index is also disabled when we detect moves or
  replaces, since this implies that the index is out of date.
-}
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)

-- Implementation note: it is important to do things in the right order: we
-- first have to read the pending patch, then detect moves, then detect adds,
-- then detect replaces.
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             -- pristine with (pending + moves)
        , Tree IO             -- working
        , (FL (PrimOf p) :> FL (PrimOf p)) wR wU -- pending :> moves
        )
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
  -- we want to include any user specified paths before and after pending
  -- and detected moves
  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"
  -- the moves are detected i.e. they are already applied in the working tree;
  -- also note that we have to use the amended pending tree to restrict the
  -- working tree in case we don't use the index (here and below)
  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"
  -- TODO this conditional looks wrong; so if we do have detected moves,
  -- then we cannot use the index to read the working state? Why not?
  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 useidx scan relevant index pending_tree@ reads the
-- working tree and filters it according to options and @relevant@ file paths.
-- The @pending_tree@ is understood to have @relevant@ already applied and is
-- used (only) if @useidx == 'IgnoreIndex'@ and @scan /= 'ScanBoring'@ to act as
-- a guide for filtering the working tree.
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

-- | Witnesses the fact that in the absence of a working tree, we
-- pretend that the working dir updates magically to the tentative state.
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

-- | Obtains a Tree corresponding to the "recorded" state of the repository:
-- this is the same as the pristine cache, which is the same as the result of
-- applying all the repository's patches to an empty directory.
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!"

-- | Obtains a Tree corresponding to the "unrecorded" state of the repository:
-- the modified files of the working tree plus the "pending" patch.
-- The optional list of paths allows to restrict the query to a subtree.
--
-- Limiting the query may be more efficient, since hashes on the uninteresting
-- parts of the index do not need to go through an up-to-date check (which
-- involves a relatively expensive lstat(2) per file.
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

-- | A variant of 'readUnrecorded' that takes the UseIndex and ScanKnown
-- options into account, similar to 'readPendingAndWorking'. We are only
-- interested in the resulting tree, not the patch, so the 'DiffAlgorithm' option
-- is irrelevant.
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

-- | Obtains the relevant (according to the given filter) part of the 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
".")

-- | Obtains the recorded 'Tree' with the pending patch applied.
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

-- | Obtains the recorded 'Tree' with the pending patch applied, plus
--   the pending patch itself. The pending patch should start at the
--   recorded state (we even verify that it applies, and degrade to
--   renaming pending and starting afresh if it doesn't).
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)

-- | Mark the existing index as invalid. This has to be called whenever the
-- listing of pristine+pending changes and will cause darcs to update the index.
-- This will happen either when we call updateIndex in finalizeRepositoryChanges
-- or else when we try to read the index the next time.
-- (NB. This is about files added and removed from
-- pristine: changes to file content in either pristine or working are handled
-- transparently by the index reading code.)
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

-- | Update the index so that it matches pristine+pending. If the index does
-- not exist or is invalid, create a new one. Returns the updated index.
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

-- | Update the index so that it matches pristine+pending. If the index does
-- not exist or is invalid, create a new one.
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
  -- call checkIndex to throw away the index if it is invalid;
  -- this can happen if we are called with --ignore-times
  -- TODO make this impossible i.e. honor UseIndex here
  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

-- | Check if we have a valid index. This means that the index file exists, is
-- readable, and can be mmapped, /and/ that indexInvalidPath does /not/ exist.
-- We do not yet remove indexInvalidPath in case updating the index fails.
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
  -- this fails with a permission (access denied) error on windows
  -- if we use removeFileMayNotExist instead of renameFile
  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)

-- |Remove any patches (+dependencies) from a sequence that
-- conflict with the recorded or unrecorded changes in a repo
filterOutConflicts
  :: (RepoPatch p, ApplyState p ~ Tree)
  => Repository rt p wR wU wR     -- ^Repository itself, used for grabbing
                                  --  unrecorded changes
  -> FL (PatchInfoAnd rt p) wX wR -- ^Recorded patches from repository, starting from
                                  --  same context as the patches to filter
  -> FL (PatchInfoAnd rt p) wX wZ -- ^Patches to filter
  -> IO (Bool, Sealed (FL (PatchInfoAnd rt p) wX))
                                  -- ^True iff any patches were removed,
                                  --  possibly filtered patches
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 -- Note: use of anonymous is benign here since we only try to merge cleanly
          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

-- | Automatically detect file moves using the index.
-- TODO: This function lies about the witnesses.
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
        -- Input relation is left-and-right-unique. Makes cycle detection easier.
        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
                 -- destination is source of another move
                 | 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
                 -- parent of destination is also destination of a move
                 | 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

        -- rewrite [d/ -> e/, .., d/f -> e/h] to [d/ -> e/, .., e/f -> e/h]
        -- and throw out moves that don't move anything (can they be in there?)
        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 -- no effect, throw out
                        | 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
         -- TODO why adapt only if1 here and not if2?
         --      is this a bug?
         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)

-- | Search for possible replaces between the recordedAndPending state
-- and the unrecorded (or working) state. Return a Sealed FL list of
-- replace patches to be applied to the recordedAndPending state.
getReplaces :: forall rt p wR wU wT
             . (RepoPatch p, ApplyState p ~ Tree)
            => LookForReplaces
            -> DiffAlgorithm
            -> Repository rt p wR wU wT
            -> Tree IO -- ^ pending tree (including possibly detected moves)
            -> Tree IO -- ^ working tree
            -> IO (Tree IO, -- new pending tree
                   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) -- only keep lines with same number of tokens
            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 -> []

    -- from a pair of token lists, create a pair of modified token lists
    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 =
          -- inconsistency detected
          [(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
        -- the tree here is the "current" pending state
        Tree IO
tree <- forall s (m :: * -> *). MonadState s m => m s
get
        -- It would be nice if we could fuse the two traversals here, that is,
        -- expandPath and findFile. OTOH it is debatable whether adding a new
        -- effectful version of findFile to Darcs.Util.Tree is justified.
        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'
        -- make sure we can apply them to the pending state
        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


-- | Add an 'FL' of patches started from the pending state to the pending patch.
-- TODO: add witnesses for pending so we can make the types precise: currently
-- the passed patch can be applied in any context, not just after pending.
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

-- | Add an 'FL' of patches starting from the working state to the pending patch,
-- including as much extra context as is necessary (context meaning
-- dependencies), by commuting the patches to be added past as much of the
-- changes between pending and working as is possible, and including anything
-- that doesn't commute, and the patch itself in the new pending patch.
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)