{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Trustworthy #-}
module System.Win32.Error.Foreign
( failIf
, failIfFalse_
, failIfNull
, failUnlessSuccess
, failWith
, errorWin
) where
import Control.Exception
import Data.Char
import Data.Text as T
import Data.Text.Foreign as T
import Foreign
import Numeric
import System.Win32 (DWORD, LPTSTR)
import qualified System.Win32 as Win32
import System.Win32.Error.Types
#include "windows_cconv.h"
failIfFalse_ :: Text -> IO Bool -> IO ()
failIfFalse_ :: Text -> IO Bool -> IO ()
failIfFalse_ Text
wh IO Bool
act = (Bool -> Bool) -> Text -> IO Bool -> IO Bool
forall a. (a -> Bool) -> Text -> IO a -> IO a
failIf Bool -> Bool
not Text
wh IO Bool
act IO Bool -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
failIf :: (a -> Bool) -> Text -> IO a -> IO a
failIf :: forall a. (a -> Bool) -> Text -> IO a -> IO a
failIf a -> Bool
p Text
wh IO a
act = do
a
v <- IO a
act
if a -> Bool
p a
v then Text -> IO a
forall a. Text -> IO a
errorWin Text
wh else a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
failIfNull :: Text -> IO (Ptr a) -> IO (Ptr a)
failIfNull :: forall a. Text -> IO (Ptr a) -> IO (Ptr a)
failIfNull = (Ptr a -> Bool) -> Text -> IO (Ptr a) -> IO (Ptr a)
forall a. (a -> Bool) -> Text -> IO a -> IO a
failIf (Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr)
failUnlessSuccess :: Text -> IO DWORD -> IO ()
failUnlessSuccess :: Text -> IO DWORD -> IO ()
failUnlessSuccess Text
fn_name IO DWORD
act = do
DWORD
r <- IO DWORD
act
if DWORD
r DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== ErrCode -> DWORD
toDWORD ErrCode
Success then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () else Text -> DWORD -> IO ()
forall a. Text -> DWORD -> IO a
failWith' Text
fn_name DWORD
r
errorWin :: Text -> IO a
errorWin :: forall a. Text -> IO a
errorWin Text
fn_name = IO DWORD
Win32.getLastError IO DWORD -> (DWORD -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> DWORD -> IO a
forall a. Text -> DWORD -> IO a
failWith' Text
fn_name
failWith' :: Text -> DWORD -> IO a
failWith' :: forall a. Text -> DWORD -> IO a
failWith' Text
fn_name DWORD
err_code = do
Text
msg <- DWORD -> IO Text
formatMessage DWORD
err_code
let msg' :: Text
msg' = Text -> Text
T.reverse (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.reverse (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
msg
Win32Exception -> IO a
forall a e. Exception e => e -> a
throw (Win32Exception -> IO a) -> Win32Exception -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> ErrCode -> Text -> Win32Exception
Win32Exception Text
fn_name (DWORD -> ErrCode
fromDWORD DWORD
err_code) Text
msg'
failWith :: Text -> ErrCode -> IO a
failWith :: forall a. Text -> ErrCode -> IO a
failWith Text
fn_name ErrCode
err_code = Text -> DWORD -> IO a
forall a. Text -> DWORD -> IO a
failWith' Text
fn_name (DWORD -> IO a) -> DWORD -> IO a
forall a b. (a -> b) -> a -> b
$ ErrCode -> DWORD
toDWORD ErrCode
err_code
#define FORMAT_MESSAGE_FROM_SYSTEM 0x00001000
#define FORMAT_MESSAGE_ALLOCATE_BUFFER 0x00000100
formatMessage :: DWORD -> IO Text
formatMessage :: DWORD -> IO Text
formatMessage DWORD
err =
(Ptr (Ptr Word8) -> IO Text) -> IO Text
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr Word8) -> IO Text) -> IO Text)
-> (Ptr (Ptr Word8) -> IO Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr Word8)
ppBuffer -> do
DWORD
len <- DWORD
-> Ptr ()
-> DWORD
-> DWORD
-> LPTSTR
-> DWORD
-> Ptr ()
-> IO DWORD
c_FormatMessage (FORMAT_MESSAGE_FROM_SYSTEM .|. FORMAT_MESSAGE_ALLOCATE_BUFFER)
Ptr ()
forall a. Ptr a
nullPtr DWORD
err DWORD
0 (Ptr (Ptr Word8) -> LPTSTR
forall a b. Ptr a -> Ptr b
castPtr Ptr (Ptr Word8)
ppBuffer) DWORD
0 Ptr ()
forall a. Ptr a
nullPtr
Ptr Word8
pBuffer <- Ptr (Ptr Word8) -> IO (Ptr Word8)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr Word8)
ppBuffer
if (DWORD
len DWORD -> DWORD -> Bool
forall a. Eq a => a -> a -> Bool
== DWORD
0 Bool -> Bool -> Bool
|| Ptr Word8
pBuffer Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
forall a. Ptr a
nullPtr)
then Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
"Error 0x" Text -> Text -> Text
`T.append` String -> Text
T.pack (DWORD -> ShowS
forall a. Integral a => a -> ShowS
Numeric.showHex DWORD
err String
"")
else Ptr Word8 -> I8 -> IO Text
fromPtr Ptr Word8
pBuffer (DWORD -> I8
forall a b. (Integral a, Num b) => a -> b
fromIntegral DWORD
len)
foreign import WINDOWS_CCONV "Windows.h FormatMessageW"
c_FormatMessage :: DWORD -> Ptr () -> DWORD -> DWORD -> LPTSTR -> DWORD
-> Ptr () -> IO DWORD