module Darcs.Patch.ApplyMonad( ApplyMonad(..), withFilePaths, withFiles ) where
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import qualified Storage.Hashed.Monad as HSM
import ByteStringUtils( linesPS, unlinesPS )
import Darcs.Patch.FileName( FileName, movedirfilename, fn2fp )
import Storage.Hashed.AnchoredPath( floatPath, AnchoredPath )
import Control.Monad.State.Strict
import Darcs.MonadProgress
fn2ap :: FileName -> AnchoredPath
fn2ap = floatPath . fn2fp
class (Functor m, Monad m) => ApplyMonad m where
mDoesDirectoryExist :: FileName -> m Bool
mReadFilePS :: FileName -> m B.ByteString
mReadFilePSs :: FileName -> m [B.ByteString]
mReadFilePSs f = linesPS `fmap` mReadFilePS f
mCreateDirectory :: FileName -> m ()
mRemoveDirectory :: FileName -> m ()
mCreateFile :: FileName -> m ()
mCreateFile f = mModifyFilePS f $ \_ -> return B.empty
mRemoveFile :: FileName -> m ()
mRename :: FileName -> FileName -> m ()
mModifyFilePS :: FileName -> (B.ByteString -> m B.ByteString) -> m ()
mModifyFilePSs :: FileName -> ([B.ByteString] -> m [B.ByteString]) -> m ()
mModifyFilePSs f j = mModifyFilePS f (fmap unlinesPS . j . linesPS)
mChangePref :: String -> String -> String -> m ()
mChangePref _ _ _ = return ()
instance (Functor m, Monad m) => ApplyMonad (HSM.TreeMonad m) where
mDoesDirectoryExist d = HSM.directoryExists (fn2ap d)
mReadFilePS p = B.concat `fmap` BL.toChunks `fmap` HSM.readFile (fn2ap p)
mModifyFilePS p j = do have <- HSM.fileExists (fn2ap p)
x <- if have then B.concat `fmap` BL.toChunks `fmap` HSM.readFile (fn2ap p)
else return B.empty
HSM.writeFile (fn2ap p) . BL.fromChunks . (:[]) =<< j x
mCreateDirectory p = HSM.createDirectory (fn2ap p)
mRename from to = HSM.rename (fn2ap from) (fn2ap to)
mRemoveDirectory = HSM.unlink . fn2ap
mRemoveFile = HSM.unlink . fn2ap
type FilePathMonad = State [FileName]
withFilePaths :: [FileName] -> FilePathMonad a -> [FileName]
withFilePaths fps x = execState x fps
instance ApplyMonad FilePathMonad where
mDoesDirectoryExist d = gets (d `elem`)
mCreateDirectory _ = return ()
mRemoveFile f = modify $ filter (/= f)
mRemoveDirectory f = modify $ filter (/= f)
mRename a b = modify $ map (movedirfilename a b)
mModifyFilePS _ _ = return ()
instance MonadProgress FilePathMonad where
runProgressActions = silentlyRunProgressActions
type RestrictedApply = State (M.Map FileName B.ByteString)
instance ApplyMonad RestrictedApply where
mDoesDirectoryExist _ = return True
mCreateDirectory _ = return ()
mRemoveFile f = modify $ M.delete f
mRemoveDirectory _ = return ()
mRename a b = modify $ M.mapKeys (movedirfilename a b)
mModifyFilePS f j = do look <- gets $ M.lookup f
case look of
Nothing -> return ()
Just bits -> do
new <- j bits
modify $ M.insert f new
instance MonadProgress RestrictedApply where
runProgressActions = silentlyRunProgressActions
withFiles :: [(FileName, B.ByteString)] -> RestrictedApply a -> [(FileName, B.ByteString)]
withFiles p x = M.toList $ execState x $ M.fromList p