src/Darcs/FilePathMonad.lhs

   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 \begin{code}
  20 {-# OPTIONS_GHC -cpp #-}
  21 {-# LANGUAGE CPP #-}
  22
  23 module Darcs.FilePathMonad ( FilePathMonad, withFilePaths ) where
  24
  25 import Control.Monad ( MonadPlus, mplus, mzero )
  26 import Data.Maybe ( catMaybes )
  27
  28 import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )
  29 import Darcs.Patch.FileName ( FileName, fp2fn, fn2fp, super_name, break_on_dir,
  30                               norm_path, movedirfilename )
  31 #include "impossible.h"
  32 \end{code}
  33
  34 \begin{code}
  35 data FilePathMonad a = FPM ([FileName] -> ([FileName], a))
  36
  37 withFilePaths :: [FilePath] -> FilePathMonad a -> [FilePath]
  38 withFilePaths fps (FPM x) = map fn2fp $ fst $ x $ map fp2fn fps
  39
  40 instance Functor FilePathMonad where
  41     fmap f m = m >>= return . f
  42
  43 instance Monad FilePathMonad where
  44     (FPM x) >>= y = FPM z where z fs = case x fs of
  45                                        (fs', a) -> case y a of
  46                                                    FPM yf -> yf fs'
  47     return x = FPM $ \fs -> (fs, x)
  48
  49 instance MonadPlus FilePathMonad where
  50     mzero = fail "mzero FilePathMonad" -- yuck!
  51     a `mplus` _ = a
  52
  53 instance ReadableDirectory FilePathMonad where
  54     -- We can't check it actually is a directory here
  55     mDoesDirectoryExist d =
  56         FPM $ \fs -> (fs, norm_path d `elem` map norm_path fs)
  57     -- We can't check it actually is a file here
  58     mDoesFileExist f =
  59         FPM $ \fs -> (fs, norm_path f `elem` map norm_path fs)
  60     mInCurrentDirectory d (FPM j) =
  61         FPM $ \fs -> (fs, snd $ j $ catMaybes $ map indir fs)
  62         where indir f = do (d',f') <- break_on_dir f
  63                            if d == d' then Just f'
  64                                       else Nothing
  65     mGetDirectoryContents =
  66         FPM $ \fs -> (fs, filter (\f -> fp2fn "." == super_name f) fs)
  67     mReadFilePS = bug "can't mReadFilePS in FilePathMonad!"
  68
  69 instance WriteableDirectory FilePathMonad where
  70     mWithCurrentDirectory d (FPM j) =
  71         FPM $ \fs ->
  72         let splitfs = map splitf fs
  73             others = catMaybes $ map snd splitfs
  74             (myfs, a) = j $ catMaybes $ map fst splitfs
  75             splitf f = case break_on_dir f of
  76                        Just (d', f') | d' == d -> (Just f', Nothing)
  77                        _ -> (Nothing, Just f)
  78         in (others ++ myfs, a)
  79     mSetFileExecutable _ _ = return ()
  80     mWriteFilePS _ _ = return ()
  81     mCreateDirectory _ = return ()
  82     mRemoveFile f = FPM $ \fs -> (filter (/= f) fs, ())
  83     mRemoveDirectory f = FPM $ \fs -> (filter (/= f) fs, ())
  84     mRename a b = FPM $ \fs -> (map (movedirfilename a b) fs, ())
  85     mModifyFilePS _ _ = return ()
  86     mModifyFilePSs _ _ = return ()
  87 \end{code}