module Darcs.Patch.ApplyMonad( ApplyMonad(..), ApplyMonadTrans(..), withFileNames, withFiles, ToTree(..) ) 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 Storage.Hashed.Tree ( Tree )
import ByteStringUtils( linesPS, unlinesPS )
import Darcs.Patch.FileName( FileName, movedirfilename, fn2fp, isParentOrEqOf )
import Storage.Hashed.AnchoredPath( floatPath, AnchoredPath )
import Control.Monad.State.Strict
import Control.Monad.Identity( Identity )
import Darcs.MonadProgress
import Darcs.Patch.Prim.V3.ObjectMap ( UUID, Object, ObjectMap, DirContent )
fn2ap :: FileName -> AnchoredPath
fn2ap = floatPath . fn2fp
class ToTree s where
toTree :: s m -> Tree m
instance ToTree Tree where
toTree = id
class (Functor m, Monad m, ApplyMonad (ApplyMonadOver m state) state)
=> ApplyMonadTrans m (state :: (* -> *) -> *) where
type ApplyMonadOver m state :: * -> *
runApplyMonad :: (ApplyMonadOver m state) x -> state m -> m (x, state m)
instance (Functor m, Monad m) => ApplyMonadTrans m Tree where
type ApplyMonadOver m Tree = HSM.TreeMonad m
runApplyMonad = HSM.virtualTreeMonad
class (Functor m, Monad m, Functor (ApplyMonadBase m), Monad (ApplyMonadBase m), ToTree state)
=> ApplyMonad m (state :: (* -> *) -> *) where
type ApplyMonadBase m :: * -> *
nestedApply :: m x -> state (ApplyMonadBase m) -> m (x, state (ApplyMonadBase m))
liftApply :: (state (ApplyMonadBase m) -> (ApplyMonadBase m) x) -> state (ApplyMonadBase m)
-> m (x, state (ApplyMonadBase m))
getApplyState :: m (state (ApplyMonadBase m))
putApplyState :: state m -> m ()
editFile :: (state ~ ObjectMap) => UUID -> (B.ByteString -> B.ByteString) -> m ()
editDirectory :: (state ~ ObjectMap) => UUID -> (DirContent -> DirContent) -> m ()
mDoesDirectoryExist :: (state ~ Tree) => FileName -> m Bool
mDoesFileExist :: (state ~ Tree) => FileName -> m Bool
mReadFilePS :: (state ~ Tree) => FileName -> m B.ByteString
mReadFilePSs :: (state ~ Tree) => FileName -> m [B.ByteString]
mReadFilePSs f = linesPS `fmap` mReadFilePS f
mCreateDirectory :: (state ~ Tree) => FileName -> m ()
mRemoveDirectory :: (state ~ Tree) => FileName -> m ()
mCreateFile :: (state ~ Tree) => FileName -> m ()
mCreateFile f = mModifyFilePS f $ \_ -> return B.empty
mRemoveFile :: (state ~ Tree) => FileName -> m ()
mRename :: (state ~ Tree) => FileName -> FileName -> m ()
mModifyFilePS :: (state ~ Tree) => FileName -> (B.ByteString -> m B.ByteString) -> m ()
mModifyFilePSs :: (state ~ Tree) => FileName -> ([B.ByteString] -> m [B.ByteString]) -> m ()
mModifyFilePSs f j = mModifyFilePS f (fmap unlinesPS . j . linesPS)
mChangePref :: (state ~ Tree) => String -> String -> String -> m ()
mChangePref _ _ _ = return ()
instance (Functor m, Monad m) => ApplyMonad (HSM.TreeMonad m) Tree where
type ApplyMonadBase (HSM.TreeMonad m) = m
getApplyState = gets HSM.tree
nestedApply a init = lift $ runApplyMonad a init
liftApply a init = do x <- gets HSM.tree
lift $ runApplyMonad (lift $ a x) init
mDoesDirectoryExist d = HSM.directoryExists (fn2ap d)
mDoesFileExist d = HSM.fileExists (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 OrigFileNameOf = (FileName, FileName)
type FilePathMonadState = ([FileName], [FileName], [OrigFileNameOf])
type FilePathMonad = State FilePathMonadState
trackOrigRename :: FileName -> FileName -> OrigFileNameOf -> OrigFileNameOf
trackOrigRename old new pair@(latest, from)
| old `isParentOrEqOf` latest = (latest, movedirfilename old new latest)
| old `isParentOrEqOf` from = (latest, movedirfilename old new from)
| otherwise = pair
withFileNames :: (Maybe [OrigFileNameOf]) -> [FileName] -> FilePathMonad a
-> FilePathMonadState
withFileNames mbofnos fps x = execState x ([], fps, ofnos) where
ofnos = maybe (map (\x -> (x, x)) fps) id mbofnos
instance ApplyMonad FilePathMonad Tree where
type ApplyMonadBase FilePathMonad = Identity
mDoesDirectoryExist d = gets $ \(_, fs, _) -> d `elem` fs
mCreateDirectory = mCreateFile
mCreateFile f = modify $ \(ms, fs, rns) -> (f : ms, fs, rns)
mRemoveFile f = modify $ \(ms, fs, rns) -> (f : ms, filter (/= f) fs, rns)
mRemoveDirectory = mRemoveFile
mRename a b =
modify $ \(ms, fs, rns) -> ( a : b : ms
, map (movedirfilename a b) fs
, map (trackOrigRename a b) rns)
mModifyFilePS f _ = mCreateFile f
instance MonadProgress FilePathMonad where
runProgressActions = silentlyRunProgressActions
type RestrictedApply = State (M.Map FileName B.ByteString)
instance ApplyMonad RestrictedApply Tree where
type ApplyMonadBase RestrictedApply = Identity
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