[project @ 2004-08-19 11:15:51 by simonmar]

Add filenames to all errors where it makes sense.  I've added
System.Posix.Error with a new family of error-throwing functions,
throwErrnoPath*.  This seemed to make the most sense: they don't
belong in Foreign.C.Error (C by itself has no notion of paths).

Fixes: [ 954378 ] getFileStatus does not include the file name in IO-Error

5 files changed, 82 insertions, 25 deletions

diff --git a/System/Posix/Directory.hsc b/System/Posix/Directory.hsc
index c2075ed..490953c 100644
--- a/System/Posix/Directory.hsc
+++ b/System/Posix/Directory.hsc
@@ -33,6 +33,7 @@ module System.Posix.Directory (
    changeWorkingDirectoryFd,
   ) where
 
+import System.Posix.Error
 import System.Posix.Types
 import System.Posix.Internals
 import System.Directory hiding (createDirectory)
@@ -42,7 +43,7 @@ import Foreign.C
 createDirectory :: FilePath -> FileMode -> IO ()
 createDirectory name mode =
   withCString name $ \s -> 
-    throwErrnoIfMinus1_ "createDirectory" (c_mkdir s mode)  
+    throwErrnoPathIfMinus1_ "createDirectory" name (c_mkdir s mode)  
 
 foreign import ccall unsafe "mkdir"
   c_mkdir :: CString -> CMode -> IO CInt
@@ -52,7 +53,7 @@ newtype DirStream = DirStream (Ptr CDir)
 openDirStream :: FilePath -> IO DirStream
 openDirStream name =
   withCString name $ \s -> do
-    dirp <- throwErrnoIfNull "openDirStream" $ c_opendir s
+    dirp <- throwErrnoPathIfNull "openDirStream" name $ c_opendir s
     return (DirStream dirp)
 
 readDirStream :: DirStream -> IO FilePath
diff --git a/System/Posix/Error.hs b/System/Posix/Error.hs
new file mode 100644
index 0000000..e42648a
--- /dev/null
+++ b/System/Posix/Error.hs
@@ -0,0 +1,50 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Posix.Error
+-- Copyright   :  (c) The University of Glasgow 2002
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  non-portable (requires POSIX)
+--
+-- POSIX error support
+--
+-----------------------------------------------------------------------------
+
+module System.Posix.Error (
+	throwErrnoPath,
+	throwErrnoPathIf, 
+	throwErrnoPathIf_,
+	throwErrnoPathIfNull,
+	throwErrnoPathIfMinus1,
+	throwErrnoPathIfMinus1_
+  ) where
+
+import Foreign.C.Error
+import Foreign.Ptr
+import Foreign.Marshal.Error 	( void )
+
+throwErrnoPath :: String -> FilePath -> IO a
+throwErrnoPath loc path =
+  do
+    errno <- getErrno
+    ioError (errnoToIOError loc errno Nothing (Just path))
+
+throwErrnoPathIf :: (a -> Bool) -> String -> FilePath -> IO a -> IO a
+throwErrnoPathIf pred loc path f  = 
+  do
+    res <- f
+    if pred res then throwErrnoPath loc path else return res
+
+throwErrnoPathIf_ :: (a -> Bool) -> String -> FilePath -> IO a -> IO ()
+throwErrnoPathIf_ pred loc path f  = void $ throwErrnoPathIf pred loc path f
+
+throwErrnoPathIfNull :: String -> FilePath -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoPathIfNull  = throwErrnoPathIf (== nullPtr)
+
+throwErrnoPathIfMinus1 :: Num a => String -> FilePath -> IO a -> IO a
+throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1)
+
+throwErrnoPathIfMinus1_ :: Num a => String -> FilePath -> IO a -> IO ()
+throwErrnoPathIfMinus1_  = throwErrnoPathIf_ (== -1)
diff --git a/System/Posix/Files.hsc b/System/Posix/Files.hsc
index 010bf4e..a793034 100644
--- a/System/Posix/Files.hsc
+++ b/System/Posix/Files.hsc
@@ -72,6 +72,7 @@ module System.Posix.Files (
 
 #include "HsUnix.h"
 
+import System.Posix.Error
 import System.Posix.Types
 import System.IO.Unsafe
 import Data.Bits
@@ -172,7 +173,7 @@ socketMode = (#const S_IFSOCK)
 setFileMode :: FilePath -> FileMode -> IO ()
 setFileMode name m =
   withCString name $ \s -> do
-    throwErrnoIfMinus1_ "setFileMode" (c_chmod s m)
+    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
 
 setFdMode :: Fd -> FileMode -> IO ()
 setFdMode fd m =
@@ -204,7 +205,7 @@ fileExist name =
 	else do err <- getErrno
 	        if (err == eNOENT)
 		   then return False
-		   else throwErrno "fileExist"
+		   else throwErrnoPath "fileExist" name
 
 access :: FilePath -> CMode -> IO Bool
 access name flags = 
@@ -215,7 +216,7 @@ access name flags =
 	else do err <- getErrno
 	        if (err == eACCES)
 		   then return False
-		   else throwErrno "fileAccess"
+		   else throwErrnoPath "fileAccess" name
 
 -- -----------------------------------------------------------------------------
 -- stat() support
@@ -285,7 +286,7 @@ getFileStatus path = do
   fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) 
   withForeignPtr fp $ \p ->
     withCString path $ \s -> 
-      throwErrnoIfMinus1_ "getFileStatus" (c_stat s p)
+      throwErrnoPathIfMinus1_ "getFileStatus" path (c_stat s p)
   return (FileStatus fp)
 
 getFdStatus :: Fd -> IO FileStatus
@@ -300,7 +301,7 @@ getSymbolicLinkStatus path = do
   fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) 
   withForeignPtr fp $ \p ->
     withCString path $ \s -> 
-      throwErrnoIfMinus1_ "getSymbolicLinkStatus" (c_lstat s p)
+      throwErrnoPathIfMinus1_ "getSymbolicLinkStatus" path (c_lstat s p)
   return (FileStatus fp)
 
 foreign import ccall unsafe "lstat" 
@@ -309,12 +310,12 @@ foreign import ccall unsafe "lstat"
 createNamedPipe :: FilePath -> FileMode -> IO ()
 createNamedPipe name mode = do
   withCString name $ \s -> 
-    throwErrnoIfMinus1_ "createNamedPipe" (c_mkfifo s mode)
+    throwErrnoPathIfMinus1_ "createNamedPipe" name (c_mkfifo s mode)
 
 createDevice :: FilePath -> FileMode -> DeviceID -> IO ()
 createDevice path mode dev =
   withCString path $ \s ->
-    throwErrnoIfMinus1_ "createDevice" (c_mknod s mode dev)
+    throwErrnoPathIfMinus1_ "createDevice" path (c_mknod s mode dev)
 
 foreign import ccall unsafe "mknod" 
   c_mknod :: CString -> CMode -> CDev -> IO CInt
@@ -326,12 +327,12 @@ createLink :: FilePath -> FilePath -> IO ()
 createLink name1 name2 =
   withCString name1 $ \s1 ->
   withCString name2 $ \s2 ->
-  throwErrnoIfMinus1_ "createLink" (c_link s1 s2)
+  throwErrnoPathIfMinus1_ "createLink" name1 (c_link s1 s2)
 
 removeLink :: FilePath -> IO ()
 removeLink name =
   withCString name $ \s ->
-  throwErrnoIfMinus1_ "removeLink" (c_unlink s)
+  throwErrnoPathIfMinus1_ "removeLink" name (c_unlink s)
 
 -- -----------------------------------------------------------------------------
 -- Symbolic Links
@@ -340,7 +341,7 @@ createSymbolicLink :: FilePath -> FilePath -> IO ()
 createSymbolicLink file1 file2 =
   withCString file1 $ \s1 ->
   withCString file2 $ \s2 ->
-  throwErrnoIfMinus1_ "createSymbolicLink" (c_symlink s1 s2)
+  throwErrnoPathIfMinus1_ "createSymbolicLink" file1 (c_symlink s1 s2)
 
 foreign import ccall unsafe "symlink"
   c_symlink :: CString -> CString -> IO CInt
@@ -352,7 +353,7 @@ readSymbolicLink :: FilePath -> IO FilePath
 readSymbolicLink file =
   allocaArray0 (#const PATH_MAX) $ \buf -> do
     withCString file $ \s -> do
-      len <- throwErrnoIfMinus1 "readSymbolicLink" $ 
+      len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ 
 	c_readlink s buf (#const PATH_MAX)
       peekCStringLen (buf,fromIntegral len)
 
@@ -366,7 +367,7 @@ rename :: FilePath -> FilePath -> IO ()
 rename name1 name2 =
   withCString name1 $ \s1 ->
   withCString name2 $ \s2 ->
-  throwErrnoIfMinus1_ "rename" (c_rename s1 s2)
+  throwErrnoPathIfMinus1_ "rename" name1 (c_rename s1 s2)
 
 -- -----------------------------------------------------------------------------
 -- chmod()
@@ -374,7 +375,7 @@ rename name1 name2 =
 setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
 setOwnerAndGroup name uid gid = do
   withCString name $ \s ->
-    throwErrnoIfMinus1_ "setOwnerAndGroup" (c_chown s uid gid)
+    throwErrnoPathIfMinus1_ "setOwnerAndGroup" name (c_chown s uid gid)
 
 foreign import ccall unsafe "chown"
   c_chown :: CString -> CUid -> CGid -> IO CInt
@@ -390,7 +391,8 @@ foreign import ccall unsafe "fchown"
 setSymbolicLinkOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
 setSymbolicLinkOwnerAndGroup name uid gid = do
   withCString name $ \s ->
-    throwErrnoIfMinus1_ "setSymbolicLinkOwnerAndGroup" (c_lchown s uid gid)
+    throwErrnoPathIfMinus1_ "setSymbolicLinkOwnerAndGroup" name
+	(c_lchown s uid gid)
 
 foreign import ccall unsafe "lchown"
   c_lchown :: CString -> CUid -> CGid -> IO CInt
@@ -405,12 +407,12 @@ setFileTimes name atime mtime = do
    allocaBytes (#const sizeof(struct utimbuf)) $ \p -> do
      (#poke struct utimbuf, actime)  p atime
      (#poke struct utimbuf, modtime) p mtime
-     throwErrnoIfMinus1_ "setFileTimes" (c_utime s p)
+     throwErrnoPathIfMinus1_ "setFileTimes" name (c_utime s p)
 
 touchFile :: FilePath -> IO ()
 touchFile name = do
   withCString name $ \s ->
-   throwErrnoIfMinus1_ "touchFile" (c_utime s nullPtr)
+   throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr)
 
 -- -----------------------------------------------------------------------------
 -- Setting file sizes
@@ -418,7 +420,7 @@ touchFile name = do
 setFileSize :: FilePath -> FileOffset -> IO ()
 setFileSize file off = 
   withCString file $ \s ->
-    throwErrnoIfMinus1_ "setFileSize" (c_truncate s off)
+    throwErrnoPathIfMinus1_ "setFileSize" file (c_truncate s off)
 
 foreign import ccall unsafe "truncate"
   c_truncate :: CString -> COff -> IO CInt
@@ -500,7 +502,7 @@ pathVarConst v = case v of
 getPathVar :: FilePath -> PathVar -> IO Limit
 getPathVar name v = do
   withCString name $ \ nameP -> 
-    throwErrnoIfMinus1 "getPathVar" $ 
+    throwErrnoPathIfMinus1 "getPathVar" name $ 
       c_pathconf nameP (pathVarConst v)
 
 foreign import ccall unsafe "pathconf" 
diff --git a/System/Posix/IO.hsc b/System/Posix/IO.hsc
index 5b7169b..286e4ac 100644
--- a/System/Posix/IO.hsc
+++ b/System/Posix/IO.hsc
@@ -60,6 +60,7 @@ module System.Posix.IO (
 import System.IO
 import System.IO.Error
 import System.Posix.Types
+import System.Posix.Error
 import System.Posix.Internals
 
 import Foreign
@@ -142,7 +143,7 @@ openFd :: FilePath
 openFd name how maybe_mode (OpenFileFlags append exclusive noctty
 				nonBlock truncate) = do
    withCString name $ \s -> do
-    fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w)
+    fd <- throwErrnoPathIfMinus1 "openFd" name (c_open s all_flags mode_w)
     return (Fd fd)
   where
     all_flags  = creat .|. flags .|. open_mode
diff --git a/System/Posix/Process.hsc b/System/Posix/Process.hsc
index ea06930..e0ea099 100644
--- a/System/Posix/Process.hsc
+++ b/System/Posix/Process.hsc
@@ -73,6 +73,7 @@ import Foreign.Storable ( Storable(..) )
 import System.IO
 import System.IO.Error
 import System.Exit
+import System.Posix.Error
 import System.Posix.Types
 import System.Posix.Signals
 import Control.Monad
@@ -244,8 +245,8 @@ executeFile path search args Nothing = do
       withArray0 nullPtr cstrs $ \arr -> do
 	pPrPr_disableITimers
 	if search 
-	   then throwErrnoIfMinus1_ "executeFile" (c_execvp s arr)
-	   else throwErrnoIfMinus1_ "executeFile" (c_execv s arr)
+	   then throwErrnoPathIfMinus1_ "executeFile" path (c_execvp s arr)
+	   else throwErrnoPathIfMinus1_ "executeFile" path (c_execv s arr)
 
 executeFile path search args (Just env) = do
   withCString path $ \s ->
@@ -256,8 +257,10 @@ executeFile path search args (Just env) = do
       withArray0 nullPtr cenv $ \env_arr -> do
 	pPrPr_disableITimers
 	if search 
-	   then throwErrnoIfMinus1_ "executeFile" (c_execvpe s arg_arr env_arr)
-	   else throwErrnoIfMinus1_ "executeFile" (c_execve s arg_arr env_arr)
+	   then throwErrnoPathIfMinus1_ "executeFile" path
+		   (c_execvpe s arg_arr env_arr)
+	   else throwErrnoPathIfMinus1_ "executeFile" path
+		   (c_execve s arg_arr env_arr)
 
 -- this function disables the itimer, which would otherwise cause confusing
 -- signals to be sent to the new process.