X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FDirectory.hs;h=cafe759c635548d616769404613efef306fc2520;hb=dd70cacd4793c4497136829c50ef31f330163638;hp=53417d657799328d6a681db3f6088aa819ffe202;hpb=402f15d3c991951972e6d21ded2d97418326e48f;p=ghc-base.git

diff --git a/System/Directory.hs b/System/Directory.hs
index 53417d6..cafe759 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -65,9 +65,10 @@ module System.Directory
     , getModificationTime       -- :: FilePath -> IO ClockTime
    ) where
 
+import System.Directory.Internals
 import System.Environment      ( getEnv )
-import System.FilePath
 import System.IO.Error
+import Control.Monad           ( when, unless )
 
 #ifdef __NHC__
 import Directory
@@ -82,7 +83,6 @@ import Hugs.Directory
 import Prelude
 
 import Control.Exception       ( bracket )
-import Control.Monad           ( when, unless )
 import System.Posix.Types
 import System.Posix.Internals
 import System.Time             ( ClockTime(..) )
@@ -240,6 +240,7 @@ createDirectory path = do
     withCString path $ \s -> do
       throwErrnoIfMinus1Retry_ "createDirectory" $
 	mkdir s 0o777
+#endif
 
 -- | @'createDirectoryIfMissing' parents dir@ creates a new directory 
 -- @dir@ if it doesn\'t exist. If the first argument is 'True'
@@ -255,6 +256,7 @@ createDirectoryIfMissing parents file = do
     (_,  True,  _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))
     (_, False,  _) -> createDirectory file
 
+#if __GLASGOW_HASKELL__
 {- | @'removeDirectory' dir@ removes an existing directory /dir/.  The
 implementation may specify additional constraints which must be
 satisfied before a directory can be removed (e.g. the directory has to
@@ -301,6 +303,7 @@ removeDirectory path = do
   modifyIOError (`ioeSetFileName` path) $
     withCString path $ \s ->
        throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
+#endif
 
 -- | @'removeDirectoryRecursive' dir@  removes an existing directory /dir/
 -- together with its content and all subdirectories. Be careful, 
@@ -320,6 +323,7 @@ removeDirectoryRecursive startLoc = do
                               removeDirectoryRecursive f
                 Right _ -> return ()
 
+#if __GLASGOW_HASKELL__
 {- |'removeFile' /file/ removes the directory entry for an existing file
 /file/, where /file/ is not itself a directory. The
 implementation may specify additional constraints which must be
@@ -515,14 +519,14 @@ copyFile fromFPath toFPath =
 -- canonicalized path, with the intent that two paths referring
 -- to the same file\/directory will map to the same canonicalized
 -- path. Note that it is impossible to guarantee that the
--- implication (same file\/dir <=> same canonicalizedPath) holds
+-- implication (same file\/dir \<=\> same canonicalizedPath) holds
 -- in either direction: this function can make only a best-effort
 -- attempt.
 canonicalizePath :: FilePath -> IO FilePath
 canonicalizePath fpath =
   withCString fpath $ \pInPath ->
   allocaBytes long_path_size $ \pOutPath ->
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
   alloca $ \ppFilePart ->
     do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart
 #else
@@ -530,7 +534,7 @@ canonicalizePath fpath =
 #endif
        peekCString pOutPath
 
-#if defined(mingw32_TARGET_OS)
+#if defined(mingw32_HOST_OS)
 foreign import stdcall unsafe "GetFullPathName"
             c_GetFullPathName :: CString
                               -> CInt
@@ -828,12 +832,14 @@ cannot be found.
 -}
 getHomeDirectory :: IO FilePath
 getHomeDirectory =
-#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
   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"
@@ -868,9 +874,10 @@ cannot be found.
 -}
 getAppUserDataDirectory :: String -> IO FilePath
 getAppUserDataDirectory appName = do
-#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
+#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
@@ -901,9 +908,10 @@ cannot be found.
 -}
 getUserDocumentsDirectory :: IO FilePath
 getUserDocumentsDirectory = do
-#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
+#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"
@@ -937,7 +945,7 @@ The function doesn\'t verify whether the path exists.
 -}
 getTemporaryDirectory :: IO FilePath
 getTemporaryDirectory = do
-#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
   allocaBytes long_path_size $ \pPath -> do
      r <- c_GetTempPath (fromIntegral long_path_size) pPath
      peekCString pPath
@@ -945,8 +953,8 @@ getTemporaryDirectory = do
   catch (getEnv "TMPDIR") (\ex -> return "/tmp")
 #endif
 
-#if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
-foreign import stdcall unsafe "SHGetFolderPath" 
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
+foreign import stdcall unsafe "dirUtils.h __hscore_getFolderPath"
             c_SHGetFolderPath :: Ptr () 
                               -> CInt 
                               -> Ptr () 
@@ -959,4 +967,8 @@ 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
+
+raiseUnsupported loc = 
+   ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
+
 #endif