module Darcs.FilePathMonad ( FilePathMonad, withFilePaths ) where
import Control.Monad ( MonadPlus, mplus, mzero )
import Data.Maybe ( catMaybes )
import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )
import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp, superName, breakOnDir,
normPath, movedirfilename )
#include "impossible.h"
data FilePathMonad a = FPM ([FileName] -> ([FileName], a))
withFilePaths :: [FilePath] -> FilePathMonad a -> [FilePath]
withFilePaths fps (FPM x) = map fn2fp $ fst $ x $ map fp2fn fps
instance Functor FilePathMonad where
fmap f m = m >>= return . f
instance Monad FilePathMonad where
(FPM x) >>= y = FPM z where z fs = case x fs of
(fs', a) -> case y a of
FPM yf -> yf fs'
return x = FPM $ \fs -> (fs, x)
instance MonadPlus FilePathMonad where
mzero = fail "mzero FilePathMonad"
a `mplus` _ = a
instance ReadableDirectory FilePathMonad where
mDoesDirectoryExist d =
FPM $ \fs -> (fs, normPath d `elem` map normPath fs)
mDoesFileExist f =
FPM $ \fs -> (fs, normPath f `elem` map normPath fs)
mInCurrentDirectory d (FPM j) =
FPM $ \fs -> (fs, snd $ j $ catMaybes $ map indir fs)
where indir f = do (d',f') <- breakOnDir f
if d == d' then Just f'
else Nothing
mGetDirectoryContents =
FPM $ \fs -> (fs, filter (\f -> fp2fn "." == superName f) fs)
mReadFilePS = bug "can't mReadFilePS in FilePathMonad!"
instance WriteableDirectory FilePathMonad where
mWithCurrentDirectory d (FPM j) =
FPM $ \fs ->
let splitfs = map splitf fs
others = catMaybes $ map snd splitfs
(myfs, a) = j $ catMaybes $ map fst splitfs
splitf f = case breakOnDir f of
Just (d', f') | d' == d -> (Just f', Nothing)
_ -> (Nothing, Just f)
in (others ++ myfs, a)
mSetFileExecutable _ _ = return ()
mWriteFilePS _ _ = return ()
mCreateDirectory _ = return ()
mRemoveFile f = FPM $ \fs -> (filter (/= f) fs, ())
mRemoveDirectory f = FPM $ \fs -> (filter (/= f) fs, ())
mRename a b = FPM $ \fs -> (map (movedirfilename a b) fs, ())
mModifyFilePS _ _ = return ()
mModifyFilePSs _ _ = return ()