module Darcs.Repository.State
( restrictSubpaths, restrictBoring
, unrecordedChanges, readPending, pendingChanges
, readRecorded, readUnrecorded, readRecordedAndPending
, readIndex, invalidateIndex ) where
import Prelude hiding ( filter )
import Control.Monad( when )
import Control.Applicative( (<$>) )
import Data.Maybe( isJust )
import Data.List( union )
import Text.Regex( matchRegex )
import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile )
import System.FilePath ( (</>) )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Darcs.Patch ( RepoPatch, Prim, invert, applyToTree, applyToFilepaths
, sortCoalesceFL )
import Darcs.Patch.TouchesFiles ( choose_touching )
import Darcs.Witnesses.Ordered ( FL(..), (+>+) )
import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal )
import Darcs.Diff ( treeDiff )
import Darcs.Flags ( DarcsFlag( LookForAdds ), willIgnoreTimes )
import Darcs.Utils ( filterPaths )
import Darcs.Repository.InternalTypes ( Repository )
import Darcs.Repository.LowLevel( read_pending )
import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps )
import Darcs.Patch.FileName ( fn2fp )
import Darcs.RepoPath ( SubPath, sp2fn )
import Storage.Hashed.AnchoredPath( AnchoredPath(..), anchorPath, floatPath, Name(..) )
import Storage.Hashed.Tree( Tree, restrict, FilterTree, expand, filter, emptyTree, overlay, find )
import Storage.Hashed.Plain( readPlainTree )
import Storage.Hashed.Darcs( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize )
import Storage.Hashed.Hash( Hash( NoHash ) )
import qualified Storage.Hashed.Index as I
#include "gadts.h"
restrictSubpaths :: (RepoPatch p) => Repository p C(r u t) -> [SubPath]
-> IO (forall t m. FilterTree t m => t m -> t m)
restrictSubpaths repo subpaths = do
Sealed pending <- read_pending repo
let paths = map (fn2fp . sp2fn) subpaths
paths' = paths `union` applyToFilepaths pending paths
anchored = map floatPath paths'
restrictPaths :: FilterTree t m => t m -> t m
restrictPaths = if null subpaths then id else filter (filterPaths anchored)
return restrictPaths
restrictBoring :: forall t m. Tree m -> IO (FilterTree t m => t m -> t m)
restrictBoring guide = do
boring <- boringRegexps
let boring' (AnchoredPath (Name x:_)) | x == BSC.pack "_darcs" = False
boring' p = not $ any (\rx -> isJust $ matchRegex rx p') boring
where p' = anchorPath "" p
restrictTree :: FilterTree t m => t m -> t m
restrictTree = filter $ \p _ -> case find guide p of
Nothing -> boring' p
_ -> True
return restrictTree
unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t)
-> [SubPath] -> IO (FL Prim C(r y))
unrecordedChanges opts repo paths = do
(all_current, _) <- readPending repo
Sealed pending <- pendingChanges repo paths
relevant <- restrictSubpaths repo paths
let getIndex = I.updateIndex =<< (relevant <$> readIndex repo)
current = relevant all_current
working <- case (LookForAdds `elem` opts, willIgnoreTimes opts) of
(False, False) -> getIndex
(False, True) -> do
guide <- expand current
relevant <$> restrict guide <$> readPlainTree "."
(True, ignoretimes) -> do
index <- getIndex
nonboring <- restrictBoring index
plain <- relevant <$> nonboring <$> readPlainTree "."
return $ if ignoretimes then plain else plain `overlay` index
ft <- filetypeFunction
diff <- treeDiff ft current working
return $ sortCoalesceFL (pending +>+ diff)
readRecorded :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO)
readRecorded _repo = do
let darcs = "_darcs"
h_inventory = darcs </> "hashed_inventory"
hashed <- doesFileExist h_inventory
if hashed
then do inv <- BS.readFile h_inventory
let linesInv = BSC.split '\n' inv
case linesInv of
[] -> return emptyTree
(pris_line:_) -> do
let hash = decodeDarcsHash $ BS.drop 9 pris_line
size = decodeDarcsSize $ BS.drop 9 pris_line
when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line
readDarcsHashed (darcs </> "pristine.hashed") (size, hash)
else do have_pristine <- doesDirectoryExist $ darcs </> "pristine"
have_current <- doesDirectoryExist $ darcs </> "current"
case (have_pristine, have_current) of
(True, _) -> readPlainTree $ darcs </> "pristine"
(False, True) -> readPlainTree $ darcs </> "current"
(_, _) -> fail "No pristine tree is available!"
readUnrecorded :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO)
readUnrecorded repo = readIndex repo >>= I.updateIndex
readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO)
readRecordedAndPending repo = do
pristine <- readRecorded repo
Sealed pending <- pendingChanges repo []
applyToTree pending pristine
readPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO, Sealed (FL Prim C(r)))
readPending repo =
do Sealed pending <- read_pending repo
pristine <- readRecorded repo
catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ err -> do
putStrLn $ "Yikes, pending has conflicts! " ++ show err
putStrLn $ "Stashing the buggy pending as _darcs/patches/pending_buggy"
renameFile "_darcs/patches/pending"
"_darcs/patches/pending_buggy"
return (pristine, seal NilFL)
pendingChanges :: (RepoPatch p) => Repository p C(r u t)
-> [SubPath] -> IO (Sealed (FL Prim C(r)))
pendingChanges repo paths = do
Sealed pending <- snd `fmap` readPending repo
let files = map (fn2fp . sp2fn) paths
pre_files = applyToFilepaths (invert pending) files
relevant = case paths of
[] -> seal pending
_ -> choose_touching pre_files pending
return relevant
invalidateIndex :: t -> IO ()
invalidateIndex _ = do
BS.writeFile "_darcs/index_invalid" BS.empty
readIndex :: (RepoPatch p) => Repository p C(r u t) -> IO I.Index
readIndex repo = do
invalid <- doesFileExist "_darcs/index_invalid"
exist <- doesFileExist "_darcs/index"
format_valid <- if exist
then I.indexFormatValid "_darcs/index"
else return True
when (exist && not format_valid) $
#if mingw32_HOST_OS
renameFile "_darcs/index" "_darcs/index.old"
#else
removeFile "_darcs/index"
#endif
if (not exist || invalid || not format_valid)
then do pris <- readRecordedAndPending repo
idx <- I.updateIndexFrom "_darcs/index" darcsTreeHash pris
when invalid $ removeFile "_darcs/index_invalid"
return idx
else I.readIndex "_darcs/index" darcsTreeHash