{-# 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 for more information. -} module Darcs.Repository.PatchIndex ( doesPatchIndexExist, isPatchIndexDisabled, isPatchIndexInSync, canUsePatchIndex, createPIWithInterrupt, createOrUpdatePatchIndexDisk, deletePatchIndex, attemptCreatePatchIndex, PatchFilter, maybeFilterPatches, getRelevantSubsequence, dumpPatchIndex, piTest ) where import Prelude () import Darcs.Prelude import Data.Binary ( encodeFile, decodeFile ) import Data.Word ( Word32 ) import Data.Int ( Int8 ) import Data.List ( group, mapAccumL, sort, isPrefixOf, nub, (\\) ) import Data.Maybe ( fromMaybe, isJust ) import Data.Set (Set) import Data.Map (Map) import qualified Data.Map as M import qualified Data.Set as S import Control.Exception ( catch ) import Control.Monad ( forM_, unless, when ) import Control.Monad.State.Strict ( evalState, execState, State, gets, modify ) import Control.Applicative ( (<$>) ) import System.Directory ( createDirectory, renameDirectory, doesFileExist, doesDirectoryExist ) import Darcs.Repository.Format ( formatHas, RepoProperty( HashedInventory ) ) import Darcs.Repository.InternalTypes ( Repository, repoLocation, repoFormat ) import Darcs.Patch.Witnesses.Ordered ( mapFL, RL(..), FL(..), reverseRL ) import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal, seal2, unsafeUnseal ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd(..), info ) import Darcs.Util.Lock ( withPermDir, rmRecursive ) import Darcs.Patch ( RepoPatch, listTouchedFiles ) import Darcs.Util.Path ( FileName, fp2fn, fn2fp, toFilePath ) import Darcs.Patch.Apply ( ApplyState(..) ) import Darcs.Patch.Set ( PatchSet(..), patchSet2FL, Origin, patchSet2FL ) import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Util.Global ( darcsdir ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Patch.Index.Types import Darcs.Patch.Index.Monad ( applyToFileMods, makePatchID ) import System.FilePath( () ) import System.IO (openFile, IOMode(WriteMode), hClose) import qualified Data.ByteString as B import Darcs.Util.Hash ( sha256sum, showAsHex ) import Darcs.Util.Tree ( Tree(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.SignalHandler ( catchInterrupt ) data FileIdSpan = FidSpan !FileId -- the fileid has some fixed name in the !PatchId -- span starting here !(Maybe PatchId) -- and (maybe) ending here deriving (Show,Eq,Ord) data FilePathSpan = FpSpan !FileName -- the file path has some fixed fileid in the !PatchId -- span starting here !(Maybe PatchId) -- and (maybe) ending here deriving (Show,Eq,Ord) -- | info about a given fileid, e.g.. is a file or a directory data FileInfo = FileInfo { isFile::Bool, touching::Set Word32} -- first word of patch hash deriving (Show,Eq,Ord) -- | timespans where a certain filename corresponds to a file with a given id type FileIdSpans = Map FileName [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 { -- |all the PatchIds tracked by this patch index, with the most -- recent patch at the head of the list (note, stored in the -- reverse order to this on disk for backwards compatibility -- with an older format). pids::[PatchId], fidspans::FileIdSpans, fpspans::FilePathSpans, 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 version :: Int8 version = 2 type PIM a = State PatchIndex a -- | 'applyPatchMods pmods pindex' applies a list of PatchMods to the given -- patch index pindex applyPatchMods :: [(PatchId, [PatchMod FileName])] -> PatchIndex -> PatchIndex applyPatchMods pmods pindex = flip execState pindex $ mapM_ goList pmods where goList :: (PatchId, [PatchMod FileName]) -> PIM () goList (pid, mods) = do modify (\pind -> pind{pids = pid:pids pind}) mapM_ (curry go pid) (nubSeq mods) -- nubSeq handles invalid patch in darcs repo: -- move with identical target name "rename darcs_patcher to darcs-patcher." nubSeq = map head . group go :: (PatchId, PatchMod FileName) -> PIM () go (pid, PCreateFile fn) = do fid <- createFidStartSpan fn pid startFpSpan fid fn pid createInfo fid True insertTouch fid pid go (pid, PCreateDir fn) = do fid <- createFidStartSpan fn pid startFpSpan fid fn pid createInfo fid False insertTouch fid pid go (pid, PTouch fn) = do fid <- lookupFid fn insertTouch fid pid go (pid, PRename oldfn newfn) = do fid <- lookupFid oldfn stopFpSpan fid pid startFpSpan fid newfn pid insertTouch fid pid stopFidSpan oldfn pid startFidSpan newfn pid fid go (pid, PRemove fn) = do fid <- lookupFid fn insertTouch fid pid stopFidSpan fn pid stopFpSpan fid pid go (_, PInvalid _) = return () -- just ignore invalid changes go (pid, PDuplicateTouch fn) = do fidm <- gets fidspans case M.lookup fn fidm of Just (FidSpan fid _ _:_) -> insertTouch fid pid Nothing -> return () Just [] -> error $ "applyPatchMods: impossible, no entry for "++show fn ++" in FileIdSpans in duplicate, empty list" -- | create new filespan for created file createFidStartSpan :: FileName -> PatchId -> PIM FileId createFidStartSpan fn pstart = do fidspans <- gets fidspans case M.lookup fn fidspans of Nothing -> do let fid = FileId fn 1 modify (\pind -> pind {fidspans=M.insert fn [FidSpan fid pstart Nothing] fidspans}) return fid Just fspans -> do let fid = FileId fn (length fspans+1) modify (\pind -> pind {fidspans=M.insert fn (FidSpan fid pstart Nothing:fspans) fidspans}) return fid -- | start new span for name fn for file fid starting with patch pid startFpSpan :: FileId -> FileName -> PatchId -> PIM () startFpSpan fid fn pstart = modify (\pind -> pind {fpspans=M.alter alt fid (fpspans pind)}) where alt Nothing = Just [FpSpan fn pstart Nothing] alt (Just spans) = Just (FpSpan fn pstart Nothing:spans) -- | stop current span for file name fn stopFpSpan :: FileId -> PatchId -> PIM () stopFpSpan fid pend = modify (\pind -> pind {fpspans=M.alter alt fid (fpspans pind)}) where alt Nothing = error $ "impossible: no span for " ++ show fid alt (Just []) = error $ "impossible: no span for " ++ show fid++", empty list" alt (Just (FpSpan fp pstart Nothing:spans)) = Just (FpSpan fp pstart (Just pend):spans) alt _ = error $ "impossible: span already ended for " ++ show fid -- | start new span for name fn for file fid starting with patch pid startFidSpan :: FileName -> PatchId -> FileId -> PIM () startFidSpan fn pstart fid = modify (\pind -> pind {fidspans=M.alter alt fn (fidspans pind)}) where alt Nothing = Just [FidSpan fid pstart Nothing] alt (Just spans) = Just (FidSpan fid pstart Nothing:spans) -- | stop current span for file name fn stopFidSpan :: FileName -> PatchId -> PIM () stopFidSpan fn pend = modify (\pind -> pind {fidspans=M.alter alt fn (fidspans pind)}) where alt Nothing = error $ "impossible: no span for " ++ show fn alt (Just []) = error $ "impossible: no span for " ++ show fn++", empty list" alt (Just (FidSpan fid pstart Nothing:spans)) = Just (FidSpan fid pstart (Just pend):spans) alt _ = error $ "impossible: span already ended for " ++ show fn -- | insert touching patchid for given file id createInfo :: FileId -> Bool -> PIM () createInfo fid isF = modify (\pind -> pind {infom=M.alter alt fid (infom pind)}) where alt Nothing = Just (FileInfo isF S.empty) alt (Just _) = Just (FileInfo isF S.empty) -- forget old false positives -- | insert touching patchid for given file id insertTouch :: FileId -> PatchId -> PIM () insertTouch fid pid = modify (\pind -> pind {infom=M.alter alt fid (infom pind)}) where alt Nothing = impossible "Fileid does not exist" alt (Just (FileInfo isF pids)) = Just (FileInfo isF (S.insert (short pid) pids)) -- | lookup current fid of filepath lookupFid :: FileName -> PIM FileId lookupFid fn = do maybeFid <- lookupFid' fn case maybeFid of Nothing -> bug $ "couldn't find " ++ fn2fp fn ++ " in patch index" Just fid -> return fid -- | lookup current fid of filepatch, returning a Maybe to allow failure lookupFid' :: FileName -> PIM (Maybe FileId) lookupFid' fn = do fidm <- gets fidspans case M.lookup fn fidm of Just (FidSpan fid _ _:_) -> return $ Just fid _ -> return Nothing -- | lookup all the file ids of a given path lookupFidf' :: FileName -> PIM [FileId] lookupFidf' fn = do fidm <- gets fidspans case M.lookup fn fidm of Just spans -> return $ map (\(FidSpan fid _ _) -> fid) spans Nothing -> error $ "lookupFidf': no entry for " ++ show fn ++ " in FileIdSpans" -- | return all fids of matching subpaths -- of the given filepath lookupFids :: FileName -> PIM [FileId] lookupFids fn = do fid_spans <- gets fidspans file_idss <- mapM (lookupFidf' . fp2fn) $ filter (isPrefixOf (fn2fp fn)) (fpSpans2filePaths' fid_spans) return $ nub $ concat file_idss -- | returns a single file id if the given path is a file -- if it is a directory, if returns all the file ids of all paths inside it, -- at any point in repository history lookupFids' :: FileName -> PIM [FileId] lookupFids' fn = do info_map <- gets infom fps_spans <- gets fpspans a <- lookupFid' fn if isJust a then do let fid = fromJust a case M.lookup fid info_map of Just (FileInfo True _) -> return [fid] Just (FileInfo False _) -> let file_names = map (\(FpSpan x _ _) -> x) (fps_spans M.! fid) in nub . concat <$> mapM lookupFids file_names Nothing -> error "lookupFids' : could not find file" else return [] -- | Creates patch index that corresponds to all patches in repo. createPatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO () createPatchIndexDisk repository ps = do let patches = mapFL Sealed2 $ patchSet2FL ps createPatchIndexFrom repository $ patches2patchMods patches S.empty -- | convert patches to patchmods patches2patchMods :: (Apply p, PatchInspect p, ApplyState p ~ Tree) => [Sealed2 (PatchInfoAnd rt p)] -> Set FileName -> [(PatchId, [PatchMod FileName])] patches2patchMods patches fns = snd $ mapAccumL go fns patches where go filenames (Sealed2 p) = (filenames', (pid, pmods_effect ++ pmods_dup)) where pid = makePatchID . info $ p (filenames', pmods_effect) = applyToFileMods p filenames -- applyToFileMods only returns patchmods that actually modify a file, -- i.e., never duplicate patches touched pm = case pm of {PTouch f -> [f]; PRename a b -> [a,b]; PCreateDir f -> [f]; PCreateFile f -> [f]; PRemove f -> [f]; _ -> []} touched_all = map fp2fn $ listTouchedFiles p touched_effect = concatMap touched pmods_effect touched_invalid = [ f | (PInvalid f) <- pmods_effect] -- listTouchedFiles returns all files that touched by these -- patches, even if they have no effect, e.g. by duplicate patches pmods_dup = map PDuplicateTouch . S.elems $ S.difference (S.fromList touched_all) (S.fromList touched_invalid `S.union` S.fromList touched_effect) -- | return set of current filenames in patch index fpSpans2fileNames :: FilePathSpans -> Set FileName fpSpans2fileNames fpSpans = S.fromList [fn | (FpSpan fn _ Nothing:_)<- M.elems 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 _ [] pindex = pindex removePidSuffix pid2idx oldpids@(oldpid:_) (PatchIndex pids fidspans fpspans infom) = PatchIndex (pids \\ oldpids) (M.mapMaybe removefid fidspans) (M.mapMaybe removefp fpspans) infom -- leave hashes in infom, false positives are harmless where findIdx pid = fromMaybe (impossible "removePidSuffix") (M.lookup pid pid2idx) oldidx = findIdx oldpid from `after` idx = findIdx from > idx mto `afterM` idx | Just to <- mto, findIdx to > idx = True | otherwise = False removefid fidsps = if null fidsps' then Nothing else Just fidsps' where fidsps' = concatMap go fidsps go (FidSpan fid from mto) | from `after` oldidx && mto `afterM` oldidx = [FidSpan fid from mto] | from `after` oldidx = [FidSpan fid from Nothing] | otherwise = [] removefp fpsps = if null fpsps' then Nothing else Just fpsps' where fpsps' = concatMap go fpsps go (FpSpan fn from mto) | from `after` oldidx && mto `afterM` oldidx = [FpSpan fn from mto] | from `after` oldidx = [FpSpan fn from Nothing] | otherwise = [] -- | update the patch index to the current state of the repository updatePatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO () updatePatchIndexDisk repo patches = do let repodir = repoLocation repo (_,_,pid2idx,pindex) <- loadPatchIndex repodir -- check that patch index is up to date let flpatches = patchSet2FL patches let pidsrepo = mapFL (makePatchID . info) flpatches (oldpids,_,len_common) = uncommon (reverse $ pids pindex) pidsrepo pindex' = removePidSuffix pid2idx oldpids pindex filenames = fpSpans2fileNames (fpspans pindex') cdir = repodir indexDir -- reread to prevent holding onto patches for too long let newpatches = drop len_common $ mapFL seal2 flpatches newpmods = patches2patchMods newpatches filenames inv_hash <- getInventoryHash repodir storePatchIndex repodir cdir inv_hash (applyPatchMods newpmods pindex') where -- return uncommon suffixes and length of common prefix of as and bs uncommon = uncommon' 0 uncommon' x (a:as) (b:bs) | a == b = uncommon' (x+1) as bs | otherwise = (a:as,b:bs,x) uncommon' x as bs = (as,bs,x) -- | 'createPatchIndexFrom repo pmods' creates a patch index from the given -- patchmods. createPatchIndexFrom :: Repository rt p wR wU wT -> [(PatchId, [PatchMod FileName])] -> IO () createPatchIndexFrom repo pmods = do inv_hash <- getInventoryHash repodir storePatchIndex repodir cdir inv_hash (applyPatchMods pmods emptyPatchIndex) where repodir = repoLocation repo cdir = repodir indexDir emptyPatchIndex = PatchIndex [] M.empty M.empty M.empty getInventoryHash :: FilePath -> IO String getInventoryHash repodir = do inv <- B.readFile (repodir darcsdir "hashed_inventory") return $ sha256sum inv -- | Load patch-index from disk along with some meta data. loadPatchIndex :: FilePath -> IO (Int8, String, Map PatchId Int, PatchIndex) loadPatchIndex repodir = do let pindex_dir = repodir indexDir (v,inv_hash) <- loadRepoState (pindex_dir repoStateFile) pids <- loadPatchIds (pindex_dir pidsFile) let pid2idx = M.fromList $ zip pids [(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 wR wU wT -> PatchSet rt p Origin wR -- ^ PatchSet of the repository, used if we need to create the patch-index. -> IO PatchIndex loadSafePatchIndex repo ps = do let repodir = repoLocation repo can_use <- isPatchIndexInSync repo (_,_,_,pi) <- if can_use then loadPatchIndex repodir 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 repodir = do filesArePresent <- and <$> mapM (doesFileExist . (pindex_dir )) [repoStateFile, pidsFile, touchMapFile, fidMapFile, 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 = repodir indexDir piVersion = fst <$> loadRepoState (pindex_dir repoStateFile) -- | Read-only. Checks if @_darcs\/noPatchIndex@ exists, that is, if patch-index is explicitely disabled. isPatchIndexDisabled :: FilePath -> IO Bool isPatchIndexDisabled repodir = doesFileExist (repodir darcsdir 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 wR wU wT -> PatchSet rt p Origin wR -> IO () createOrUpdatePatchIndexDisk repo ps = do let repodir = repoLocation repo rmRecursive (repodir darcsdir noPatchIndex) `catch` \(_ :: IOError) -> return () dpie <- doesPatchIndexExist repodir if dpie then updatePatchIndexDisk repo ps else createPatchIndexDisk repo ps -- | 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 wR wU wT -> IO Bool canUsePatchIndex repo = do let repodir = repoLocation repo piExists <- doesPatchIndexExist repodir piDisabled <- isPatchIndexDisabled repodir case (piExists, piDisabled) of (True, False) -> return True (False, True) -> return False (True, True) -> error "patch index exists, and patch index is disabled. run optimize enable-patch-index or disable-patch-index to rectify." (False, False) -> return 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 wR wU wT -> PatchSet rt p Origin wR -> IO () createPIWithInterrupt repo ps = do let repodir = repoLocation repo putStrLn "Creating a patch index, please wait. To stop press Ctrl-C" (do createPatchIndexDisk repo ps putStrLn "Created patch index.") `catchInterrupt` (putStrLn "Patch Index Disabled" >> deletePatchIndex repodir) -- | Checks if patch-index exists and is in sync with repository (more precisely with @_darcs\/hashed_inventory@). -- That is, checks if patch-index can be used as it is now. isPatchIndexInSync :: Repository rt p wR wU wT -> IO Bool isPatchIndexInSync repo = do let repodir = repoLocation repo dpie <- doesPatchIndexExist 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 -> FilePath -> String -> PatchIndex -> IO () storePatchIndex repodir cdir inv_hash (PatchIndex pids fidspans fpspans infom) = do createDirectory cdir `catch` \(_ :: IOError) -> return () tmpdir <- withPermDir (repodir "filecache-tmp") $ \dir -> do debugMessage "About to create patch index..." let tmpdir = toFilePath dir storeRepoState (tmpdir repoStateFile) inv_hash storePatchIds (tmpdir pidsFile) pids storeInfoMap (tmpdir touchMapFile) infom storeFidMap (tmpdir fidMapFile) fidspans storeFpMap (tmpdir fpMapFile) fpspans debugMessage "Patch index created" return tmpdir rmRecursive cdir `catch` \(_ :: IOError) -> return () renameDirectory tmpdir cdir storeRepoState :: FilePath -> String -> IO () storeRepoState fp inv_hash = encodeFile fp (version,inv_hash) loadRepoState :: FilePath -> IO (Int8, String) loadRepoState = decodeFile storePatchIds :: FilePath -> [PatchId] -> IO () storePatchIds = encodeFile loadPatchIds :: FilePath -> IO [PatchId] loadPatchIds = decodeFile storeFidMap :: FilePath -> FileIdSpans -> IO () storeFidMap fp fidm = encodeFile fp $ M.map (map (\(FidSpan a b c) -> (a, b, toIdxM c))) fidm where toIdxM Nothing = zero toIdxM (Just pid) = pid loadFidMap :: FilePath -> IO FileIdSpans loadFidMap fp = M.map (map (\(a,b,c) -> FidSpan a b (toPidM c))) <$> decodeFile fp where toPidM pid | pid == zero = Nothing | otherwise = Just pid storeFpMap :: FilePath -> FilePathSpans -> IO () storeFpMap fp fidm = encodeFile fp $ M.map (map (\(FpSpan a b c) -> (a, b, toIdxM c))) fidm where toIdxM Nothing = zero toIdxM (Just pid) = pid loadFpMap :: FilePath -> IO FilePathSpans loadFpMap fp = M.map (map (\(a,b,c) -> FpSpan a b (toPidM c))) <$> decodeFile fp where toPidM pid | pid == zero = Nothing | otherwise = Just pid storeInfoMap :: FilePath -> InfoMap -> IO () storeInfoMap fp infom = encodeFile fp $ M.map (\fi -> (isFile fi, touching fi)) infom loadInfoMap :: FilePath -> IO InfoMap loadInfoMap fp = M.map (\(isF,pids) -> FileInfo isF pids) <$> decodeFile fp indexDir, repoStateFile, pidsFile, fidMapFile, fpMapFile, touchMapFile, noPatchIndex :: String indexDir = darcsdir "patch_index" repoStateFile = "repo_state" pidsFile = "patch_ids" fidMapFile = "fid_map" fpMapFile = "fp_map" touchMapFile = "touch_map" noPatchIndex = "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 repodir = do exists <- doesDirectoryExist indexDir when exists $ rmRecursive indexDir `catch` \(e :: IOError) -> error $ "Error: Could not delete patch index\n" ++ show e (openFile (repodir darcsdir noPatchIndex) WriteMode >>= hClose) `catch` \(e :: IOError) -> error $ "Error: Could not disable patch index\n" ++ show e dumpRepoState :: [PatchId] -> String dumpRepoState = unlines . map pid2string dumpFileIdSpans :: FileIdSpans -> String dumpFileIdSpans fidspans = unlines [fn2fp fn++" -> "++showFileId fid++" from "++pid2string from++" to "++maybe "-" pid2string mto | (fn, fids) <- M.toList fidspans, FidSpan fid from mto <- fids] dumpFilePathSpans :: FilePathSpans -> String dumpFilePathSpans fpspans = unlines [showFileId fid++" -> "++ fn2fp fn++" from "++pid2string from++" to "++maybe "-" pid2string mto | (fid, fns) <- M.toList fpspans, FpSpan fn from mto <- fns] dumpTouchingMap :: InfoMap -> String dumpTouchingMap infom = unlines [showFileId fid++(if isF then "" else "/")++" -> "++ showAsHex w32 | (fid,FileInfo isF w32s) <- M.toList infom, w32 <- S.elems w32s] -- | return set of current filepaths in patch index fpSpans2filePaths :: FilePathSpans -> InfoMap -> [FilePath] fpSpans2filePaths fpSpans infom = sort [fn2fp fn ++ (if isF then "" else "/") | (fid,FpSpan fn _ Nothing:_) <- M.toList fpSpans, let Just (FileInfo isF _) = M.lookup fid infom] -- | return set of current filepaths in patch index, for internal use fpSpans2filePaths' :: FileIdSpans -> [FilePath] fpSpans2filePaths' fidSpans = [fn2fp fp | (fp, _) <- M.toList fidSpans] -- | Checks if patch index can be created and build it with interrupt. attemptCreatePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> PatchSet rt p Origin wR -> IO () attemptCreatePatchIndex repo ps = do canCreate <- canCreatePI 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 wR wU wT -> IO Bool canCreatePI repo = (not . or) <$> sequence [ doesntHaveHashedInventory (repoFormat repo) , isPatchIndexDisabled repodir , doesPatchIndexExist repodir ] where repodir = repoLocation repo doesntHaveHashedInventory = return . not . formatHas 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 rt p) => Sealed ((RL a) wK) -- ^ Sequence of patches you want to filter -> Repository rt p wR wU wR -- ^ The repository (to attempt loading patch-index from its path) -> PatchSet rt p Origin wR -- ^ PatchSet of repository (in case we need to create patch-index) -> [FileName] -- ^ File(s) about which you want patches from given sequence -> IO (Sealed ((RL a) Origin)) -- ^ Filtered sequence of patches. getRelevantSubsequence pxes repository ps fns = do pi@(PatchIndex _ _ _ infom) <- loadSafePatchIndex repository ps let fids = map (\fn -> evalState (lookupFid fn) pi) fns pidss = map ((\(FileInfo _ a) -> a).fromJust.(`M.lookup` infom)) fids pids = S.unions pidss let flpxes = reverseRL $ unsafeUnseal pxes return.seal $ keepElems flpxes NilRL pids where keepElems :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd rt p) => FL a wX wY -> RL a wB wX -> S.Set Word32 -> RL a wP wQ keepElems NilFL acc _ = unsafeCoerceP acc keepElems (x:>:xs) acc pids | short (makePatchID $ info x) `S.member` pids = keepElems xs (acc:<:x) pids | otherwise = keepElems (unsafeCoerceP xs) acc pids type PatchFilter rt p = [FilePath] -> [Sealed2 (PatchInfoAnd rt p)] -> IO [Sealed2 (PatchInfoAnd rt 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 wR wU wT -- ^ The repository -> PatchSet rt p Origin wR -- ^ PatchSet of patches of repository (in case patch-index needs to be created) -> PatchFilter rt p -- ^ PatchFilter ready to be used by SelectChanges. maybeFilterPatches repo ps fps ops = do usePI <- canUsePatchIndex repo if usePI then do pi@(PatchIndex _ _ _ infom) <- loadSafePatchIndex repo ps let fids = concatMap ((\fn -> evalState (lookupFids' fn) pi). fp2fn) fps npids = S.unions $ map (touching.fromJust.(`M.lookup` infom)) fids return $ filter (flip S.member npids . (\(Sealed2 (PIAP pin _)) -> short $ makePatchID pin)) ops else return ops -- | Dump information in patch index. Patch-index should be checked to exist beforehand. Read-only. dumpPatchIndex :: FilePath -> IO () dumpPatchIndex repodir = do (_,inv_hash,_,PatchIndex pids fidspans fpspans infom) <- loadPatchIndex 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 repodir = do (_,_,_,PatchIndex rpids fidspans fpspans infom) <- loadPatchIndex repodir let pids = reverse rpids -- test fidspans putStrLn "fidspans" putStrLn "===========" forM_ (M.toList fidspans) $ \(fn, spans) -> do let g :: FileIdSpan -> [PatchId] g (FidSpan _ x (Just y)) = [y,x] g (FidSpan _ x _) = [x] ascTs = reverse . nub . concat $ map g spans unless (isInOrder ascTs pids) (error $ "In order test failed! filename: " ++ show fn) forM_ spans $ \(FidSpan fid _ _) -> unless (M.member fid fpspans) (error $ "Valid file id test failed! fid: " ++ show fid) putStrLn "fidspans tests passed" -- test fpspans putStrLn "fpspans" putStrLn "===========" forM_ (M.toList fpspans) $ \(fid, spans) -> do let g :: FilePathSpan -> [PatchId] g (FpSpan _ x (Just y)) = [y,x] g (FpSpan _ x _) = [x] ascTs = reverse . nub . concat $ map g spans unless (isInOrder ascTs pids) (error $ "In order test failed! fileid: " ++ show fid) forM_ spans $ \(FpSpan fn _ _) -> unless (M.member fn fidspans) (error $ "Valid file name test failed! file name: " ++ show fn) let f :: FilePathSpan -> FilePathSpan -> Bool f (FpSpan _ x _) (FpSpan _ _ (Just y)) = x == y f _ _ = error "adj test of fpspans fail" unless (and $ zipWith f spans (tail spans)) (error $ "Adjcency test failed! fid: " ++ show 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 S.isSubsetOf (S.fromList $ map short pids) . S.unions . map touching . M.elems $ infom) where isInOrder :: Eq a => [a] -> [a] -> Bool isInOrder (x:xs) (y:ys) | x == y = isInOrder xs ys | otherwise = isInOrder (x:xs) ys isInOrder [] _ = True isInOrder _ [] = False