diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +## 0.2.3 + +* Support for GHC 8.2.x and GHC 8.4.x + +## 0.2.2 + +* Support for GHC 8.0.x + ## 0.2.1 * Support for GHC 7.8.x @@ -6,4 +14,3 @@ * Add several additional error codes. * Update constraints on base package. - diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/System/Win32/Error.hs b/System/Win32/Error.hs --- a/System/Win32/Error.hs +++ b/System/Win32/Error.hs @@ -1,40 +1,40 @@ -{-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - --- | --- module: System.Win32.Error --- copyright: (c) Michael Steele, 2014 --- license: BSD3 --- maintainer: mikesteele81@gmail.com --- stability: experimental --- portability: Windows --- --- This package assumes that you will be using strict `T.Text` values for string --- handling. Consider using the following language pragma and import --- statements: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > module Main where --- > --- > import Data.Text (Text) --- > import qualified Data.Text as T --- > import qualified Data.Text.Foreign as T --- --- This module is intended to be imported qualified. --- --- > import System.Win32.Errors (ErrCode, Win32Exception) --- > import qualified System.Win32.Errors as E --- --- See the 'Win32Exception' type's documentation for an instructions on --- working with functions that may throw exceptions of this type. -module System.Win32.Error - ( Win32Exception (..) - , tryWin32 - , toDWORD - , fromDWORD - , ErrCode (..) - ) where - -import qualified Data.Text as T -import System.Win32.Error.Types +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +-- | +-- module: System.Win32.Error +-- copyright: (c) Michael Steele, 2014 +-- license: BSD3 +-- maintainer: mikesteele81@gmail.com +-- stability: experimental +-- portability: Windows +-- +-- This package assumes that you will be using strict `T.Text` values for string +-- handling. Consider using the following language pragma and import +-- statements: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main where +-- > +-- > import Data.Text (Text) +-- > import qualified Data.Text as T +-- > import qualified Data.Text.Foreign as T +-- +-- This module is intended to be imported qualified. +-- +-- > import System.Win32.Errors (ErrCode, Win32Exception) +-- > import qualified System.Win32.Errors as E +-- +-- See the 'Win32Exception' type's documentation for an instructions on +-- working with functions that may throw exceptions of this type. +module System.Win32.Error + ( Win32Exception (..) + , tryWin32 + , toDWORD + , fromDWORD + , ErrCode (..) + ) where + +import qualified Data.Text as T +import System.Win32.Error.Types diff --git a/System/Win32/Error/Foreign.hs b/System/Win32/Error/Foreign.hs --- a/System/Win32/Error/Foreign.hs +++ b/System/Win32/Error/Foreign.hs @@ -1,168 +1,168 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Trustworthy #-} - --- | --- module: System.Win32.Error.Foreign --- copyright: (c) Michael Steele, 2014 --- license: BSD3 --- maintainer: mikesteele81@gmail.com --- stability: experimental --- portability: Windows --- --- This module provides functions which can be used as drop-in replacements --- for Win32 when writing wrappers to foreign imports. --- --- You will likely need to import modules from Win32 as well. To avoid --- accidentally calling the standard error handling functions it's a good idea --- to hide a few names: --- --- > import qualified System.Win32.Error.Foreign as E --- > import System.Win32 hiding (failIfFalse_, failIf, failUnlessSuccess, failWith) --- --- Handling error conditions in Windows revolves around a thread-local --- global variable representing the most recent error condition. Functions --- indicate that an error occurred in various ways. The C++ programmer will --- observe that a function failed, and immediately call GetLastError to --- retrieve details on the possible cause or to get a localized error message --- which can be relayed to a human in some way. --- --- There are some cases where an error code may mean different things --- depending on varying context, but in general these codes are globally --- unique. Microsoft documents which error codes may be expected for any --- given function. --- --- When working with functions exported by Win32, error conditions are dealt --- with using the `IOError` exception type. Most native Win32 functions return --- an error code which can be used to determine whether something went wrong --- during its execution. By convention these functions are all named something --- of the form "c_DoSomething" where "DoSomething" matches the name given by --- Microsoft. A haskell wrapper function named "doSomething" will typically, --- among other things, check this error code. Based on its value the operating --- system will be queried for additional error information, and a Haskell --- exception will be thrown. --- --- Consider the `System.Win32.File.createFile` function used to --- open existing files which may or may not actually exist. --- --- > createFile "c:\\nofilehere.txt" gENERIC_READ --- > fILE_SHARE_NONE Nothing oPEN_EXISTING 0 Nothing --- --- If no file by that name exists the underlying `Win32.c_CreateFile` call will --- return `Win32.iNVALID_HANDLE_VALUE`. This will result in an `IOError` exception --- being thrown with a `String` value indicating the function and file name. --- Internally, the `IOError` will also contain the error code, which will be --- converted to a general Haskell value. --- --- The Win32-errors package works similarly. A (simplified) wrapper around --- c_CreateFile could be written as follows. Source code --- from the Win32 package often provides a good starting point: --- --- > createFile name access mode = withTString name $ \ c_name -> --- > E.failIf (== E.toDWORD E.InvalidHandle) "CreateFile" $ --- > c_CreateFile c_name access fILE_SHARE_NONE nullPtr --- > mode 0 nullPtr --- -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" - --- |This function mirrors the Win32 package's 'System.Win32.Types.failIfFalse_' --- function. -failIfFalse_ :: Text -> IO Bool -> IO () -failIfFalse_ wh act = failIf not wh act >> return () - --- |Copied from the Win32 package. Use this to throw a Win32 exception --- when an action returns a value satisfying the given predicate. --- The exception thrown will depend on a thead-local global error condition. --- The supplied `Text` value should be set to the human-friendly name of the --- action that triggered the error. -failIf :: (a -> Bool) -> Text -> IO a -> IO a -failIf p wh act = do - v <- act - if p v then errorWin wh else return v - --- |This function mirrors the Win32 package's 'System.Win32.Types.failIfNull' --- function. -failIfNull :: Text -> IO (Ptr a) -> IO (Ptr a) -failIfNull = failIf (== nullPtr) - --- |Perform the supplied action, and throw a `Win32Exception` exception if the --- return code is anything other than `Success`. The supplied action returns --- a `DWORD` instead of an `ErrCode` so that foreign imports can be used more --- conveniently. -failUnlessSuccess :: Text -> IO DWORD -> IO () -failUnlessSuccess fn_name act = do - r <- act - if r == toDWORD Success then return () else failWith' fn_name r - --- |Windows maintains a thread-local value representing the previously triggered --- error code. Calling `errorWin` will look up the value, and throw a `Win32Exception` --- exception. The supplied `Text` argument should be set to the name of the function --- which triggered the error condition. --- --- Calling this action when no error has occurred (0x00000000 -- ERROR_SUCCESS) will --- result in an exception being thrown for the `Success` error code. -errorWin :: Text -> IO a -errorWin fn_name = Win32.getLastError >>= failWith' fn_name - --- |Like failWith, but avoid multiple conversions to and from 'ErrCode'. -failWith' :: Text -> DWORD -> IO a -failWith' fn_name err_code = do - msg <- formatMessage err_code - -- drop trailing \n - let msg' = T.reverse . T.dropWhile isSpace . T.reverse $ msg - throw $ Win32Exception fn_name (fromDWORD err_code) msg' - --- |Throw a `Win32Exception` exception for the given function name and error code. -failWith :: Text -> ErrCode -> IO a -failWith fn_name err_code = failWith' fn_name $ toDWORD err_code - -#define FORMAT_MESSAGE_FROM_SYSTEM 0x00001000 -#define FORMAT_MESSAGE_ALLOCATE_BUFFER 0x00000100 - --- |This function doesn't belong in Win32-errors, which is why it isn't --- exported. FormatMessage is required to get the standard system message --- associated with an error code. -formatMessage :: DWORD -> IO Text -formatMessage err = - -- Specifying FORMAT_MESSAGE_ALLOCATE_BUFFER changes the lpBuffer argument - -- to a pointer to LPTSTR - alloca $ \ ppBuffer -> do - len <- c_FormatMessage (FORMAT_MESSAGE_FROM_SYSTEM .|. FORMAT_MESSAGE_ALLOCATE_BUFFER) - nullPtr err 0 (castPtr ppBuffer) 0 nullPtr - pBuffer <- peek ppBuffer - if (len == 0 || pBuffer == nullPtr) - then return $ "Error 0x" `T.append` T.pack (Numeric.showHex err "") - else fromPtr pBuffer (fromIntegral len) - --- DWORD WINAPI FormatMessage( --- _In_ DWORD dwFlags, --- _In_opt_ LPCVOID lpSource, --- _In_ DWORD dwMessageId, --- _In_ DWORD dwLanguageId, --- _Out_ LPTSTR lpBuffer, --- _In_ DWORD nSize, --- _In_opt_ va_list *Arguments --- ); -foreign import WINDOWS_CCONV "Windows.h FormatMessageW" - c_FormatMessage :: DWORD -> Ptr () -> DWORD -> DWORD -> LPTSTR -> DWORD - -> Ptr () -> IO DWORD +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- module: System.Win32.Error.Foreign +-- copyright: (c) Michael Steele, 2014 +-- license: BSD3 +-- maintainer: mikesteele81@gmail.com +-- stability: experimental +-- portability: Windows +-- +-- This module provides functions which can be used as drop-in replacements +-- for Win32 when writing wrappers to foreign imports. +-- +-- You will likely need to import modules from Win32 as well. To avoid +-- accidentally calling the standard error handling functions it's a good idea +-- to hide a few names: +-- +-- > import qualified System.Win32.Error.Foreign as E +-- > import System.Win32 hiding (failIfFalse_, failIf, failUnlessSuccess, failWith) +-- +-- Handling error conditions in Windows revolves around a thread-local +-- global variable representing the most recent error condition. Functions +-- indicate that an error occurred in various ways. The C++ programmer will +-- observe that a function failed, and immediately call GetLastError to +-- retrieve details on the possible cause or to get a localized error message +-- which can be relayed to a human in some way. +-- +-- There are some cases where an error code may mean different things +-- depending on varying context, but in general these codes are globally +-- unique. Microsoft documents which error codes may be expected for any +-- given function. +-- +-- When working with functions exported by Win32, error conditions are dealt +-- with using the `IOError` exception type. Most native Win32 functions return +-- an error code which can be used to determine whether something went wrong +-- during its execution. By convention these functions are all named something +-- of the form "c_DoSomething" where "DoSomething" matches the name given by +-- Microsoft. A haskell wrapper function named "doSomething" will typically, +-- among other things, check this error code. Based on its value the operating +-- system will be queried for additional error information, and a Haskell +-- exception will be thrown. +-- +-- Consider the `System.Win32.File.createFile` function used to +-- open existing files which may or may not actually exist. +-- +-- > createFile "c:\\nofilehere.txt" gENERIC_READ +-- > fILE_SHARE_NONE Nothing oPEN_EXISTING 0 Nothing +-- +-- If no file by that name exists the underlying `Win32.c_CreateFile` call will +-- return `Win32.iNVALID_HANDLE_VALUE`. This will result in an `IOError` exception +-- being thrown with a `String` value indicating the function and file name. +-- Internally, the `IOError` will also contain the error code, which will be +-- converted to a general Haskell value. +-- +-- The Win32-errors package works similarly. A (simplified) wrapper around +-- c_CreateFile could be written as follows. Source code +-- from the Win32 package often provides a good starting point: +-- +-- > createFile name access mode = withTString name $ \ c_name -> +-- > E.failIf (== E.toDWORD E.InvalidHandle) "CreateFile" $ +-- > c_CreateFile c_name access fILE_SHARE_NONE nullPtr +-- > mode 0 nullPtr +-- +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" + +-- |This function mirrors the Win32 package's 'System.Win32.Types.failIfFalse_' +-- function. +failIfFalse_ :: Text -> IO Bool -> IO () +failIfFalse_ wh act = failIf not wh act >> return () + +-- |Copied from the Win32 package. Use this to throw a Win32 exception +-- when an action returns a value satisfying the given predicate. +-- The exception thrown will depend on a thead-local global error condition. +-- The supplied `Text` value should be set to the human-friendly name of the +-- action that triggered the error. +failIf :: (a -> Bool) -> Text -> IO a -> IO a +failIf p wh act = do + v <- act + if p v then errorWin wh else return v + +-- |This function mirrors the Win32 package's 'System.Win32.Types.failIfNull' +-- function. +failIfNull :: Text -> IO (Ptr a) -> IO (Ptr a) +failIfNull = failIf (== nullPtr) + +-- |Perform the supplied action, and throw a `Win32Exception` exception if the +-- return code is anything other than `Success`. The supplied action returns +-- a `DWORD` instead of an `ErrCode` so that foreign imports can be used more +-- conveniently. +failUnlessSuccess :: Text -> IO DWORD -> IO () +failUnlessSuccess fn_name act = do + r <- act + if r == toDWORD Success then return () else failWith' fn_name r + +-- |Windows maintains a thread-local value representing the previously triggered +-- error code. Calling `errorWin` will look up the value, and throw a `Win32Exception` +-- exception. The supplied `Text` argument should be set to the name of the function +-- which triggered the error condition. +-- +-- Calling this action when no error has occurred (0x00000000 -- ERROR_SUCCESS) will +-- result in an exception being thrown for the `Success` error code. +errorWin :: Text -> IO a +errorWin fn_name = Win32.getLastError >>= failWith' fn_name + +-- |Like failWith, but avoid multiple conversions to and from 'ErrCode'. +failWith' :: Text -> DWORD -> IO a +failWith' fn_name err_code = do + msg <- formatMessage err_code + -- drop trailing \n + let msg' = T.reverse . T.dropWhile isSpace . T.reverse $ msg + throw $ Win32Exception fn_name (fromDWORD err_code) msg' + +-- |Throw a `Win32Exception` exception for the given function name and error code. +failWith :: Text -> ErrCode -> IO a +failWith fn_name err_code = failWith' fn_name $ toDWORD err_code + +#define FORMAT_MESSAGE_FROM_SYSTEM 0x00001000 +#define FORMAT_MESSAGE_ALLOCATE_BUFFER 0x00000100 + +-- |This function doesn't belong in Win32-errors, which is why it isn't +-- exported. FormatMessage is required to get the standard system message +-- associated with an error code. +formatMessage :: DWORD -> IO Text +formatMessage err = + -- Specifying FORMAT_MESSAGE_ALLOCATE_BUFFER changes the lpBuffer argument + -- to a pointer to LPTSTR + alloca $ \ ppBuffer -> do + len <- c_FormatMessage (FORMAT_MESSAGE_FROM_SYSTEM .|. FORMAT_MESSAGE_ALLOCATE_BUFFER) + nullPtr err 0 (castPtr ppBuffer) 0 nullPtr + pBuffer <- peek ppBuffer + if (len == 0 || pBuffer == nullPtr) + then return $ "Error 0x" `T.append` T.pack (Numeric.showHex err "") + else fromPtr pBuffer (fromIntegral len) + +-- DWORD WINAPI FormatMessage( +-- _In_ DWORD dwFlags, +-- _In_opt_ LPCVOID lpSource, +-- _In_ DWORD dwMessageId, +-- _In_ DWORD dwLanguageId, +-- _Out_ LPTSTR lpBuffer, +-- _In_ DWORD nSize, +-- _In_opt_ va_list *Arguments +-- ); +foreign import WINDOWS_CCONV "Windows.h FormatMessageW" + c_FormatMessage :: DWORD -> Ptr () -> DWORD -> DWORD -> LPTSTR -> DWORD + -> Ptr () -> IO DWORD diff --git a/System/Win32/Error/Mapping.hs b/System/Win32/Error/Mapping.hs --- a/System/Win32/Error/Mapping.hs +++ b/System/Win32/Error/Mapping.hs @@ -1,49 +1,49 @@ -module System.Win32.Error.Mapping - ( mapping - ) where - -import Language.Haskell.TH (mkName, Name) - -import System.Win32.Types (DWORD) - -mapping :: [(DWORD, Name)] -mapping = map (fmap mkName) $ - [ -- INVALID_HANDLE_VALUE is -1 for compatibility with 16-bit windows - (fromIntegral (-1 :: Int), "InvalidHandleValue") - , (0x00000000, "Success") - , (0x00000002, "FileNotFound") - , (0x00000003, "PathNotFound") - , (0x00000005, "AccessDenied") - , (0x00000006, "InvalidHandle") - , (0x0000000d, "InvalidData") - , (0x0000000f, "InvalidDrive") - , (0x00000010, "CurrentDirectory") - , (0x00000012, "NoMoreFiles") - , (0x00000078, "CallNotImplemented") - , (0x000000ea, "MoreData") - , (0x00000103, "NoMoreItems") - , (0x00000420, "ServiceAlreadyRunning") - , (0x00000422, "ServiceDisabled") - , (0x00000424, "ServiceDoesNotExist") - , (0x00000425, "ServiceCannotAcceptCtrl") - , (0x00000426, "ServiceNotActive") - , (0x00000427, "FailedServiceControllerConnect") - , (0x00000428, "ExceptionInService") - , (0x0000042a, "ServiceSpecificError") - , (0x0000043b, "ServiceNotInExe") - , (0x000006ba, "RPCSServerUnavailable") - , (0x000006bb, "RPCSServerTooBusy") - , (0x00001126, "NotAReparsePoint") - , (0x00004e25, "DhcpSubnetNotPresent") - , (0x00004e27, "DhcpElementCantRemove") - , (0x00004e2a, "DhcpOptionNotPresent") - , (0x00004e2d, "DhcpJetError") - , (0x00004e32, "DhcpNotReservedClient") - , (0x00004e33, "DhcpReservedClient") - , (0x00004e35, "DhcpIprangeExists") - , (0x00004e36, "DhcpReservedipExists") - , (0x00004e37, "DhcpInvalidRange") - , (0x00004e51, "DhcpIprangeConvIllegal") - , (0x00004e90, "ScopeRangePolicyRangeConflict") - , (0x00004ea1, "DhcpFoIprangeTypeConvIllegal") - ] +module System.Win32.Error.Mapping + ( mapping + ) where + +import Language.Haskell.TH (mkName, Name) + +import System.Win32.Types (DWORD) + +mapping :: [(DWORD, Name)] +mapping = map (fmap mkName) $ + [ -- INVALID_HANDLE_VALUE is -1 for compatibility with 16-bit windows + (fromIntegral (-1 :: Int), "InvalidHandleValue") + , (0x00000000, "Success") + , (0x00000002, "FileNotFound") + , (0x00000003, "PathNotFound") + , (0x00000005, "AccessDenied") + , (0x00000006, "InvalidHandle") + , (0x0000000d, "InvalidData") + , (0x0000000f, "InvalidDrive") + , (0x00000010, "CurrentDirectory") + , (0x00000012, "NoMoreFiles") + , (0x00000078, "CallNotImplemented") + , (0x000000ea, "MoreData") + , (0x00000103, "NoMoreItems") + , (0x00000420, "ServiceAlreadyRunning") + , (0x00000422, "ServiceDisabled") + , (0x00000424, "ServiceDoesNotExist") + , (0x00000425, "ServiceCannotAcceptCtrl") + , (0x00000426, "ServiceNotActive") + , (0x00000427, "FailedServiceControllerConnect") + , (0x00000428, "ExceptionInService") + , (0x0000042a, "ServiceSpecificError") + , (0x0000043b, "ServiceNotInExe") + , (0x000006ba, "RPCSServerUnavailable") + , (0x000006bb, "RPCSServerTooBusy") + , (0x00001126, "NotAReparsePoint") + , (0x00004e25, "DhcpSubnetNotPresent") + , (0x00004e27, "DhcpElementCantRemove") + , (0x00004e2a, "DhcpOptionNotPresent") + , (0x00004e2d, "DhcpJetError") + , (0x00004e32, "DhcpNotReservedClient") + , (0x00004e33, "DhcpReservedClient") + , (0x00004e35, "DhcpIprangeExists") + , (0x00004e36, "DhcpReservedipExists") + , (0x00004e37, "DhcpInvalidRange") + , (0x00004e51, "DhcpIprangeConvIllegal") + , (0x00004e90, "ScopeRangePolicyRangeConflict") + , (0x00004ea1, "DhcpFoIprangeTypeConvIllegal") + ] diff --git a/System/Win32/Error/TH.hs b/System/Win32/Error/TH.hs --- a/System/Win32/Error/TH.hs +++ b/System/Win32/Error/TH.hs @@ -1,65 +1,77 @@ -{-# LANGUAGE TemplateHaskell #-} - -module System.Win32.Error.TH - ( genErrCode - , gentoDWORD - , genfromDWORD - ) where - -import Language.Haskell.TH -import System.Win32 (DWORD) - -import System.Win32.Error.Mapping - -errCode :: Name -errCode = mkName "ErrCode" - -errOther :: Name -errOther = mkName "Other" - --- |Given something like [(undefined, "Success")], the following will be produced: --- data ErrCode --- = Success --- | Other !DWORD --- deriving (Eq, Show) -genErrCode :: Q [Dec] -genErrCode = return [DataD [] errCode [] cons [''Eq, ''Show]] - where - con name = NormalC name [] - cons = map (con . snd) mapping ++ [NormalC errOther [(IsStrict, ConT ''DWORD)]] - --- toDWORD :: ErrCode -> DWORD --- toDWORD (ErrorOther x) = x --- toDWORD errorSomethingElse = # --- toDWORD errorSomethingElse = # --- toDWORD errorSomethingElse = # -gentoDWORD :: Q [Dec] -gentoDWORD = do - x <- newName "x" - return [ SigD toDWORD (AppT (AppT ArrowT (ConT errCode)) (ConT ''DWORD)) - , FunD toDWORD $ Clause [ConP errOther [VarP x]] (NormalB (VarE x)) [] : map genClause mapping - ] - where - toDWORD = mkName "toDWORD" - genClause :: (DWORD, Name) -> Clause - genClause (dw, err) = Clause [ConP err []] (NormalB (LitE . litDWORD $ dw)) [] - --- fromDWORD :: DWORD -> ErrCode --- fromDWORD 0 = ErrorSuccess --- fromDWORD # = ErrorSomethingElse --- fromDWORD # = ErrorSomethingElse --- fromDWORD # = ErrorSomethingElse --- fromDWORD x = ErrorOther x -genfromDWORD :: Q [Dec] -genfromDWORD = do - x <- newName "x" - return [ SigD fromDWORD (AppT (AppT ArrowT (ConT ''DWORD)) (ConT errCode)) - , FunD fromDWORD $ map genClause mapping ++ [Clause [VarP x] (NormalB (AppE (ConE errOther) (VarE x))) []] - ] - where - fromDWORD = mkName "fromDWORD" - genClause :: (DWORD, Name) -> Clause - genClause (dw, err) = Clause [LitP $ litDWORD dw] (NormalB (ConE err)) [] - -litDWORD :: DWORD -> Lit -litDWORD = IntegerL . toInteger +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} + +module System.Win32.Error.TH + ( genErrCode + , gentoDWORD + , genfromDWORD + ) where + +import Language.Haskell.TH +import System.Win32 (DWORD) + +import System.Win32.Error.Mapping + +errCode :: Name +errCode = mkName "ErrCode" + +errOther :: Name +errOther = mkName "Other" + +-- |Given something like [(undefined, "Success")], the following will be produced: +-- data ErrCode +-- = Success +-- | Other !DWORD +-- deriving (Eq, Show) +genErrCode :: Q [Dec] + +#if MIN_VERSION_template_haskell(2,12,0) +genErrCode = return [DataD [] errCode [] Nothing cons [(DerivClause Nothing $ map ConT [''Eq, ''Show])]] +#elif MIN_VERSION_template_haskell(2,11,0) +genErrCode = return [DataD [] errCode [] Nothing cons (map ConT [''Eq, ''Show])] +#else +genErrCode = return [DataD [] errCode [] cons [''Eq, ''Show]] +#endif + where + con name = NormalC name [] +#if __GLASGOW_HASKELL__ < 800 + cons = map (con . snd) mapping ++ [NormalC errOther [(IsStrict, ConT ''DWORD)]] +#else + cons = map (con . snd) mapping ++ [NormalC errOther [(Bang NoSourceUnpackedness SourceStrict, ConT ''DWORD)]] +#endif + +-- toDWORD :: ErrCode -> DWORD +-- toDWORD (ErrorOther x) = x +-- toDWORD errorSomethingElse = # +-- toDWORD errorSomethingElse = # +-- toDWORD errorSomethingElse = # +gentoDWORD :: Q [Dec] +gentoDWORD = do + x <- newName "x" + return [ SigD toDWORD (AppT (AppT ArrowT (ConT errCode)) (ConT ''DWORD)) + , FunD toDWORD $ Clause [ConP errOther [VarP x]] (NormalB (VarE x)) [] : map genClause mapping + ] + where + toDWORD = mkName "toDWORD" + genClause :: (DWORD, Name) -> Clause + genClause (dw, err) = Clause [ConP err []] (NormalB (LitE . litDWORD $ dw)) [] + +-- fromDWORD :: DWORD -> ErrCode +-- fromDWORD 0 = ErrorSuccess +-- fromDWORD # = ErrorSomethingElse +-- fromDWORD # = ErrorSomethingElse +-- fromDWORD # = ErrorSomethingElse +-- fromDWORD x = ErrorOther x +genfromDWORD :: Q [Dec] +genfromDWORD = do + x <- newName "x" + return [ SigD fromDWORD (AppT (AppT ArrowT (ConT ''DWORD)) (ConT errCode)) + , FunD fromDWORD $ map genClause mapping ++ [Clause [VarP x] (NormalB (AppE (ConE errOther) (VarE x))) []] + ] + where + fromDWORD = mkName "fromDWORD" + genClause :: (DWORD, Name) -> Clause + genClause (dw, err) = Clause [LitP $ litDWORD dw] (NormalB (ConE err)) [] + +litDWORD :: DWORD -> Lit +litDWORD = IntegerL . toInteger diff --git a/System/Win32/Error/Types.hs b/System/Win32/Error/Types.hs --- a/System/Win32/Error/Types.hs +++ b/System/Win32/Error/Types.hs @@ -1,81 +1,81 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} - -module System.Win32.Error.Types where - -import Control.Exception -import Data.Text -import Data.Typeable -import Foreign -import System.Win32.Types (DWORD) - -import System.Win32.Error.TH - --- |Win32 actions typically return an error code to indicate success or failure. --- These codes are intended to be globally unique, though there may be some overlap. --- MSDN documents which errors may be returned by any given action. --- --- The naming of errors follows a convention. An error such as ERROR_SUCCESS --- becomes `Success`, ERROR_FILE_NOT_FOUND becomes `FileNotFound`, and so --- on. There are thousands of errors, so it would be impractical to add them --- all. The `Other` constructor is used to represent error codes which are not --- handled specifically. --- --- User's of this library are encouraged to submit new error codes. Add new entries to --- System.Win32.Errors.Mapping. Send your pull requests along with a link to relevent --- documentation to --- . -genErrCode - --- |Convert an `ErrCode` into a `DWORD`. -gentoDWORD - --- |Convert a `DWORD` into an `ErrCode`. Values which don't have a --- corresponding constructor will end up becoming an `Other`. -genfromDWORD - --- |Performs marshalling by converting to and from `DWORD`. -instance Storable ErrCode where - sizeOf _ = sizeOf (undefined :: DWORD) - alignment _ = alignment (undefined :: DWORD) - peek ptr = (peek . castPtr) ptr >>= return . fromDWORD - poke ptr ec = poke (castPtr ptr) (toDWORD ec) - --- |Exception type for Win32 errors. --- --- This type will be thrown as an extensible exception when a foreign call out --- to part of the Win32 indicates that an error has occurred. In most cases you --- should wrap an IO computation in a call to `tryWin32`. --- --- The following example uses the custom 'createFile' function described in --- "System.Win32.Error.Foreign": --- --- > eHandle <- do --- > h <- E.tryWin32 $ createFile "c:\\missing.txt" gENERIC_READ oPEN_EXISTING --- > -- perform other actions --- > return h --- > case eHandle of --- > Right handle -> do --- > -- do something with the file handle --- > Left w32Err -> do --- > case E.errCode w32Err of --- > E.InvalidHandle -> do --- > -- perform cleanup --- > -- handle other error codes. --- > T.putStrLn $ E.systemMessage w32Err -data Win32Exception = Win32Exception - { function :: Text - -- ^ The foreign action which triggered this exception. - , errCode :: ErrCode - -- ^ The error code - , systemMessage :: Text - -- ^ The standard system message associated with the error code. - } deriving (Typeable, Show) - -instance Exception Win32Exception - --- |Actions calling out to Win32 may throw exceptions. Wrapping the action in --- `tryWin32` will catch `Win32Exception` exceptions, but will allow any other --- exception type to pass through. -tryWin32 :: IO a -> IO (Either Win32Exception a) -tryWin32 = try +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} + +module System.Win32.Error.Types where + +import Control.Exception +import Data.Text +import Data.Typeable +import Foreign +import System.Win32.Types (DWORD) + +import System.Win32.Error.TH + +-- |Win32 actions typically return an error code to indicate success or failure. +-- These codes are intended to be globally unique, though there may be some overlap. +-- MSDN documents which errors may be returned by any given action. +-- +-- The naming of errors follows a convention. An error such as ERROR_SUCCESS +-- becomes `Success`, ERROR_FILE_NOT_FOUND becomes `FileNotFound`, and so +-- on. There are thousands of errors, so it would be impractical to add them +-- all. The `Other` constructor is used to represent error codes which are not +-- handled specifically. +-- +-- User's of this library are encouraged to submit new error codes. Add new entries to +-- System.Win32.Errors.Mapping. Send your pull requests along with a link to relevent +-- documentation to +-- . +genErrCode + +-- |Convert an `ErrCode` into a `DWORD`. +gentoDWORD + +-- |Convert a `DWORD` into an `ErrCode`. Values which don't have a +-- corresponding constructor will end up becoming an `Other`. +genfromDWORD + +-- |Performs marshalling by converting to and from `DWORD`. +instance Storable ErrCode where + sizeOf _ = sizeOf (undefined :: DWORD) + alignment _ = alignment (undefined :: DWORD) + peek ptr = (peek . castPtr) ptr >>= return . fromDWORD + poke ptr ec = poke (castPtr ptr) (toDWORD ec) + +-- |Exception type for Win32 errors. +-- +-- This type will be thrown as an extensible exception when a foreign call out +-- to part of the Win32 indicates that an error has occurred. In most cases you +-- should wrap an IO computation in a call to `tryWin32`. +-- +-- The following example uses the custom 'createFile' function described in +-- "System.Win32.Error.Foreign": +-- +-- > eHandle <- do +-- > h <- E.tryWin32 $ createFile "c:\\missing.txt" gENERIC_READ oPEN_EXISTING +-- > -- perform other actions +-- > return h +-- > case eHandle of +-- > Right handle -> do +-- > -- do something with the file handle +-- > Left w32Err -> do +-- > case E.errCode w32Err of +-- > E.InvalidHandle -> do +-- > -- perform cleanup +-- > -- handle other error codes. +-- > T.putStrLn $ E.systemMessage w32Err +data Win32Exception = Win32Exception + { function :: Text + -- ^ The foreign action which triggered this exception. + , errCode :: ErrCode + -- ^ The error code + , systemMessage :: Text + -- ^ The standard system message associated with the error code. + } deriving (Typeable, Show) + +instance Exception Win32Exception + +-- |Actions calling out to Win32 may throw exceptions. Wrapping the action in +-- `tryWin32` will catch `Win32Exception` exceptions, but will allow any other +-- exception type to pass through. +tryWin32 :: IO a -> IO (Either Win32Exception a) +tryWin32 = try diff --git a/Win32-errors.cabal b/Win32-errors.cabal --- a/Win32-errors.cabal +++ b/Win32-errors.cabal @@ -1,5 +1,5 @@ name: Win32-errors -version: 0.2.2.1 +version: 0.2.2.3 synopsis: Alternative error handling for Win32 foreign calls description: This package provides an alternative to the Win32 library's error handling @@ -18,23 +18,27 @@ copyright: Michael Steele, 2014 - 2015 category: System build-type: Simple -cabal-version: >=1.16 +cabal-version: 1.16 homepage: http://github.com/mikesteele81/win32-errors bug-reports: http://github.com/mikesteele81/win32-errors/issues -tested-with: GHC == 7.8.3, GHC == 7.10.1 +tested-with: GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3 extra-source-files: include/windows_cconv.h ChangeLog +source-repository head + type: git + location: http://github.com/mikesteele81/win32-errors + library default-language: Haskell2010 ghc-options: -Wall cc-options: -fno-strict-aliasing build-depends: - base >= 4.6 && < 4.9 - , template-haskell >= 2.8 && < 2.11 + base >= 4.6 && < 5.0 + , template-haskell >= 2.8 && < 2.14 , text >= 0.11 && < 1.3 - , Win32 >= 2.2 && < 2.4 + , Win32 >= 2.2 && < 2.8 exposed-modules: System.Win32.Error System.Win32.Error.Foreign @@ -43,3 +47,13 @@ System.Win32.Error.TH System.Win32.Error.Types include-dirs: include + +test-suite Win32-errors-test + default-language: Haskell2010 + ghc-options: -Wall + type: exitcode-stdio-1.0 + hs-source-dirs: test + other-modules: ErrorSpec + main-is: Spec.hs + build-depends: + base, hspec, QuickCheck, Win32-errors, Win32 diff --git a/include/windows_cconv.h b/include/windows_cconv.h --- a/include/windows_cconv.h +++ b/include/windows_cconv.h @@ -1,16 +1,16 @@ -/* Taken from Win32. 64-bit Windows uses the 'ccall' calling convention - instead of 'stdcall' -*/ - -#ifndef __WINDOWS_CCONV_H -#define __WINDOWS_CCONV_H - -#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 +/* Taken from Win32. 64-bit Windows uses the 'ccall' calling convention + instead of 'stdcall' +*/ + +#ifndef __WINDOWS_CCONV_H +#define __WINDOWS_CCONV_H + +#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 diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs new file mode 100644 --- /dev/null +++ b/test/ErrorSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ErrorSpec where + +import Test.Hspec +import Test.QuickCheck hiding (Success) -- Success is a constructor for ErrCode +import System.Win32.Error (toDWORD, fromDWORD, ErrCode(..)) + +-- I have made changes to TH.hs so I have made some simple tests for +-- the parts generated by TH.hs: ErrCode, toDWORD and fromDWORD. + +-- errCode :: Win32Exception -> ErrCode +-- toDWORD :: ErrCode -> DWORD +-- fromDWORD :: DWORD -> ErrCode + +spec :: Spec +spec = do + describe "TH.toDWORD" $ do + it "it converts an ErrorCode Success to DWORD 0" $ do + d <- return $ toDWORD Success + d `shouldBe` 0 + describe "TH.toDWORD" $ do + it "it converts an ErrorCode AccessDenied to DWORD 5" $ do + d <- return $ toDWORD AccessDenied + d `shouldBe` 0x00000005 + describe "TH.fromDWORD" $ do + it "it converts a DWORD 0 to a ErrorCode Success" $ do + e <- return $ fromDWORD 0 + e `shouldBe` Success + describe "TH.fromDWORD" $ do + it "it converts a DWORD 99999 to a ErrorCode Other" $ do + e <- return $ fromDWORD 99999 + e `shouldBe` Other 99999 + describe "toDWORD and fromDWORD" $ do + it "are inverses i.e. toDWORD (fromDWORD d) == d" $ do + property $ \d -> toDWORD (fromDWORD d) == d diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,3 @@ + +-- file test/Spec.hs +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}