GHC.Windows: more error support (guards, system error strings)

This changes the output of throwGetLastError to include the system error
message, rather than the message of our fictitious errno.

It also adds several definitions to GHC.Windows, mostly from the Win32 package.
The exceptions are:

 * getErrorMessage: returns a String, unlike in System.Win32.Types,
   where it returns an LPWSTR.

 * errCodeToIOError: new

 * c_maperrno_func: new

4 files changed, 200 insertions, 40 deletions

diff --git a/libraries/base/GHC/Windows.hs b/libraries/base/GHC/Windows.hs
index fa25f63e32..8316824f55 100644
--- a/libraries/base/GHC/Windows.hs
+++ b/libraries/base/GHC/Windows.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE NoImplicitPrelude, ForeignFunctionInterface #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Windows
@@ -19,30 +21,172 @@
 -----------------------------------------------------------------------------
 
 module GHC.Windows (
-        HANDLE, DWORD, LPTSTR, iNFINITE,
-        throwGetLastError, c_maperrno
-    ) where
+        -- * Types
+        BOOL,
+        DWORD,
+        ErrCode,
+        HANDLE,
+        LPWSTR,
+        LPTSTR,
 
-import GHC.Base
-import GHC.Ptr
+        -- * Constants
+        iNFINITE,
+        iNVALID_HANDLE_VALUE,
 
-import Data.Word
+        -- * System errors
+        throwGetLastError,
+        failWith,
+        getLastError,
+        getErrorMessage,
+        errCodeToIOError,
+
+        -- ** Guards for system calls that might fail
+        failIf,
+        failIf_,
+        failIfNull,
+        failIfZero,
+        failIfFalse_,
+        failUnlessSuccess,
+        failUnlessSuccessOr,
 
-import Foreign.C.Error (throwErrno)
+        -- ** Mapping system errors to errno
+        -- $errno
+        c_maperrno,
+        c_maperrno_func,
+    ) where
+
+import Data.Char
+import Data.List
+import Data.Maybe
+import Data.Word
+import Foreign.C.Error
+import Foreign.C.String
 import Foreign.C.Types
+import Foreign.Ptr
+import GHC.Base
+import GHC.IO
+import GHC.Num
+import System.IO.Error
+
+import qualified Numeric
 
+#ifdef mingw32_HOST_OS
+# if defined(i386_HOST_ARCH)
+#  define WINDOWS_CCONV stdcall
+# elif defined(x86_64_HOST_ARCH)
+#  define WINDOWS_CCONV ccall
+# else
+#  error Unknown mingw32 arch
+# endif
+#endif
 
-type HANDLE       = Ptr ()
-type DWORD        = Word32
+type BOOL    = Bool
+type DWORD   = Word32
+type ErrCode = DWORD
+type HANDLE  = Ptr ()
+type LPWSTR  = Ptr CWchar
 
-type LPTSTR = Ptr CWchar
+-- | Be careful with this.  LPTSTR can mean either WCHAR* or CHAR*, depending
+-- on whether the UNICODE macro is defined in the corresponding C code.
+-- Consider using LPWSTR instead.
+type LPTSTR = LPWSTR
 
 iNFINITE :: DWORD
 iNFINITE = 0xFFFFFFFF -- urgh
 
+iNVALID_HANDLE_VALUE :: HANDLE
+iNVALID_HANDLE_VALUE = wordPtrToPtr (-1)
+
+-- | Get the last system error, and throw it as an 'IOError' exception.
 throwGetLastError :: String -> IO a
-throwGetLastError where_from = c_maperrno >> throwErrno where_from
+throwGetLastError where_from =
+    getLastError >>= failWith where_from
+
+-- | Convert a Windows error code to an exception, then throw it.
+failWith :: String -> ErrCode -> IO a
+failWith fn_name err_code =
+    errCodeToIOError fn_name err_code >>= throwIO
+
+-- | Convert a Windows error code to an exception.
+errCodeToIOError :: String -> ErrCode -> IO IOError
+errCodeToIOError fn_name err_code = do
+    msg <- getErrorMessage err_code
+
+    -- turn GetLastError() into errno, which errnoToIOError knows
+    -- how to convert to an IOException we can throw.
+    -- XXX we should really do this directly.
+    let errno = c_maperrno_func err_code
+
+    let msg' = reverse $ dropWhile isSpace $ reverse msg -- drop trailing \n
+        ioerror = errnoToIOError fn_name errno Nothing Nothing
+                    `ioeSetErrorString` msg'
+    return ioerror
 
+-- | Get a string describing a Windows error code.  This uses the
+-- @FormatMessage@ system call.
+getErrorMessage :: ErrCode -> IO String
+getErrorMessage err_code =
+    mask_ $ do
+        c_msg <- c_getErrorMessage err_code
+        if c_msg == nullPtr
+          then return $ "Error 0x" ++ Numeric.showHex err_code ""
+          else do msg <- peekCWString c_msg
+                  -- We ignore failure of freeing c_msg, given we're already failing
+                  _ <- localFree c_msg
+                  return msg
+
+failIf :: (a -> Bool) -> String -> IO a -> IO a
+failIf p wh act = do
+    v <- act
+    if p v then throwGetLastError wh else return v
+
+failIf_ :: (a -> Bool) -> String -> IO a -> IO ()
+failIf_ p wh act = do
+    v <- act
+    if p v then throwGetLastError wh else return ()
+
+failIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
+failIfNull = failIf (== nullPtr)
+
+failIfZero :: (Eq a, Num a) => String -> IO a -> IO a
+failIfZero = failIf (== 0)
+
+failIfFalse_ :: String -> IO Bool -> IO ()
+failIfFalse_ = failIf_ not
+
+failUnlessSuccess :: String -> IO ErrCode -> IO ()
+failUnlessSuccess fn_name act = do
+    r <- act
+    if r == 0 then return () else failWith fn_name r
+
+failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool
+failUnlessSuccessOr val fn_name act = do
+    r <- act
+    if r == 0 then return False
+        else if r == val then return True
+        else failWith fn_name r
+
+-- $errno
+--
+-- On Windows, @errno@ is defined by msvcrt.dll for compatibility with other
+-- systems, and is distinct from the system error as returned
+-- by @GetLastError@.
+
+-- | Map the last system error to an errno value, and assign it to @errno@.
 foreign import ccall unsafe "maperrno"             -- in Win32Utils.c
    c_maperrno :: IO ()
 
+-- | Pure function variant of 'c_maperrno' that does not call @GetLastError@
+-- or modify @errno@.
+foreign import ccall unsafe "maperrno_func"        -- in Win32Utils.c
+   c_maperrno_func :: ErrCode -> Errno
+
+foreign import ccall unsafe "base_getErrorMessage" -- in Win32Utils.c
+    c_getErrorMessage :: DWORD -> IO LPWSTR
+
+foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"
+    localFree :: Ptr a -> IO (Ptr a)
+
+-- | Get the last system error produced in the current thread.
+foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
+    getLastError :: IO ErrCode
diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs
index c74286f29d..184c910330 100644
--- a/libraries/base/System/Environment.hs
+++ b/libraries/base/System/Environment.hs
@@ -238,7 +238,7 @@ lookupEnv name = withCWString name $ \s -> try_size s 256
           | otherwise  -> peekCWString p_value >>= return . Just
 
 foreign import WINDOWS_CCONV unsafe "windows.h GetEnvironmentVariableW"
-  c_GetEnvironmentVariable :: LPTSTR -> LPTSTR -> DWORD -> IO DWORD
+  c_GetEnvironmentVariable :: LPWSTR -> LPWSTR -> DWORD -> IO DWORD
 #else
 lookupEnv name =
     withCString name $ \s -> do
diff --git a/libraries/base/cbits/Win32Utils.c b/libraries/base/cbits/Win32Utils.c
index ecd54f32c2..7038cbf48e 100644
--- a/libraries/base/cbits/Win32Utils.c
+++ b/libraries/base/cbits/Win32Utils.c
@@ -80,34 +80,49 @@ static struct errentry errtable[] = {
 #define MIN_EACCES_RANGE ERROR_WRITE_PROTECT
 #define MAX_EACCES_RANGE ERROR_SHARING_BUFFER_EXCEEDED
 
-void maperrno (void)
+void maperrno(void)
 {
-	int i;
-	DWORD dwErrorCode;
-
-	dwErrorCode = GetLastError();
-
-	/* check the table for the OS error code */
-	for (i = 0; i < ERRTABLESIZE; ++i)
-	{
-		if (dwErrorCode == errtable[i].oscode)
-		{
-			errno = errtable[i].errnocode;
-			return;
-		}
-	}
-
-	/* The error code wasn't in the table.  We check for a range of */
-	/* EACCES errors or exec failure errors (ENOEXEC).  Otherwise   */
-	/* EINVAL is returned.                                          */
-
-	if (dwErrorCode >= MIN_EACCES_RANGE && dwErrorCode <= MAX_EACCES_RANGE)
-		errno = EACCES;
-	else
-		if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR)
-			errno = ENOEXEC;
-		else
-			errno = EINVAL;
+    errno = maperrno_func(GetLastError());
+}
+
+int maperrno_func(DWORD dwErrorCode)
+{
+    int i;
+
+    /* check the table for the OS error code */
+    for (i = 0; i < ERRTABLESIZE; ++i)
+        if (dwErrorCode == errtable[i].oscode)
+            return errtable[i].errnocode;
+
+    /* The error code wasn't in the table.  We check for a range of */
+    /* EACCES errors or exec failure errors (ENOEXEC).  Otherwise   */
+    /* EINVAL is returned.                                          */
+
+    if (dwErrorCode >= MIN_EACCES_RANGE && dwErrorCode <= MAX_EACCES_RANGE)
+        return EACCES;
+    else if (dwErrorCode >= MIN_EXEC_ERROR && dwErrorCode <= MAX_EXEC_ERROR)
+        return ENOEXEC;
+    else
+        return EINVAL;
+}
+
+LPWSTR base_getErrorMessage(DWORD err)
+{
+    LPWSTR what;
+    DWORD res;
+
+    res = FormatMessageW(
+              (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER),
+              NULL,
+              err,
+              MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), /* Default language */
+              (LPWSTR) &what,
+              0,
+              NULL
+          );
+    if (res == 0)
+        return NULL;
+    return what;
 }
 
 int get_unique_file_info(int fd, HsWord64 *dev, HsWord64 *ino)
diff --git a/libraries/base/include/HsBase.h b/libraries/base/include/HsBase.h
index 74ab816d84..b1a62fd131 100644
--- a/libraries/base/include/HsBase.h
+++ b/libraries/base/include/HsBase.h
@@ -141,6 +141,7 @@
 #if defined(__MINGW32__)
 /* in Win32Utils.c */
 extern void maperrno (void);
+extern int maperrno_func(DWORD dwErrorCode);
 extern HsWord64 getMonotonicUSec(void);
 #endif