-- * Actions on directories
createDirectory -- :: FilePath -> IO ()
+#ifndef __NHC__
, createDirectoryIfMissing -- :: Bool -> FilePath -> IO ()
+#endif
, removeDirectory -- :: FilePath -> IO ()
, removeDirectoryRecursive -- :: FilePath -> IO ()
, renameDirectory -- :: FilePath -> FilePath -> IO ()
-- $permissions
- , Permissions(
- Permissions,
- readable, -- :: Permissions -> Bool
- writable, -- :: Permissions -> Bool
- executable, -- :: Permissions -> Bool
- searchable -- :: Permissions -> Bool
- )
+ , Permissions
+ , emptyPermissions
+ , readable -- :: Permissions -> Bool
+ , writable -- :: Permissions -> Bool
+ , executable -- :: Permissions -> Bool
+ , searchable -- :: Permissions -> Bool
+ , setOwnerReadable
+ , setOwnerWritable
+ , setOwnerExecutable
+ , setOwnerSearchable
, getPermissions -- :: FilePath -> IO Permissions
, setPermissions -- :: FilePath -> Permissions -> IO ()
+ , copyPermissions
-- * Timestamps
import Prelude hiding ( catch )
import qualified Prelude
+import Control.Monad (guard)
import System.Environment ( getEnv )
import System.FilePath
import System.IO
import System.IO.Error hiding ( catch, try )
import Control.Monad ( when, unless )
-import Control.Exception
+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 System.Posix.Types
+import System.Posix.Internals
+import qualified System.Win32 as Win32
+#else
+import qualified System.Posix as Posix
+#endif
{- $intro
A directory contains a series of entries, each of which is a named
executable, searchable :: Bool
} deriving (Eq, Ord, Read, Show)
+emptyPermissions :: Permissions
+emptyPermissions = Permissions {
+ readable = False,
+ writable = False,
+ executable = False,
+ searchable = False
+ }
+
+setOwnerReadable :: Bool -> Permissions -> Permissions
+setOwnerReadable b p = p { readable = b }
+
+setOwnerWritable :: Bool -> Permissions -> Permissions
+setOwnerWritable b p = p { writable = b }
+
+setOwnerExecutable :: Bool -> Permissions -> Permissions
+setOwnerExecutable b p = p { executable = b }
+
+setOwnerSearchable :: Bool -> Permissions -> Permissions
+setOwnerSearchable b p = p { searchable = b }
+
{- |The 'getPermissions' operation returns the
permissions for the file or directory.
getPermissions :: FilePath -> IO Permissions
getPermissions name = do
- withCString name $ \s -> do
#ifdef mingw32_HOST_OS
+ withFilePath name $ \s -> do
-- stat() does a better job of guessing the permissions on Windows
-- than access() does. e.g. for execute permission, it looks at the
-- filename extension :-)
}
)
#else
- read_ok <- c_access s r_OK
- write_ok <- c_access s w_OK
- exec_ok <- c_access s x_OK
- withFileStatus "getPermissions" name $ \st -> do
- is_dir <- isDirectory st
+ read_ok <- Posix.fileAccess name True False False
+ write_ok <- Posix.fileAccess name False True False
+ exec_ok <- Posix.fileAccess name False False True
+ stat <- Posix.getFileStatus name
+ let is_dir = Posix.isDirectory stat
return (
Permissions {
- readable = read_ok == 0,
- writable = write_ok == 0,
- executable = not is_dir && exec_ok == 0,
- searchable = is_dir && exec_ok == 0
+ readable = read_ok,
+ writable = write_ok,
+ executable = not is_dir && exec_ok,
+ searchable = is_dir && exec_ok
}
)
#endif
setPermissions :: FilePath -> Permissions -> IO ()
setPermissions name (Permissions r w e s) = do
+#ifdef mingw32_HOST_OS
allocaBytes sizeof_stat $ \ p_stat -> do
- withCString name $ \p_name -> do
+ withFilePath name $ \p_name -> do
throwErrnoIfMinus1_ "setPermissions" $ do
c_stat p_name p_stat
mode <- st_mode p_stat
let mode1 = modifyBit r mode s_IRUSR
let mode2 = modifyBit w mode1 s_IWUSR
let mode3 = modifyBit (e || s) mode2 s_IXUSR
- c_chmod p_name mode3
-
+ c_wchmod p_name mode3
where
modifyBit :: Bool -> CMode -> CMode -> CMode
modifyBit False m b = m .&. (complement b)
modifyBit True m b = m .|. b
+#else
+ stat <- Posix.getFileStatus name
+ let mode = Posix.fileMode stat
+ let mode1 = modifyBit r mode Posix.ownerReadMode
+ let mode2 = modifyBit w mode1 Posix.ownerWriteMode
+ let mode3 = modifyBit (e || s) mode2 Posix.ownerExecuteMode
+ Posix.setFileMode name mode3
+ where
+ modifyBit :: Bool -> Posix.FileMode -> Posix.FileMode -> Posix.FileMode
+ modifyBit False m b = m .&. (complement b)
+ modifyBit True m b = m .|. b
+#endif
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "_wchmod"
+ c_wchmod :: CWString -> CMode -> IO CInt
+#endif
copyPermissions :: FilePath -> FilePath -> IO ()
copyPermissions source dest = do
+#ifdef mingw32_HOST_OS
allocaBytes sizeof_stat $ \ p_stat -> do
- withCString source $ \p_source -> do
- withCString dest $ \p_dest -> do
+ withFilePath source $ \p_source -> do
+ withFilePath dest $ \p_dest -> do
throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat
mode <- st_mode p_stat
- throwErrnoIfMinus1_ "copyPermissions" $ c_chmod p_dest mode
+ throwErrnoIfMinus1_ "copyPermissions" $ c_wchmod p_dest mode
+#else
+ stat <- Posix.getFileStatus source
+ let mode = Posix.fileMode stat
+ Posix.setFileMode dest mode
+#endif
-----------------------------------------------------------------------------
-- Implementation
createDirectory :: FilePath -> IO ()
createDirectory path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s -> do
- throwErrnoIfMinus1Retry_ "createDirectory" $
- mkdir s 0o777
+#ifdef mingw32_HOST_OS
+ Win32.createDirectory path Nothing
+#else
+ Posix.createDirectory path 0o777
+#endif
#else /* !__GLASGOW_HASKELL__ */
#endif
+#ifndef __NHC__
-- | @'createDirectoryIfMissing' parents dir@ creates a new directory
-- @dir@ if it doesn\'t exist. If the first argument is 'True'
-- the function will also create all parent directories if they are missing.
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 the
+ -- directory and creates a file in its place before we can check
+ -- that the directory did indeed exist.
+ | isAlreadyExistsError e -> (do
+#ifdef mingw32_HOST_OS
+ withFileStatus "createDirectoryIfMissing" dir $ \st -> do
+ isDir <- isDirectory st
+ if isDir then return ()
+ else throw e
+#else
+ stat <- Posix.getFileStatus dir
+ if Posix.isDirectory stat
+ then return ()
+ else throw e
+#endif
+ ) `catch` ((\_ -> return ()) :: IOException -> IO ())
+ | otherwise -> throw e
+#endif /* !__NHC__ */
#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
+ Win32.removeDirectory path
+#else
+ 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
+ Win32.deleteFile path
+#else
+ 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 =
+renameDirectory opath npath = do
+ -- XXX this test isn't performed atomically with the following rename
+#ifdef mingw32_HOST_OS
+ -- ToDo: use Win32 API
withFileStatus "renameDirectory" opath $ \st -> do
is_dir <- isDirectory st
+#else
+ stat <- Posix.getFileStatus opath
+ let is_dir = Posix.fileMode stat .&. Posix.directoryMode /= 0
+#endif
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
+ Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING
+#else
+ 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 =
+renameFile opath npath = do
+ -- XXX this test isn't performed atomically with the following rename
+#ifdef mingw32_HOST_OS
+ -- ToDo: use Win32 API
withFileOrSymlinkStatus "renameFile" opath $ \st -> do
is_dir <- isDirectory st
+#else
+ stat <- Posix.getSymbolicLinkStatus opath
+ let is_dir = Posix.isDirectory stat
+#endif
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
+ Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING
+#else
+ Posix.rename opath npath
+#endif
#endif /* __GLASGOW_HASKELL__ */
-- 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 <- Win32.getFullPathName fpath
#else
- do c_realpath pInPath pOutPath
-#endif
+ withCString fpath $ \pInPath ->
+ allocaBytes long_path_size $ \pOutPath ->
+ do throwErrnoPathIfNull "canonicalizePath" fpath $ c_realpath pInPath pOutPath
path <- peekCString pOutPath
+#endif
return (normalise path)
-- normalise does more stuff, like upper-casing the drive letter
-#if defined(mingw32_HOST_OS)
-foreign import stdcall unsafe "GetFullPathNameA"
- c_GetFullPathName :: CString
- -> CInt
- -> CString
- -> Ptr CString
- -> IO CInt
-#else
+#if !defined(mingw32_HOST_OS)
foreign import ccall unsafe "realpath"
c_realpath :: CString
-> CString
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)
- withCString binary $ \c_binary ->
- withCString ('.':exeExtension) $ \c_ext ->
- allocaBytes long_path_size $ \pOutPath ->
- alloca $ \ppFilePart -> do
- res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart
- if res > 0 && res < fromIntegral long_path_size
- then do fpath <- peekCString pOutPath
- return (Just fpath)
- else return Nothing
-
-foreign import stdcall unsafe "SearchPathA"
- c_SearchPath :: CString
- -> CString
- -> CString
- -> CInt
- -> CString
- -> Ptr CString
- -> IO CInt
+ Win32.searchPath Nothing binary ('.':exeExtension)
#else
do
path <- getEnv "PATH"
-}
getDirectoryContents :: FilePath -> IO [FilePath]
-getDirectoryContents path = do
- modifyIOError (`ioeSetFileName` path) $
- alloca $ \ ptr_dEnt ->
- bracket
- (withCString path $ \s ->
- throwErrnoIfNullRetry desc (c_opendir s))
- (\p -> throwErrnoIfMinus1_ desc (c_closedir p))
- (\p -> loop ptr_dEnt p)
+getDirectoryContents path =
+ modifyIOError ((`ioeSetFileName` path) .
+ (`ioeSetLocation` "getDirectoryContents")) $ do
+#ifndef mingw32_HOST_OS
+ bracket
+ (Posix.openDirStream path)
+ Posix.closeDirStream
+ loop
+ where
+ loop dirp = do
+ e <- Posix.readDirStream dirp
+ if null e then return [] else do
+ es <- loop dirp
+ return (e:es)
+#else
+ bracket
+ (Win32.findFirstFile (path </> "*"))
+ (\(h,_) -> Win32.findClose h)
+ (\(h,fdat) -> loop h fdat [])
where
- desc = "getDirectoryContents"
-
- loop :: Ptr (Ptr CDirent) -> Ptr CDir -> IO [String]
- loop ptr_dEnt dir = do
- resetErrno
- r <- readdir dir ptr_dEnt
- if (r == 0)
- then do
- dEnt <- peek ptr_dEnt
- if (dEnt == nullPtr)
- then return []
- else do
- entry <- (d_name dEnt >>= peekCString)
- freeDirEnt dEnt
- entries <- loop ptr_dEnt 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
+ -- we needn't worry about empty directories: adirectory always
+ -- has at least "." and ".." entries
+ loop :: Win32.HANDLE -> Win32.FindData -> [FilePath] -> IO [FilePath]
+ loop h fdat acc = do
+ filename <- Win32.getFindDataFileName fdat
+ more <- Win32.findNextFile h fdat
+ if more
+ then loop h fdat (filename:acc)
+ else return (filename:acc)
+ -- no need to reverse, ordering is undefined
+#endif /* mingw32 */
+#endif /* __GLASGOW_HASKELL__ */
{- |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
- 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"
+#ifdef mingw32_HOST_OS
+ Win32.getCurrentDirectory
+#else
+ Posix.getWorkingDirectory
+#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
+ Win32.setCurrentDirectory path
+#else
+ Posix.changeWorkingDirectory path
+#endif
+
+#endif /* __GLASGOW_HASKELL__ */
+#ifdef __GLASGOW_HASKELL__
{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
exists and is a directory, and 'False' otherwise.
-}
doesDirectoryExist :: FilePath -> IO Bool
doesDirectoryExist name =
+#ifdef mingw32_HOST_OS
(withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)
+#else
+ (do stat <- Posix.getFileStatus name
+ return (Posix.isDirectory stat))
+#endif
`catch` ((\ _ -> return False) :: IOException -> IO Bool)
{- |The operation 'doesFileExist' returns 'True'
doesFileExist :: FilePath -> IO Bool
doesFileExist name =
+#ifdef mingw32_HOST_OS
(withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))
+#else
+ (do stat <- Posix.getFileStatus name
+ return (not (Posix.isDirectory stat)))
+#endif
`catch` ((\ _ -> return False) :: IOException -> IO Bool)
{- |The 'getModificationTime' operation returns the
-}
getModificationTime :: FilePath -> IO ClockTime
-getModificationTime name =
- withFileStatus "getModificationTime" name $ \ st ->
+getModificationTime name = do
+#ifdef mingw32_HOST_OS
+ -- ToDo: use Win32 API
+ withFileStatus "getModificationTime" name $ \ st -> do
modificationTime st
+#else
+ stat <- Posix.getFileStatus name
+ let mod_time :: Posix.EpochTime
+ mod_time = Posix.modificationTime stat
+ dbl_time :: Double
+ dbl_time = realToFrac mod_time
+ return (TOD (round dbl_time) 0)
+#endif
+ -- For info
+ -- round :: (RealFrac a, Integral b => a -> b
+ -- realToFrac :: (Real a, Fractional b) => a -> b
+#endif /* __GLASGOW_HASKELL__ */
+
+#ifdef mingw32_HOST_OS
withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
withFileStatus loc name f = do
modifyIOError (`ioeSetFileName` name) $
allocaBytes sizeof_stat $ \p ->
- withCString (fileNameEndClean name) $ \s -> do
+ withFilePath (fileNameEndClean name) $ \s -> do
throwErrnoIfMinus1Retry_ loc (c_stat s p)
f p
withFileOrSymlinkStatus loc name f = do
modifyIOError (`ioeSetFileName` name) $
allocaBytes sizeof_stat $ \p ->
- withCString name $ \s -> do
+ withFilePath name $ \s -> do
throwErrnoIfMinus1Retry_ loc (lstat s p)
f p
modificationTime :: Ptr CStat -> IO ClockTime
modificationTime stat = do
mtime <- st_mtime stat
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- return (TOD (realToInteger (mtime :: CTime)) 0)
+ let dbl_time :: Double
+ dbl_time = realToFrac (mtime :: CTime)
+ return (TOD (round dbl_time) 0)
isDirectory :: Ptr CStat -> IO Bool
isDirectory stat = do
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 "__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
-#ifdef mingw32_HOST_OS
+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
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.
-}
getHomeDirectory :: IO FilePath
getHomeDirectory =
+ modifyIOError ((`ioeSetLocation` "getHomeDirectory")) $ do
#if defined(mingw32_HOST_OS)
- allocaBytes long_path_size $ \pPath -> do
- r0 <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath
- if (r0 < 0)
- then do
- r1 <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath
- when (r1 < 0) (raiseUnsupported "System.Directory.getHomeDirectory")
- else return ()
- peekCString pPath
+ r <- try $ Win32.sHGetFolderPath nullPtr Win32.cSIDL_PROFILE nullPtr 0
+ case (r :: Either IOException String) of
+ Right s -> return s
+ Left _ -> do
+ r1 <- try $ Win32.sHGetFolderPath nullPtr Win32.cSIDL_WINDOWS nullPtr 0
+ case r1 of
+ Right s -> return s
+ Left e -> ioError (e :: IOException)
#else
- getEnv "HOME"
+ getEnv "HOME"
#endif
{- | Returns the pathname of a directory in which application-specific
-}
getAppUserDataDirectory :: String -> IO FilePath
getAppUserDataDirectory appName = do
+ modifyIOError ((`ioeSetLocation` "getAppUserDataDirectory")) $ do
#if defined(mingw32_HOST_OS)
- allocaBytes long_path_size $ \pPath -> do
- r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
- when (r<0) (raiseUnsupported "System.Directory.getAppUserDataDirectory")
- s <- peekCString pPath
- return (s++'\\':appName)
+ s <- Win32.sHGetFolderPath nullPtr Win32.cSIDL_APPDATA nullPtr 0
+ return (s++'\\':appName)
#else
- path <- getEnv "HOME"
- return (path++'/':'.':appName)
+ path <- getEnv "HOME"
+ return (path++'/':'.':appName)
#endif
{- | Returns the current user's document directory.
-}
getUserDocumentsDirectory :: IO FilePath
getUserDocumentsDirectory = do
+ modifyIOError ((`ioeSetLocation` "getUserDocumentsDirectory")) $ do
#if defined(mingw32_HOST_OS)
- allocaBytes long_path_size $ \pPath -> do
- r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath
- when (r<0) (raiseUnsupported "System.Directory.getUserDocumentsDirectory")
- peekCString pPath
+ Win32.sHGetFolderPath nullPtr Win32.cSIDL_PERSONAL nullPtr 0
#else
- getEnv "HOME"
+ getEnv "HOME"
#endif
{- | Returns the current directory for temporary files.
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
+ Win32.getTemporaryDirectory
#else
getEnv "TMPDIR"
#if !__NHC__
#endif
#endif
-#if defined(mingw32_HOST_OS)
-foreign import ccall unsafe "__hscore_getFolderPath"
- c_SHGetFolderPath :: Ptr ()
- -> CInt
- -> Ptr ()
- -> CInt
- -> CString
- -> IO CInt
-foreign import ccall unsafe "__hscore_CSIDL_PROFILE" csidl_PROFILE :: CInt
-foreign import ccall unsafe "__hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt
-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)
-
-#endif
-
-- ToDo: This should be determined via autoconf (AC_EXEEXT)
-- | Extension for executable files
-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)
#else
exeExtension = ""
#endif
-
projects / haskell-directory.git / blobdiff