use correct names of IOArray operations for nhc98

[haskell-directory.git] / System / Directory.hs

diff --git a/System/Directory.hs b/System/Directory.hs
index c6f3d66..bdd7f3c 100644 (file)
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -77,10 +77,13 @@ import NHC.FFI
 
 #ifdef __HUGS__
 import Hugs.Directory
-import Control.Exception       ( bracket )
-import System.IO
 #endif /* __HUGS__ */
 
+#if defined(__GLASGOW_HASKELL__) || defined(mingw32_HOST_OS)
+import Foreign
+import Foreign.C
+#endif
+
 #ifdef __GLASGOW_HASKELL__
 import Prelude
 
@@ -89,8 +92,6 @@ import System.Posix.Types
 import System.Posix.Internals
 import System.Time             ( ClockTime(..) )
 import System.IO
-import Foreign
-import Foreign.C
 
 import GHC.IOBase      ( IOException(..), IOErrorType(..), ioException )
 
@@ -196,6 +197,16 @@ setPermissions name (Permissions r w e s) = do
    modifyBit False m b = m .&. (complement b)
    modifyBit True  m b = m .|. b
 
+
+copyPermissions :: FilePath -> FilePath -> IO ()
+copyPermissions source dest = do
+  allocaBytes sizeof_stat $ \ p_stat -> do
+  withCString source $ \p_source -> do
+  withCString dest $ \p_dest -> do
+    throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat
+    mode <- st_mode p_stat
+    throwErrnoIfMinus1_ "copyPermissions" $ c_chmod p_dest mode
+
 -----------------------------------------------------------------------------
 -- Implementation
 
@@ -242,6 +253,13 @@ createDirectory path = do
     withCString path $ \s -> do
       throwErrnoIfMinus1Retry_ "createDirectory" $
        mkdir s 0o777
+
+#else /* !__GLASGOW_HASKELL__ */
+
+copyPermissions :: FilePath -> FilePath -> IO ()
+copyPermissions fromFPath toFPath
+  = getPermissions fromFPath >>= setPermissions toFPath
+
 #endif
 
 -- | @'createDirectoryIfMissing' parents dir@ creates a new directory 
@@ -493,23 +511,16 @@ Neither path may refer to an existing directory.
 -}
 copyFile :: FilePath -> FilePath -> IO ()
 copyFile fromFPath toFPath =
-#if defined(__HUGS__)
-       (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
-        bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo -> do
-        hGetContents hFrom >>= hPutStr hTo
-        try (getPermissions fromFPath >>= setPermissions toFPath)
-        return ()) `catch` \err ->
-               ioError (annotateIOError err "copyFile" Nothing Nothing)
-#elif (!defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ <= 600)
+#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
        do readFile fromFPath >>= writeFile toFPath
-          try (getPermissions fromFPath >>= setPermissions toFPath)
+          try (copyPermissions fromFPath toFPath)
           return ()
 #else
        (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
         bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
         allocaBytes bufferSize $ \buffer -> do
                copyContents hFrom hTo buffer
-               try (getPermissions fromFPath >>= setPermissions toFPath)
+               try (copyPermissions fromFPath toFPath)
                return ()) `catch` (ioError . changeFunName)
        where
                bufferSize = 1024
@@ -544,7 +555,7 @@ canonicalizePath fpath =
        peekCString pOutPath
 
 #if defined(mingw32_HOST_OS)
-foreign import stdcall unsafe "GetFullPathName"
+foreign import stdcall unsafe "GetFullPathNameA"
             c_GetFullPathName :: CString
                               -> CInt
                               -> CString
@@ -568,7 +579,32 @@ canonicalizePath fpath = return fpath
 -- such executable. For example (findExecutable \"ghc\")
 -- gives you the path to GHC.
 findExecutable :: String -> IO (Maybe FilePath)
-findExecutable binary = do
+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
+# if !defined(__GLASGOW_HASKELL__)
+long_path_size :: Int
+long_path_size = 4096
+# endif
+#else
+ do
   path <- getEnv "PATH"
   search (parseSearchPath path)
   where
@@ -581,6 +617,8 @@ findExecutable binary = do
        b <- doesFileExist path
        if b then return (Just path)
              else search ds
+#endif
+
 
 #ifdef __GLASGOW_HASKELL__
 {- |@'getDirectoryContents' dir@ returns a list of /all/ entries
@@ -845,8 +883,10 @@ getHomeDirectory =
   allocaBytes long_path_size $ \pPath -> do
      r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath
      if (r < 0)
-       then c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath
-       else return 0
+       then do
+          r <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath
+         when (r < 0) (raiseUnsupported "System.Directory.getHomeDirectory")
+       else return ()
      peekCString pPath
 #else
   getEnv "HOME"
@@ -884,6 +924,7 @@ getAppUserDataDirectory appName = do
 #if __GLASGOW_HASKELL__ && 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)
 #else
@@ -917,6 +958,7 @@ getUserDocumentsDirectory = do
 #if __GLASGOW_HASKELL__ && 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
 #else
   getEnv "HOME"
@@ -959,7 +1001,7 @@ getTemporaryDirectory = do
 #endif
 
 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
-foreign import stdcall unsafe "SHGetFolderPath" 
+foreign import ccall unsafe "__hscore_getFolderPath"
             c_SHGetFolderPath :: Ptr () 
                               -> CInt 
                               -> Ptr () 
@@ -971,5 +1013,9 @@ 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 "GetTempPath" c_GetTempPath :: CInt -> CString -> IO CInt
+foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt
+
+raiseUnsupported loc = 
+   ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
+
 #endif