{-# 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
    , maybeRestrictSubpaths
    -- * Diffs
    , unrecordedChanges, readPending
    -- * 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 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 }

-- | From a repository and a list of SubPath'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 -> [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

-- | 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) 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)

-- |Is the given path in (or equal to) the _darcs metadata directory?
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

-- | 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 :: 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)

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

{- |
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 copy + 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 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)

-- 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 :: 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             -- pristine with (pending + moves)
        , Tree IO             -- working
        , FL (PrimOf p) wT wU -- pending + moves
        )
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 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 == 'ScanKnown'@ to act as
-- a guide for filtering the working tree.
-- Note that even if @useidx '==' 'IgnoreIndex'@, the index is still used
-- to avoid filtering boring files that darcs knows about (see 'restrictBoring').
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

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

-- | 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 :: 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!"

-- | 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 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

-- | 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 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

-- | Obtains a Tree corresponding to the complete working copy of the
-- repository (modified and non-modified files).
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 ".")

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

-- | 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), but we've set to
--   say it starts at the tentative state.
--
--   Question (Eric Kow) Is this a bug? Darcs.Repository.Pending.readPending
--   says it is
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"

-- | Mark the existing index as invalid. This has to be called whenever the
-- listing of pristine changes and will cause darcs to update the index next
-- time it tries to read it. (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 :: 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
-- TODO this conditional logic (rename or delete) is mirrored in
-- Darcs.Util.Index.updateIndexFrom and should be refactored
#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)

-- |Remove any patches (+dependencies) from a sequence that
-- conflict with the recorded or unrecorded changes in a repo
filterOutConflicts
  :: (RepoPatch p, ApplyState p ~ Tree)
  => RL (PatchInfoAnd rt p) wX wT -- ^Recorded patches from repository, starting from
                                  --  same context as the patches to filter
  -> Repository rt p wR wU wT     -- ^Repository itself, used for grabbing
                                  --  unrecorded changes
  -> 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 :: 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

-- | Automatically detect file moves using the index.
-- TODO: This function lies about the witnesses.
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
        -- 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@(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
                 -- destination is source of another move
                 | 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
                 -- parent of destination is also destination of a move
                 | 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

        -- rewrite [d/ -> e/, .., d/f -> e/h] to [d/ -> e/, .., e/f -> e/h]
        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

-- | 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 :: 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) -- only keep lines with same number of tokens
            ([([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 -> []

    -- from a pair of token lists, create a pair of modified token lists
    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 =
          -- inconsistency detected
          [(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
        -- the tree here is the "current" pending state
        Tree IO
tree <- StateT (Tree IO) IO (Tree IO)
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 <- 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'
        -- make sure we can apply them to the pending state
        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


-- | 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 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

-- | 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 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