import Prelude hiding ( catch )
import qualified Prelude
+import Control.Monad (guard)
import System.Environment ( getEnv )
import System.FilePath
import System.IO
import GHC.IOBase ( IOException(..), IOErrorType(..), ioException )
+#ifdef mingw32_HOST_OS
+import qualified System.Win32
+#else
+import qualified System.Posix
+#endif
+
{- $intro
A directory contains a series of entries, each of which is a named
reference to a file system object (file, directory etc.). Some
createDirectory :: FilePath -> IO ()
createDirectory path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s -> do
- throwErrnoIfMinus1Retry_ "createDirectory" $
- mkdir s 0o777
+#ifdef mingw32_HOST_OS
+ System.Win32.createDirectory path Nothing
+#else
+ System.Posix.createDirectory path 0o777
+#endif
#else /* !__GLASGOW_HASKELL__ */
createDirectoryIfMissing :: Bool -- ^ Create its parents too?
-> FilePath -- ^ The path to the directory you want to make
-> IO ()
-createDirectoryIfMissing parents file = do
- b <- doesDirectoryExist file
- case (b,parents, file) of
- (_, _, "") -> return ()
- (True, _, _) -> return ()
- (_, True, _) -> mapM_ (createDirectoryIfMissing False) $ mkParents file
- (_, False, _) -> createDirectory file
- where mkParents = scanl1 (</>) . splitDirectories . normalise
+createDirectoryIfMissing create_parents path0
+ | create_parents = createDirs (parents path0)
+ | otherwise = createDirs (take 1 (parents path0))
+ where
+ parents = reverse . scanl1 (</>) . splitDirectories . normalise
+
+ createDirs [] = return ()
+ createDirs (dir:[]) = createDir dir throw
+ createDirs (dir:dirs) =
+ createDir dir $ \_ -> do
+ createDirs dirs
+ createDir dir throw
+
+ createDir :: FilePath -> (IOException -> IO ()) -> IO ()
+ createDir dir notExistHandler = do
+ r <- try $ createDirectory dir
+ case (r :: Either IOException ()) of
+ Right () -> return ()
+ Left e
+ | isDoesNotExistError e -> notExistHandler e
+ -- createDirectory (and indeed POSIX mkdir) does not distinguish
+ -- between a dir already existing and a file already existing. So we
+ -- check for it here. Unfortunately there is a slight race condition
+ -- here, but we think it is benign. It could report an exeption in
+ -- the case that the dir did exist but another process deletes it
+ -- before we can check that it did indeed exist.
+ | isAlreadyExistsError e -> do exists <- doesDirectoryExist dir
+ if exists then return ()
+ else throw e
+ | otherwise -> throw e
#if __GLASGOW_HASKELL__
{- | @'removeDirectory' dir@ removes an existing directory /dir/. The
-}
removeDirectory :: FilePath -> IO ()
-removeDirectory path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s ->
- throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
+removeDirectory path =
+#ifdef mingw32_HOST_OS
+ System.Win32.removeDirectory path
+#else
+ System.Posix.removeDirectory path
+#endif
+
#endif
-- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/
-}
removeFile :: FilePath -> IO ()
-removeFile path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s ->
- throwErrnoIfMinus1Retry_ "removeFile" (c_unlink s)
+removeFile path =
+#if mingw32_HOST_OS
+ System.Win32.deleteFile path
+#else
+ System.Posix.removeLink path
+#endif
{- |@'renameDirectory' old new@ changes the name of an existing
directory from /old/ to /new/. If the /new/ directory
renameDirectory :: FilePath -> FilePath -> IO ()
renameDirectory opath npath =
+ -- XXX this test isn't performed atomically with the following rename
withFileStatus "renameDirectory" opath $ \st -> do
is_dir <- isDirectory st
if (not is_dir)
- then ioException (IOError Nothing InappropriateType "renameDirectory"
- ("not a directory") (Just opath))
+ then ioException (ioeSetErrorString
+ (mkIOError InappropriateType "renameDirectory" Nothing (Just opath))
+ "not a directory")
else do
-
- withCString opath $ \s1 ->
- withCString npath $ \s2 ->
- throwErrnoIfMinus1Retry_ "renameDirectory" (c_rename s1 s2)
+#ifdef mingw32_HOST_OS
+ System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
+#else
+ System.Posix.rename opath npath
+#endif
{- |@'renameFile' old new@ changes the name of an existing file system
object from /old/ to /new/. If the /new/ object already
renameFile :: FilePath -> FilePath -> IO ()
renameFile opath npath =
+ -- XXX this test isn't performed atomically with the following rename
withFileOrSymlinkStatus "renameFile" opath $ \st -> do
is_dir <- isDirectory st
if is_dir
- then ioException (IOError Nothing InappropriateType "renameFile"
- "is a directory" (Just opath))
+ then ioException (ioeSetErrorString
+ (mkIOError InappropriateType "renameFile" Nothing (Just opath))
+ "is a directory")
else do
-
- withCString opath $ \s1 ->
- withCString npath $ \s2 ->
- throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2)
+#ifdef mingw32_HOST_OS
+ System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
+#else
+ System.Posix.rename opath npath
+#endif
#endif /* __GLASGOW_HASKELL__ */
getCurrentDirectory :: IO FilePath
getCurrentDirectory = do
+#ifdef mingw32_HOST_OS
+ -- XXX: should use something from Win32
p <- mallocBytes long_path_size
go p long_path_size
where go p bytes = do
p'' <- reallocBytes p bytes'
go p'' bytes'
else throwErrno "getCurrentDirectory"
+#else
+ System.Posix.getWorkingDirectory
+#endif
+
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "getcwd"
+ c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar)
+#endif
{- |If the operating system has a notion of current directories,
@'setCurrentDirectory' dir@ changes the current
-}
setCurrentDirectory :: FilePath -> IO ()
-setCurrentDirectory path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s ->
- throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s)
- -- ToDo: add path to error
+setCurrentDirectory path =
+#ifdef mingw32_HOST_OS
+ System.Win32.setCurrentDirectory path
+#else
+ System.Posix.changeWorkingDirectory path
+#endif
{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
exists and is a directory, and 'False' otherwise.
raiseUnsupported :: String -> IO ()
raiseUnsupported loc =
- ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
+ ioException (ioeSetErrorString (mkIOError UnsupportedOperation loc Nothing Nothing) "unsupported operation")
#endif
projects / haskell-directory.git / blobdiff