From dd98821bb79a1e4d266a4660b9282f1f3d4401e3 Mon Sep 17 00:00:00 2001 From: ross Date: Tue, 31 Aug 2004 09:07:26 +0000 Subject: [PATCH] [project @ 2004-08-31 09:07:26 by ross] make the new directory queries available to all implementations, though the mingw versions only work for GHC. --- System/Directory.hs | 199 +++++++++++++++++++++++++-------------------------- 1 file changed, 97 insertions(+), 102 deletions(-) diff --git a/System/Directory.hs b/System/Directory.hs index 096712c..c63a88a 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -64,17 +64,14 @@ module System.Directory #ifdef __NHC__ import Directory import System (getEnv) -getHomeDirectory :: IO FilePath -getHomeDirectory = getEnv "HOME" -getAppUserDataDirectory :: String -> IO FilePath -getAppUserDataDirectory appName = do path <- getEnv "HOME" - return (path++'/':'.':appName) -getUserDocumentsDirectory :: IO FilePath -getUserDocumentsDirectory= getEnv "HOME" -#elif defined(__HUGS__) +#endif /* __NHC__ */ + +#ifdef __HUGS__ import Hugs.Directory -#else +import System.Environment (getEnv) +#endif /* __HUGS__ */ +#ifdef __GLASGOW_HASKELL__ import Prelude import Control.Exception ( bracket ) @@ -87,9 +84,7 @@ import System.IO.Error import Foreign import Foreign.C -#ifdef __GLASGOW_HASKELL__ import GHC.IOBase ( IOException(..), IOErrorType(..), ioException ) -#endif #ifndef mingw32_TARGET_OS import System.Environment @@ -619,6 +614,93 @@ setCurrentDirectory path = do throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s) -- ToDo: add path to error +{- |The operation 'doesDirectoryExist' returns 'True' if the argument file +exists and is a directory, and 'False' otherwise. +-} + +doesDirectoryExist :: FilePath -> IO Bool +doesDirectoryExist name = + catch + (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st) + (\ _ -> return False) + +{- |The operation 'doesFileExist' returns 'True' +if the argument file exists and is not a directory, and 'False' otherwise. +-} + +doesFileExist :: FilePath -> IO Bool +doesFileExist name = do + catch + (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) + (\ _ -> return False) + +{- |The 'getModificationTime' operation returns the +clock time at which the file or directory was last modified. + +The operation may fail with: + +* 'isPermissionError' if the user is not permitted to access + the modification time; or + +* 'isDoesNotExistError' if the file or directory does not exist. + +-} + +getModificationTime :: FilePath -> IO ClockTime +getModificationTime name = + withFileStatus "getModificationTime" name $ \ st -> + modificationTime st + +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 + throwErrnoIfMinus1Retry_ loc (c_stat s p) + f p + +withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a +withFileOrSymlinkStatus loc name f = do + modifyIOError (`ioeSetFileName` name) $ + allocaBytes sizeof_stat $ \p -> + withCString 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) + +isDirectory :: Ptr CStat -> IO Bool +isDirectory stat = do + mode <- st_mode stat + return (s_isdir mode) + +fileNameEndClean :: String -> String +fileNameEndClean name = + if i > 0 && (ec == '\\' || ec == '/') then + fileNameEndClean (take i name) + else + name + where + i = (length name) - 1 + ec = name !! i + +foreign import ccall unsafe "__hscore_long_path_size" + long_path_size :: Int + +foreign import ccall unsafe "__hscore_R_OK" r_OK :: CMode +foreign import ccall unsafe "__hscore_W_OK" w_OK :: CMode +foreign import ccall unsafe "__hscore_X_OK" x_OK :: CMode + +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 + +#endif /* __GLASGOW_HASKELL__ */ + {- | Returns the current user's home directory. The directory returned is expected to be writable by the current user, @@ -642,7 +724,7 @@ cannot be found. -} getHomeDirectory :: IO FilePath getHomeDirectory = -#ifdef mingw32_TARGET_OS +#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) allocaBytes long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath if (r < 0) @@ -682,7 +764,7 @@ cannot be found. -} getAppUserDataDirectory :: String -> IO FilePath getAppUserDataDirectory appName = do -#ifdef mingw32_TARGET_OS +#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) allocaBytes long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath s <- peekCString pPath @@ -715,7 +797,7 @@ cannot be found. -} getUserDocumentsDirectory :: IO FilePath getUserDocumentsDirectory = do -#ifdef mingw32_TARGET_OS +#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) allocaBytes long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath peekCString pPath @@ -723,7 +805,7 @@ getUserDocumentsDirectory = do getEnv "HOME" #endif -#ifdef mingw32_TARGET_OS +#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS) foreign import stdcall unsafe "SHGetFolderPath" c_SHGetFolderPath :: Ptr () -> CInt @@ -736,90 +818,3 @@ 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 #endif - -{- |The operation 'doesDirectoryExist' returns 'True' if the argument file -exists and is a directory, and 'False' otherwise. --} - -doesDirectoryExist :: FilePath -> IO Bool -doesDirectoryExist name = - catch - (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st) - (\ _ -> return False) - -{- |The operation 'doesFileExist' returns 'True' -if the argument file exists and is not a directory, and 'False' otherwise. --} - -doesFileExist :: FilePath -> IO Bool -doesFileExist name = do - catch - (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) - (\ _ -> return False) - -{- |The 'getModificationTime' operation returns the -clock time at which the file or directory was last modified. - -The operation may fail with: - -* 'isPermissionError' if the user is not permitted to access - the modification time; or - -* 'isDoesNotExistError' if the file or directory does not exist. - --} - -getModificationTime :: FilePath -> IO ClockTime -getModificationTime name = - withFileStatus "getModificationTime" name $ \ st -> - modificationTime st - -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 - throwErrnoIfMinus1Retry_ loc (c_stat s p) - f p - -withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a -withFileOrSymlinkStatus loc name f = do - modifyIOError (`ioeSetFileName` name) $ - allocaBytes sizeof_stat $ \p -> - withCString 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) - -isDirectory :: Ptr CStat -> IO Bool -isDirectory stat = do - mode <- st_mode stat - return (s_isdir mode) - -fileNameEndClean :: String -> String -fileNameEndClean name = - if i > 0 && (ec == '\\' || ec == '/') then - fileNameEndClean (take i name) - else - name - where - i = (length name) - 1 - ec = name !! i - -foreign import ccall unsafe "__hscore_long_path_size" - long_path_size :: Int - -foreign import ccall unsafe "__hscore_R_OK" r_OK :: CMode -foreign import ccall unsafe "__hscore_W_OK" w_OK :: CMode -foreign import ccall unsafe "__hscore_X_OK" x_OK :: CMode - -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 - -#endif -- 1.7.10.4