#include "gadts.h"
module Darcs.Repository.Pristine ( Pristine, flagsToPristine, nopristine,
createPristine, removePristine, identifyPristine,
applyPristine, createPristineFromWorking,
getPristinePop,
pristineDirectory, pristineToFlagString,
easyCreatePristineDirectoryTree,
easyCreatePartialsPristineDirectoryTree
) where
import Data.Maybe ( isJust )
import Control.Monad ( when, liftM )
import System.Directory ( createDirectory, doesDirectoryExist, doesFileExist, removeFile )
import Darcs.Lock ( rmRecursive, writeBinFile )
import Darcs.PopulationData ( Population, getPopFrom )
import Darcs.Flags ( DarcsFlag( PristinePlain, PristineNone ) )
import Darcs.Repository.Format ( RepoFormat, formatHas,
RepoProperty(HashedInventory) )
import Darcs.IO ( WriteableDirectory(mWithCurrentDirectory) )
import Darcs.Patch ( Patchy, apply )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Patch.FileName ( fp2fn )
import Darcs.RepoPath ( FilePathLike, toFilePath )
import Darcs.External ( cloneTree, cloneTreeExcept, clonePartialsTree )
import Darcs.Repository.InternalTypes ( Pristine(..) )
import Darcs.Global ( darcsdir )
import Storage.Hashed.Darcs( writeDarcsHashed )
import Storage.Hashed.Tree( emptyTree )
#include "impossible.h"
nopristine :: Pristine
nopristine = NoPristine "aack?"
pristineName :: String
pristineName = "pristine"
identifyPristine :: IO (Pristine)
identifyPristine = do mp <- reallyIdentifyPristine
case mp of
Nothing -> fail "Pristine tree doesn't exist."
Just pristine -> return pristine
reallyIdentifyPristine :: IO (Maybe Pristine)
reallyIdentifyPristine =
do dir <- findpristine doesDirectoryExist ""
none <- findpristine doesFileExist ".none"
hashinv <- doesFileExist $ darcsdir++"/hashed_inventory"
hashpris <- doesDirectoryExist hashedPristineDirectory
case (dir, none, hashinv && hashpris) of
(Nothing, Nothing, False) -> return Nothing
(Just n, Nothing, False) ->
return (Just (PlainPristine n))
(Nothing, Just n, False) ->
return (Just (NoPristine n))
(Nothing, Nothing, True) ->
return (Just HashedPristine)
_ -> fail "Multiple pristine trees."
where findpristine fn ext =
do e1 <- fn n1
e2 <- fn n2
case (e1, e2) of
(False, False) -> return Nothing
(True, False) -> return (Just n1)
(False, True) -> return (Just n2)
(True, True) -> fail "Multiple pristine trees."
where n1 = darcsdir++"/pristine" ++ ext
n2 = darcsdir++"/current" ++ ext
flagsToPristine :: [DarcsFlag] -> RepoFormat -> Pristine
flagsToPristine _ rf | formatHas HashedInventory rf = HashedPristine
flagsToPristine (PristineNone : _) _ = NoPristine (darcsdir++"/" ++ pristineName ++ ".none")
flagsToPristine (PristinePlain : _) _ = PlainPristine (darcsdir++"/" ++ pristineName)
flagsToPristine (_ : t) rf = flagsToPristine t rf
flagsToPristine [] rf = flagsToPristine [PristinePlain] rf
createPristine :: Pristine -> IO Pristine
createPristine p =
do oldpristine <- reallyIdentifyPristine
when (isJust oldpristine) $ fail "Pristine tree already exists."
case p of
NoPristine n -> writeBinFile n "Do not delete this file.\n"
PlainPristine n -> createDirectory n
HashedPristine -> do createDirectory hashedPristineDirectory
writeDarcsHashed emptyTree "_darcs/pristine.hashed"
return ()
return p
hashedPristineDirectory :: String
hashedPristineDirectory = darcsdir++"/pristine.hashed"
removePristine :: Pristine -> IO ()
removePristine (NoPristine n) = removeFile n
removePristine (PlainPristine n) = rmRecursive n
removePristine HashedPristine = rmRecursive hashedPristineDirectory
applyPristine :: Patchy p => Pristine -> p C(x y) -> IO ()
applyPristine (NoPristine _) _ = return ()
applyPristine (PlainPristine n) p =
mWithCurrentDirectory (fp2fn n) $ apply [] p
applyPristine HashedPristine _ =
bug "3 HashedPristine is not implemented yet."
createPristineFromWorking :: Pristine -> IO ()
createPristineFromWorking (NoPristine _) = return ()
createPristineFromWorking (PlainPristine n) = cloneTreeExcept [darcsdir] "." n
createPristineFromWorking HashedPristine =
bug "HashedPristine is not implemented yet."
getPristinePop :: PatchInfo -> Pristine -> IO (Maybe Population)
getPristinePop pinfo (PlainPristine n) =
Just `liftM` getPopFrom n pinfo
getPristinePop _ _ = return Nothing
pristineDirectory :: Pristine -> Maybe String
pristineDirectory (PlainPristine n) = Just n
pristineDirectory _ = Nothing
pristineToFlagString :: Pristine -> String
pristineToFlagString (NoPristine _) = "--no-pristine-tree"
pristineToFlagString (PlainPristine _) = "--plain-pristine-tree"
pristineToFlagString HashedPristine =
bug "HashedPristine is not implemented yet."
easyCreatePristineDirectoryTree :: Pristine -> FilePath -> IO Bool
easyCreatePristineDirectoryTree (NoPristine _) _ = return False
easyCreatePristineDirectoryTree (PlainPristine n) p
= cloneTree n p >> return True
easyCreatePristineDirectoryTree HashedPristine _ =
bug "HashedPristine is not implemented yet."
easyCreatePartialsPristineDirectoryTree :: FilePathLike fp => [fp] -> Pristine
-> FilePath -> IO Bool
easyCreatePartialsPristineDirectoryTree _ (NoPristine _) _ = return False
easyCreatePartialsPristineDirectoryTree prefs (PlainPristine n) p
= clonePartialsTree n p (map toFilePath prefs) >> return True
easyCreatePartialsPristineDirectoryTree _ HashedPristine _ =
bug "HashedPristine is not implemented yet."