{-# LANGUAGE NamedFieldPuns #-}

{-|
License : GPL-2

The patch-index stores additional information that is extracted from
the PatchSet for the repository to speed up certain commands (namely
@log@ and @annotate@). More precisely, for every file tracked by the
repository, it stores the list of patches that touch it.

When created, patch-index lives in @_darcs\/patch_index\/@, and it
should be automatically maintained each time the set of patches of
the repository is updated.

Patch-index can also be explicitely disabled by creating a file
@_darcs\/no_patch_index@. "Explicitely disabed" means that no command
should attempt to automatically create the patch-index.

See <http://darcs.net/Internals/PatchIndex> for more information.
-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Darcs.Repository.PatchIndex
    ( doesPatchIndexExist
    , isPatchIndexDisabled
    , isPatchIndexInSync
    , canUsePatchIndex
    , createPIWithInterrupt
    , createOrUpdatePatchIndexDisk
    , deletePatchIndex
    , attemptCreatePatchIndex
    , PatchFilter
    , maybeFilterPatches
    , getRelevantSubsequence
    , dumpPatchIndex
    , piTest
    ) where

import Darcs.Prelude

import Control.Exception ( catch )
import Control.Monad ( forM_, unless, when, (>=>) )
import Control.Monad.State.Strict ( evalState, execState, State, gets, modify )

import Data.Binary ( Binary, encodeFile, decodeFileOrFail )
import qualified Data.ByteString as B
import Data.Int ( Int8 )
import Data.List ( mapAccumL, sort, nub, (\\) )
import Data.Maybe ( catMaybes, fromJust, fromMaybe )
import qualified Data.IntSet as I
import qualified Data.Map as M
import qualified Data.Set as S

import Safe ( tailErr )

import System.Directory
    ( createDirectory
    , doesDirectoryExist
    , doesFileExist
    , removeDirectoryRecursive
    , removeFile
    , renameDirectory
    , copyPermissions
    )
import System.FilePath( (</>) )
import System.IO ( openFile, IOMode(WriteMode), hClose )

import Darcs.Patch ( RepoPatch, listTouchedFiles )
import Darcs.Patch.Apply ( ApplyState, Apply )
import Darcs.Patch.Index.Types
    ( FileId(..)
    , PatchId
    , makePatchID
    , pid2string
    , short
    , showFileId
    , zero
    )
import Darcs.Patch.Index.Monad ( FileMod(..), applyToFileMods )
import Darcs.Patch.Inspect ( PatchInspect )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )
import Darcs.Patch.Progress (progressFL )
import Darcs.Patch.Set ( PatchSet, patchSet2FL, Origin, patchSet2FL )
import Darcs.Patch.Witnesses.Ordered ( mapFL, RL(..), FL(..), reverseRL )
import Darcs.Patch.Witnesses.Sealed
    ( Sealed2(..)
    , Sealed(..)
    , seal
    , seal2
    , unseal
    , unseal2
    )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )

import Darcs.Repository.Format ( formatHas, RepoProperty( HashedInventory ) )
import Darcs.Repository.InternalTypes ( Repository, repoLocation, repoFormat )
import Darcs.Repository.Paths ( hashedInventoryPath )

import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Hash ( sha256sum, showAsHex )
import Darcs.Util.Lock ( withPermDir )
import Darcs.Util.Path ( AnchoredPath, displayPath, isRoot, parents, toFilePath )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.SignalHandler ( catchInterrupt )
import Darcs.Util.Tree ( Tree(..) )

type Map = M.Map
type Set = S.Set
type IntSet = I.IntSet

data FileIdSpan = FidSpan
  !FileId                   -- ^ the fileid has some fixed name in the
  !PatchId                  -- ^ span starting here
  !(Maybe PatchId)          -- ^ and (maybe) ending here
  deriving (Key -> FileIdSpan -> ShowS
[FileIdSpan] -> ShowS
FileIdSpan -> FilePath
(Key -> FileIdSpan -> ShowS)
-> (FileIdSpan -> FilePath)
-> ([FileIdSpan] -> ShowS)
-> Show FileIdSpan
forall a.
(Key -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Key -> FileIdSpan -> ShowS
showsPrec :: Key -> FileIdSpan -> ShowS
$cshow :: FileIdSpan -> FilePath
show :: FileIdSpan -> FilePath
$cshowList :: [FileIdSpan] -> ShowS
showList :: [FileIdSpan] -> ShowS
Show, FileIdSpan -> FileIdSpan -> Bool
(FileIdSpan -> FileIdSpan -> Bool)
-> (FileIdSpan -> FileIdSpan -> Bool) -> Eq FileIdSpan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileIdSpan -> FileIdSpan -> Bool
== :: FileIdSpan -> FileIdSpan -> Bool
$c/= :: FileIdSpan -> FileIdSpan -> Bool
/= :: FileIdSpan -> FileIdSpan -> Bool
Eq, Eq FileIdSpan
Eq FileIdSpan =>
(FileIdSpan -> FileIdSpan -> Ordering)
-> (FileIdSpan -> FileIdSpan -> Bool)
-> (FileIdSpan -> FileIdSpan -> Bool)
-> (FileIdSpan -> FileIdSpan -> Bool)
-> (FileIdSpan -> FileIdSpan -> Bool)
-> (FileIdSpan -> FileIdSpan -> FileIdSpan)
-> (FileIdSpan -> FileIdSpan -> FileIdSpan)
-> Ord FileIdSpan
FileIdSpan -> FileIdSpan -> Bool
FileIdSpan -> FileIdSpan -> Ordering
FileIdSpan -> FileIdSpan -> FileIdSpan
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FileIdSpan -> FileIdSpan -> Ordering
compare :: FileIdSpan -> FileIdSpan -> Ordering
$c< :: FileIdSpan -> FileIdSpan -> Bool
< :: FileIdSpan -> FileIdSpan -> Bool
$c<= :: FileIdSpan -> FileIdSpan -> Bool
<= :: FileIdSpan -> FileIdSpan -> Bool
$c> :: FileIdSpan -> FileIdSpan -> Bool
> :: FileIdSpan -> FileIdSpan -> Bool
$c>= :: FileIdSpan -> FileIdSpan -> Bool
>= :: FileIdSpan -> FileIdSpan -> Bool
$cmax :: FileIdSpan -> FileIdSpan -> FileIdSpan
max :: FileIdSpan -> FileIdSpan -> FileIdSpan
$cmin :: FileIdSpan -> FileIdSpan -> FileIdSpan
min :: FileIdSpan -> FileIdSpan -> FileIdSpan
Ord)

data FilePathSpan = FpSpan
  !AnchoredPath             -- ^ the file path has some fixed fileid in the
  !PatchId                  -- ^ span starting here
  !(Maybe PatchId)          -- ^ and (maybe) ending here
  deriving (Key -> FilePathSpan -> ShowS
[FilePathSpan] -> ShowS
FilePathSpan -> FilePath
(Key -> FilePathSpan -> ShowS)
-> (FilePathSpan -> FilePath)
-> ([FilePathSpan] -> ShowS)
-> Show FilePathSpan
forall a.
(Key -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Key -> FilePathSpan -> ShowS
showsPrec :: Key -> FilePathSpan -> ShowS
$cshow :: FilePathSpan -> FilePath
show :: FilePathSpan -> FilePath
$cshowList :: [FilePathSpan] -> ShowS
showList :: [FilePathSpan] -> ShowS
Show, FilePathSpan -> FilePathSpan -> Bool
(FilePathSpan -> FilePathSpan -> Bool)
-> (FilePathSpan -> FilePathSpan -> Bool) -> Eq FilePathSpan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FilePathSpan -> FilePathSpan -> Bool
== :: FilePathSpan -> FilePathSpan -> Bool
$c/= :: FilePathSpan -> FilePathSpan -> Bool
/= :: FilePathSpan -> FilePathSpan -> Bool
Eq, Eq FilePathSpan
Eq FilePathSpan =>
(FilePathSpan -> FilePathSpan -> Ordering)
-> (FilePathSpan -> FilePathSpan -> Bool)
-> (FilePathSpan -> FilePathSpan -> Bool)
-> (FilePathSpan -> FilePathSpan -> Bool)
-> (FilePathSpan -> FilePathSpan -> Bool)
-> (FilePathSpan -> FilePathSpan -> FilePathSpan)
-> (FilePathSpan -> FilePathSpan -> FilePathSpan)
-> Ord FilePathSpan
FilePathSpan -> FilePathSpan -> Bool
FilePathSpan -> FilePathSpan -> Ordering
FilePathSpan -> FilePathSpan -> FilePathSpan
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FilePathSpan -> FilePathSpan -> Ordering
compare :: FilePathSpan -> FilePathSpan -> Ordering
$c< :: FilePathSpan -> FilePathSpan -> Bool
< :: FilePathSpan -> FilePathSpan -> Bool
$c<= :: FilePathSpan -> FilePathSpan -> Bool
<= :: FilePathSpan -> FilePathSpan -> Bool
$c> :: FilePathSpan -> FilePathSpan -> Bool
> :: FilePathSpan -> FilePathSpan -> Bool
$c>= :: FilePathSpan -> FilePathSpan -> Bool
>= :: FilePathSpan -> FilePathSpan -> Bool
$cmax :: FilePathSpan -> FilePathSpan -> FilePathSpan
max :: FilePathSpan -> FilePathSpan -> FilePathSpan
$cmin :: FilePathSpan -> FilePathSpan -> FilePathSpan
min :: FilePathSpan -> FilePathSpan -> FilePathSpan
Ord)

-- | info about a given fileid
data FileInfo = FileInfo
  { FileInfo -> Bool
isFile :: Bool          -- ^ whether file or dir
  , FileInfo -> IntSet
touching :: IntSet      -- ^ first words of patch hashes
  } deriving (Key -> FileInfo -> ShowS
[FileInfo] -> ShowS
FileInfo -> FilePath
(Key -> FileInfo -> ShowS)
-> (FileInfo -> FilePath) -> ([FileInfo] -> ShowS) -> Show FileInfo
forall a.
(Key -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Key -> FileInfo -> ShowS
showsPrec :: Key -> FileInfo -> ShowS
$cshow :: FileInfo -> FilePath
show :: FileInfo -> FilePath
$cshowList :: [FileInfo] -> ShowS
showList :: [FileInfo] -> ShowS
Show, FileInfo -> FileInfo -> Bool
(FileInfo -> FileInfo -> Bool)
-> (FileInfo -> FileInfo -> Bool) -> Eq FileInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileInfo -> FileInfo -> Bool
== :: FileInfo -> FileInfo -> Bool
$c/= :: FileInfo -> FileInfo -> Bool
/= :: FileInfo -> FileInfo -> Bool
Eq, Eq FileInfo
Eq FileInfo =>
(FileInfo -> FileInfo -> Ordering)
-> (FileInfo -> FileInfo -> Bool)
-> (FileInfo -> FileInfo -> Bool)
-> (FileInfo -> FileInfo -> Bool)
-> (FileInfo -> FileInfo -> Bool)
-> (FileInfo -> FileInfo -> FileInfo)
-> (FileInfo -> FileInfo -> FileInfo)
-> Ord FileInfo
FileInfo -> FileInfo -> Bool
FileInfo -> FileInfo -> Ordering
FileInfo -> FileInfo -> FileInfo
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FileInfo -> FileInfo -> Ordering
compare :: FileInfo -> FileInfo -> Ordering
$c< :: FileInfo -> FileInfo -> Bool
< :: FileInfo -> FileInfo -> Bool
$c<= :: FileInfo -> FileInfo -> Bool
<= :: FileInfo -> FileInfo -> Bool
$c> :: FileInfo -> FileInfo -> Bool
> :: FileInfo -> FileInfo -> Bool
$c>= :: FileInfo -> FileInfo -> Bool
>= :: FileInfo -> FileInfo -> Bool
$cmax :: FileInfo -> FileInfo -> FileInfo
max :: FileInfo -> FileInfo -> FileInfo
$cmin :: FileInfo -> FileInfo -> FileInfo
min :: FileInfo -> FileInfo -> FileInfo
Ord)

-- | timespans where a certain filename corresponds to a file with a given id
type FileIdSpans = Map AnchoredPath [FileIdSpan]

-- | timespans where a file with a certain id corresponds to given filenames
type FilePathSpans = Map FileId [FilePathSpan]

-- | information file with a given ID
type InfoMap = Map FileId FileInfo

-- | the patch-index
data PatchIndex = PatchIndex
  { PatchIndex -> [PatchId]
pids :: [PatchId]
    -- ^ all the 'PatchId's tracked by this patch index, with the most
    -- recent patch at the head of the list (note, stored in the
    -- reverse order on disk for backwards compatibility
    -- with an older format).
  , PatchIndex -> FileIdSpans
fidspans :: FileIdSpans
  , PatchIndex -> FilePathSpans
fpspans :: FilePathSpans
  , PatchIndex -> InfoMap
infom :: InfoMap
  }

-- | On-disk version of patch index
--   version 1 is the one introduced in darcs 2.10
--           2 changes the pids order to newer-to-older
--           3 changes FileName to AnchoredPath everywhere, which has
--             different Binary (and Ord) instances
--           4 adds all parent dirs of each file or dir as
--             being touched by a patch
--           5 replaces Set Word32 with IntSet

version :: Int8
version :: Int8
version = Int8
5

type PIM a = State PatchIndex a

-- | 'applyPatchMods pmods pindex' applies a list of PatchMods to the given
--   patch index pindex
applyPatchMods :: [(PatchId, [FileMod AnchoredPath])] -> PatchIndex -> PatchIndex
applyPatchMods :: [(PatchId, [FileMod AnchoredPath])] -> PatchIndex -> PatchIndex
applyPatchMods [(PatchId, [FileMod AnchoredPath])]
pmods PatchIndex
pindex =
  (State PatchIndex () -> PatchIndex -> PatchIndex)
-> PatchIndex -> State PatchIndex () -> PatchIndex
forall a b c. (a -> b -> c) -> b -> a -> c
flip State PatchIndex () -> PatchIndex -> PatchIndex
forall s a. State s a -> s -> s
execState PatchIndex
pindex (State PatchIndex () -> PatchIndex)
-> State PatchIndex () -> PatchIndex
forall a b. (a -> b) -> a -> b
$ ((PatchId, [FileMod AnchoredPath]) -> State PatchIndex ())
-> [(PatchId, [FileMod AnchoredPath])] -> State PatchIndex ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (PatchId, [FileMod AnchoredPath]) -> State PatchIndex ()
goList [(PatchId, [FileMod AnchoredPath])]
pmods
 where goList :: (PatchId, [FileMod AnchoredPath]) -> PIM ()
       goList :: (PatchId, [FileMod AnchoredPath]) -> State PatchIndex ()
goList (PatchId
pid, [FileMod AnchoredPath]
mods) = do
           (PatchIndex -> PatchIndex) -> State PatchIndex ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PatchIndex
pind -> PatchIndex
pind{pids = pid:pids pind})
           (FileMod AnchoredPath -> State PatchIndex ())
-> [FileMod AnchoredPath] -> State PatchIndex ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((PatchId, FileMod AnchoredPath) -> State PatchIndex ())
-> PatchId -> FileMod AnchoredPath -> State PatchIndex ()
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (PatchId, FileMod AnchoredPath) -> State PatchIndex ()
go PatchId
pid) [FileMod AnchoredPath]
mods
       go :: (PatchId, FileMod AnchoredPath) -> PIM ()
       go :: (PatchId, FileMod AnchoredPath) -> State PatchIndex ()
go (PatchId
pid, PCreateFile AnchoredPath
fn) = do
         fid <- AnchoredPath -> PatchId -> PIM FileId
createFidStartSpan AnchoredPath
fn PatchId
pid
         startFpSpan fid fn pid
         createInfo fid True
         insertTouch pid fid
         insertParentsTouch pid fn
       go (PatchId
pid, PCreateDir AnchoredPath
fn) = do
         fid <- AnchoredPath -> PatchId -> PIM FileId
createFidStartSpan AnchoredPath
fn PatchId
pid
         startFpSpan fid fn pid
         createInfo fid False
         insertTouch pid fid
         insertParentsTouch pid fn
       go (PatchId
pid, PTouch AnchoredPath
fn) = do
         fid <- AnchoredPath -> PIM FileId
lookupFid AnchoredPath
fn
         insertTouch pid fid
         insertParentsTouch pid fn
       go (PatchId
pid, PRename AnchoredPath
oldfn AnchoredPath
newfn) = do
         fid <- AnchoredPath -> PIM FileId
lookupFid AnchoredPath
oldfn
         stopFpSpan fid pid
         startFpSpan fid newfn pid
         insertTouch pid fid
         insertParentsTouch pid oldfn
         insertParentsTouch pid newfn
         stopFidSpan oldfn pid
         startFidSpan newfn pid fid
       go (PatchId
pid, PRemove AnchoredPath
fn) = do
         fid <- AnchoredPath -> PIM FileId
lookupFid AnchoredPath
fn
         insertTouch pid fid
         insertParentsTouch pid fn
         stopFidSpan fn pid
         stopFpSpan fid pid
       go (PatchId
pid, PDuplicateTouch AnchoredPath
fn) = do
         fidm <- (PatchIndex -> FileIdSpans)
-> StateT PatchIndex Identity FileIdSpans
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PatchIndex -> FileIdSpans
fidspans
         case M.lookup fn fidm of
           Just (FidSpan FileId
fid PatchId
_ Maybe PatchId
_:[FileIdSpan]
_) -> do
             PatchId -> FileId -> State PatchIndex ()
insertTouch PatchId
pid FileId
fid
             PatchId -> AnchoredPath -> State PatchIndex ()
insertParentsTouch PatchId
pid AnchoredPath
fn
           Maybe [FileIdSpan]
Nothing -> () -> State PatchIndex ()
forall a. a -> StateT PatchIndex Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           Just [] -> FilePath -> State PatchIndex ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> State PatchIndex ())
-> FilePath -> State PatchIndex ()
forall a b. (a -> b) -> a -> b
$ FilePath
"applyPatchMods: impossible, no entry for "FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++AnchoredPath -> FilePath
forall a. Show a => a -> FilePath
show AnchoredPath
fn
                              FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
" in FileIdSpans in duplicate, empty list"

-- | create new filespan for created file
createFidStartSpan :: AnchoredPath -> PatchId -> PIM FileId
createFidStartSpan :: AnchoredPath -> PatchId -> PIM FileId
createFidStartSpan AnchoredPath
fn PatchId
pstart = do
  fidspans <- (PatchIndex -> FileIdSpans)
-> StateT PatchIndex Identity FileIdSpans
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PatchIndex -> FileIdSpans
fidspans
  case M.lookup fn fidspans of
    Maybe [FileIdSpan]
Nothing -> do
      let fid :: FileId
fid = AnchoredPath -> Key -> FileId
FileId AnchoredPath
fn Key
1
      (PatchIndex -> PatchIndex) -> State PatchIndex ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PatchIndex
pind -> PatchIndex
pind {fidspans=M.insert fn [FidSpan fid pstart Nothing] fidspans})
      FileId -> PIM FileId
forall a. a -> StateT PatchIndex Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return FileId
fid
    Just [FileIdSpan]
fspans -> do
      let fid :: FileId
fid = AnchoredPath -> Key -> FileId
FileId AnchoredPath
fn ([FileIdSpan] -> Key
forall a. [a] -> Key
forall (t :: * -> *) a. Foldable t => t a -> Key
length [FileIdSpan]
fspansKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1)
      (PatchIndex -> PatchIndex) -> State PatchIndex ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PatchIndex
pind -> PatchIndex
pind {fidspans=M.insert fn (FidSpan fid pstart Nothing:fspans) fidspans})
      FileId -> PIM FileId
forall a. a -> StateT PatchIndex Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return FileId
fid

-- | start new span for name fn for file fid starting with patch pid
startFpSpan :: FileId -> AnchoredPath -> PatchId -> PIM ()
startFpSpan :: FileId -> AnchoredPath -> PatchId -> State PatchIndex ()
startFpSpan FileId
fid AnchoredPath
fn PatchId
pstart = (PatchIndex -> PatchIndex) -> State PatchIndex ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PatchIndex
pind -> PatchIndex
pind {fpspans=M.alter alt fid (fpspans pind)})
  where alt :: Maybe [FilePathSpan] -> Maybe [FilePathSpan]
alt Maybe [FilePathSpan]
Nothing = [FilePathSpan] -> Maybe [FilePathSpan]
forall a. a -> Maybe a
Just [AnchoredPath -> PatchId -> Maybe PatchId -> FilePathSpan
FpSpan AnchoredPath
fn PatchId
pstart Maybe PatchId
forall a. Maybe a
Nothing]
        alt (Just [FilePathSpan]
spans) = [FilePathSpan] -> Maybe [FilePathSpan]
forall a. a -> Maybe a
Just (AnchoredPath -> PatchId -> Maybe PatchId -> FilePathSpan
FpSpan AnchoredPath
fn PatchId
pstart Maybe PatchId
forall a. Maybe a
NothingFilePathSpan -> [FilePathSpan] -> [FilePathSpan]
forall a. a -> [a] -> [a]
:[FilePathSpan]
spans)

-- | stop current span for file name fn
stopFpSpan :: FileId -> PatchId -> PIM ()
stopFpSpan :: FileId -> PatchId -> State PatchIndex ()
stopFpSpan FileId
fid PatchId
pend = (PatchIndex -> PatchIndex) -> State PatchIndex ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PatchIndex
pind -> PatchIndex
pind {fpspans=M.alter alt fid (fpspans pind)})
  where alt :: Maybe [FilePathSpan] -> Maybe [FilePathSpan]
alt Maybe [FilePathSpan]
Nothing = FilePath -> Maybe [FilePathSpan]
forall a. HasCallStack => FilePath -> a
error (FilePath -> Maybe [FilePathSpan])
-> FilePath -> Maybe [FilePathSpan]
forall a b. (a -> b) -> a -> b
$ FilePath
"impossible: no span for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FileId -> FilePath
forall a. Show a => a -> FilePath
show FileId
fid
        alt (Just []) = FilePath -> Maybe [FilePathSpan]
forall a. HasCallStack => FilePath -> a
error (FilePath -> Maybe [FilePathSpan])
-> FilePath -> Maybe [FilePathSpan]
forall a b. (a -> b) -> a -> b
$ FilePath
"impossible: no span for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FileId -> FilePath
forall a. Show a => a -> FilePath
show FileId
fidFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
", empty list"
        alt (Just (FpSpan AnchoredPath
fp PatchId
pstart Maybe PatchId
Nothing:[FilePathSpan]
spans)) =
          [FilePathSpan] -> Maybe [FilePathSpan]
forall a. a -> Maybe a
Just (AnchoredPath -> PatchId -> Maybe PatchId -> FilePathSpan
FpSpan AnchoredPath
fp PatchId
pstart (PatchId -> Maybe PatchId
forall a. a -> Maybe a
Just PatchId
pend)FilePathSpan -> [FilePathSpan] -> [FilePathSpan]
forall a. a -> [a] -> [a]
:[FilePathSpan]
spans)
        alt Maybe [FilePathSpan]
_ = FilePath -> Maybe [FilePathSpan]
forall a. HasCallStack => FilePath -> a
error (FilePath -> Maybe [FilePathSpan])
-> FilePath -> Maybe [FilePathSpan]
forall a b. (a -> b) -> a -> b
$ FilePath
"impossible: span already ended for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FileId -> FilePath
forall a. Show a => a -> FilePath
show FileId
fid

-- | start new span for name fn for file fid starting with patch pid
startFidSpan :: AnchoredPath -> PatchId -> FileId -> PIM ()
startFidSpan :: AnchoredPath -> PatchId -> FileId -> State PatchIndex ()
startFidSpan AnchoredPath
fn PatchId
pstart FileId
fid = (PatchIndex -> PatchIndex) -> State PatchIndex ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PatchIndex
pind -> PatchIndex
pind {fidspans=M.alter alt fn (fidspans pind)})
  where alt :: Maybe [FileIdSpan] -> Maybe [FileIdSpan]
alt Maybe [FileIdSpan]
Nothing = [FileIdSpan] -> Maybe [FileIdSpan]
forall a. a -> Maybe a
Just [FileId -> PatchId -> Maybe PatchId -> FileIdSpan
FidSpan FileId
fid PatchId
pstart Maybe PatchId
forall a. Maybe a
Nothing]
        alt (Just [FileIdSpan]
spans) = [FileIdSpan] -> Maybe [FileIdSpan]
forall a. a -> Maybe a
Just (FileId -> PatchId -> Maybe PatchId -> FileIdSpan
FidSpan FileId
fid PatchId
pstart Maybe PatchId
forall a. Maybe a
NothingFileIdSpan -> [FileIdSpan] -> [FileIdSpan]
forall a. a -> [a] -> [a]
:[FileIdSpan]
spans)

-- | stop current span for file name fn
stopFidSpan :: AnchoredPath -> PatchId -> PIM ()
stopFidSpan :: AnchoredPath -> PatchId -> State PatchIndex ()
stopFidSpan AnchoredPath
fn PatchId
pend = (PatchIndex -> PatchIndex) -> State PatchIndex ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PatchIndex
pind -> PatchIndex
pind {fidspans=M.alter alt fn (fidspans pind)})
  where alt :: Maybe [FileIdSpan] -> Maybe [FileIdSpan]
alt Maybe [FileIdSpan]
Nothing = FilePath -> Maybe [FileIdSpan]
forall a. HasCallStack => FilePath -> a
error (FilePath -> Maybe [FileIdSpan]) -> FilePath -> Maybe [FileIdSpan]
forall a b. (a -> b) -> a -> b
$ FilePath
"impossible: no span for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
forall a. Show a => a -> FilePath
show AnchoredPath
fn
        alt (Just []) = FilePath -> Maybe [FileIdSpan]
forall a. HasCallStack => FilePath -> a
error (FilePath -> Maybe [FileIdSpan]) -> FilePath -> Maybe [FileIdSpan]
forall a b. (a -> b) -> a -> b
$ FilePath
"impossible: no span for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
forall a. Show a => a -> FilePath
show AnchoredPath
fnFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
", empty list"
        alt (Just (FidSpan FileId
fid PatchId
pstart Maybe PatchId
Nothing:[FileIdSpan]
spans)) =
          [FileIdSpan] -> Maybe [FileIdSpan]
forall a. a -> Maybe a
Just (FileId -> PatchId -> Maybe PatchId -> FileIdSpan
FidSpan FileId
fid PatchId
pstart (PatchId -> Maybe PatchId
forall a. a -> Maybe a
Just PatchId
pend)FileIdSpan -> [FileIdSpan] -> [FileIdSpan]
forall a. a -> [a] -> [a]
:[FileIdSpan]
spans)
        alt Maybe [FileIdSpan]
_ = FilePath -> Maybe [FileIdSpan]
forall a. HasCallStack => FilePath -> a
error (FilePath -> Maybe [FileIdSpan]) -> FilePath -> Maybe [FileIdSpan]
forall a b. (a -> b) -> a -> b
$ FilePath
"impossible: span already ended for " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
forall a. Show a => a -> FilePath
show AnchoredPath
fn

-- | insert touching patchid for given file id
createInfo :: FileId -> Bool -> PIM ()
createInfo :: FileId -> Bool -> State PatchIndex ()
createInfo FileId
fid Bool
isF = (PatchIndex -> PatchIndex) -> State PatchIndex ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PatchIndex
pind -> PatchIndex
pind {infom=M.alter alt fid (infom pind)})
  where alt :: Maybe a -> Maybe FileInfo
alt Maybe a
Nothing = FileInfo -> Maybe FileInfo
forall a. a -> Maybe a
Just (Bool -> IntSet -> FileInfo
FileInfo Bool
isF IntSet
I.empty)
        alt (Just a
_) = FileInfo -> Maybe FileInfo
forall a. a -> Maybe a
Just (Bool -> IntSet -> FileInfo
FileInfo Bool
isF IntSet
I.empty) -- forget old false positives

-- | insert touching patchid for given file id
insertTouch :: PatchId -> FileId -> PIM ()
insertTouch :: PatchId -> FileId -> State PatchIndex ()
insertTouch PatchId
pid FileId
fid = (PatchIndex -> PatchIndex) -> State PatchIndex ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PatchIndex
pind -> PatchIndex
pind {infom=M.alter alt fid (infom pind)})
  where alt :: Maybe FileInfo -> Maybe FileInfo
alt Maybe FileInfo
Nothing =  FilePath -> Maybe FileInfo
forall a. HasCallStack => FilePath -> a
error FilePath
"impossible: Fileid does not exist"
        alt (Just (FileInfo Bool
isF IntSet
pids)) = FileInfo -> Maybe FileInfo
forall a. a -> Maybe a
Just (Bool -> IntSet -> FileInfo
FileInfo Bool
isF (Key -> IntSet -> IntSet
I.insert (PatchId -> Key
short PatchId
pid) IntSet
pids))

-- | insert touching patchid for the parents of a given path
insertParentsTouch :: PatchId -> AnchoredPath -> PIM ()
insertParentsTouch :: PatchId -> AnchoredPath -> State PatchIndex ()
insertParentsTouch PatchId
pid AnchoredPath
path =
  [AnchoredPath]
-> (AnchoredPath -> State PatchIndex ()) -> State PatchIndex ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((AnchoredPath -> Bool) -> [AnchoredPath] -> [AnchoredPath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (AnchoredPath -> Bool) -> AnchoredPath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredPath -> Bool
isRoot) (AnchoredPath -> [AnchoredPath]
parents AnchoredPath
path)) ((AnchoredPath -> State PatchIndex ()) -> State PatchIndex ())
-> (AnchoredPath -> State PatchIndex ()) -> State PatchIndex ()
forall a b. (a -> b) -> a -> b
$
    AnchoredPath -> PIM FileId
lookupFid (AnchoredPath -> PIM FileId)
-> (FileId -> State PatchIndex ())
-> AnchoredPath
-> State PatchIndex ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> PatchId -> FileId -> State PatchIndex ()
insertTouch PatchId
pid

-- | lookup current fid of filepath
lookupFid :: AnchoredPath -> PIM FileId
lookupFid :: AnchoredPath -> PIM FileId
lookupFid AnchoredPath
fn = do
    maybeFid <- AnchoredPath -> PIM (Maybe FileId)
lookupFid' AnchoredPath
fn
    case maybeFid of
        Maybe FileId
Nothing -> FilePath -> PIM FileId
forall a. HasCallStack => FilePath -> a
error (FilePath -> PIM FileId) -> FilePath -> PIM FileId
forall a b. (a -> b) -> a -> b
$ FilePath
"couldn't find " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
displayPath AnchoredPath
fn FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" in patch index"
        Just FileId
fid -> FileId -> PIM FileId
forall a. a -> StateT PatchIndex Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return FileId
fid

-- | lookup current fid of filepatch, returning a Maybe to allow failure
lookupFid' :: AnchoredPath -> PIM (Maybe FileId)
lookupFid' :: AnchoredPath -> PIM (Maybe FileId)
lookupFid' AnchoredPath
fn = do
   fidm <- (PatchIndex -> FileIdSpans)
-> StateT PatchIndex Identity FileIdSpans
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PatchIndex -> FileIdSpans
fidspans
   case M.lookup fn fidm of
    Just (FidSpan FileId
fid PatchId
_ Maybe PatchId
_:[FileIdSpan]
_) -> Maybe FileId -> PIM (Maybe FileId)
forall a. a -> StateT PatchIndex Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FileId -> PIM (Maybe FileId))
-> Maybe FileId -> PIM (Maybe FileId)
forall a b. (a -> b) -> a -> b
$ FileId -> Maybe FileId
forall a. a -> Maybe a
Just FileId
fid
    Maybe [FileIdSpan]
_ -> Maybe FileId -> PIM (Maybe FileId)
forall a. a -> StateT PatchIndex Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FileId
forall a. Maybe a
Nothing


-- | Creates patch index that corresponds to all patches in repo.
createPatchIndexDisk
  :: (RepoPatch p, ApplyState p ~ Tree)
  => Repository rt p wU wR
  -> PatchSet p Origin wR
  -> IO ()
createPatchIndexDisk :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSet p Origin wR -> IO ()
createPatchIndexDisk Repository rt p wU wR
repository PatchSet p Origin wR
ps = do
  let patches :: [Sealed2 (PatchInfoAnd p)]
patches = (forall wW wZ. PatchInfoAnd p wW wZ -> Sealed2 (PatchInfoAnd p))
-> FL (PatchInfoAnd p) Origin wR -> [Sealed2 (PatchInfoAnd p)]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL PatchInfoAnd p wW wZ -> Sealed2 (PatchInfoAnd p)
forall wW wZ. PatchInfoAnd p wW wZ -> Sealed2 (PatchInfoAnd p)
forall (a :: * -> * -> *) wX wY. a wX wY -> Sealed2 a
Sealed2 (FL (PatchInfoAnd p) Origin wR -> [Sealed2 (PatchInfoAnd p)])
-> FL (PatchInfoAnd p) Origin wR -> [Sealed2 (PatchInfoAnd p)]
forall a b. (a -> b) -> a -> b
$ FilePath
-> FL (PatchInfoAnd p) Origin wR -> FL (PatchInfoAnd p) Origin wR
forall (a :: * -> * -> *) wX wY.
FilePath -> FL a wX wY -> FL a wX wY
progressFL FilePath
"Create patch index" (FL (PatchInfoAnd p) Origin wR -> FL (PatchInfoAnd p) Origin wR)
-> FL (PatchInfoAnd p) Origin wR -> FL (PatchInfoAnd p) Origin wR
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR -> FL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX
patchSet2FL PatchSet p Origin wR
ps
  Repository rt p wU wR
-> [(PatchId, [FileMod AnchoredPath])] -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR
-> [(PatchId, [FileMod AnchoredPath])] -> IO ()
createPatchIndexFrom Repository rt p wU wR
repository ([(PatchId, [FileMod AnchoredPath])] -> IO ())
-> [(PatchId, [FileMod AnchoredPath])] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Sealed2 (PatchInfoAnd p)]
-> Set AnchoredPath -> [(PatchId, [FileMod AnchoredPath])]
forall (p :: * -> * -> *).
(Apply p, PatchInspect p, ApplyState p ~ Tree) =>
[Sealed2 (PatchInfoAnd p)]
-> Set AnchoredPath -> [(PatchId, [FileMod AnchoredPath])]
patches2fileMods [Sealed2 (PatchInfoAnd p)]
patches Set AnchoredPath
forall a. Set a
S.empty

-- | convert patches to patchmods
patches2fileMods :: (Apply p, PatchInspect p, ApplyState p ~ Tree)
                  => [Sealed2 (PatchInfoAnd p)] -> Set AnchoredPath -> [(PatchId, [FileMod AnchoredPath])]
patches2fileMods :: forall (p :: * -> * -> *).
(Apply p, PatchInspect p, ApplyState p ~ Tree) =>
[Sealed2 (PatchInfoAnd p)]
-> Set AnchoredPath -> [(PatchId, [FileMod AnchoredPath])]
patches2fileMods [Sealed2 (PatchInfoAnd p)]
patches Set AnchoredPath
fns = (Set AnchoredPath, [(PatchId, [FileMod AnchoredPath])])
-> [(PatchId, [FileMod AnchoredPath])]
forall a b. (a, b) -> b
snd ((Set AnchoredPath, [(PatchId, [FileMod AnchoredPath])])
 -> [(PatchId, [FileMod AnchoredPath])])
-> (Set AnchoredPath, [(PatchId, [FileMod AnchoredPath])])
-> [(PatchId, [FileMod AnchoredPath])]
forall a b. (a -> b) -> a -> b
$ (Set AnchoredPath
 -> Sealed2 (PatchInfoAnd p)
 -> (Set AnchoredPath, (PatchId, [FileMod AnchoredPath])))
-> Set AnchoredPath
-> [Sealed2 (PatchInfoAnd p)]
-> (Set AnchoredPath, [(PatchId, [FileMod AnchoredPath])])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Set AnchoredPath
-> Sealed2 (PatchInfoAnd p)
-> (Set AnchoredPath, (PatchId, [FileMod AnchoredPath]))
forall {p :: * -> * -> *}.
(ApplyState p ~ Tree, PatchInspect p, Apply p) =>
Set AnchoredPath
-> Sealed2 (PatchInfoAndG p)
-> (Set AnchoredPath, (PatchId, [FileMod AnchoredPath]))
go Set AnchoredPath
fns [Sealed2 (PatchInfoAnd p)]
patches
  where
    go :: Set AnchoredPath
-> Sealed2 (PatchInfoAndG p)
-> (Set AnchoredPath, (PatchId, [FileMod AnchoredPath]))
go Set AnchoredPath
filenames (Sealed2 PatchInfoAndG p wX wY
p) = (Set AnchoredPath
filenames', (PatchId
pid, [FileMod AnchoredPath]
pmods_effect [FileMod AnchoredPath]
-> [FileMod AnchoredPath] -> [FileMod AnchoredPath]
forall a. [a] -> [a] -> [a]
++ [FileMod AnchoredPath]
pmods_dup))
      where pid :: PatchId
pid = PatchInfo -> PatchId
makePatchID (PatchInfo -> PatchId)
-> (PatchInfoAndG p wX wY -> PatchInfo)
-> PatchInfoAndG p wX wY
-> PatchId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAndG p wX wY -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info (PatchInfoAndG p wX wY -> PatchId)
-> PatchInfoAndG p wX wY -> PatchId
forall a b. (a -> b) -> a -> b
$ PatchInfoAndG p wX wY
p
            (Set AnchoredPath
filenames', [FileMod AnchoredPath]
pmods_effect) = PatchInfoAndG p wX wY
-> Set AnchoredPath -> (Set AnchoredPath, [FileMod AnchoredPath])
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY
-> Set AnchoredPath -> (Set AnchoredPath, [FileMod AnchoredPath])
applyToFileMods PatchInfoAndG p wX wY
p Set AnchoredPath
filenames
            -- applyToFileMods only returns patchmods that actually modify a file,
            -- i.e., never duplicate patches
            touched :: FileMod a -> [a]
touched FileMod a
pm = case FileMod a
pm of {PTouch a
f -> [a
f]; PRename a
a a
b -> [a
a,a
b];
                                     PCreateDir a
f -> [a
f]; PCreateFile a
f -> [a
f];
                                     PRemove a
f -> [a
f]; FileMod a
_ -> []}
            touched_all :: [AnchoredPath]
touched_all = PatchInfoAndG p wX wY -> [AnchoredPath]
forall wX wY. PatchInfoAndG p wX wY -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles PatchInfoAndG p wX wY
p
            touched_effect :: [AnchoredPath]
touched_effect = (FileMod AnchoredPath -> [AnchoredPath])
-> [FileMod AnchoredPath] -> [AnchoredPath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FileMod AnchoredPath -> [AnchoredPath]
forall {a}. FileMod a -> [a]
touched [FileMod AnchoredPath]
pmods_effect
            -- listTouchedFiles returns all files that touched by these
            --  patches, even if they have no effect, e.g. by duplicate patches
            pmods_dup :: [FileMod AnchoredPath]
pmods_dup = (AnchoredPath -> FileMod AnchoredPath)
-> [AnchoredPath] -> [FileMod AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> FileMod AnchoredPath
forall a. a -> FileMod a
PDuplicateTouch ([AnchoredPath] -> [FileMod AnchoredPath])
-> (Set AnchoredPath -> [AnchoredPath])
-> Set AnchoredPath
-> [FileMod AnchoredPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set AnchoredPath -> [AnchoredPath]
forall a. Set a -> [a]
S.elems
                            (Set AnchoredPath -> [FileMod AnchoredPath])
-> Set AnchoredPath -> [FileMod AnchoredPath]
forall a b. (a -> b) -> a -> b
$ Set AnchoredPath -> Set AnchoredPath -> Set AnchoredPath
forall a. Ord a => Set a -> Set a -> Set a
S.difference ([AnchoredPath] -> Set AnchoredPath
forall a. Ord a => [a] -> Set a
S.fromList [AnchoredPath]
touched_all)
                                           ([AnchoredPath] -> Set AnchoredPath
forall a. Ord a => [a] -> Set a
S.fromList [AnchoredPath]
touched_effect)

-- | return set of current filenames in patch index
fpSpans2fileNames :: FilePathSpans -> Set AnchoredPath
fpSpans2fileNames :: FilePathSpans -> Set AnchoredPath
fpSpans2fileNames FilePathSpans
fpSpans =
  [AnchoredPath] -> Set AnchoredPath
forall a. Ord a => [a] -> Set a
S.fromList [AnchoredPath
fn | (FpSpan AnchoredPath
fn PatchId
_ Maybe PatchId
Nothing:[FilePathSpan]
_)<- FilePathSpans -> [[FilePathSpan]]
forall k a. Map k a -> [a]
M.elems FilePathSpans
fpSpans]

-- | remove all patch effects of given patches from patch index.
--   assumes that the given list of patches is a suffix of the
--   patches tracked by the patch-index
removePidSuffix :: Map PatchId Int -> [PatchId] -> PatchIndex -> PatchIndex
removePidSuffix :: Map PatchId Key -> [PatchId] -> PatchIndex -> PatchIndex
removePidSuffix Map PatchId Key
_ [] PatchIndex
pindex = PatchIndex
pindex
removePidSuffix Map PatchId Key
pid2idx oldpids :: [PatchId]
oldpids@(PatchId
oldpid:[PatchId]
_) (PatchIndex [PatchId]
pids FileIdSpans
fidspans FilePathSpans
fpspans InfoMap
infom) =
    [PatchId] -> FileIdSpans -> FilePathSpans -> InfoMap -> PatchIndex
PatchIndex ([PatchId]
pids [PatchId] -> [PatchId] -> [PatchId]
forall a. Eq a => [a] -> [a] -> [a]
\\ [PatchId]
oldpids)
               (([FileIdSpan] -> Maybe [FileIdSpan]) -> FileIdSpans -> FileIdSpans
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe [FileIdSpan] -> Maybe [FileIdSpan]
forall {t :: * -> *}.
Foldable t =>
t FileIdSpan -> Maybe [FileIdSpan]
removefid FileIdSpans
fidspans)
               (([FilePathSpan] -> Maybe [FilePathSpan])
-> FilePathSpans -> FilePathSpans
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe [FilePathSpan] -> Maybe [FilePathSpan]
forall {t :: * -> *}.
Foldable t =>
t FilePathSpan -> Maybe [FilePathSpan]
removefp FilePathSpans
fpspans)
               InfoMap
infom -- leave hashes in infom, false positives are harmless
  where
    findIdx :: PatchId -> Key
findIdx PatchId
pid = Key -> Maybe Key -> Key
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Key
forall a. HasCallStack => FilePath -> a
error FilePath
"impossible case") (PatchId -> Map PatchId Key -> Maybe Key
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PatchId
pid Map PatchId Key
pid2idx)
    oldidx :: Key
oldidx = PatchId -> Key
findIdx PatchId
oldpid
    PatchId
from after :: PatchId -> Key -> Bool
`after` Key
idx = PatchId -> Key
findIdx PatchId
from Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
idx
    Maybe PatchId
mto afterM :: Maybe PatchId -> Key -> Bool
`afterM` Key
idx | Just PatchId
to <- Maybe PatchId
mto, PatchId -> Key
findIdx PatchId
to Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
> Key
idx = Bool
True
                     | Bool
otherwise = Bool
False
    removefid :: t FileIdSpan -> Maybe [FileIdSpan]
removefid t FileIdSpan
fidsps = if [FileIdSpan] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FileIdSpan]
fidsps' then Maybe [FileIdSpan]
forall a. Maybe a
Nothing else [FileIdSpan] -> Maybe [FileIdSpan]
forall a. a -> Maybe a
Just [FileIdSpan]
fidsps'
      where
        fidsps' :: [FileIdSpan]
fidsps' = (FileIdSpan -> [FileIdSpan]) -> t FileIdSpan -> [FileIdSpan]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FileIdSpan -> [FileIdSpan]
go t FileIdSpan
fidsps
        go :: FileIdSpan -> [FileIdSpan]
go (FidSpan FileId
fid PatchId
from Maybe PatchId
mto)
          | PatchId
from PatchId -> Key -> Bool
`after` Key
oldidx Bool -> Bool -> Bool
&& Maybe PatchId
mto Maybe PatchId -> Key -> Bool
`afterM` Key
oldidx = [FileId -> PatchId -> Maybe PatchId -> FileIdSpan
FidSpan FileId
fid PatchId
from Maybe PatchId
mto]
          | PatchId
from PatchId -> Key -> Bool
`after` Key
oldidx = [FileId -> PatchId -> Maybe PatchId -> FileIdSpan
FidSpan FileId
fid PatchId
from Maybe PatchId
forall a. Maybe a
Nothing]
          | Bool
otherwise = []
    removefp :: t FilePathSpan -> Maybe [FilePathSpan]
removefp t FilePathSpan
fpsps = if [FilePathSpan] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePathSpan]
fpsps' then Maybe [FilePathSpan]
forall a. Maybe a
Nothing else [FilePathSpan] -> Maybe [FilePathSpan]
forall a. a -> Maybe a
Just [FilePathSpan]
fpsps'
      where
        fpsps' :: [FilePathSpan]
fpsps' = (FilePathSpan -> [FilePathSpan])
-> t FilePathSpan -> [FilePathSpan]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FilePathSpan -> [FilePathSpan]
go t FilePathSpan
fpsps
        go :: FilePathSpan -> [FilePathSpan]
go (FpSpan AnchoredPath
fn PatchId
from Maybe PatchId
mto)
          | PatchId
from PatchId -> Key -> Bool
`after` Key
oldidx Bool -> Bool -> Bool
&& Maybe PatchId
mto Maybe PatchId -> Key -> Bool
`afterM` Key
oldidx = [AnchoredPath -> PatchId -> Maybe PatchId -> FilePathSpan
FpSpan AnchoredPath
fn PatchId
from Maybe PatchId
mto]
          | PatchId
from PatchId -> Key -> Bool
`after` Key
oldidx = [AnchoredPath -> PatchId -> Maybe PatchId -> FilePathSpan
FpSpan AnchoredPath
fn PatchId
from Maybe PatchId
forall a. Maybe a
Nothing]
          | Bool
otherwise = []

-- | update the patch index to the current state of the repository
updatePatchIndexDisk
    :: (RepoPatch p, ApplyState p ~ Tree)
    => Repository rt p wU wR
    -> PatchSet p Origin wR
    -> IO ()
updatePatchIndexDisk :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSet p Origin wR -> IO ()
updatePatchIndexDisk Repository rt p wU wR
repo PatchSet p Origin wR
patches = do
    let repodir :: FilePath
repodir = Repository rt p wU wR -> FilePath
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> FilePath
repoLocation Repository rt p wU wR
repo
    (_,_,pid2idx,pindex) <- FilePath -> IO (Int8, FilePath, Map PatchId Key, PatchIndex)
loadPatchIndex FilePath
repodir
    -- check that patch index is up to date
    let flpatches = FilePath
-> FL (PatchInfoAnd p) Origin wR -> FL (PatchInfoAnd p) Origin wR
forall (a :: * -> * -> *) wX wY.
FilePath -> FL a wX wY -> FL a wX wY
progressFL FilePath
"Update patch index" (FL (PatchInfoAnd p) Origin wR -> FL (PatchInfoAnd p) Origin wR)
-> FL (PatchInfoAnd p) Origin wR -> FL (PatchInfoAnd p) Origin wR
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR -> FL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX
patchSet2FL PatchSet p Origin wR
patches
    let pidsrepo = (forall wW wZ. PatchInfoAnd p wW wZ -> PatchId)
-> FL (PatchInfoAnd p) Origin wR -> [PatchId]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (PatchInfo -> PatchId
makePatchID (PatchInfo -> PatchId)
-> (PatchInfoAnd p wW wZ -> PatchInfo)
-> PatchInfoAnd p wW wZ
-> PatchId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wW wZ -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info) FL (PatchInfoAnd p) Origin wR
flpatches
        (oldpids,_,len_common) = uncommon (reverse $ pids pindex) pidsrepo
        pindex' = Map PatchId Key -> [PatchId] -> PatchIndex -> PatchIndex
removePidSuffix Map PatchId Key
pid2idx [PatchId]
oldpids PatchIndex
pindex
        filenames = FilePathSpans -> Set AnchoredPath
fpSpans2fileNames (PatchIndex -> FilePathSpans
fpspans PatchIndex
pindex')
        cdir = FilePath
repodir FilePath -> ShowS
</> FilePath
indexDir
    -- reread to prevent holding onto patches for too long
    let newpatches = Key -> [Sealed2 (PatchInfoAnd p)] -> [Sealed2 (PatchInfoAnd p)]
forall a. Key -> [a] -> [a]
drop Key
len_common ([Sealed2 (PatchInfoAnd p)] -> [Sealed2 (PatchInfoAnd p)])
-> [Sealed2 (PatchInfoAnd p)] -> [Sealed2 (PatchInfoAnd p)]
forall a b. (a -> b) -> a -> b
$ (forall wW wZ. PatchInfoAnd p wW wZ -> Sealed2 (PatchInfoAnd p))
-> FL (PatchInfoAnd p) Origin wR -> [Sealed2 (PatchInfoAnd p)]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL PatchInfoAnd p wW wZ -> Sealed2 (PatchInfoAnd p)
forall wW wZ. PatchInfoAnd p wW wZ -> Sealed2 (PatchInfoAnd p)
forall (a :: * -> * -> *) wX wY. a wX wY -> Sealed2 a
seal2 FL (PatchInfoAnd p) Origin wR
flpatches
        newpmods = [Sealed2 (PatchInfoAnd p)]
-> Set AnchoredPath -> [(PatchId, [FileMod AnchoredPath])]
forall (p :: * -> * -> *).
(Apply p, PatchInspect p, ApplyState p ~ Tree) =>
[Sealed2 (PatchInfoAnd p)]
-> Set AnchoredPath -> [(PatchId, [FileMod AnchoredPath])]
patches2fileMods [Sealed2 (PatchInfoAnd p)]
newpatches Set AnchoredPath
filenames
    inv_hash <- getInventoryHash repodir
    storePatchIndex cdir inv_hash (applyPatchMods newpmods pindex')
  where
    -- return uncommon suffixes and length of common prefix of as and bs
    uncommon :: [PatchId] -> [PatchId] -> ([PatchId], [PatchId], Key)
uncommon = Key -> [PatchId] -> [PatchId] -> ([PatchId], [PatchId], Key)
forall {a} {c}. (Eq a, Num c) => c -> [a] -> [a] -> ([a], [a], c)
uncommon' Key
0
    uncommon' :: c -> [a] -> [a] -> ([a], [a], c)
uncommon' c
x (a
a:[a]
as) (a
b:[a]
bs)
      | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b     = c -> [a] -> [a] -> ([a], [a], c)
uncommon' (c
xc -> c -> c
forall a. Num a => a -> a -> a
+c
1) [a]
as [a]
bs
      | Bool
otherwise  =  (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as,a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs,c
x)
    uncommon' c
x [a]
as [a]
bs = ([a]
as,[a]
bs,c
x)

-- | 'createPatchIndexFrom repo pmods' creates a patch index from the given
--   patchmods.
createPatchIndexFrom :: Repository rt p wU wR
                     -> [(PatchId, [FileMod AnchoredPath])] -> IO ()
createPatchIndexFrom :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR
-> [(PatchId, [FileMod AnchoredPath])] -> IO ()
createPatchIndexFrom Repository rt p wU wR
repo [(PatchId, [FileMod AnchoredPath])]
pmods = do
    inv_hash <- FilePath -> IO FilePath
getInventoryHash FilePath
repodir
    storePatchIndex cdir inv_hash (applyPatchMods pmods emptyPatchIndex)
  where repodir :: FilePath
repodir = Repository rt p wU wR -> FilePath
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> FilePath
repoLocation Repository rt p wU wR
repo
        cdir :: FilePath
cdir = FilePath
repodir FilePath -> ShowS
</> FilePath
indexDir
        emptyPatchIndex :: PatchIndex
emptyPatchIndex = [PatchId] -> FileIdSpans -> FilePathSpans -> InfoMap -> PatchIndex
PatchIndex [] FileIdSpans
forall k a. Map k a
M.empty FilePathSpans
forall k a. Map k a
M.empty InfoMap
forall k a. Map k a
M.empty

getInventoryHash :: FilePath -> IO String
getInventoryHash :: FilePath -> IO FilePath
getInventoryHash FilePath
repodir = do
  inv <- FilePath -> IO ByteString
B.readFile (FilePath
repodir FilePath -> ShowS
</> FilePath
hashedInventoryPath)
  return $ sha256sum inv

-- | Load patch-index from disk along with some meta data.
loadPatchIndex :: FilePath -> IO (Int8, String, Map PatchId Int, PatchIndex)
loadPatchIndex :: FilePath -> IO (Int8, FilePath, Map PatchId Key, PatchIndex)
loadPatchIndex FilePath
repodir = do
  let pindex_dir :: FilePath
pindex_dir = FilePath
repodir FilePath -> ShowS
</> FilePath
indexDir
  (v,inv_hash) <- FilePath -> IO (Int8, FilePath)
loadRepoState (FilePath
pindex_dir FilePath -> ShowS
</> FilePath
repoStateFile)
  pids <- loadPatchIds (pindex_dir </> pidsFile)
  let pid2idx  = [(PatchId, Key)] -> Map PatchId Key
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PatchId, Key)] -> Map PatchId Key)
-> [(PatchId, Key)] -> Map PatchId Key
forall a b. (a -> b) -> a -> b
$ [PatchId] -> [Key] -> [(PatchId, Key)]
forall a b. [a] -> [b] -> [(a, b)]
zip [PatchId]
pids [(Key
1::Int)..]
  infom <- loadInfoMap (pindex_dir </> touchMapFile)
  fidspans <- loadFidMap (pindex_dir </> fidMapFile)
  fpspans <- loadFpMap (pindex_dir </> fpMapFile)
  return (v, inv_hash, pid2idx, PatchIndex pids fidspans fpspans infom)

-- | If patch-index is useful as it is now, read it. If not, create or update it, then read it.
loadSafePatchIndex :: (RepoPatch p, ApplyState p ~ Tree)
                   => Repository rt p wU wR
                   -> PatchSet p Origin wR     -- ^ PatchSet of the repository, used if we need to create the patch-index.
                   -> IO PatchIndex
loadSafePatchIndex :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSet p Origin wR -> IO PatchIndex
loadSafePatchIndex Repository rt p wU wR
repo PatchSet p Origin wR
ps = do
   let repodir :: FilePath
repodir = Repository rt p wU wR -> FilePath
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> FilePath
repoLocation Repository rt p wU wR
repo
   can_use <- Repository rt p wU wR -> IO Bool
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO Bool
isPatchIndexInSync Repository rt p wU wR
repo
   (_,_,_,pi) <-
     if can_use
       then do
          debugMessage "Loading patch index..."
          r <- loadPatchIndex repodir
          debugMessage "Done."
          return r
       else do createOrUpdatePatchIndexDisk repo ps
               loadPatchIndex repodir
   return pi

-- | Read-only. Checks if patch-index exists for this repository
--   it works by checking if:
--
--     1. @_darcs\/patch_index\/@ and its corresponding files are all present
--     2. patch index version is the one handled by this version of Darcs
doesPatchIndexExist :: FilePath -> IO Bool
doesPatchIndexExist :: FilePath -> IO Bool
doesPatchIndexExist FilePath
repodir = do
 filesArePresent <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO Bool) -> [FilePath] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> ShowS -> FilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
pindex_dir FilePath -> ShowS
</>))
                    [FilePath
repoStateFile, FilePath
pidsFile, FilePath
touchMapFile, FilePath
fidMapFile, FilePath
fpMapFile]
 if filesArePresent
  then do v <- piVersion
          return (v == version)   -- consider PI only of on-disk format is the current one
  else return False
   where pindex_dir :: FilePath
pindex_dir = FilePath
repodir FilePath -> ShowS
</> FilePath
indexDir
         piVersion :: IO Int8
piVersion = (Int8, FilePath) -> Int8
forall a b. (a, b) -> a
fst ((Int8, FilePath) -> Int8) -> IO (Int8, FilePath) -> IO Int8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Int8, FilePath)
loadRepoState (FilePath
pindex_dir FilePath -> ShowS
</> FilePath
repoStateFile)

-- | Read-only. Checks if @_darcs\/noPatchIndex@ exists, that is, if patch-index is explicitely disabled.
isPatchIndexDisabled :: FilePath -> IO Bool
isPatchIndexDisabled :: FilePath -> IO Bool
isPatchIndexDisabled FilePath
repodir = FilePath -> IO Bool
doesFileExist (FilePath
repodir FilePath -> ShowS
</> FilePath
darcsdir  FilePath -> ShowS
</> FilePath
noPatchIndex)

-- | Create or update patch index
--
--   1. if @_darcs\/no_patch_index@ exists, delete it
--   2. if patch index exists, update it
--   3. if not, create it from scratch
createOrUpdatePatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree)
                             => Repository rt p wU wR -> PatchSet p Origin wR -> IO ()
createOrUpdatePatchIndexDisk :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSet p Origin wR -> IO ()
createOrUpdatePatchIndexDisk Repository rt p wU wR
repo PatchSet p Origin wR
ps = do
   FilePath -> IO ()
debugMessage FilePath
"createOrUpdatePatchIndexDisk: start"
   let repodir :: FilePath
repodir = Repository rt p wU wR -> FilePath
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> FilePath
repoLocation Repository rt p wU wR
repo
   FilePath -> IO ()
removeFile (FilePath
repodir FilePath -> ShowS
</> FilePath
darcsdir FilePath -> ShowS
</> FilePath
noPatchIndex) IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOError
_ :: IOError) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   dpie <- FilePath -> IO Bool
doesPatchIndexExist FilePath
repodir
   if dpie
      then updatePatchIndexDisk repo ps
      else createPatchIndexDisk repo ps
   debugMessage "createOrUpdatePatchIndexDisk: done"

-- | Read-only. Checks the two following things:
--
--   1. 'doesPatchIndexExist'
--   2. 'isPatchIndexDisabled'
--
-- Then only if it exists and it is not explicitely disabled, returns @True@, else returns @False@
-- (or an error if it exists and is explicitely disabled at the same time).
canUsePatchIndex :: Repository rt p wU wR -> IO Bool
canUsePatchIndex :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO Bool
canUsePatchIndex Repository rt p wU wR
repo = do
     let repodir :: FilePath
repodir = Repository rt p wU wR -> FilePath
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> FilePath
repoLocation Repository rt p wU wR
repo
     piExists <- FilePath -> IO Bool
doesPatchIndexExist FilePath
repodir
     piDisabled <- isPatchIndexDisabled repodir
     case (piExists, piDisabled) of
        (Bool
True, Bool
False) -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        (Bool
False, Bool
True) -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        (Bool
True, Bool
True) -> FilePath -> IO Bool
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"patch index exists, and patch index is disabled. run optimize enable-patch-index or disable-patch-index to rectify."
        (Bool
False, Bool
False) -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Creates patch-index (ignoring whether it is explicitely disabled).
--   If it is ctrl-c'ed, then aborts, delete patch-index and mark it as disabled.
createPIWithInterrupt :: (RepoPatch p, ApplyState p ~ Tree)
                      => Repository rt p wU wR -> PatchSet p Origin wR -> IO ()
createPIWithInterrupt :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSet p Origin wR -> IO ()
createPIWithInterrupt Repository rt p wU wR
repo PatchSet p Origin wR
ps = do
    let repodir :: FilePath
repodir = Repository rt p wU wR -> FilePath
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> FilePath
repoLocation Repository rt p wU wR
repo
    FilePath -> IO ()
putStrLn FilePath
"Creating a patch index, please wait. To stop press Ctrl-C"
    (do
      Repository rt p wU wR -> PatchSet p Origin wR -> IO ()
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSet p Origin wR -> IO ()
createPatchIndexDisk Repository rt p wU wR
repo PatchSet p Origin wR
ps
      FilePath -> IO ()
putStrLn FilePath
"Created patch index.") IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchInterrupt` (FilePath -> IO ()
putStrLn FilePath
"Patch Index Disabled" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO ()
deletePatchIndex FilePath
repodir)

-- | Checks if patch-index exists and is in sync with repository.
--   That is, checks if patch-index can be used as it is now.
isPatchIndexInSync :: Repository rt p wU wR -> IO Bool
isPatchIndexInSync :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO Bool
isPatchIndexInSync Repository rt p wU wR
repo = do
   let repodir :: FilePath
repodir = Repository rt p wU wR -> FilePath
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> FilePath
repoLocation Repository rt p wU wR
repo
   dpie <- FilePath -> IO Bool
doesPatchIndexExist FilePath
repodir
   if dpie
    then do
      (_, inv_hash_pindex, _, _) <- loadPatchIndex repodir
      inv_hash <- getInventoryHash repodir
      return (inv_hash == inv_hash_pindex)
    else return False

-- | Stores patch-index on disk.
storePatchIndex :: FilePath -> String -> PatchIndex -> IO ()
storePatchIndex :: FilePath -> FilePath -> PatchIndex -> IO ()
storePatchIndex FilePath
cdir FilePath
inv_hash (PatchIndex [PatchId]
pids FileIdSpans
fidspans FilePathSpans
fpspans InfoMap
infom) = do
  FilePath -> IO ()
createDirectory FilePath
cdir IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOError
_ :: IOError) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  tmpdir <- FilePath -> (AbsolutePath -> IO FilePath) -> IO FilePath
forall a. FilePath -> (AbsolutePath -> IO a) -> IO a
withPermDir FilePath
cdir ((AbsolutePath -> IO FilePath) -> IO FilePath)
-> (AbsolutePath -> IO FilePath) -> IO FilePath
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
dir -> do
              FilePath -> IO ()
debugMessage FilePath
"About to create patch index..."
              let tmpdir :: FilePath
tmpdir = AbsolutePath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath AbsolutePath
dir
              FilePath -> FilePath -> IO ()
storeRepoState (FilePath
tmpdir FilePath -> ShowS
</> FilePath
repoStateFile) FilePath
inv_hash
              FilePath -> [PatchId] -> IO ()
storePatchIds (FilePath
tmpdir FilePath -> ShowS
</> FilePath
pidsFile) [PatchId]
pids
              FilePath -> InfoMap -> IO ()
storeInfoMap (FilePath
tmpdir FilePath -> ShowS
</> FilePath
touchMapFile) InfoMap
infom
              FilePath -> FileIdSpans -> IO ()
storeFidMap (FilePath
tmpdir FilePath -> ShowS
</> FilePath
fidMapFile) FileIdSpans
fidspans
              FilePath -> FilePathSpans -> IO ()
storeFpMap (FilePath
tmpdir FilePath -> ShowS
</> FilePath
fpMapFile) FilePathSpans
fpspans
              FilePath -> IO ()
debugMessage FilePath
"Patch index created"
              FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
tmpdir
  removeDirectoryRecursive cdir `catch` \(IOError
_ :: IOError) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  copyPermissions darcsdir tmpdir
  renameDirectory tmpdir cdir

decodeFile :: Binary a => FilePath -> IO a
decodeFile :: forall a. Binary a => FilePath -> IO a
decodeFile FilePath
path = do
  result <- FilePath -> IO (Either (ByteOffset, FilePath) a)
forall a.
Binary a =>
FilePath -> IO (Either (ByteOffset, FilePath) a)
decodeFileOrFail FilePath
path
  case result of
    Left (ByteOffset
offset, FilePath
msg) ->
      FilePath -> IO a
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$
        FilePath
"Patch index is corrupt (file "FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
pathFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
" at offset "FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ByteOffset -> FilePath
forall a. Show a => a -> FilePath
show ByteOffset
offsetFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
"): "FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
msgFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
        FilePath
"\nPlease remove the corrupt file and then try again."
    Right a
r -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

storeRepoState :: FilePath -> String -> IO ()
storeRepoState :: FilePath -> FilePath -> IO ()
storeRepoState FilePath
fp FilePath
inv_hash = FilePath -> (Int8, FilePath) -> IO ()
forall a. Binary a => FilePath -> a -> IO ()
encodeFile FilePath
fp (Int8
version,FilePath
inv_hash)

loadRepoState :: FilePath -> IO (Int8, String)
loadRepoState :: FilePath -> IO (Int8, FilePath)
loadRepoState = FilePath -> IO (Int8, FilePath)
forall a. Binary a => FilePath -> IO a
decodeFile

storePatchIds :: FilePath -> [PatchId] -> IO ()
storePatchIds :: FilePath -> [PatchId] -> IO ()
storePatchIds = FilePath -> [PatchId] -> IO ()
forall a. Binary a => FilePath -> a -> IO ()
encodeFile

loadPatchIds :: FilePath -> IO [PatchId]
loadPatchIds :: FilePath -> IO [PatchId]
loadPatchIds = FilePath -> IO [PatchId]
forall a. Binary a => FilePath -> IO a
decodeFile

storeFidMap :: FilePath -> FileIdSpans -> IO ()
storeFidMap :: FilePath -> FileIdSpans -> IO ()
storeFidMap FilePath
fp FileIdSpans
fidm =
  FilePath -> Map AnchoredPath [(FileId, PatchId, PatchId)] -> IO ()
forall a. Binary a => FilePath -> a -> IO ()
encodeFile FilePath
fp (Map AnchoredPath [(FileId, PatchId, PatchId)] -> IO ())
-> Map AnchoredPath [(FileId, PatchId, PatchId)] -> IO ()
forall a b. (a -> b) -> a -> b
$ ([FileIdSpan] -> [(FileId, PatchId, PatchId)])
-> FileIdSpans -> Map AnchoredPath [(FileId, PatchId, PatchId)]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((FileIdSpan -> (FileId, PatchId, PatchId))
-> [FileIdSpan] -> [(FileId, PatchId, PatchId)]
forall a b. (a -> b) -> [a] -> [b]
map (\(FidSpan FileId
a PatchId
b Maybe PatchId
c) -> (FileId
a, PatchId
b, Maybe PatchId -> PatchId
toIdxM Maybe PatchId
c))) FileIdSpans
fidm
 where toIdxM :: Maybe PatchId -> PatchId
toIdxM Maybe PatchId
Nothing = PatchId
zero
       toIdxM (Just PatchId
pid) = PatchId
pid

loadFidMap :: FilePath -> IO FileIdSpans
loadFidMap :: FilePath -> IO FileIdSpans
loadFidMap FilePath
fp = ([(FileId, PatchId, PatchId)] -> [FileIdSpan])
-> Map AnchoredPath [(FileId, PatchId, PatchId)] -> FileIdSpans
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (((FileId, PatchId, PatchId) -> FileIdSpan)
-> [(FileId, PatchId, PatchId)] -> [FileIdSpan]
forall a b. (a -> b) -> [a] -> [b]
map (\(FileId
a,PatchId
b,PatchId
c) -> FileId -> PatchId -> Maybe PatchId -> FileIdSpan
FidSpan FileId
a PatchId
b (PatchId -> Maybe PatchId
toPidM PatchId
c))) (Map AnchoredPath [(FileId, PatchId, PatchId)] -> FileIdSpans)
-> IO (Map AnchoredPath [(FileId, PatchId, PatchId)])
-> IO FileIdSpans
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Map AnchoredPath [(FileId, PatchId, PatchId)])
forall a. Binary a => FilePath -> IO a
decodeFile FilePath
fp
  where toPidM :: PatchId -> Maybe PatchId
toPidM PatchId
pid | PatchId
pid PatchId -> PatchId -> Bool
forall a. Eq a => a -> a -> Bool
== PatchId
zero = Maybe PatchId
forall a. Maybe a
Nothing
                   | Bool
otherwise   = PatchId -> Maybe PatchId
forall a. a -> Maybe a
Just PatchId
pid

storeFpMap :: FilePath -> FilePathSpans -> IO ()
storeFpMap :: FilePath -> FilePathSpans -> IO ()
storeFpMap FilePath
fp FilePathSpans
fidm =
  FilePath -> Map FileId [(AnchoredPath, PatchId, PatchId)] -> IO ()
forall a. Binary a => FilePath -> a -> IO ()
encodeFile FilePath
fp (Map FileId [(AnchoredPath, PatchId, PatchId)] -> IO ())
-> Map FileId [(AnchoredPath, PatchId, PatchId)] -> IO ()
forall a b. (a -> b) -> a -> b
$ ([FilePathSpan] -> [(AnchoredPath, PatchId, PatchId)])
-> FilePathSpans -> Map FileId [(AnchoredPath, PatchId, PatchId)]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((FilePathSpan -> (AnchoredPath, PatchId, PatchId))
-> [FilePathSpan] -> [(AnchoredPath, PatchId, PatchId)]
forall a b. (a -> b) -> [a] -> [b]
map (\(FpSpan AnchoredPath
a PatchId
b Maybe PatchId
c) -> (AnchoredPath
a, PatchId
b, Maybe PatchId -> PatchId
toIdxM Maybe PatchId
c))) FilePathSpans
fidm
 where toIdxM :: Maybe PatchId -> PatchId
toIdxM Maybe PatchId
Nothing = PatchId
zero
       toIdxM (Just PatchId
pid) = PatchId
pid

loadFpMap :: FilePath -> IO FilePathSpans
loadFpMap :: FilePath -> IO FilePathSpans
loadFpMap FilePath
fp = ([(AnchoredPath, PatchId, PatchId)] -> [FilePathSpan])
-> Map FileId [(AnchoredPath, PatchId, PatchId)] -> FilePathSpans
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (((AnchoredPath, PatchId, PatchId) -> FilePathSpan)
-> [(AnchoredPath, PatchId, PatchId)] -> [FilePathSpan]
forall a b. (a -> b) -> [a] -> [b]
map (\(AnchoredPath
a,PatchId
b,PatchId
c) -> AnchoredPath -> PatchId -> Maybe PatchId -> FilePathSpan
FpSpan AnchoredPath
a PatchId
b (PatchId -> Maybe PatchId
toPidM PatchId
c))) (Map FileId [(AnchoredPath, PatchId, PatchId)] -> FilePathSpans)
-> IO (Map FileId [(AnchoredPath, PatchId, PatchId)])
-> IO FilePathSpans
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Map FileId [(AnchoredPath, PatchId, PatchId)])
forall a. Binary a => FilePath -> IO a
decodeFile FilePath
fp
  where toPidM :: PatchId -> Maybe PatchId
toPidM PatchId
pid | PatchId
pid PatchId -> PatchId -> Bool
forall a. Eq a => a -> a -> Bool
== PatchId
zero = Maybe PatchId
forall a. Maybe a
Nothing
                   | Bool
otherwise   = PatchId -> Maybe PatchId
forall a. a -> Maybe a
Just PatchId
pid

storeInfoMap :: FilePath -> InfoMap -> IO ()
storeInfoMap :: FilePath -> InfoMap -> IO ()
storeInfoMap FilePath
fp InfoMap
infom =
  FilePath -> Map FileId (Bool, IntSet) -> IO ()
forall a. Binary a => FilePath -> a -> IO ()
encodeFile FilePath
fp (Map FileId (Bool, IntSet) -> IO ())
-> Map FileId (Bool, IntSet) -> IO ()
forall a b. (a -> b) -> a -> b
$ (FileInfo -> (Bool, IntSet))
-> InfoMap -> Map FileId (Bool, IntSet)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\FileInfo
fi -> (FileInfo -> Bool
isFile FileInfo
fi, FileInfo -> IntSet
touching FileInfo
fi)) InfoMap
infom

loadInfoMap :: FilePath -> IO InfoMap
loadInfoMap :: FilePath -> IO InfoMap
loadInfoMap FilePath
fp = ((Bool, IntSet) -> FileInfo)
-> Map FileId (Bool, IntSet) -> InfoMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\(Bool
isF,IntSet
pids) -> Bool -> IntSet -> FileInfo
FileInfo Bool
isF IntSet
pids) (Map FileId (Bool, IntSet) -> InfoMap)
-> IO (Map FileId (Bool, IntSet)) -> IO InfoMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Map FileId (Bool, IntSet))
forall a. Binary a => FilePath -> IO a
decodeFile FilePath
fp

indexDir, repoStateFile, pidsFile, fidMapFile, fpMapFile,
  touchMapFile, noPatchIndex :: String
indexDir :: FilePath
indexDir = FilePath
darcsdir FilePath -> ShowS
</> FilePath
"patch_index"
repoStateFile :: FilePath
repoStateFile = FilePath
"repo_state"
pidsFile :: FilePath
pidsFile = FilePath
"patch_ids"
fidMapFile :: FilePath
fidMapFile = FilePath
"fid_map"
fpMapFile :: FilePath
fpMapFile = FilePath
"fp_map"
touchMapFile :: FilePath
touchMapFile = FilePath
"touch_map"
noPatchIndex :: FilePath
noPatchIndex = FilePath
"no_patch_index"

-- | Deletes patch-index (@_darcs\/patch_index\/@ and its contents) and mark repository as disabled (creates @_darcs\/no_patch_index@).
deletePatchIndex :: FilePath -> IO ()
deletePatchIndex :: FilePath -> IO ()
deletePatchIndex FilePath
repodir = do
    exists <- FilePath -> IO Bool
doesDirectoryExist FilePath
indexDir
    when exists $
         removeDirectoryRecursive indexDir
            `catch` \(IOError
e :: IOError) -> FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Error: Could not delete patch index\n" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
e
    (openFile (repodir </> darcsdir </> noPatchIndex) WriteMode >>= hClose)
            `catch` \(IOError
e :: IOError) -> FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Error: Could not disable patch index\n" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
e

dumpRepoState :: [PatchId] -> String
dumpRepoState :: [PatchId] -> FilePath
dumpRepoState = [FilePath] -> FilePath
unlines ([FilePath] -> FilePath)
-> ([PatchId] -> [FilePath]) -> [PatchId] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatchId -> FilePath) -> [PatchId] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PatchId -> FilePath
pid2string

dumpFileIdSpans :: FileIdSpans -> String
dumpFileIdSpans :: FileIdSpans -> FilePath
dumpFileIdSpans FileIdSpans
fidspans =
  [FilePath] -> FilePath
unlines [AnchoredPath -> FilePath
displayPath AnchoredPath
fnFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
" -> "FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FileId -> FilePath
showFileId FileId
fidFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
" from "FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++PatchId -> FilePath
pid2string PatchId
fromFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
" to "FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath -> (PatchId -> FilePath) -> Maybe PatchId -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"-" PatchId -> FilePath
pid2string Maybe PatchId
mto
           | (AnchoredPath
fn, [FileIdSpan]
fids) <- FileIdSpans -> [(AnchoredPath, [FileIdSpan])]
forall k a. Map k a -> [(k, a)]
M.toList FileIdSpans
fidspans, FidSpan FileId
fid PatchId
from Maybe PatchId
mto <- [FileIdSpan]
fids]

dumpFilePathSpans :: FilePathSpans -> String
dumpFilePathSpans :: FilePathSpans -> FilePath
dumpFilePathSpans FilePathSpans
fpspans =
  [FilePath] -> FilePath
unlines [FileId -> FilePath
showFileId FileId
fidFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
" -> "FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
displayPath AnchoredPath
fnFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
" from "FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++PatchId -> FilePath
pid2string PatchId
fromFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
" to "FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath -> (PatchId -> FilePath) -> Maybe PatchId -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"-" PatchId -> FilePath
pid2string Maybe PatchId
mto
           | (FileId
fid, [FilePathSpan]
fns) <- FilePathSpans -> [(FileId, [FilePathSpan])]
forall k a. Map k a -> [(k, a)]
M.toList FilePathSpans
fpspans, FpSpan AnchoredPath
fn PatchId
from Maybe PatchId
mto <- [FilePathSpan]
fns]

dumpTouchingMap :: InfoMap -> String
dumpTouchingMap :: InfoMap -> FilePath
dumpTouchingMap InfoMap
infom = [FilePath] -> FilePath
unlines [FileId -> FilePath
showFileId FileId
fidFilePath -> ShowS
forall a. [a] -> [a] -> [a]
++(if Bool
isF then FilePath
"" else FilePath
"/")FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
" -> "FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> FilePath
showAsHex (Key -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Key
i)
                                | (FileId
fid,FileInfo Bool
isF IntSet
w32s) <- InfoMap -> [(FileId, FileInfo)]
forall k a. Map k a -> [(k, a)]
M.toList InfoMap
infom, Key
i <- IntSet -> [Key]
I.elems IntSet
w32s]

-- | return set of current filepaths in patch index
fpSpans2filePaths :: FilePathSpans -> InfoMap -> [FilePath]
fpSpans2filePaths :: FilePathSpans -> InfoMap -> [FilePath]
fpSpans2filePaths FilePathSpans
fpSpans InfoMap
infom =
  [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort [AnchoredPath -> FilePath
displayPath AnchoredPath
fn FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Bool
isF then FilePath
"" else FilePath
"/") | (FileId
fid,FpSpan AnchoredPath
fn PatchId
_ Maybe PatchId
Nothing:[FilePathSpan]
_) <- FilePathSpans -> [(FileId, [FilePathSpan])]
forall k a. Map k a -> [(k, a)]
M.toList FilePathSpans
fpSpans,
                                                let Just (FileInfo Bool
isF IntSet
_) = FileId -> InfoMap -> Maybe FileInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FileId
fid InfoMap
infom]

-- | Checks if patch index can be created and build it with interrupt.
attemptCreatePatchIndex
  :: (RepoPatch p, ApplyState p ~ Tree)
  => Repository rt p wU wR -> PatchSet p Origin wR -> IO ()
attemptCreatePatchIndex :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSet p Origin wR -> IO ()
attemptCreatePatchIndex Repository rt p wU wR
repo PatchSet p Origin wR
ps = do
  canCreate <- Repository rt p wU wR -> IO Bool
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO Bool
canCreatePI Repository rt p wU wR
repo
  when canCreate $ createPIWithInterrupt repo ps

-- | Checks whether a patch index can (and should) be created. If we are not in
-- an old-fashioned repo, and if we haven't been told not to, then we should
-- create a patch index if it doesn't already exist.
canCreatePI :: Repository rt p wU wR -> IO Bool
canCreatePI :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO Bool
canCreatePI Repository rt p wU wR
repo =
    (Bool -> Bool
not (Bool -> Bool) -> ([Bool] -> Bool) -> [Bool] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or) ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO Bool] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ RepoFormat -> IO Bool
doesntHaveHashedInventory (Repository rt p wU wR -> RepoFormat
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat Repository rt p wU wR
repo)
                            , FilePath -> IO Bool
isPatchIndexDisabled FilePath
repodir
                            , FilePath -> IO Bool
doesPatchIndexExist FilePath
repodir
                            ]
  where
    repodir :: FilePath
repodir = Repository rt p wU wR -> FilePath
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> FilePath
repoLocation Repository rt p wU wR
repo
    doesntHaveHashedInventory :: RepoFormat -> IO Bool
doesntHaveHashedInventory = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (RepoFormat -> Bool) -> RepoFormat -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (RepoFormat -> Bool) -> RepoFormat -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory

-- | Returns an RL in which the order of patches matters. Useful for the
-- @annotate@ command. If patch-index does not exist and is not explicitely
-- disabled, silently create it. (Also, if it is out-of-sync, which should not
-- happen, silently update it).
getRelevantSubsequence
    :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p)
    => Sealed ((RL a) wK)
    -- ^ Sequence of patches you want to filter
    -> Repository rt p wU wR
    -- ^ The repository (to attempt loading patch-index from its path)
    -> PatchSet p Origin wR
    -- ^ PatchSet of repository (in case we need to create patch-index)
    -> [AnchoredPath]
    -- ^ File(s) about which you want patches from given sequence
    -> IO (Sealed ((RL a) Origin))
    -- ^ Filtered sequence of patches
getRelevantSubsequence :: forall (p :: * -> * -> *) (a :: * -> * -> *) wK (rt :: AccessType)
       wU wR.
(RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) =>
Sealed (RL a wK)
-> Repository rt p wU wR
-> PatchSet p Origin wR
-> [AnchoredPath]
-> IO (Sealed (RL a Origin))
getRelevantSubsequence Sealed (RL a wK)
pxes Repository rt p wU wR
repository PatchSet p Origin wR
ps [AnchoredPath]
fns = do
    pi@(PatchIndex _ _ _ infom) <- Repository rt p wU wR -> PatchSet p Origin wR -> IO PatchIndex
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSet p Origin wR -> IO PatchIndex
loadSafePatchIndex Repository rt p wU wR
repository PatchSet p Origin wR
ps
    let fids = (AnchoredPath -> FileId) -> [AnchoredPath] -> [FileId]
forall a b. (a -> b) -> [a] -> [b]
map (\AnchoredPath
fn -> PIM FileId -> PatchIndex -> FileId
forall s a. State s a -> s -> a
evalState (AnchoredPath -> PIM FileId
lookupFid AnchoredPath
fn) PatchIndex
pi) [AnchoredPath]
fns
        pidss = (FileId -> IntSet) -> [FileId] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map ((\(FileInfo Bool
_ IntSet
a) -> IntSet
a) (FileInfo -> IntSet) -> (FileId -> FileInfo) -> FileId -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FileInfo -> FileInfo
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FileInfo -> FileInfo)
-> (FileId -> Maybe FileInfo) -> FileId -> FileInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FileId -> InfoMap -> Maybe FileInfo
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` InfoMap
infom)) [FileId]
fids
        pids = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
I.unions [IntSet]
pidss
    let flpxes = RL a wK wZ -> FL a wK wZ
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL (RL a wK wZ -> FL a wK wZ) -> RL a wK wZ -> FL a wK wZ
forall a b. (a -> b) -> a -> b
$ (forall wX. RL a wK wX -> RL a wK wZ)
-> Sealed (RL a wK) -> RL a wK wZ
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal RL a wK wX -> RL a wK wZ
forall wX. RL a wK wX -> RL a wK wZ
forall (a :: * -> * -> *) wX wY1 wY2. a wX wY1 -> a wX wY2
unsafeCoercePEnd Sealed (RL a wK)
pxes
    return . seal $ keepElems flpxes NilRL pids
  where
    keepElems :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p)
              => FL a wX wY -> RL a wB wX -> IntSet -> RL a wP wQ
    keepElems :: forall (p :: * -> * -> *) (a :: * -> * -> *) wX wY wB wP wQ.
(RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) =>
FL a wX wY -> RL a wB wX -> IntSet -> RL a wP wQ
keepElems FL a wX wY
NilFL RL a wB wX
acc IntSet
_ = RL a wB wX -> RL a wP wQ
forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP RL a wB wX
acc
    keepElems (a wX wY
x :>: FL a wY wY
xs) RL a wB wX
acc IntSet
pids
      | PatchId -> Key
short (PatchInfo -> PatchId
makePatchID (PatchInfo -> PatchId) -> PatchInfo -> PatchId
forall a b. (a -> b) -> a -> b
$ PatchInfoAndG (Named p) wX wY -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info a wX wY
PatchInfoAndG (Named p) wX wY
x) Key -> IntSet -> Bool
`I.member` IntSet
pids = FL a wY wY -> RL a wB wY -> IntSet -> RL a wP wQ
forall (p :: * -> * -> *) (a :: * -> * -> *) wX wY wB wP wQ.
(RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) =>
FL a wX wY -> RL a wB wX -> IntSet -> RL a wP wQ
keepElems FL a wY wY
xs (RL a wB wX
acc RL a wB wX -> a wX wY -> RL a wB wY
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: a wX wY
x) IntSet
pids
      | Bool
otherwise = FL a wX (ZonkAny 0) -> RL a wB wX -> IntSet -> RL a wP wQ
forall (p :: * -> * -> *) (a :: * -> * -> *) wX wY wB wP wQ.
(RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) =>
FL a wX wY -> RL a wB wX -> IntSet -> RL a wP wQ
keepElems (FL a wY wY -> FL a wX (ZonkAny 0)
forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP FL a wY wY
xs) RL a wB wX
acc IntSet
pids

type PatchFilter p = [AnchoredPath] -> [Sealed2 (PatchInfoAnd p)] -> IO [Sealed2 (PatchInfoAnd p)]

-- | If a patch index is available, returns a filter that takes a list of files
--   and returns a @PatchFilter@ that only keeps patches that modify the given
--   list of files. If patch-index cannot be used, return the original input.
--   If patch-index does not exist and is not explicitely disabled, silently
--   create it. (Also, if it is out-of-sync, which should not happen, silently
--   update it).
maybeFilterPatches
    :: (RepoPatch p, ApplyState p ~ Tree)
    => Repository rt p wU wR  -- ^ The repository
    -> PatchSet p Origin wR   -- ^ PatchSet of patches of repository (in case patch-index needs to be created)
    -> PatchFilter p          -- ^ PatchFilter ready to be used by SelectChanges.
maybeFilterPatches :: forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSet p Origin wR -> PatchFilter p
maybeFilterPatches Repository rt p wU wR
repo PatchSet p Origin wR
ps [AnchoredPath]
fps [Sealed2 (PatchInfoAnd p)]
ops = do
    usePI <- Repository rt p wU wR -> IO Bool
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO Bool
canUsePatchIndex Repository rt p wU wR
repo
    if usePI
      then do
        pi@(PatchIndex _ _ _ infom) <- loadSafePatchIndex repo ps
        let fids = [Maybe FileId] -> [FileId]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FileId] -> [FileId]) -> [Maybe FileId] -> [FileId]
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> Maybe FileId) -> [AnchoredPath] -> [Maybe FileId]
forall a b. (a -> b) -> [a] -> [b]
map ((\AnchoredPath
fn -> PIM (Maybe FileId) -> PatchIndex -> Maybe FileId
forall s a. State s a -> s -> a
evalState (AnchoredPath -> PIM (Maybe FileId)
lookupFid' AnchoredPath
fn) PatchIndex
pi)) [AnchoredPath]
fps
            npids = [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
I.unions ([IntSet] -> IntSet) -> [IntSet] -> IntSet
forall a b. (a -> b) -> a -> b
$ (FileId -> IntSet) -> [FileId] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map (FileInfo -> IntSet
touching(FileInfo -> IntSet) -> (FileId -> FileInfo) -> FileId -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Maybe FileInfo -> FileInfo
forall a. HasCallStack => Maybe a -> a
fromJust(Maybe FileInfo -> FileInfo)
-> (FileId -> Maybe FileInfo) -> FileId -> FileInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(FileId -> InfoMap -> Maybe FileInfo
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` InfoMap
infom)) [FileId]
fids
        return $ filter
          (flip I.member npids . (unseal2 (short . makePatchID . info))) ops
      else return ops

-- | Dump information in patch index. Patch-index should be checked to exist beforehand. Read-only.
dumpPatchIndex :: FilePath -> IO ()
dumpPatchIndex :: FilePath -> IO ()
dumpPatchIndex FilePath
repodir = do
  (_,inv_hash,_,PatchIndex pids fidspans fpspans infom) <- FilePath -> IO (Int8, FilePath, Map PatchId Key, PatchIndex)
loadPatchIndex FilePath
repodir
  putStrLn $ unlines $
    [ "Inventory hash:" ++ inv_hash
    , "================="
    , "Repo state:"
    , "==========="
    , dumpRepoState pids
    , "Fileid spans:"
    , "============="
    , dumpFileIdSpans fidspans
    , "Filepath spans:"
    , "=============="
    , dumpFilePathSpans fpspans
    , "Info Map:"
    , "========="
    , dumpTouchingMap infom
    , "Files:"
    , "=============="
    ] ++ fpSpans2filePaths fpspans infom

-- | Read-only sanity check on patch-index. Patch-index should be checked to exist beforehand. It may not be in sync with repository.
piTest :: FilePath -> IO ()
piTest :: FilePath -> IO ()
piTest FilePath
repodir = do
   (_,_,_,PatchIndex rpids fidspans fpspans infom) <- FilePath -> IO (Int8, FilePath, Map PatchId Key, PatchIndex)
loadPatchIndex FilePath
repodir
   let pids = [PatchId] -> [PatchId]
forall a. [a] -> [a]
reverse [PatchId]
rpids

   -- test fidspans
   putStrLn "fidspans"
   putStrLn "==========="
   forM_ (M.toList fidspans) $ \(AnchoredPath
fn, [FileIdSpan]
spans) -> do
      let g :: FileIdSpan -> [PatchId]
          g :: FileIdSpan -> [PatchId]
g (FidSpan FileId
_ PatchId
x (Just PatchId
y)) = [PatchId
y,PatchId
x]
          g (FidSpan FileId
_ PatchId
x Maybe PatchId
_) = [PatchId
x]
          ascTs :: [PatchId]
ascTs = [PatchId] -> [PatchId]
forall a. [a] -> [a]
reverse ([PatchId] -> [PatchId])
-> ([[PatchId]] -> [PatchId]) -> [[PatchId]] -> [PatchId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PatchId] -> [PatchId]
forall a. Eq a => [a] -> [a]
nub ([PatchId] -> [PatchId])
-> ([[PatchId]] -> [PatchId]) -> [[PatchId]] -> [PatchId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[PatchId]] -> [PatchId]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PatchId]] -> [PatchId]) -> [[PatchId]] -> [PatchId]
forall a b. (a -> b) -> a -> b
$ (FileIdSpan -> [PatchId]) -> [FileIdSpan] -> [[PatchId]]
forall a b. (a -> b) -> [a] -> [b]
map FileIdSpan -> [PatchId]
g [FileIdSpan]
spans
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PatchId] -> [PatchId] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInOrder [PatchId]
ascTs [PatchId]
pids) (FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"In order test failed! filename: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
forall a. Show a => a -> FilePath
show AnchoredPath
fn)
      [FileIdSpan] -> (FileIdSpan -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FileIdSpan]
spans ((FileIdSpan -> IO ()) -> IO ()) -> (FileIdSpan -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FidSpan FileId
fid PatchId
_ Maybe PatchId
_) -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FileId -> FilePathSpans -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member FileId
fid FilePathSpans
fpspans) (FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Valid file id test failed! fid: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FileId -> FilePath
forall a. Show a => a -> FilePath
show FileId
fid)
   putStrLn "fidspans tests passed"

   -- test fpspans
   putStrLn "fpspans"
   putStrLn "==========="
   forM_ (M.toList fpspans) $ \(FileId
fid, [FilePathSpan]
spans) -> do
      let g :: FilePathSpan -> [PatchId]
          g :: FilePathSpan -> [PatchId]
g (FpSpan AnchoredPath
_ PatchId
x (Just PatchId
y)) = [PatchId
y,PatchId
x]
          g (FpSpan AnchoredPath
_ PatchId
x Maybe PatchId
_) = [PatchId
x]
          ascTs :: [PatchId]
ascTs = [PatchId] -> [PatchId]
forall a. [a] -> [a]
reverse ([PatchId] -> [PatchId])
-> ([[PatchId]] -> [PatchId]) -> [[PatchId]] -> [PatchId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PatchId] -> [PatchId]
forall a. Eq a => [a] -> [a]
nub ([PatchId] -> [PatchId])
-> ([[PatchId]] -> [PatchId]) -> [[PatchId]] -> [PatchId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[PatchId]] -> [PatchId]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PatchId]] -> [PatchId]) -> [[PatchId]] -> [PatchId]
forall a b. (a -> b) -> a -> b
$ (FilePathSpan -> [PatchId]) -> [FilePathSpan] -> [[PatchId]]
forall a b. (a -> b) -> [a] -> [b]
map FilePathSpan -> [PatchId]
g [FilePathSpan]
spans
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PatchId] -> [PatchId] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInOrder [PatchId]
ascTs [PatchId]
pids) (FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"In order test failed! fileid: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FileId -> FilePath
forall a. Show a => a -> FilePath
show FileId
fid)
      [FilePathSpan] -> (FilePathSpan -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePathSpan]
spans ((FilePathSpan -> IO ()) -> IO ())
-> (FilePathSpan -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FpSpan AnchoredPath
fn PatchId
_ Maybe PatchId
_) -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AnchoredPath -> FileIdSpans -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member AnchoredPath
fn FileIdSpans
fidspans) (FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Valid file name test failed! file name: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
forall a. Show a => a -> FilePath
show AnchoredPath
fn)
      let f :: FilePathSpan -> FilePathSpan -> Bool
          f :: FilePathSpan -> FilePathSpan -> Bool
f (FpSpan AnchoredPath
_ PatchId
x Maybe PatchId
_) (FpSpan AnchoredPath
_ PatchId
_ (Just PatchId
y)) = PatchId
x PatchId -> PatchId -> Bool
forall a. Eq a => a -> a -> Bool
== PatchId
y
          f FilePathSpan
_ FilePathSpan
_ = FilePath -> Bool
forall a. HasCallStack => FilePath -> a
error FilePath
"adj test of fpspans fail"
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (FilePathSpan -> FilePathSpan -> Bool)
-> [FilePathSpan] -> [FilePathSpan] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FilePathSpan -> FilePathSpan -> Bool
f [FilePathSpan]
spans ([FilePathSpan] -> [FilePathSpan]
forall a. HasCallStack => [a] -> [a]
tailErr [FilePathSpan]
spans)) (FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Adjcency test failed! fid: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FileId -> FilePath
forall a. Show a => a -> FilePath
show FileId
fid)
   putStrLn "fpspans tests passed"

   -- test infomap
   putStrLn "infom"
   putStrLn "==========="
   putStrLn $ "Valid fid test: " ++ (show.and $ map (`M.member` fpspans) (M.keys infom))
   putStrLn $ "Valid pid test: " ++ (show.flip I.isSubsetOf (I.fromList $ map short pids)  . I.unions . map touching . M.elems $ infom)
   where
          isInOrder :: Eq a => [a] -> [a] -> Bool
          isInOrder :: forall a. Eq a => [a] -> [a] -> Bool
isInOrder (a
x:[a]
xs) (a
y:[a]
ys) | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInOrder [a]
xs [a]
ys
                                  | Bool
otherwise = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInOrder (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [a]
ys
          isInOrder [] [a]
_ = Bool
True
          isInOrder [a]
_ [] = Bool
False