src/Darcs/SlurpDirectory.lhs

   1 %  Copyright (C) 2002-2004 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 \chapter{SlurpDirectory}
  19
  20 \section{Introduction}
  21
  22 SlurpDirectory is intended to give a nice lazy way of traversing directory
  23 trees.
  24
  25 \begin{code}
  26 {-# OPTIONS_GHC -cpp #-}
  27 {-# LANGUAGE CPP #-}
  28
  29 module Darcs.SlurpDirectory ( Slurpy(..), FileContents, empty_slurpy,
  30                         slurp, mmap_slurp, slurp_unboring, co_slurp,
  31                         slurp_name, is_file, is_dir,
  32                         get_filecontents, get_dircontents, get_mtime,
  33                         get_length, get_slurp,
  34                         get_slurp_context, get_slurp_context_maybe,
  35                         get_slurp_context_list,
  36                         slurp_removefile, slurp_removedir,
  37                         slurp_remove,
  38                         slurp_modfile, slurp_hasfile, slurp_hasdir,
  39                         slurp_has_anycase, wait_a_moment, undefined_time,
  40                         undefined_size,
  41                         slurp_has, list_slurpy, list_slurpy_files,
  42                         get_path_list,
  43                         list_slurpy_dirs,
  44                         isFileReallySymlink,
  45                         doesFileReallyExist, doesDirectoryReallyExist,
  46                         SlurpMonad, withSlurpy, write_files,
  47                         writeSlurpy
  48                       ) where
  49
  50 import System.IO
  51 import System.Directory hiding ( getCurrentDirectory, renameFile )
  52 import Workaround ( getCurrentDirectory )
  53 import Darcs.Utils ( withCurrentDirectory, formatPath )
  54 import Darcs.RepoPath ( FilePathLike, toPath )
  55 import System.IO.Unsafe ( unsafeInterleaveIO )
  56 import Data.List ( sort, tails, isPrefixOf )
  57 import Control.Monad ( MonadPlus(..) )
  58 import Data.Char ( toLower )
  59 import System.Posix.Types ( EpochTime )
  60 import System.Posix.Files
  61         ( getSymbolicLinkStatus, modificationTime,
  62           fileSize,
  63           isRegularFile, isDirectory, isSymbolicLink
  64         )
  65 import System.Posix ( sleep )
  66 import Data.Maybe ( catMaybes, isJust, maybeToList )
  67
  68 import Darcs.SignalHandler ( tryNonSignal )
  69 import Darcs.CheckFileSystem ( can_I_use_mmap )
  70 import Darcs.IO ( ReadableDirectory(..), WriteableDirectory(..) )
  71
  72 import ByteStringUtils
  73 import qualified Data.ByteString as B
  74
  75 import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, norm_path, break_on_dir,
  76                               own_name, super_name )
  77 #if mingw32_HOST_OS
  78 import Data.Int ( Int64 )
  79 #else
  80 import System.Posix.Types ( FileOffset )
  81 #endif
  82
  83 #include "impossible.h"
  84
  85 #if mingw32_HOST_OS
  86 type FileOffset = Int64
  87 #endif
  88
  89 data Slurpy = SlurpDir FileName (Maybe String) [Slurpy]
  90             | SlurpFile FileName (Maybe String,EpochTime,FileOffset) FileContents
  91 type FileContents = B.ByteString
  92
  93 instance Show Slurpy where
  94     show (SlurpDir fn _ l) =
  95         "Dir " ++ (fn2fp fn) ++ "\n" ++
  96               concat (map show l) ++ "End Dir " ++ (fn2fp fn) ++ "\n"
  97     show (SlurpFile fn _ _) = "File " ++ (fn2fp fn) ++ "\n"
  98
  99 slurp :: FilePathLike p => p -> IO Slurpy
 100 mmap_slurp :: FilePath -> IO Slurpy
 101 slurp_unboring :: (FilePath->Bool) -> FilePath -> IO Slurpy
 102 empty_slurpy :: Slurpy
 103 empty_slurpy = SlurpDir (fp2fn ".") Nothing []
 104 slurp_name :: Slurpy -> FilePath
 105 is_file :: Slurpy -> Bool
 106 is_dir :: Slurpy -> Bool
 107
 108 get_filecontents :: Slurpy -> FileContents
 109 get_dircontents :: Slurpy -> [Slurpy]
 110 get_mtime :: Slurpy -> EpochTime
 111 get_length :: Slurpy -> FileOffset
 112
 113 instance Eq Slurpy where
 114     s1 == s2 = (slurp_name s1) == (slurp_name s2)
 115 instance Ord Slurpy where
 116     s1 <= s2 = (slurp_name s1) <= (slurp_name s2)
 117 \end{code}
 118
 119 \begin{code}
 120 data SlurpMonad a = SM ((Either String Slurpy)
 121                         -> Either String (Slurpy, a))
 122 mksm :: (Slurpy -> Either String (Slurpy, a)) -> SlurpMonad a
 123 mksm x = SM sm where sm (Left e) = Left e
 124                      sm (Right s) = x s
 125
 126 instance Functor SlurpMonad where
 127     fmap f m = m >>= return . f
 128
 129 instance Monad SlurpMonad where
 130     (SM p) >>= k  =  SM sm
 131         where sm e = case p e of
 132                      Left er -> Left er
 133                      Right (s, a) -> case k a of
 134                                      (SM q) -> q (Right s)
 135     return a = SM ( \s -> case s of
 136                           Left e -> Left e
 137                           Right x -> Right (x, a) )
 138     fail e = SM ( \s -> case s of
 139                         Left x -> Left x
 140                         _ -> Left e )
 141
 142 instance MonadPlus SlurpMonad where
 143     mzero = fail "SlurpMonad mzero"
 144     (SM p) `mplus` (SM q) = SM sm
 145         where sm e = case p e of
 146                      Left _ -> q e
 147                      okay -> okay
 148
 149 instance ReadableDirectory SlurpMonad where
 150     mDoesDirectoryExist d = smDoesDirectoryExist d
 151     mDoesFileExist f = smDoesFileExist f
 152     mInCurrentDirectory = smInSlurpy
 153     mGetDirectoryContents = smGetDirContents
 154     mReadFilePS = smReadFilePS
 155     mReadFilePSs = smReadFilePSs
 156
 157 instance WriteableDirectory SlurpMonad where
 158     mWithCurrentDirectory = modifySubSlurpy
 159     mSetFileExecutable _ _ = return ()
 160     mWriteFilePS = smWriteFilePS
 161     mCreateDirectory = smCreateDirectory
 162     mRename = smRename
 163     mRemoveDirectory = smRemoveDirectory
 164     mRemoveFile = smRemoveFile
 165 \end{code}
 166
 167 \begin{code}
 168
 169
 170 write_file :: Slurpy -> FileName -> IO ()
 171 write_file s fn = case withSlurpy s $ smReadFilePS fn of
 172                      Left err -> fail err
 173                      Right (_, c) -> do
 174                        ensureDirectories (super_name fn)
 175                        mWriteFilePS fn c
 176
 177 try_write_file :: Slurpy -> FilePath -> IO ()
 178 try_write_file s fp = let fn = fp2fn fp in
 179   if slurp_hasfile fn s
 180       then write_file s fn
 181       else if slurp_hasdir fn s
 182                then ensureDirectories fn
 183                else return ()
 184
 185 ensureDirectories :: WriteableDirectory m => FileName -> m ()
 186 ensureDirectories d = do
 187           isPar <- mDoesDirectoryExist d
 188           if isPar
 189             then return ()
 190             else ensureDirectories (super_name d) >> (mCreateDirectory d)
 191
 192 write_files ::  Slurpy -> [FilePath] -> IO ()
 193 write_files s fps = mapM_ (try_write_file s) fps
 194
 195 -- don't overwrite non-empty directories unless explicitly asked by
 196 -- being passed "." (which always exists)
 197 writeSlurpy :: Slurpy -> FilePath -> IO ()
 198 writeSlurpy s "." = withCurrentDirectory "." $ write_files s (list_slurpy s)
 199 writeSlurpy s d = do
 200   createDirectory d
 201   withCurrentDirectory d $ write_files s (list_slurpy s)
 202
 203 withSlurpy :: Slurpy -> SlurpMonad a -> Either String (Slurpy, a)
 204 withSlurpy s (SM f) = f (Right s)
 205
 206 smDoesDirectoryExist :: FileName -> SlurpMonad Bool
 207 smDoesDirectoryExist d = mksm $ \s -> (Right (s, slurp_hasdir d s))
 208
 209 smDoesFileExist :: FileName -> SlurpMonad Bool
 210 smDoesFileExist f = mksm $ \s -> (Right (s, slurp_hasfile f s))
 211
 212 -- smInSlurpy doesn't make any changes to the subdirectory.
 213 smInSlurpy :: FileName -> SlurpMonad a -> SlurpMonad a
 214 smInSlurpy d job = mksm sm
 215     where sm s = case get_slurp d s of
 216                  Just s' | is_dir s' -> case withSlurpy s' job of
 217                                         Left e -> Left e
 218                                         Right (_,a) -> Right (s, a)
 219                  _ -> Left $ "smInSlurpy:  Couldn't find directory " ++
 220                              formatPath (fn2fp d)
 221
 222 fromSlurpFile :: FileName -> (Slurpy -> a) -> SlurpMonad a
 223 fromSlurpFile f job = mksm sm
 224     where sm s = case get_slurp f s of
 225                  Just s' | is_file s' -> Right (s, job s')
 226                  _ -> Left $ "fromSlurpFile:  Couldn't find file " ++
 227                              formatPath (fn2fp f)
 228
 229 modifySubSlurpy :: FileName -> SlurpMonad a -> SlurpMonad a
 230 modifySubSlurpy d job = mksm sm
 231     where sm s = case get_slurp_context d s of
 232                  Just (ctx, sub@(SlurpDir _ _ _)) ->
 233                      case withSlurpy sub job of
 234                      Left e -> Left e
 235                      Right (sub',a) -> Right (ctx sub', a)
 236                  _ -> Left $ "modifySubSlurpy:  Couldn't find directory " ++
 237                              formatPath (fn2fp d)
 238
 239 modifyFileSlurpy :: FileName -> (Slurpy -> Slurpy) -> SlurpMonad ()
 240 modifyFileSlurpy f job = mksm sm
 241     where sm s = case get_slurp_context f s of
 242                  Just (ctx, sf@(SlurpFile _ _ _)) -> Right (ctx $ job sf, ())
 243                  _ -> Left $ "modifyFileSlurpy:  Couldn't find file " ++
 244                              formatPath (fn2fp f)
 245
 246 insertSlurpy :: FileName -> Slurpy -> SlurpMonad ()
 247 insertSlurpy f news = mksm $ \s ->
 248                       if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s)
 249                       then Left $ "Error creating file "++fn2fp f
 250                       else Right (addslurp f news s, ())
 251
 252 smReadFilePS :: FileName -> SlurpMonad B.ByteString
 253 smReadFilePS f = fromSlurpFile f get_filecontents
 254
 255 smReadFilePSs :: FileName -> SlurpMonad [B.ByteString]
 256 smReadFilePSs f = fromSlurpFile f (linesPS . get_filecontents)
 257
 258 smGetDirContents :: SlurpMonad [FileName]
 259 smGetDirContents = mksm $ \s -> Right (s, map slurp_fn $ get_dircontents s)
 260
 261 smWriteFilePS :: FileName -> B.ByteString -> SlurpMonad ()
 262 smWriteFilePS f ps = -- this implementation could be made rather more direct
 263                      -- and limited to a single pass down the Slurpy
 264                      modifyFileSlurpy f (\_ -> sl)
 265                      `mplus` insertSlurpy f sl
 266     where sl = SlurpFile (own_name f) undef_time_size ps
 267
 268 smCreateDirectory :: FileName -> SlurpMonad ()
 269 smCreateDirectory a = mksm sm
 270     where sm s = case slurp_adddir a s of
 271                  Just s' -> Right (s', ())
 272                  Nothing -> Left $ "Error creating directory "++fn2fp a
 273
 274 smRename :: FileName -> FileName -> SlurpMonad ()
 275 smRename a b = mksm sm
 276     where sm s = case slurp_move a b s of
 277                  Just s' -> Right (s', ())
 278                  Nothing ->
 279                      -- Workaround for some old patches having moves when the source file doesn't exist.
 280                      if (slurp_has (fn2fp a) s)
 281                          then Left $ "Error moving "++fn2fp a++" to "++fn2fp b
 282                          else Right (s, ())
 283
 284 smRemove :: FileName -> SlurpMonad ()
 285 smRemove f = mksm sm
 286     where sm s = case slurp_remove f s of
 287                  Nothing -> Left $ fn2fp f++" does not exist."
 288                  Just s' -> Right (s', ())
 289
 290 smRemoveFile :: FileName -> SlurpMonad ()
 291 smRemoveFile f =
 292     do exists <- mDoesFileExist f
 293        if exists then smRemove f
 294                  else fail $ "File "++fn2fp f++" does not exist."
 295
 296 smRemoveDirectory :: FileName -> SlurpMonad ()
 297 smRemoveDirectory f =
 298     do exists <- mDoesDirectoryExist f
 299        if exists then smRemove f
 300                  else fail $ "Directory "++fn2fp f++" does not exist."
 301 \end{code}
 302
 303 Here are a few access functions.
 304
 305 \begin{code}
 306 slurp_name (SlurpFile f _ _) = fn2fp f
 307 slurp_name (SlurpDir d _ _) = fn2fp d
 308 slurp_fn :: Slurpy -> FileName
 309 slurp_fn (SlurpFile f _ _) = f
 310 slurp_fn (SlurpDir d _ _) = d
 311 slurp_setname :: FileName -> Slurpy -> Slurpy
 312 slurp_setname f (SlurpDir _ x c) = SlurpDir f x c
 313 slurp_setname f (SlurpFile _ m c) = SlurpFile f m c
 314
 315 is_file (SlurpDir _ _ _) = False
 316 is_file (SlurpFile _ _ _) = True
 317
 318 is_dir (SlurpDir _ _ _) = True
 319 is_dir (SlurpFile _ _ _) = False
 320
 321 get_filecontents (SlurpFile _ _ c) = c
 322 get_filecontents _ = bug "Can't get_filecontents on SlurpDir."
 323
 324 get_dircontents (SlurpDir _ _ c) = sort c
 325 get_dircontents _ = bug "Can't get_dircontents on SlurpFile."
 326
 327 get_mtime (SlurpFile _ (_,t,_) _) = t
 328 get_mtime _ = bug "can't get_mtime on SlurpDir."
 329 get_length (SlurpFile _ (_,_,l) _) = l
 330 get_length _ = bug "can't get_length on SlurpDir."
 331
 332 undefined_time :: EpochTime
 333 undefined_time = -1
 334 undefined_size :: FileOffset
 335 undefined_size = -1
 336 undef_time_size :: (Maybe String, EpochTime, FileOffset)
 337 undef_time_size = (Nothing, undefined_time, undefined_size)
 338
 339 wait_a_moment :: IO ()
 340 wait_a_moment = do { sleep 1; return () }
 341     -- HACKERY: In ghc 6.1, sleep has the type signature IO Int; it
 342     -- returns an integer just like sleep(3) does. To stay compatible
 343     -- with older versions, though, we just ignore sleep's return
 344     -- value. Hackery, like I said.
 345
 346 isFileReallySymlink :: FilePath -> IO Bool
 347 isFileReallySymlink f = do fs <- getSymbolicLinkStatus f
 348                            return (isSymbolicLink fs)
 349
 350 doesFileReallyExist :: FilePath -> IO Bool
 351 doesFileReallyExist f = do fs <- getSymbolicLinkStatus f
 352                            return (isRegularFile fs)
 353
 354 doesDirectoryReallyExist :: FilePath -> IO Bool
 355 doesDirectoryReallyExist f = do fs <- getSymbolicLinkStatus f
 356                                 return (isDirectory fs)
 357 \end{code}
 358
 359 slurp is how we get a slurpy in the first place\ldots
 360
 361 \begin{code}
 362 slurp = slurp_unboring (\_->True) . toPath
 363 mmap_slurp d = do canmmap <- can_I_use_mmap
 364                   if canmmap then genslurp True (\_->True) d
 365                              else genslurp False (\_->True) d
 366 slurp_unboring = genslurp False
 367 genslurp :: Bool -> (FilePath -> Bool)
 368          -> FilePath -> IO Slurpy
 369 genslurp usemm nb dirname = do
 370     isdir <- doesDirectoryExist dirname
 371     ms <- if isdir
 372           then withCurrentDirectory dirname $
 373                do actualname <- getCurrentDirectory
 374                   genslurp_helper usemm nb (reverse actualname) "" "."
 375           else do former_dir <- getCurrentDirectory
 376                   genslurp_helper usemm nb (reverse former_dir) "" dirname
 377     case ms of
 378       Just s -> return s
 379       Nothing -> fail $ "Unable to read directory " ++ dirname ++
 380                  " (it appears to be neither file nor directory)"
 381
 382 unsafeInterleaveMapIO :: (a -> IO b) -> [a] -> IO [b]
 383 unsafeInterleaveMapIO _ [] = return []
 384 unsafeInterleaveMapIO f (x:xs)
 385  = do x' <- f x
 386       xs' <- unsafeInterleaveIO $ unsafeInterleaveMapIO f xs
 387       return (x':xs')
 388
 389 genslurp_helper :: Bool -> (FilePath -> Bool)
 390                 -> FilePath -> String -> String -> IO (Maybe Slurpy)
 391 genslurp_helper usemm nb formerdir fullpath dirname = do
 392     fs <- getSymbolicLinkStatus fulldirname
 393     if isRegularFile fs
 394      then do let mtime = (Nothing, modificationTime fs, fileSize fs)
 395              ls <- unsafeInterleaveIO $ myReadFileLinesPSetc fulldirname
 396              return $ Just $ SlurpFile (fp2fn dirname) mtime ls
 397      else if isDirectory fs || (isSymbolicLink fs && dirname == ".")
 398           then do sl <- unsafeInterleaveIO $
 399                         do fnames <- getDirectoryContents fulldirname
 400                            unsafeInterleaveMapIO
 401                                              (\f -> genslurp_helper usemm nb fulldirname'
 402                                               (fullpath///f) f)
 403                                              $ filter (nb . (fullpath///)) $ filter not_hidden fnames
 404                   return $ Just $ SlurpDir (fp2fn dirname) Nothing $ catMaybes sl
 405           else return Nothing
 406     where fulldirname' = formerdir\\\dirname
 407           fulldirname = reverse fulldirname'
 408           myReadFileLinesPSetc = if usemm then mmapFilePS
 409                                           else B.readFile
 410
 411 not_hidden :: FilePath -> Bool
 412 not_hidden "." = False
 413 not_hidden ".." = False
 414 not_hidden _ = True
 415
 416 (\\\) :: FilePath -> FilePath -> FilePath
 417 (\\\) "" d = d
 418 (\\\) d "." = d
 419 (\\\) d subdir = reverse subdir ++ "/" ++ d
 420
 421 (///) :: FilePath -> FilePath -> FilePath
 422 (///) "" d = d
 423 (///) d "." = d
 424 (///) d subdir = d ++ "/" ++ subdir
 425
 426 co_slurp :: Slurpy -> FilePath -> IO Slurpy
 427 co_slurp guide dirname = do
 428     isdir <- doesDirectoryExist dirname
 429     if isdir
 430        then withCurrentDirectory dirname $ do
 431               actualname <- getCurrentDirectory
 432               Just slurpy <- co_slurp_helper (reverse actualname) guide
 433               return slurpy
 434        else error "Error coslurping!!! Please report this."
 435
 436 co_slurp_helper :: FilePath -> Slurpy -> IO (Maybe Slurpy)
 437 co_slurp_helper former_dir (SlurpDir d _ c) = unsafeInterleaveIO $ do
 438     let d' = fn2fp d
 439         fn' = former_dir\\\d'
 440         fn = reverse fn'
 441     efs <- tryNonSignal $ getSymbolicLinkStatus fn
 442     case efs of
 443         Right fs
 444          | isDirectory fs || (isSymbolicLink fs && d' == ".") ->
 445             do sl <- unsafeInterleaveIO
 446                    $ unsafeInterleaveMapIO (co_slurp_helper fn') c
 447                return $ Just $ SlurpDir d Nothing $ catMaybes sl
 448         _ -> return Nothing
 449 co_slurp_helper former_dir (SlurpFile f _ _) = unsafeInterleaveIO $ do
 450    let fn' = former_dir\\\fn2fp f
 451        fn = reverse fn'
 452    efs <- tryNonSignal $ getSymbolicLinkStatus fn
 453    case efs of
 454        Right fs
 455         | isRegularFile fs ->
 456            do let mtime = (Nothing, modificationTime fs, fileSize fs)
 457               ls <- unsafeInterleaveIO $ B.readFile fn
 458               return $ Just $ SlurpFile f mtime ls
 459        _ -> return Nothing
 460 \end{code}
 461
 462 \begin{code}
 463 get_slurp_context_generic :: (Slurpy -> a) -> (a -> [Slurpy]) -> FileName -> Slurpy -> Maybe (a -> a, Slurpy)
 464 get_slurp_context_generic h1 h2 fn0 s0 =
 465     let norm_fn0 = norm_path fn0 in
 466     if norm_fn0 == empty
 467         then Just (id, s0)
 468         else slurp_context_private norm_fn0 id s0
 469   where
 470     slurp_context_private f ctx s@(SlurpFile f' _ _) =
 471         if f == f' then Just (ctx, s)
 472         else Nothing
 473     slurp_context_private f ctx s@(SlurpDir d _ c)
 474       | f == d = Just (ctx, s)
 475       | d == dot =
 476             case break_on_dir f of
 477                 Just (dn,fn) | dn == dot ->
 478                     descend fn
 479                 _ ->
 480                     descend f
 481       | otherwise =
 482             case break_on_dir f of
 483                 Just (dn,fn) ->
 484                     if dn == d
 485                         then descend fn
 486                         else Nothing
 487                 _ -> Nothing
 488       where
 489         descend fname =
 490             let l = [ slurp_context_private
 491                         fname
 492                         (\x -> ctx (h1 (SlurpDir d Nothing (pre ++ h2 x ++ post))))
 493                         this
 494                     | (pre, this:post) <- zip (inits' c) (tails c)
 495                     ]
 496             in
 497             case filter isJust l of
 498                 [] -> Nothing
 499                 [msf] -> msf
 500                 _ -> impossible
 501
 502     -- a lazier implementation of inits
 503     inits' l = [ take i l | i <- [0 .. length l] ]
 504     dot = fp2fn "."
 505     empty = fp2fn ""
 506 \end{code}
 507
 508 \begin{code}
 509 -- |get_slurp_context navigates to a specified filename in the given slurpy,
 510 -- and returns the child slurpy at that point together with a update function that can be used
 511 -- to reconstruct the original slurpy from a replacement value for the child slurpy.
 512 get_slurp_context :: FileName -> Slurpy -> Maybe (Slurpy -> Slurpy, Slurpy)
 513 get_slurp_context = get_slurp_context_generic id return
 514
 515 -- |A variant of 'get_slurp_context' that allows for removing the child slurpy
 516 -- altogether by passing in 'Nothing' to the update function.
 517 -- If the child slurpy happened to be at the top level and 'Nothing' was passed in,
 518 -- then the result of the update function will also be 'Nothing', otherwise it will always
 519 -- be a 'Just' value.
 520 get_slurp_context_maybe :: FileName -> Slurpy -> Maybe (Maybe Slurpy -> Maybe Slurpy, Slurpy)
 521 get_slurp_context_maybe = get_slurp_context_generic Just maybeToList
 522
 523 -- |A variant of 'get_slurp_context' that allows for replacing the child slurpy by
 524 -- a list of slurpies. The result of the update function will always be a singleton
 525 -- list unless the child slurpy was at the top level.
 526 get_slurp_context_list :: FileName -> Slurpy -> Maybe ([Slurpy] -> [Slurpy], Slurpy)
 527 get_slurp_context_list = get_slurp_context_generic return id
 528 \end{code}
 529
 530 It is important to be able to readily modify a slurpy.
 531
 532 \begin{code}
 533 slurp_remove :: FileName -> Slurpy -> Maybe Slurpy
 534 slurp_remove fname s@(SlurpDir _ _ _) =
 535     case get_slurp_context_maybe fname s of
 536         Just (ctx, _) -> ctx Nothing
 537         Nothing -> Nothing
 538 slurp_remove _ _ = bug "slurp_remove only acts on SlurpDirs"
 539
 540 slurp_removefile :: FileName -> Slurpy -> Maybe Slurpy
 541 slurp_removefile f s =
 542   if slurp_hasfile f s
 543   then case slurp_remove f s of
 544        Just (SlurpDir d x c) -> Just $ SlurpDir d x c
 545        _ -> impossible
 546   else Nothing
 547 \end{code}
 548
 549 \begin{code}
 550 slurp_move :: FileName -> FileName -> Slurpy -> Maybe Slurpy
 551 slurp_move f f' s =
 552     if not (slurp_has (fn2fp f') s) && slurp_hasdir (super_name f') s
 553     then case get_slurp f s of
 554          Nothing -> Nothing
 555          Just sf ->
 556              case slurp_remove f s of
 557              Nothing -> Nothing
 558              Just (SlurpDir d x c) ->
 559                  Just $ addslurp f' (slurp_setname (own_name f') sf)
 560                            $ SlurpDir d x c
 561              _ -> impossible
 562     else Nothing
 563
 564 addslurp :: FileName -> Slurpy -> Slurpy -> Slurpy
 565 addslurp fname s s' =
 566     case get_slurp_context (super_name fname) s' of
 567         Just (ctx, SlurpDir d _ c) -> ctx (SlurpDir d Nothing (s:c))
 568         _ -> s'
 569
 570 get_slurp :: FileName -> Slurpy -> Maybe Slurpy
 571 get_slurp f s = fmap snd (get_slurp_context f s)
 572 \end{code}
 573
 574 \begin{code}
 575 slurp_removedir :: FileName -> Slurpy -> Maybe Slurpy
 576 slurp_removedir f s =
 577     case get_slurp f s of
 578     Just (SlurpDir _ _ []) ->
 579         case slurp_remove f s of
 580         Just (SlurpDir d x c) -> Just $ SlurpDir d x c
 581         _ -> impossible
 582     _ -> Nothing
 583 \end{code}
 584
 585 \begin{code}
 586 slurp_adddir :: FileName -> Slurpy -> Maybe Slurpy
 587 slurp_adddir f s =
 588   if slurp_hasfile f s || slurp_hasdir f s || not (slurp_hasdir (super_name f) s)
 589   then Nothing
 590   else Just $ addslurp f (SlurpDir (own_name f) Nothing []) s
 591 \end{code}
 592
 593 Code to modify a given file in a slurpy.
 594
 595 \begin{code}
 596 slurp_modfile :: FileName -> (FileContents -> Maybe FileContents)
 597               -> Slurpy -> Maybe Slurpy
 598 slurp_modfile fname modify sl =
 599     case get_slurp_context fname sl of
 600         Just (ctx, SlurpFile ff _ c) ->
 601             case modify c of
 602                 Nothing -> Nothing
 603                 Just c' -> Just (ctx (SlurpFile ff undef_time_size c'))
 604         _ ->
 605             Nothing
 606 \end{code}
 607
 608 \begin{code}
 609 slurp_hasfile :: FileName -> Slurpy -> Bool
 610 slurp_hasfile f s =
 611     case get_slurp f s of
 612         Just s' | is_file s' -> True
 613         _ -> False
 614
 615 slurp_has :: FilePath -> Slurpy -> Bool
 616 slurp_has f s = isJust (get_slurp (fp2fn f) s)
 617
 618 slurp_has_anycase :: FilePath -> Slurpy -> Bool
 619 slurp_has_anycase fname (SlurpDir _ _ contents) =
 620   seq normed_name $ or $ map (hasany_private normed_name) contents
 621   where normed_name = norm_path $ fp2fn $ map toLower fname
 622         hasany_private f (SlurpFile f' _ _) = f == tolower f'
 623         hasany_private f (SlurpDir d _ c)
 624             | f == tolower d = True
 625             | otherwise =
 626                 case break_on_dir f of
 627                 Just (dn,fn) -> if tolower dn == tolower d
 628                                 then or $ map (hasany_private fn) c
 629                                 else False
 630                 _ -> False
 631 slurp_has_anycase f (SlurpFile f' _ _) =
 632     (norm_path $ fp2fn $ map toLower f) == tolower f'
 633 tolower :: FileName -> FileName
 634 tolower = fp2fn . (map toLower) . fn2fp
 635
 636 slurp_hasdir :: FileName -> Slurpy -> Bool
 637 slurp_hasdir d _ | norm_path d == fp2fn "" = True
 638 slurp_hasdir f (SlurpDir _ _ c) =
 639     seq f $ or $ map (slurp_hasdir_private $ norm_path f) c
 640 slurp_hasdir _ _ = False
 641
 642 slurp_hasdir_private :: FileName -> Slurpy -> Bool
 643 slurp_hasdir_private _ (SlurpFile _ _ _) = False
 644 slurp_hasdir_private f (SlurpDir d _ c)
 645   | f == d = True
 646   | otherwise =
 647        case break_on_dir f of
 648        Just (dn,fn) ->
 649            if dn == d
 650            then or $ map (slurp_hasdir_private fn) c
 651            else False
 652        _ -> False
 653 \end{code}
 654
 655 \begin{code}
 656 get_path_list :: Slurpy -> FilePath -> [FilePath]
 657 get_path_list s fp = get_path_list' s ("./" ++ fp)
 658
 659 get_path_list' :: Slurpy -> FilePath -> [FilePath]
 660 get_path_list' s "" = list_slurpy s
 661 get_path_list' (SlurpFile f _ _) fp
 662  | f' == fp = [f']
 663     where f' = fn2fp f
 664 get_path_list' (SlurpDir d _ ss) fp
 665  | (d' ++ "/") `isPrefixOf` (fp ++ "/")
 666     = let fp' = drop (length d' + 1) fp
 667       in map (d' ///) $ concatMap (\s -> get_path_list' s fp') ss
 668     where d' = fn2fp d
 669 get_path_list' _ _ = []
 670
 671 list_slurpy :: Slurpy -> [FilePath]
 672 list_slurpy (SlurpFile f _ _) = [fn2fp f]
 673 list_slurpy (SlurpDir dd _ ss) = d : map (d ///) (concatMap list_slurpy ss)
 674     where d = fn2fp dd
 675
 676 list_slurpy_files :: Slurpy -> [FilePath]
 677 list_slurpy_files (SlurpFile f _ _) = [fn2fp f]
 678 list_slurpy_files (SlurpDir dd _ ss) =
 679     map ((fn2fp dd) ///) (concatMap list_slurpy_files ss)
 680
 681 list_slurpy_dirs :: Slurpy -> [FilePath]
 682 list_slurpy_dirs (SlurpFile _ _ _) = []
 683 list_slurpy_dirs (SlurpDir dd _ ss) =
 684     d : map (d ///) (concatMap list_slurpy_dirs ss)
 685     where d = fn2fp dd
 686 \end{code}
 687