Error.hs

{-# LANGUAGE CPP, DeriveDataTypeable, ForeignFunctionInterface #-}
{-# INCLUDE "HsWinError.h" #-}
{-# CFILES "cbits/HsWinError.c" #-}
{- |
   Module      :  System.Windows.Error
   Copyright   :  2008 Felix Martini
   License     :  BSD-style

   Maintainer  :  fmartini@gmail.com
   Stability   :  Provisional
   Portability :  Portable

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

module System.Windows.Error
  ( WinError(..),
    getWinError,
    getWinErrorMessage,
    throwWinError,
    throwWinErrorIf,
    throwWinErrorIfFalse,
    throwWinErrorIfInvalidHandle,
#ifdef __GLASGOW_HASKELL__
    catchWinError,
#endif

-- ** 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>. If you regularly
-- use an error code please contact the maintainer of this package to have it
-- included.

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

  ) where

import Data.Word        (Word32)
import Foreign.Ptr      (Ptr)
import Foreign.C.String (CWString, peekCWString)
import System.IO.Error  (mkIOError)

#ifdef __GLASGOW_HASKELL__
import GHC.IOBase       (IOErrorType(DynIOError))
import Data.Dynamic     (fromDynamic, toDyn)
import Data.Typeable    (Typeable)
import System.IO.Error  (ioeGetErrorType)
#else
import System.IO.Error  (userErrorType)
#endif

newtype WinError = WinError Word32
#ifdef __GLASGOW_HASKELL__
  deriving (Eq, Typeable)
#else
  deriving Eq
#endif

instance Show WinError where
    show (WinError err) = "Windows error " ++ show 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 an 'IOError' corresponding to the Windows error code. For GHC the
-- IOError type is DynIOError WinError. For other compilers the IOError type
-- is UserError.
throwWinError     :: WinError  -- ^ Windows error code
                  -> String	   -- ^ Textual description of the error location
                  -> IO a
throwWinError werr loc = do
  str <- getWinErrorMessage werr
  let loc' = loc ++ ": " ++ str ++ " (" ++ show werr ++ ")"
#ifdef __GLASGOW_HASKELL__
  let ioe = mkIOError (DynIOError (toDyn werr)) loc' Nothing Nothing
#else
  let ioe = mkIOError userErrorType loc' Nothing Nothing
#endif
  ioError ioe

#ifdef __GLASGOW_HASKELL__
-- | Catch Windows errors. Other exceptions are not caught. Note that this
-- function is available only for GHC.
catchWinError :: IO a               -- ^ The 'IO' operation to be executed
              -> (WinError -> IO a) -- ^ Exception handler
              -> IO a
catchWinError act h = catch act handle
  where handle ex = case ioeGetErrorType ex of
                      DynIOError dyn ->
                        case fromDynamic dyn of
                          Just err -> h err
                          _other -> ioError ex
                      _other -> ioError ex
#endif

-- | Throw an 'IOError' 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
                -> String       -- ^ Textual description of the error location
                -> IO a         -- ^ The 'IO' action to be executed
                -> IO a
throwWinErrorIf predicate loc act  = do
  res <- act
  if predicate res
    then do err <- c_GetLastError
            throwWinError (WinError err) loc
    else return res

-- | Throw an 'IOError' corresponding to the last error code if the result
-- value of the 'IO' action is False.
throwWinErrorIfFalse :: String  -- ^ Textual description of the error location
                     -> IO Bool -- ^ The 'IO' action to be executed
                     -> IO ()
throwWinErrorIfFalse loc act  = do
  res <- act
  if not res
    then do err <- c_GetLastError
            throwWinError (WinError err) loc
    else return ()

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

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

errorSuccess, errorInvalidFunction, errorFileNotFound,
  errorPathNotFound, errorTooManyOpenFiles, errorAccessDenied,
  errorInvalidHandle, errorArenaTrashed, errorNotEnoughMemory,
  errorInvalidBlock, errorBadEnvironment, errorBadFormat,
  errorInvalidAccess, errorInvalidData, errorOutOfMemory,
  errorInvalidDrive, errorCurrentDirectory, errorNotReady,
  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