-- 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, unrecordedChangesWithPatches, readPending
    -- * Trees
    , readRecorded, readUnrecorded, readRecordedAndPending, readWorking
    , readPendingAndWorking, readUnrecordedFiltered
    -- * Index
    , readIndex, updateIndex, invalidateIndex, UseIndex(..), ScanKnown(..)
    -- * Utilities
    , filterOutConflicts
    -- * Detection of changes
    , getMovesPs, getReplaces
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Monad( when, foldM )
import Control.Exception ( catch, IOException )
import Data.Maybe ( isJust, fromJust )
import Data.Ord ( comparing )
import Data.List ( sortBy, union, delete )
import Text.Regex( matchRegex )

import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile )
import System.FilePath ( (</>) )
import qualified Data.ByteString as B
    ( 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 ( effect, RepoPatch, PrimOf, sortCoalesceFL, fromPrim, fromPrims
                   , PrimPatch, primIsHunk, maybeApplyToTree
                   , tokreplace, forceTokReplace, move )
import Darcs.Patch.Named.Wrapped ( anonymous )
import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnFilePaths )
import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), (+>+), mapFL_FL
                                     , (:>)(..), reverseRL, reverseFL
                                     , mapFL, concatFL, toFL )
import Darcs.Patch.Witnesses.Eq ( EqCheck(IsEq, NotEq) )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal
                                    , freeGap, emptyGap, joinGap, FreeLeft, Gap(..) )
import Darcs.Patch.Commute ( selfCommuter )
import Darcs.Patch.CommuteFn ( commuterIdRL )
import Darcs.Patch.Permutations ( partitionConflictingFL, partitionRL )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )
import Darcs.Patch.Prim.V1 () -- instances Commute Prim and PrimPatch Prim
import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ), Prim(..) )
import Darcs.Patch.Prim.Class ( PrimConstruct, PrimCanonize )
import Darcs.Patch.TokenReplace ( breakToTokens, defaultToks )

import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(..) )
import Darcs.Util.Global ( darcsdir )

import Darcs.Repository.InternalTypes ( Repository(..) )
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, Name(..), fn2fp,
                   SubPath, sp2fn, filterPaths
                 , parents, replacePrefixPath, anchoredRoot
                 , toFilePath, simpleSubPath, normPath, floatSubPath )
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 { applyTreeFilter :: forall tr . FilterTree tr m => tr m -> tr m }

-- TODO: We wrap the pending patch inside RepoPatch here, to avoid the
-- requirement to propagate an (ApplyState (PrimOf p) ~ ApplyState p)
-- constraint everywhere. When we have GHC 7.2 as a minimum requirement, we can
-- lift this constraint into RepoPatch superclass context and remove this hack.
readPendingLL :: (RepoPatch p, ApplyState p ~ Tree)
              => Repository rt p wR wU wT -> IO (Sealed ((FL p) wT))
readPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` Pending.readPending repo

-- | 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 :: forall rt p m wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
                 => Repository rt p wR wU wT -> [SubPath]
                 -> IO (TreeFilter m)
restrictSubpaths repo subpaths = do
  Sealed pending <- readPendingLL repo
  let paths = map (fn2fp . sp2fn) subpaths
      paths' = paths `union` effectOnFilePaths pending paths
      anchored = map floatPath paths'
      restrictPaths :: FilterTree tree m => tree m -> tree m
      restrictPaths = Tree.filter (filterPaths anchored)
  return (TreeFilter restrictPaths)

maybeRestrictSubpaths :: forall rt p m wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
                      => Repository rt p wR wU wT
                      -> Maybe [SubPath]
                      -> IO (TreeFilter m)
maybeRestrictSubpaths repo = maybe (return $ TreeFilter id) (restrictSubpaths repo)

-- |Is the given path in (or equal to) the _darcs metadata directory?
inDarcsDir :: AnchoredPath -> Bool
inDarcsDir (AnchoredPath (Name x:_)) | x == BC.pack darcsdir = True
inDarcsDir _ = False

-- | Construct a Tree filter that removes any boring files the Tree might have
-- contained. Additionally, you should (in most cases) pass an (expanded) Tree
-- that corresponds to the recorded content of the repository. This is
-- important in the cases when the repository contains files that would be
-- boring otherwise. (If you pass emptyTree instead, such files will simply be
-- discarded by the filter, which is usually not what you want.)
--
-- This function is most useful when you have a plain Tree corresponding to the
-- full working copy of the repository, including untracked
-- files. Cf. whatsnew, record --look-for-adds.
restrictBoring :: forall m . Tree m -> IO (TreeFilter m)
restrictBoring guide = do
  boring <- boringRegexps
  let boring' p | inDarcsDir p = False
      boring' p = not $ any (\rx -> isJust $ matchRegex rx p') boring
          where p' = anchorPath "" p
      restrictTree :: FilterTree t m => t m -> t m
      restrictTree = Tree.filter $ \p _ -> case find guide p of
                                             Nothing -> boring' p
                                             _ -> True
  return (TreeFilter restrictTree)

-- | Construct a Tree filter that removes any darcs metadata files the
-- Tree might have contained.
restrictDarcsdir :: forall m . TreeFilter m
restrictDarcsdir = TreeFilter $ Tree.filter $ \p _ -> not (inDarcsDir 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: with LookForAdds, we will include
-- any non-boring files (i.e. also those that do not exist in the "recorded"
-- state) in the working in the "unrecorded" state, and therefore they will
-- show up in the patches as addfiles.
--
-- The IgnoreTimes option 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).
unrecordedChanges :: forall rt p wR wU wT . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
                  => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository rt p wR wU wT
                  -> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU)
unrecordedChanges = unrecordedChangesWithPatches NilFL NilFL

unrecordedChangesWithPatches :: forall rt p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
                  => FL (PrimOf p) wX wT -- look-for-moves patches
                  -> FL (PrimOf p) wT wT -- look-for-replaces patches
                  -> (UseIndex, ScanKnown, DiffAlgorithm) -> Repository rt p wR wU wT
                  -> Maybe [SubPath]
                  -> IO (FL (PrimOf p) wT wU)
unrecordedChangesWithPatches movPs replPs opts r paths = do
    (pending :> working) <- readPendingAndWorkingWithPatches movPs replPs opts r paths
    return $ sortCoalesceFL (pending +>+ unsafeCoerceP (movPs +>+ replPs) +>+ working)

-- | Mostly a helper function to 'unrecordedChangesWithPatches', returning the pending
--   patch plus `patches` and the subsequent diff from working as two different patches
readPendingAndWorkingWithPatches :: forall rt p wR wU wT wZ. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
                                 => FL (PrimOf p) wZ wT  -- look-for-moves patches
                                 -> FL (PrimOf p) wT wT  -- look-for-replaces patches
                                 -> (UseIndex, ScanKnown, DiffAlgorithm)
                                 -> Repository rt p wR wU wT
                                 -> Maybe [SubPath]
                                 -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU)
readPendingAndWorkingWithPatches _ _ _ r@(Repo _ rf _ _) _ | formatHas NoWorkingDir rf = do
    IsEq <- return $ workDirLessRepoWitness r
    return (NilFL :> NilFL)
readPendingAndWorkingWithPatches movPs replPs (useidx', scan, dflag) repo mbpaths = do
  let allPatches = movPs +>+ replPs
  let useidx = case allPatches of
                 NilFL -> useidx'
                 _ -> IgnoreIndex
  (all_current, Sealed (pending :: FL p wT wX)) <- readPending repo
  all_current_with_patches <- applyToTree allPatches all_current

  relevant <- maybeRestrictSubpaths repo mbpaths
  let getIndex = applyToTree movPs =<< I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo)
      current = applyTreeFilter relevant all_current_with_patches

  working <- filteredWorking useidx scan relevant getIndex current
  ft <- filetypeFunction
  Sealed (diff :: FL (PrimOf p) wX wY) <- (unFreeLeft `fmap` treeDiff dflag ft current working) :: IO (Sealed (FL (PrimOf p) wX))
  IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck wY wU)
  return (effect pending :> diff)

readPendingAndWorking :: forall rt p wR wU wT . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
                      => (UseIndex, ScanKnown, DiffAlgorithm)
                      -> Repository rt p wR wU wT
                      -> Maybe [SubPath]
                      -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU)
readPendingAndWorking = readPendingAndWorkingWithPatches NilFL NilFL

-- | @filteredWorking useidx scan relevant getIndex 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.

-- TODO: untangle the arguments and make this more orthogonal
filteredWorking :: UseIndex
              -> ScanKnown
              -> TreeFilter IO
              -> IO (Tree IO)
              -> Tree IO
              -> IO (Tree IO)
filteredWorking useidx scan relevant getIndex pending_tree = do
  index <- getIndex
  applyTreeFilter restrictDarcsdir <$> case scan of
    ScanKnown -> case useidx of
      UseIndex -> getIndex
      IgnoreIndex -> do
        guide <- expand pending_tree
        applyTreeFilter relevant . restrict guide <$> readPlainTree "."
    ScanAll -> do
      nonboring <- restrictBoring index
      plain <- applyTreeFilter relevant . applyTreeFilter nonboring <$> readPlainTree "."
      return $ case useidx of
        UseIndex -> plain `overlay` index
        IgnoreIndex -> plain
    ScanBoring -> do
      plain <- applyTreeFilter relevant <$> readPlainTree "."
      return $ case useidx of
        UseIndex -> plain `overlay` index
        IgnoreIndex -> 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 (Repo _ rf _ _)
 | formatHas NoWorkingDir rf = unsafeCoerceP IsEq
 | otherwise                 = 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 :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO (Tree IO)
readRecorded _repo = do
  let h_inventory = darcsdir </> "hashed_inventory"
  hashed <- doesFileExist h_inventory
  if hashed
     then do inv <- B.readFile h_inventory
             let linesInv = BC.split '\n' inv
             case linesInv of
               [] -> return emptyTree
               (pris_line:_) -> do
                          let hash = decodeDarcsHash $ B.drop 9 pris_line
                              size = decodeDarcsSize $ B.drop 9 pris_line
                          when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line
                          readDarcsHashed (darcsdir </> "pristine.hashed") (size, hash)
     else do have_pristine <- doesDirectoryExist $ darcsdir </> "pristine"
             have_current <- doesDirectoryExist $ darcsdir </> "current"
             case (have_pristine, have_current) of
               (True, _) -> readPlainTree $ darcsdir </> "pristine"
               (False, True) -> readPlainTree $ darcsdir </> "current"
               (_, _) -> 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 repo mbpaths = do
  relevant <- maybeRestrictSubpaths repo mbpaths
  readIndex repo >>= I.updateIndex . applyTreeFilter 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
                       -> Maybe [SubPath] -> IO (Tree IO)
readUnrecordedFiltered repo useidx scan mbpaths = do
  (all_current, _) <- readPending repo -- we have no need for the pending patch
  relevant <- maybeRestrictSubpaths repo mbpaths
  let getIndex = I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo)
      current = applyTreeFilter relevant all_current
  filteredWorking useidx scan relevant getIndex current

-- | Obtains a Tree corresponding to the complete working copy of the
-- repository (modified and non-modified files).
readWorking :: IO (Tree IO)
readWorking = expand =<< (nodarcs `fmap` readPlainTree ".")
  where nodarcs = Tree.filter (\(AnchoredPath (Name x:_)) _ -> x /= BC.pack darcsdir)

-- | Obtains the same Tree as 'readRecorded' would but with the additional side
--   effect of reading/checking the pending patch.
readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree)
                       => Repository rt p wR wU wT -> IO (Tree IO)
readRecordedAndPending repo = fst `fmap` readPending repo

-- | Obtains a Tree corresponding to the recorded state of the repository
--   and a pending patch to go with it. 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 p wT))
readPending repo =
  do Sealed pending <- readPendingLL repo
     pristine <- readRecorded repo
     catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ (err :: IOException) -> do
       putStrLn $ "Yikes, pending has conflicts! " ++ show err
       putStrLn "Stashing the buggy pending as _darcs/patches/pending_buggy"
       renameFile (darcsdir </> "patches" </> "pending")
                  (darcsdir </> "patches" </> "pending_buggy")
       return (pristine, seal NilFL)

-- | 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 _ = B.writeFile (darcsdir </> "index_invalid") B.empty

readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO I.Index
readIndex repo = do
  invalid <- doesFileExist $ darcsdir </> "index_invalid"
  exists <- doesFileExist $ darcsdir </> "index"
  formatValid <- if exists
                     then I.indexFormatValid $ darcsdir </> "index"
                     else return True
  when (exists && not formatValid) $ removeFile $ darcsdir </> "index"
  if not exists || invalid || not formatValid
     then do pris <- readRecordedAndPending repo
             idx <- I.updateIndexFrom (darcsdir </> "index") darcsTreeHash pris
             when invalid $ removeFile $ darcsdir </> "index_invalid"
             return idx
     else I.readIndex (darcsdir </> "index") darcsTreeHash

updateIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> IO ()
updateIndex repo = do
    invalid <- doesFileExist $ darcsdir </> "index_invalid"
    exists <- doesFileExist $ darcsdir </> "index"
    formatValid <- if exists
                     then I.indexFormatValid $ darcsdir </> "index"
                     else return True
    when (exists && not formatValid) $ removeFile $ darcsdir </> "index"
    pris <- readRecordedAndPending repo
    _ <- I.updateIndexFrom (darcsdir </> "index") darcsTreeHash pris
    when invalid $ removeFile $ darcsdir </> "index_invalid"

-- |Remove any patches (+dependencies) from a sequence that
-- conflict with the recorded or unrecorded changes in a repo
filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf 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 us repository them
     = do let commuter = commuterIdRL selfCommuter
          unrec <- fmap n2pia . anonymous . fromPrims
                     =<< unrecordedChanges (UseIndex, ScanKnown, MyersDiff) repository Nothing
          them' :> rest <- return $ partitionConflictingFL commuter them (us :<: unrec)
          return (check rest, Sealed them')
  where check :: FL p wA wB -> Bool
        check NilFL = False
        check _ = True

-- |Automatically detect file moves using the index
getMovesPs :: forall rt p wR wU wB prim.
              (PrimConstruct prim, PrimCanonize prim, RepoPatch p,
               ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
           => Repository rt p wR wU wR
           -> Maybe [SubPath]
           -> IO (FL prim wB wB)
getMovesPs repository files = mkMovesFL <$> getMovedFiles repository files
  where
    mkMovesFL [] = NilFL
    mkMovesFL ((a,b,_):xs) = move (anchorPath "" a) (anchorPath "" b) :>: mkMovesFL xs

    getMovedFiles :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
                  => Repository rt p wR wU wR
                  -> Maybe [SubPath]
                  -> IO [(AnchoredPath, AnchoredPath, ItemType)]
    getMovedFiles repo fs = do
        old <- sortBy (comparing snd) <$> (listFileIDs =<< readIndex repo)
        nonboring <- restrictBoring emptyTree
        let addIDs = foldM (\xs (p, it)-> do mfid <- getFileID p
                                             return $ case mfid of
                                               Nothing -> xs
                                               Just fid -> ((p, it), fid):xs) []
        new <- sortBy (comparing snd) <$>
                 (addIDs . map (\(a,b) -> (a, itemType b)) . Tree.list  =<<
                   expand =<< applyTreeFilter nonboring <$> readPlainTree ".")
        let match (x:xs) (y:ys) | snd x > snd y = match (x:xs) ys
                                | snd x < snd y = match xs (y:ys)
                                | snd (fst x) /= snd (fst y) = match xs ys
                                | otherwise = (fst (fst x), fst (fst y), snd (fst x)):match xs ys
            match _ _ = []
            movedfiles = match old new
            fmovedfiles = case fs of
                            Nothing -> movedfiles
                            Just subpath -> filter (\(f1,f2,_) -> any (`elem` selfiles) [f1,f2]) movedfiles
                                               where selfiles = map (floatPath . toFilePath) subpath
        return (resolve fmovedfiles)

    resolve :: [(AnchoredPath, AnchoredPath, ItemType)] -> [(AnchoredPath, AnchoredPath, ItemType)]
    resolve xs = fixPaths $ sortMoves $ deleteCycles xs
      where
        -- Input relation is left-and-right-unique. Makes cycle detection easier.
        deleteCycles [] = []
        deleteCycles whole@( x@(start,_,_):rest)
            = if hasCycle start whole start
                  then deleteCycles (deleteFrom start whole [])
                  else x:deleteCycles rest
           where hasCycle current ((a',b',_):rest') first
                     | a' == current = b' == first || hasCycle b' whole first
                     | otherwise     = hasCycle current rest' first 
                 hasCycle _ [] _     = False
                 deleteFrom a (y@(a',b',_):ys) seen
                   | a == a'   = deleteFrom b' (seen++ys) []
                   | otherwise = deleteFrom a ys (y:seen)
                 deleteFrom _ [] seen = seen

        sortMoves []                           = []
        sortMoves whole@(current@(_,dest,_):_) =
              smallest:sortMoves (delete smallest whole)
              where
               smallest = follow dest whole current
               follow prevDest (y@(s,d,_):ys) currentSmallest
                 -- destination is source of another move
                 | prevDest == s             = follow d whole y
                 -- parent of destination is also destination of a move
                 | d `elem` parents prevDest = follow d whole y
                 | otherwise     = follow prevDest ys currentSmallest
               follow _ [] currentSmallest = currentSmallest

        -- rewrite [d/ -> e/, .., d/f -> e/h] to [d/ -> e/, .., e/f -> e/h]
        fixPaths [] = []
        fixPaths (y@(f1,f2,t):ys)
                        | f1 == f2         = fixPaths ys
                        | TreeType <- t    = y:fixPaths (map replacepp ys)
                        | otherwise        = y:fixPaths ys
         where replacepp i@(if1,if2,it) | nfst == anchoredRoot = i
                                        | otherwise = (nfst, if2, it)
                where nfst = replacePrefixPath f1 f2 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 wX. (RepoPatch p, ApplyState p ~ Tree,
                          ApplyState (PrimOf p) ~ Tree, wX ~ wR)
                       => (UseIndex, ScanKnown, DiffAlgorithm)
                       -> Repository rt p wR wU wT
                       -> Maybe [SubPath]
                       -> IO (Sealed (FL (PrimOf p) wX))
getReplaces (useindex, scan, dopts) repo files = do
    relevant <- maybeRestrictSubpaths repo files
    working <- readUnrecordedFiltered repo useindex scan files
    pending <- applyTreeFilter relevant <$> readRecordedAndPending repo
    ftf <- filetypeFunction

    Sealed changes <- unFreeLeft <$> treeDiff dopts ftf pending working
    _ :> hunks <- return $ partitionRL primIsHunk $ reverseFL changes
    let allModifiedTokens = concat $ mapFL modifiedTokens (reverseRL hunks)
        replaces = rmInvalidReplaces allModifiedTokens
    mapSeal concatFL . toFL <$>
        mapM (\(f,a,b) -> doReplace defaultToks pending
                            (fromJust $ simpleSubPath $ fn2fp $ normPath f)
                            (BC.unpack a) (BC.unpack b)) replaces
  where -- get individual tokens that have been modified
        modifiedTokens (FP f (Hunk _ old new)) = -- old and new are list of lines (= 1 bytestring per line)
          map (\(a,b) -> (f, a, b)) (concatMap checkModified $
             filter (\(a,b) -> length a == length b) -- only keep lines with same number of tokens
                  $ zip (map breakToTokens old) (map breakToTokens new))
        modifiedTokens _ = error "modifiedTokens: Not Hunk patch"

        -- from a pair of token lists, create a pair of modified token lists
        checkModified = filter (\(a,b) -> a/=b) . uncurry zip

        rmInvalidReplaces [] = []
        rmInvalidReplaces ((f,old,new):rs)
          | any (\(f',a,b) -> f' == f && old == a && b /= new) rs = -- inconsistency detected
              rmInvalidReplaces $ filter (\(f'',a',_) -> f'' /= f || a' /= old) rs
        rmInvalidReplaces (r:rs) = r:rmInvalidReplaces (filter (/=r) rs)

        doReplace toks pend f old new = do
            let maybeReplace p = isJust <$> maybeApplyToTree replacePatch p
            pendReplaced <- maybeReplace pend
            if pendReplaced
                then return $ joinGap (:>:) (freeGap replacePatch) (emptyGap NilFL)
                else getForceReplace f toks pend old new
          where
            replacePatch = tokreplace (toFilePath f) toks old new

        getForceReplace :: PrimPatch prim => SubPath -> String -> Tree IO -> String -> String
                        -> IO (FreeLeft (FL prim))
        getForceReplace f toks tree old new = do
            let path = floatSubPath f
            -- 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.
            expandedTree <- expandPath tree path
            content <- case findFile expandedTree path of
              Just blob -> readBlob blob
              Nothing -> error $ "getForceReplace: not in tree: " ++ show path
            let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old)
                                (B.concat $ BL.toChunks content)
                tree' = modifyTree expandedTree path . Just . File $ makeBlobBS newcontent
            ftf <- filetypeFunction
            normaliseNewTokPatch <- treeDiff dopts ftf expandedTree tree'
            return . joinGap (+>+) normaliseNewTokPatch $ freeGap $
                tokreplace (toFilePath f) toks old new :>: NilFL