module Darcs.Repository.State
( restrictSubpaths, restrictBoring, TreeFilter(..)
, unrecordedChanges, readPending
, readRecorded, readUnrecorded, readRecordedAndPending, readWorking
, 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 ( chooseTouching )
import Darcs.Witnesses.Ordered ( FL(..), (+>+) )
import Darcs.Witnesses.Ordered ( unsafeCoerceP, EqCheck(IsEq) )
import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft )
import Darcs.Diff ( treeDiff )
import Darcs.Flags ( DarcsFlag( LookForAdds ), willIgnoreTimes )
import Darcs.Global ( darcsdir )
import Darcs.Utils ( filterPaths )
import Darcs.Repository.InternalTypes ( Repository )
import qualified Darcs.Repository.LowLevel as LowLevel
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
import qualified Storage.Hashed.Tree as Tree
#include "gadts.h"
newtype TreeFilter m = TreeFilter { applyTreeFilter :: forall tr . FilterTree tr m => tr m -> tr m }
restrictSubpaths :: (RepoPatch p) => Repository p C(r u t) -> [SubPath]
-> IO (TreeFilter m)
restrictSubpaths repo subpaths = do
Sealed pending <- LowLevel.readPending 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 (TreeFilter restrictPaths)
restrictBoring :: forall m . Tree m -> IO (TreeFilter m)
restrictBoring guide = do
boring <- boringRegexps
let boring' (AnchoredPath (Name x:_)) | x == BSC.pack darcsdir = 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 (TreeFilter restrictTree)
unrecordedChanges :: FORALL(p r u t) (RepoPatch p)
=> [DarcsFlag] -> Repository p C(r u t)
-> [SubPath] -> IO (FL Prim C(t u))
unrecordedChanges opts repo paths = do
(all_current, Sealed (pending :: FL Prim C(t x))) <- readPending repo
relevant <- restrictSubpaths repo paths
let getIndex = I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo)
current = applyTreeFilter relevant all_current
working <- case (LookForAdds `elem` opts, willIgnoreTimes opts) of
(False, False) -> getIndex
(False, True) -> do
guide <- expand current
applyTreeFilter relevant <$> restrict guide <$> readPlainTree "."
(True, ignoretimes) -> do
index <- getIndex
nonboring <- restrictBoring index
plain <- applyTreeFilter relevant <$> applyTreeFilter nonboring <$> readPlainTree "."
return $ if ignoretimes then plain else plain `overlay` index
ft <- filetypeFunction
Sealed (diff :: FL Prim C(x y)) <- (unFreeLeft `fmap` treeDiff ft current working) :: IO (Sealed (FL Prim C(x)))
IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck C(y u))
return $ sortCoalesceFL (pending +>+ diff)
readRecorded :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO)
readRecorded _repo = do
let h_inventory = darcsdir </> "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 (darcsdir </> "pristine.hashed") (size, hash)
else do have_pristine <- doesDirectoryExist $ darcsdir </> "pristine"
have_current <- doesDirectoryExist $ darcsdir </> "current"
case (have_pristine, have_current) of
(True, _) -> readPlainTree $ darcsdir </> "pristine"
(False, True) -> readPlainTree $ darcsdir </> "current"
(_, _) -> fail "No pristine tree is available!"
readUnrecorded :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO (Tree IO)
readUnrecorded repo paths = do
relevant <- restrictSubpaths repo paths
readIndex repo >>= I.updateIndex . applyTreeFilter relevant
readWorking :: IO (Tree IO)
readWorking = expand =<< (nodarcs `fmap` readPlainTree ".")
where nodarcs = Tree.filter (\(AnchoredPath (Name x:_)) _ -> x /= BSC.pack "_darcs")
readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO)
readRecordedAndPending repo = do
pristine <- readRecorded repo
Sealed pending <- snd `fmap` readPending repo
applyToTree pending pristine
readPending :: (RepoPatch p) => Repository p C(r u t) -> IO (Tree IO, Sealed (FL Prim C(t)))
readPending repo =
do Sealed pending <- LowLevel.readPending 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)
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