Error.hs

{-# LANGUAGE CPP, DeriveDataTypeable, ForeignFunctionInterface #-}
{- |
   Module      :  System.Windows.Error
   Copyright   :  2008 Felix Martini
   License     :  BSD-style

   Maintainer  :  fmartini@gmail.com
   Stability   :  Provisional
   Portability :  Non-portable (extended exceptions)

   Error handling for foreign calls to the Windows API.
-}

module System.Windows.Error
  ( WinError(..),
    getWinError,
    getWinErrorMessage,
    throwWinErrorIf,
    throwWinErrorIfFalse,
    throwWinErrorIfInvalidHandle,

-- ** Common Windows error codes
-- | If the error code that you need is not listed below you can create your
-- own with the 'WinError' constructor and a numeric error code obtained from
-- the MSDN documentation at
-- <http://msdn2.microsoft.com/en-us/library/ms681381.aspx>.

    errorSuccess, errorInvalidFunction, errorFileNotFound,
    errorPathNotFound, errorTooManyOpenFiles, errorAccessDenied,
    errorInvalidHandle, errorArenaTrashed, errorNotEnoughMemory,
    errorInvalidBlock, errorBadEnvironment, errorBadFormat,
    errorInvalidAccess, errorInvalidData, errorOutOfMemory,
    errorInvalidDrive, errorCurrentDirectory, errorNotReady,
    errorHandleEOF,

  ) where

import Prelude hiding (catch)

import Control.Exception (Exception, throwIO)
import Data.Typeable     (Typeable)
import Data.Word         (Word32)
import Foreign.Ptr       (Ptr)
import Foreign.C.String  (CWString, peekCWString)

-- | WinError is an exception that corresponds to a Windows error code.
newtype WinError = WinError Word32
  deriving (Eq, Typeable)

instance Exception WinError

instance Show WinError where
  showsPrec _ (WinError err) = showString "Windows error " . shows err

-- | Get the current thread's last error code. Each OS thread maintains it's
-- own last error code.
getWinError :: IO WinError
getWinError = do
  err <- c_GetLastError
  return (WinError err)

-- | Get the error message corresponding to the error code.
getWinErrorMessage :: WinError  -- ^ Windows error code
                   -> IO String
getWinErrorMessage (WinError err) = do
  msg <- c_GetErrorMessage err
  str <- peekCWString msg
  let str' = (unwords . words) str
  c_LocalFree msg
  return str'

-- | Throw a 'WinError' exception corresponding to the last error code if the
-- result value of the 'IO' action meets the given predicate.
throwWinErrorIf :: (a -> Bool)  -- ^ Predicate to apply to the result value
                                -- of the 'IO' operation
                -> IO a         -- ^ The 'IO' action to be executed
                -> IO a
throwWinErrorIf predicate act  = do
  res <- act
  if predicate res
    then do err <- c_GetLastError
            throwIO (WinError err)
    else return res

-- | Throw a 'WinError' exception corresponding to the last error code if the
-- result value of the 'IO' action is False.
throwWinErrorIfFalse :: IO Bool -- ^ The 'IO' action to be executed
                     -> IO ()
throwWinErrorIfFalse act  = do
  res <- act
  if not res
    then do err <- c_GetLastError
            throwIO (WinError err)
    else return ()

-- | Throw a 'WinError' exception corresponding to the last error code if
-- the result value of the 'IO' action is an invalid handle.
throwWinErrorIfInvalidHandle :: IO (Ptr a) -- ^ The 'IO' action to be
                                           -- executed
                             -> IO (Ptr a)
throwWinErrorIfInvalidHandle act  = do
  res <- act
  if res == invalidHandleValue
    then do err <- c_GetLastError
            throwIO (WinError err)
    else return res

-- ---------------------------------------------------------------------
-- Error codes

errorSuccess          :: WinError
errorInvalidFunction  :: WinError
errorFileNotFound     :: WinError
errorPathNotFound     :: WinError
errorTooManyOpenFiles :: WinError
errorAccessDenied     :: WinError
errorInvalidHandle    :: WinError
errorArenaTrashed     :: WinError
errorNotEnoughMemory  :: WinError
errorInvalidBlock     :: WinError
errorBadEnvironment   :: WinError
errorBadFormat        :: WinError
errorInvalidAccess    :: WinError
errorInvalidData      :: WinError
errorOutOfMemory      :: WinError
errorInvalidDrive     :: WinError
errorCurrentDirectory :: WinError
errorNotReady         :: WinError
errorHandleEOF        :: WinError

errorSuccess          = WinError 0
errorInvalidFunction  = WinError 1
errorFileNotFound     = WinError 2
errorPathNotFound     = WinError 3
errorTooManyOpenFiles = WinError 4
errorAccessDenied     = WinError 5
errorInvalidHandle    = WinError 6
errorArenaTrashed     = WinError 7
errorNotEnoughMemory  = WinError 8
errorInvalidBlock     = WinError 9
errorBadEnvironment   = WinError 10
errorBadFormat        = WinError 11
errorInvalidAccess    = WinError 12
errorInvalidData      = WinError 13
errorOutOfMemory      = WinError 14
errorInvalidDrive     = WinError 15
errorCurrentDirectory = WinError 16
errorNotReady         = WinError 21
errorHandleEOF        = WinError 38

-- ---------------------------------------------------------------------
-- Foreign functions

foreign import stdcall unsafe "GetLastError"
  c_GetLastError :: IO Word32

foreign import ccall unsafe "GetErrorMessageW"
  c_GetErrorMessage :: Word32 -> IO CWString

foreign import stdcall unsafe "LocalFree"
  c_LocalFree :: Ptr a -> IO (Ptr a)

foreign import ccall unsafe "invalidHandleValue"
  invalidHandleValue :: Ptr a