1 -- Copyright (C) 2005 David Roundy
    2 --
    3 -- This program is free software; you can redistribute it and/or modify
    4 -- it under the terms of the GNU General Public License as published by
    5 -- the Free Software Foundation; either version 2, or (at your option)
    6 -- any later version.
    7 --
    8 -- This program is distributed in the hope that it will be useful,
    9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of
   10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   11 -- GNU General Public License for more details.
   12 --
   13 -- You should have received a copy of the GNU General Public License
   14 -- along with this program; see the file COPYING.  If not, write to
   15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   16 -- Boston, MA 02110-1301, USA.
   17 
   18 
   19 {-# OPTIONS_GHC -cpp #-}
   20 {-# LANGUAGE CPP #-}
   21 
   22 module Darcs.FilePathMonad ( FilePathMonad, withFilePaths ) where
   23 
   24 import Control.Monad ( MonadPlus, mplus, mzero )
   25 import Data.Maybe ( catMaybes )
   26 
   27 import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )
   28 import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp, super_name, break_on_dir,
   29                               norm_path, movedirfilename )
   30 #include "impossible.h"
   31 
   32 data FilePathMonad a = FPM ([FileName] -> ([FileName], a))
   33 
   34 withFilePaths :: [FilePath] -> FilePathMonad a -> [FilePath]
   35 withFilePaths fps (FPM x) = map fn2fp $ fst $ x $ map fp2fn fps
   36 
   37 instance Functor FilePathMonad where
   38     fmap f m = m >>= return . f
   39 
   40 instance Monad FilePathMonad where
   41     (FPM x) >>= y = FPM z where z fs = case x fs of
   42                                        (fs', a) -> case y a of
   43                                                    FPM yf -> yf fs'
   44     return x = FPM $ \fs -> (fs, x)
   45 
   46 instance MonadPlus FilePathMonad where
   47     mzero = fail "mzero FilePathMonad" -- yuck!
   48     a `mplus` _ = a
   49 
   50 instance ReadableDirectory FilePathMonad where
   51     -- We can't check it actually is a directory here
   52     mDoesDirectoryExist d =
   53         FPM $ \fs -> (fs, norm_path d `elem` map norm_path fs)
   54     -- We can't check it actually is a file here
   55     mDoesFileExist f =
   56         FPM $ \fs -> (fs, norm_path f `elem` map norm_path fs)
   57     mInCurrentDirectory d (FPM j) =
   58         FPM $ \fs -> (fs, snd $ j $ catMaybes $ map indir fs)
   59         where indir f = do (d',f') <- break_on_dir f
   60                            if d == d' then Just f'
   61                                       else Nothing
   62     mGetDirectoryContents =
   63         FPM $ \fs -> (fs, filter (\f -> fp2fn "." == super_name f) fs)
   64     mReadFilePS = bug "can't mReadFilePS in FilePathMonad!"                                                                                                      
   65 
   66 instance WriteableDirectory FilePathMonad where
   67     mWithCurrentDirectory d (FPM j) =
   68         FPM $ \fs ->
   69         let splitfs = map splitf fs
   70             others = catMaybes $ map snd splitfs
   71             (myfs, a) = j $ catMaybes $ map fst splitfs
   72             splitf f = case break_on_dir f of
   73                        Just (d', f') | d' == d -> (Just f', Nothing)
   74                        _ -> (Nothing, Just f)
   75         in (others ++ myfs, a)
   76     mSetFileExecutable _ _ = return ()
   77     mWriteFilePS _ _ = return ()
   78     mCreateDirectory _ = return ()
   79     mRemoveFile f = FPM $ \fs -> (filter (/= f) fs, ())
   80     mRemoveDirectory f = FPM $ \fs -> (filter (/= f) fs, ())
   81     mRename a b = FPM $ \fs -> (map (movedirfilename a b) fs, ())
   82     mModifyFilePS _ _ = return ()
   83     mModifyFilePSs _ _ = return ()