import Control.Exception.Base
#ifdef __NHC__
-import Directory
+import Directory hiding ( getDirectoryContents
+ , doesDirectoryExist, doesFileExist
+ , getModificationTime )
import System (system)
#endif /* __NHC__ */
{-# CFILES cbits/directory.c #-}
-#ifdef __GLASGOW_HASKELL__
import System.Posix.Types
import System.Posix.Internals
import System.Time ( ClockTime(..) )
+#ifdef __GLASGOW_HASKELL__
+
+#if __GLASGOW_HASKELL__ >= 611
+import GHC.IO.Exception ( IOException(..), IOErrorType(..), ioException )
+#else
import GHC.IOBase ( IOException(..), IOErrorType(..), ioException )
+#endif
#ifdef mingw32_HOST_OS
import qualified System.Win32
createDirectoryIfMissing :: Bool -- ^ Create its parents too?
-> FilePath -- ^ The path to the directory you want to make
-> IO ()
-createDirectoryIfMissing create_parents "" = return ()
createDirectoryIfMissing create_parents path0
- = do r <- try $ createDirectory path
- case (r :: Either IOException ()) of
- Right _ -> return ()
- Left e
- | isAlreadyExistsError e -> return ()
- | isDoesNotExistError e && create_parents -> do
- createDirectoryIfMissing True (dropFileName path)
- createDirectoryIfMissing True path
- | otherwise -> throw e
+ | create_parents = createDirs (parents path0)
+ | otherwise = createDirs (take 1 (parents path0))
where
- -- we want createDirectoryIfMissing "a/" to behave like
- -- createDirectoryIfMissing "a". Also, unless we apply
- -- dropTrailingPathSeparator first, dropFileName won't drop
- -- anything from "a/".
- path = dropTrailingPathSeparator path0
+ 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 the
+ -- directory and creates a file in its place before we can check
+ -- that the directory did indeed exist.
+ | isAlreadyExistsError e ->
+ (withFileStatus "createDirectoryIfMissing" dir $ \st -> do
+ isDir <- isDirectory st
+ if isDir then return ()
+ else throw e
+ ) `catch` ((\_ -> return ()) :: IOException -> IO ())
+ | otherwise -> throw e
#if __GLASGOW_HASKELL__
{- | @'removeDirectory' dir@ removes an existing directory /dir/. The
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
#ifdef mingw32_HOST_OS
System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
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
#ifdef mingw32_HOST_OS
System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
-- attempt.
canonicalizePath :: FilePath -> IO FilePath
canonicalizePath fpath =
- withCString fpath $ \pInPath ->
- allocaBytes long_path_size $ \pOutPath ->
#if defined(mingw32_HOST_OS)
- alloca $ \ppFilePart ->
- do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart
+ do path <- System.Win32.getFullPathName fpath
#else
+ withCString fpath $ \pInPath ->
+ allocaBytes long_path_size $ \pOutPath ->
do c_realpath pInPath pOutPath
-#endif
path <- peekCString pOutPath
+#endif
return (normalise path)
-- normalise does more stuff, like upper-casing the drive letter
cur <- getCurrentDirectory
return $ makeRelative cur x
--- | Given an executable file name, searches for such file
--- in the directories listed in system PATH. The returned value
--- is the path to the found executable or Nothing if there isn't
--- such executable. For example (findExecutable \"ghc\")
--- gives you the path to GHC.
+-- | Given an executable file name, searches for such file in the
+-- directories listed in system PATH. The returned value is the path
+-- to the found executable or Nothing if an executable with the given
+-- name was not found. For example (findExecutable \"ghc\") gives you
+-- the path to GHC.
+--
+-- The path returned by 'findExecutable' corresponds to the
+-- program that would be executed by 'System.Process.createProcess'
+-- when passed the same string (as a RawCommand, not a ShellCommand).
+--
+-- On Windows, 'findExecutable' calls the Win32 function 'SearchPath',
+-- which may search other places before checking the directories in
+-- @PATH@. Where it actually searches depends on registry settings,
+-- but notably includes the directory containing the current
+-- executable. See
+-- <http://msdn.microsoft.com/en-us/library/aa365527.aspx> for more
+-- details.
+--
findExecutable :: String -> IO (Maybe FilePath)
findExecutable binary =
#if defined(mingw32_HOST_OS)
#endif
-#ifdef __GLASGOW_HASKELL__
+#ifndef __HUGS__
{- |@'getDirectoryContents' dir@ returns a list of /all/ entries
in /dir/.
return (entry:entries)
else do errno <- getErrno
if (errno == eINTR) then loop ptr_dEnt dir else do
- let (Errno eo) = errno
- if (eo == end_of_dir)
- then return []
- else throwErrno desc
-
+ let (Errno eo) = errno
+ if (eo == end_of_dir)
+ then return []
+ else throwErrno desc
+#endif /* !__HUGS__ */
{- |If the operating system has a notion of current directories,
The operating system has no notion of current directory.
-}
-
+#ifdef __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' <- c_getcwd p (fromIntegral bytes)
- if p' /= nullPtr
- then do s <- peekCString p'
- free p'
- return s
- else do errno <- getErrno
- if errno == eRANGE
- then do let bytes' = bytes * 2
- p'' <- reallocBytes p bytes'
- go p'' bytes'
- else throwErrno "getCurrentDirectory"
+ System.Win32.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
directory of the calling process to /dir/.
System.Posix.changeWorkingDirectory path
#endif
+#endif /* __GLASGOW_HASKELL__ */
+
+#ifndef __HUGS__
{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
exists and is a directory, and 'False' otherwise.
-}
withFileStatus "getModificationTime" name $ \ st ->
modificationTime st
+#endif /* !__HUGS__ */
+
withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
withFileStatus loc name f = do
modifyIOError (`ioeSetFileName` name) $
fileNameEndClean name = if isDrive name then addTrailingPathSeparator name
else dropTrailingPathSeparator name
-foreign import ccall unsafe "__hscore_R_OK" r_OK :: CInt
-foreign import ccall unsafe "__hscore_W_OK" w_OK :: CInt
-foreign import ccall unsafe "__hscore_X_OK" x_OK :: CInt
+foreign import ccall unsafe "HsDirectory.h __hscore_R_OK" r_OK :: CInt
+foreign import ccall unsafe "HsDirectory.h __hscore_W_OK" w_OK :: CInt
+foreign import ccall unsafe "HsDirectory.h __hscore_X_OK" x_OK :: CInt
-foreign import ccall unsafe "__hscore_S_IRUSR" s_IRUSR :: CMode
-foreign import ccall unsafe "__hscore_S_IWUSR" s_IWUSR :: CMode
-foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode
+foreign import ccall unsafe "HsDirectory.h __hscore_S_IRUSR" s_IRUSR :: CMode
+foreign import ccall unsafe "HsDirectory.h __hscore_S_IWUSR" s_IWUSR :: CMode
+foreign import ccall unsafe "HsDirectory.h __hscore_S_IXUSR" s_IXUSR :: CMode
#ifdef mingw32_HOST_OS
foreign import ccall unsafe "__hscore_S_IFDIR" s_IFDIR :: CMode
#endif
+
+#ifdef __GLASGOW_HASKELL__
foreign import ccall unsafe "__hscore_long_path_size"
long_path_size :: Int
-
#else
long_path_size :: Int
long_path_size = 2048 -- // guess?
-
#endif /* __GLASGOW_HASKELL__ */
{- | Returns the current user's home directory.
getTemporaryDirectory :: IO FilePath
getTemporaryDirectory = do
#if defined(mingw32_HOST_OS)
- allocaBytes long_path_size $ \pPath -> do
- _r <- c_GetTempPath (fromIntegral long_path_size) pPath
- peekCString pPath
+ System.Win32.getTemporaryDirectory
#else
getEnv "TMPDIR"
#if !__NHC__
foreign import ccall unsafe "__hscore_CSIDL_WINDOWS" csidl_WINDOWS :: CInt
foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt
-foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt
-
raiseUnsupported :: String -> IO ()
raiseUnsupported loc =
- ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
+ ioException (ioeSetErrorString (mkIOError UnsupportedOperation loc Nothing Nothing) "unsupported operation")
#endif
#else
exeExtension = ""
#endif
-