diff --git a/Graphics/Win32/Dialogue.hsc b/Graphics/Win32/Dialogue.hsc --- a/Graphics/Win32/Dialogue.hsc +++ b/Graphics/Win32/Dialogue.hsc @@ -179,7 +179,7 @@ dia_id) = do prim_text <- marshall_res mb_text prim_class <- marshall_res mb_class - addDiaControl dtemp prim_text dia_id prim_class style + _ <- addDiaControl dtemp prim_text dia_id prim_class style x y cx cy exstyle return () @@ -255,7 +255,7 @@ getDlgItemText :: HWND -> Int -> Int -> IO String getDlgItemText dlg item size = allocaArray size $ \ p_buf -> do - failIfZero "GetDlgItemInt" $ c_GetDlgItemText dlg item p_buf size + _ <- failIfZero "GetDlgItemInt" $ c_GetDlgItemText dlg item p_buf size peekTString p_buf foreign import stdcall "windows.h GetDlgItemTextW" c_GetDlgItemText :: HWND -> Int -> LPTSTR -> Int -> IO Int diff --git a/Graphics/Win32/GDI/Graphics2D.hs b/Graphics/Win32/GDI/Graphics2D.hs --- a/Graphics/Win32/GDI/Graphics2D.hs +++ b/Graphics/Win32/GDI/Graphics2D.hs @@ -17,7 +17,6 @@ import System.Win32.Types import Graphics.Win32.GDI.Types -import Graphics.Win32.GDI.Bitmap import Foreign diff --git a/Graphics/Win32/Window.hsc b/Graphics/Win32/Window.hsc --- a/Graphics/Win32/Window.hsc +++ b/Graphics/Win32/Window.hsc @@ -182,7 +182,7 @@ setWindowClosure :: HWND -> WindowClosure -> IO () setWindowClosure wnd closure = do fp <- mkWindowClosure closure - c_SetWindowLong wnd (#{const GWL_USERDATA}) (castFunPtrToLONG fp) + _ <- c_SetWindowLong wnd (#{const GWL_USERDATA}) (castFunPtrToLONG fp) return () foreign import stdcall unsafe "windows.h SetWindowLongW" c_SetWindowLong :: HWND -> INT -> LONG -> IO LONG @@ -648,9 +648,8 @@ peekMessage :: LPMSG -> Maybe HWND -> UINT -> UINT -> UINT -> IO () peekMessage msg mb_wnd filterMin filterMax remove = do - failIf (== -1) "PeekMessage" $ + failIf_ (== -1) "PeekMessage" $ c_PeekMessage msg (maybePtr mb_wnd) filterMin filterMax remove - return () foreign import stdcall "windows.h PeekMessageW" c_PeekMessage :: LPMSG -> HWND -> UINT -> UINT -> UINT -> IO LONG diff --git a/System/Win32.hs b/System/Win32.hs --- a/System/Win32.hs +++ b/System/Win32.hs @@ -25,6 +25,7 @@ , module System.Win32.Console , module System.Win32.Security , module System.Win32.Types + , module System.Win32.Shell ) where import System.Win32.DLL @@ -42,6 +43,7 @@ import System.Win32.Console import System.Win32.Types import System.Win32.Security +import System.Win32.Shell ---------------------------------------------------------------- -- End diff --git a/System/Win32/File.hsc b/System/Win32/File.hsc --- a/System/Win32/File.hsc +++ b/System/Win32/File.hsc @@ -255,7 +255,8 @@ deleteFile :: String -> IO () deleteFile name = withTString name $ \ c_name -> - failIfFalse_ "DeleteFile" $ c_DeleteFile c_name + failIfFalse_ (unwords ["DeleteFile",show name]) $ + c_DeleteFile c_name foreign import stdcall unsafe "windows.h DeleteFileW" c_DeleteFile :: LPCTSTR -> IO Bool @@ -263,7 +264,8 @@ copyFile src dest over = withTString src $ \ c_src -> withTString dest $ \ c_dest -> - failIfFalse_ "CopyFile" $ c_CopyFile c_src c_dest over + failIfFalse_ (unwords ["CopyFile",show src,show dest]) $ + c_CopyFile c_src c_dest over foreign import stdcall unsafe "windows.h CopyFileW" c_CopyFile :: LPCTSTR -> LPCTSTR -> Bool -> IO Bool @@ -271,7 +273,8 @@ moveFile src dest = withTString src $ \ c_src -> withTString dest $ \ c_dest -> - failIfFalse_ "MoveFile" $ c_MoveFile c_src c_dest + failIfFalse_ (unwords ["MoveFile",show src,show dest]) $ + c_MoveFile c_src c_dest foreign import stdcall unsafe "windows.h MoveFileW" c_MoveFile :: LPCTSTR -> LPCTSTR -> IO Bool @@ -279,21 +282,24 @@ moveFileEx src dest flags = withTString src $ \ c_src -> withTString dest $ \ c_dest -> - failIfFalse_ "MoveFileEx" $ c_MoveFileEx c_src c_dest flags + failIfFalse_ (unwords ["MoveFileEx",show src,show dest]) $ + c_MoveFileEx c_src c_dest flags foreign import stdcall unsafe "windows.h MoveFileExW" c_MoveFileEx :: LPCTSTR -> LPCTSTR -> MoveFileFlag -> IO Bool setCurrentDirectory :: String -> IO () setCurrentDirectory name = withTString name $ \ c_name -> - failIfFalse_ "SetCurrentDirectory" $ c_SetCurrentDirectory c_name + failIfFalse_ (unwords ["SetCurrentDirectory",show name]) $ + c_SetCurrentDirectory c_name foreign import stdcall unsafe "windows.h SetCurrentDirectoryW" c_SetCurrentDirectory :: LPCTSTR -> IO Bool createDirectory :: String -> Maybe LPSECURITY_ATTRIBUTES -> IO () createDirectory name mb_attr = withTString name $ \ c_name -> - failIfFalse_ "CreateDirectory" $ c_CreateDirectory c_name (maybePtr mb_attr) + failIfFalse_ (unwords ["CreateDirectory",show name]) $ + c_CreateDirectory c_name (maybePtr mb_attr) foreign import stdcall unsafe "windows.h CreateDirectoryW" c_CreateDirectory :: LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool @@ -301,7 +307,7 @@ createDirectoryEx template name mb_attr = withTString template $ \ c_template -> withTString name $ \ c_name -> - failIfFalse_ "CreateDirectoryEx" $ + failIfFalse_ (unwords ["CreateDirectoryEx",show template,show name]) $ c_CreateDirectoryEx c_template c_name (maybePtr mb_attr) foreign import stdcall unsafe "windows.h CreateDirectoryExW" c_CreateDirectoryEx :: LPCTSTR -> LPCTSTR -> LPSECURITY_ATTRIBUTES -> IO Bool @@ -309,7 +315,8 @@ removeDirectory :: String -> IO () removeDirectory name = withTString name $ \ c_name -> - failIfFalse_ "RemoveDirectory" $ c_RemoveDirectory c_name + failIfFalse_ (unwords ["RemoveDirectory",show name]) $ + c_RemoveDirectory c_name foreign import stdcall unsafe "windows.h RemoveDirectoryW" c_RemoveDirectory :: LPCTSTR -> IO Bool @@ -317,7 +324,8 @@ getBinaryType name = withTString name $ \ c_name -> alloca $ \ p_btype -> do - failIfFalse_ "GetBinaryType" $ c_GetBinaryType c_name p_btype + failIfFalse_ (unwords ["GetBinaryType",show name]) $ + c_GetBinaryType c_name p_btype peek p_btype foreign import stdcall unsafe "windows.h GetBinaryTypeW" c_GetBinaryType :: LPCTSTR -> Ptr DWORD -> IO Bool @@ -329,7 +337,7 @@ createFile :: String -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE createFile name access share mb_attr mode flag mb_h = withTString name $ \ c_name -> - failIf (==iNVALID_HANDLE_VALUE) "CreateFile" $ + failIf (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile",show name]) $ c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) foreign import stdcall unsafe "windows.h CreateFileW" c_CreateFile :: LPCTSTR -> AccessMode -> ShareMode -> LPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> HANDLE -> IO HANDLE @@ -363,14 +371,16 @@ setFileAttributes :: String -> FileAttributeOrFlag -> IO () setFileAttributes name attr = withTString name $ \ c_name -> - failIfFalse_ "SetFileAttributes" $ c_SetFileAttributes c_name attr + failIfFalse_ (unwords ["SetFileAttributes",show name]) + $ c_SetFileAttributes c_name attr foreign import stdcall unsafe "windows.h SetFileAttributesW" c_SetFileAttributes :: LPCTSTR -> FileAttributeOrFlag -> IO Bool getFileAttributes :: String -> IO FileAttributeOrFlag getFileAttributes name = withTString name $ \ c_name -> - failIf (== 0xFFFFFFFF) "GetFileAttributes" $ c_GetFileAttributes c_name + failIf (== 0xFFFFFFFF) (unwords ["GetFileAttributes",show name]) $ + c_GetFileAttributes c_name foreign import stdcall unsafe "windows.h GetFileAttributesW" c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag @@ -428,7 +438,7 @@ findFirstChangeNotification :: String -> Bool -> FileNotificationFlag -> IO HANDLE findFirstChangeNotification path watch flag = withTString path $ \ c_path -> - failIfNull "FindFirstChangeNotification" $ + failIfNull (unwords ["FindFirstChangeNotification",show path]) $ c_FindFirstChangeNotification c_path watch flag foreign import stdcall unsafe "windows.h FindFirstChangeNotificationW" c_FindFirstChangeNotification :: LPCTSTR -> Bool -> FileNotificationFlag -> IO HANDLE @@ -444,6 +454,49 @@ failIfFalse_ "FindCloseChangeNotification" $ c_FindCloseChangeNotification h foreign import stdcall unsafe "windows.h FindCloseChangeNotification" c_FindCloseChangeNotification :: HANDLE -> IO Bool + +---------------------------------------------------------------- +-- Directories +---------------------------------------------------------------- + +type WIN32_FIND_DATA = () + +newtype FindData = FindData (ForeignPtr WIN32_FIND_DATA) + +getFindDataFileName :: FindData -> IO FilePath +getFindDataFileName (FindData fp) = + withForeignPtr fp $ \p -> + peekTString ((# ptr WIN32_FIND_DATAW, cFileName ) p) + +findFirstFile :: String -> IO (HANDLE, FindData) +findFirstFile str = do + fp_finddata <- mallocForeignPtrBytes (# const sizeof(WIN32_FIND_DATAW) ) + withForeignPtr fp_finddata $ \p_finddata -> do + handle <- withTString str $ \tstr -> do + failIf (== iNVALID_HANDLE_VALUE) "findFirstFile" $ + c_FindFirstFile tstr p_finddata + return (handle, FindData fp_finddata) +foreign import stdcall unsafe "windows.h FindFirstFileW" + c_FindFirstFile :: LPCTSTR -> Ptr WIN32_FIND_DATA -> IO HANDLE + +findNextFile :: HANDLE -> FindData -> IO Bool -- False -> no more files +findNextFile h (FindData finddata) = do + withForeignPtr finddata $ \p_finddata -> do + b <- c_FindNextFile h p_finddata + if b + then return True + else do + err_code <- getLastError + if err_code == (# const ERROR_NO_MORE_FILES ) + then return False + else failWith "findNextFile" err_code +foreign import stdcall unsafe "windows.h FindNextFileW" + c_FindNextFile :: HANDLE -> Ptr WIN32_FIND_DATA -> IO BOOL + +findClose :: HANDLE -> IO () +findClose h = failIfFalse_ "findClose" $ c_FindClose h +foreign import stdcall unsafe "windows.h FindClose" + c_FindClose :: HANDLE -> IO BOOL ---------------------------------------------------------------- -- DOS Device flags diff --git a/System/Win32/Info.hsc b/System/Win32/Info.hsc --- a/System/Win32/Info.hsc +++ b/System/Win32/Info.hsc @@ -16,6 +16,7 @@ import System.Win32.Types +import System.IO.Error hiding (try) import Foreign ( Storable(sizeOf, alignment, peekByteOff, pokeByteOff, peek, poke) , Ptr, alloca, allocaArray ) @@ -93,6 +94,33 @@ getWindowsDirectory :: IO String getWindowsDirectory = try "GetWindowsDirectory" c_getWindowsDirectory 512 +getCurrentDirectory :: IO String +getCurrentDirectory = try "GetCurrentDirectory" (flip c_getCurrentDirectory) 512 +getTemporaryDirectory :: IO String +getTemporaryDirectory = try "GetTempPath" (flip c_getTempPath) 512 + +getFullPathName :: FilePath -> IO FilePath +getFullPathName name = do + withTString name $ \ c_name -> + try "getFullPathName" + (\buf len -> c_GetFullPathName c_name len buf nullPtr) 512 + +searchPath :: Maybe String -> FilePath -> String -> IO (Maybe FilePath) +searchPath path filename ext = + maybe ($ nullPtr) withTString path $ \p_path -> + withTString filename $ \p_filename -> + withTString ext $ \p_ext -> + alloca $ \ppFilePart -> (do + s <- try "searchPath" (\buf len -> c_SearchPath p_path p_filename p_ext + len buf ppFilePart) 512 + return (Just s)) + `catch` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +-- Support for API calls that are passed a fixed-size buffer and tell +-- you via the return value if the buffer was too small. In that +-- case, we double the buffer size and try again. try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO String try loc f n = do e <- allocaArray (fromIntegral n) $ \lptstr -> do @@ -109,6 +137,19 @@ foreign import stdcall unsafe "GetSystemDirectoryW" c_getSystemDirectory :: LPTSTR -> UINT -> IO UINT + +foreign import stdcall unsafe "GetCurrentDirectoryW" + c_getCurrentDirectory :: DWORD -> LPTSTR -> IO UINT + +foreign import stdcall unsafe "GetTempPathW" + c_getTempPath :: DWORD -> LPTSTR -> IO UINT + +foreign import stdcall unsafe "GetFullPathNameW" + c_GetFullPathName :: LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR -> IO DWORD + +foreign import stdcall unsafe "SearchPathW" + c_SearchPath :: LPCTSTR -> LPCTSTR -> LPCTSTR -> DWORD -> LPTSTR -> Ptr LPTSTR + -> IO DWORD ---------------------------------------------------------------- -- System Info (Info about processor and memory subsystem) diff --git a/System/Win32/NLS.hsc b/System/Win32/NLS.hsc --- a/System/Win32/NLS.hsc +++ b/System/Win32/NLS.hsc @@ -121,7 +121,7 @@ lCMapString locale flags src dest_size = withTStringLen src $ \ (c_src, src_len) -> allocaArray dest_size $ \ c_dest -> do - failIfZero "LCMapString" $ + _ <- failIfZero "LCMapString" $ c_LCMapString locale flags c_src src_len c_dest dest_size peekTString c_dest foreign import stdcall unsafe "windows.h LCMapStringW" diff --git a/System/Win32/Registry.hsc b/System/Win32/Registry.hsc --- a/System/Win32/Registry.hsc +++ b/System/Win32/Registry.hsc @@ -491,7 +491,7 @@ regSetStringValue :: HKEY -> String -> String -> IO () regSetStringValue hk key val = withTString val $ \ v -> - regSetValueEx hk key rEG_SZ v (length val) + regSetValueEx hk key rEG_SZ v (length val * sizeOf (undefined::TCHAR)) regSetValueEx :: HKEY -> String -> RegValueType -> LPTSTR -> Int -> IO () regSetValueEx key subkey ty value value_len = diff --git a/System/Win32/Shell.hsc b/System/Win32/Shell.hsc new file mode 100644 --- /dev/null +++ b/System/Win32/Shell.hsc @@ -0,0 +1,78 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Shell +-- Copyright : (c) The University of Glasgow 2009 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : Esa Ilari Vuokko +-- Stability : provisional +-- Portability : portable +-- +-- Win32 stuff from shell32.dll +-- +----------------------------------------------------------------------------- + +module System.Win32.Shell ( + sHGetFolderPath, + CSIDL, + cSIDL_PROFILE, + cSIDL_APPDATA, + cSIDL_WINDOWS, + cSIDL_PERSONAL, + cSIDL_PROGRAM_FILES, + SHGetFolderPathFlags, + sHGFP_TYPE_CURRENT, + sHGFP_TYPE_DEFAULT + ) where + +import System.Win32.Types +import Graphics.Win32.GDI.Types (HWND) + +import Foreign +import Foreign.C +import Control.Monad +import System.IO.Error + +-- for SHGetFolderPath stuff +#define _WIN32_IE 0x500 +#include +#include + +---------------------------------------------------------------- +-- SHGetFolderPath +-- +-- XXX: this is deprecated in Vista and later +---------------------------------------------------------------- + +type CSIDL = CInt + +#{enum CSIDL, + , cSIDL_PROFILE = CSIDL_PROFILE + , cSIDL_APPDATA = CSIDL_APPDATA + , cSIDL_WINDOWS = CSIDL_WINDOWS + , cSIDL_PERSONAL = CSIDL_PERSONAL + , cSIDL_PROGRAM_FILES = CSIDL_PROGRAM_FILES + } +-- XXX there are lots more of these + +type SHGetFolderPathFlags = DWORD + +#{enum SHGetFolderPathFlags, + , sHGFP_TYPE_CURRENT = SHGFP_TYPE_CURRENT + , sHGFP_TYPE_DEFAULT = SHGFP_TYPE_DEFAULT + } + +sHGetFolderPath :: HWND -> CSIDL -> HANDLE -> SHGetFolderPathFlags -> IO String +sHGetFolderPath hwnd csidl hdl flags = + allocaBytes ((#const MAX_PATH) * (#size TCHAR)) $ \pstr -> do + r <- c_SHGetFolderPath hwnd csidl hdl flags pstr + when (r < 0) $ raiseUnsupported "sHGetFolderPath" + peekTString pstr + +raiseUnsupported :: String -> IO () +raiseUnsupported loc = + ioError (ioeSetErrorString (mkIOError illegalOperationErrorType loc Nothing Nothing) "unsupported operation") + +foreign import stdcall unsafe "SHGetFolderPathW" + c_SHGetFolderPath :: HWND -> CInt -> HANDLE -> DWORD -> LPTSTR + -> IO HRESULT diff --git a/System/Win32/SimpleMAPI.hsc b/System/Win32/SimpleMAPI.hsc --- a/System/Win32/SimpleMAPI.hsc +++ b/System/Win32/SimpleMAPI.hsc @@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- module System.Win32.SimpleMAPI where -import Control.Exception ( bracket, handle, throw, finally, onException +import Control.Exception ( bracket, handle, finally, onException , IOException ) import Control.Monad ( liftM5 ) import Foreign ( FunPtr, newForeignPtr, pokeByteOff, maybeWith @@ -192,7 +192,7 @@ maybeWith withCString ses $ \ses -> maybeWith withCString pw $ \pw -> alloca $ \out -> do - mapiFail "MAPILogon: " $ mapifLogon + mapiFail_ "MAPILogon: " $ mapifLogon f (maybeHWND hwnd) ses pw flags 0 out peek out @@ -259,7 +259,7 @@ then do buf <- peek res v <- a buf - mapifFreeBuffer f $ castPtr buf + _ <- mapifFreeBuffer f $ castPtr buf return $ Right v else return $ Left $ err ++ ", " diff --git a/System/Win32/Time.hsc b/System/Win32/Time.hsc --- a/System/Win32/Time.hsc +++ b/System/Win32/Time.hsc @@ -155,7 +155,7 @@ c_GetSystemTimeAdjustment :: Ptr DWORD -> Ptr DWORD -> Ptr BOOL -> IO BOOL getSystemTimeAdjustment :: IO (Maybe (Int, Int)) getSystemTimeAdjustment = alloca $ \ta -> alloca $ \ti -> alloca $ \enabled -> do - failIf not "getSystemTimeAdjustment: GetSystemTimeAdjustment" $ + failIf_ not "getSystemTimeAdjustment: GetSystemTimeAdjustment" $ c_GetSystemTimeAdjustment ta ti enabled enabled <- peek enabled if enabled @@ -195,7 +195,7 @@ c_SystemTimeToFileTime :: Ptr SYSTEMTIME -> Ptr FILETIME -> IO BOOL systemTimeToFileTime :: SYSTEMTIME -> IO FILETIME systemTimeToFileTime s = with s $ \s -> alloca $ \ret -> do - failIf not "systemTimeToFileTime: SystemTimeToFileTime" $ + failIf_ not "systemTimeToFileTime: SystemTimeToFileTime" $ c_SystemTimeToFileTime s ret peek ret @@ -203,7 +203,7 @@ c_FileTimeToSystemTime :: Ptr FILETIME -> Ptr SYSTEMTIME -> IO BOOL fileTimeToSystemTime :: FILETIME -> IO SYSTEMTIME fileTimeToSystemTime s = with s $ \s -> alloca $ \ret -> do - failIf not "fileTimeToSystemTime: FileTimeToSystemTime" $ + failIf_ not "fileTimeToSystemTime: FileTimeToSystemTime" $ c_FileTimeToSystemTime s ret peek ret @@ -211,21 +211,20 @@ c_GetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL getFileTime :: HANDLE -> IO (FILETIME,FILETIME,FILETIME) getFileTime h = alloca $ \crt -> alloca $ \acc -> alloca $ \wrt -> do - failIf not "getFileTime: GetFileTime" $ c_GetFileTime h crt acc wrt + failIf_ not "getFileTime: GetFileTime" $ c_GetFileTime h crt acc wrt liftM3 (,,) (peek crt) (peek acc) (peek wrt) foreign import stdcall "windows.h SetFileTime" c_SetFileTime :: HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO BOOL setFileTime :: HANDLE -> FILETIME -> FILETIME -> FILETIME -> IO () setFileTime h crt acc wrt = with crt $ \crt -> with acc $ \acc -> with wrt $ \wrt -> do - failIf not "setFileTime: SetFileTime" $ c_SetFileTime h crt acc wrt - return () + failIf_ not "setFileTime: SetFileTime" $ c_SetFileTime h crt acc wrt foreign import stdcall "windows.h FileTimeToLocalFileTime" c_FileTimeToLocalFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL fileTimeToLocalFileTime :: FILETIME -> IO FILETIME fileTimeToLocalFileTime ft = with ft $ \ft -> alloca $ \res -> do - failIf not "fileTimeToLocalFileTime: FileTimeToLocalFileTime" + failIf_ not "fileTimeToLocalFileTime: FileTimeToLocalFileTime" $ c_FileTimeToLocalFileTime ft res peek res @@ -233,7 +232,7 @@ c_LocalFileTimeToFileTime :: Ptr FILETIME -> Ptr FILETIME -> IO BOOL localFileTimeToFileTime :: FILETIME -> IO FILETIME localFileTimeToFileTime ft = with ft $ \ft -> alloca $ \res -> do - failIf not "localFileTimeToFileTime: LocalFileTimeToFileTime" + failIf_ not "localFileTimeToFileTime: LocalFileTimeToFileTime" $ c_LocalFileTimeToFileTime ft res peek res @@ -270,7 +269,7 @@ c_QueryPerformanceFrequency :: Ptr LARGE_INTEGER -> IO BOOL queryPerformanceFrequency :: IO Integer queryPerformanceFrequency = alloca $ \res -> do - failIf not "queryPerformanceFrequency: QueryPerformanceFrequency" $ + failIf_ not "queryPerformanceFrequency: QueryPerformanceFrequency" $ c_QueryPerformanceFrequency res liftM fromIntegral $ peek res @@ -278,7 +277,7 @@ c_QueryPerformanceCounter:: Ptr LARGE_INTEGER -> IO BOOL queryPerformanceCounter:: IO Integer queryPerformanceCounter= alloca $ \res -> do - failIf not "queryPerformanceCounter: QueryPerformanceCounter" $ + failIf_ not "queryPerformanceCounter: QueryPerformanceCounter" $ c_QueryPerformanceCounter res liftM fromIntegral $ peek res diff --git a/System/Win32/Types.hs b/System/Win32/Types.hs --- a/System/Win32/Types.hs +++ b/System/Win32/Types.hs @@ -20,7 +20,6 @@ import Data.Maybe import Foreign import Foreign.C -import Numeric (showHex) import Control.Exception import System.IO.Error import Data.Char @@ -61,6 +60,8 @@ type MbATOM = Maybe ATOM +type HRESULT = LONG + ---------------------------------------------------------------- -- Pointers ---------------------------------------------------------------- @@ -204,7 +205,8 @@ failWith fn_name err_code = do c_msg <- getErrorMessage err_code msg <- peekTString c_msg - localFree c_msg + -- We ignore failure of freeing c_msg, given we're already failing + _ <- localFree c_msg c_maperrno -- turn GetLastError() into errno, which errnoToIOError knows -- how to convert to an IOException we can throw. -- XXX we should really do this directly. diff --git a/Win32.cabal b/Win32.cabal --- a/Win32.cabal +++ b/Win32.cabal @@ -1,67 +1,78 @@ name: Win32 -version: 2.2.0.0 +version: 2.2.0.1 license: BSD3 license-file: LICENSE author: Alastair Reid copyright: Alastair Reid, 1999-2003 maintainer: Esa Ilari Vuokko +bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries%20%28other%29 category: System, Graphics synopsis: A binding to part of the Win32 library build-type: Simple +cabal-version: >=1.6 extra-source-files: include/diatemp.h include/dumpBMP.h include/ellipse.h include/errors.h include/gettime.h include/Win32Aux.h include/win32debug.h -build-depends: base, bytestring -ghc-options: -Wall -fno-warn-name-shadowing -exposed-modules: - Graphics.Win32.GDI, - Graphics.Win32.GDI.Bitmap, - Graphics.Win32.GDI.Brush, - Graphics.Win32.GDI.Clip, - Graphics.Win32.GDI.Font, - Graphics.Win32.GDI.Graphics2D, - Graphics.Win32.GDI.HDC, - Graphics.Win32.GDI.Palette, - Graphics.Win32.GDI.Path, - Graphics.Win32.GDI.Pen, - Graphics.Win32.GDI.Region, - Graphics.Win32.GDI.Types, - Graphics.Win32, - Graphics.Win32.Control, - Graphics.Win32.Dialogue, - Graphics.Win32.Icon, - Graphics.Win32.Key, - Graphics.Win32.Menu, - Graphics.Win32.Message, - Graphics.Win32.Misc, - Graphics.Win32.Resource, - Graphics.Win32.Window, - System.Win32, - System.Win32.DebugApi, - System.Win32.DLL, - System.Win32.File, - System.Win32.FileMapping, - System.Win32.Info, - System.Win32.Mem, - System.Win32.NLS, - System.Win32.Process, - System.Win32.Registry, - System.Win32.SimpleMAPI, - System.Win32.Time, - System.Win32.Console, - System.Win32.Security, - System.Win32.Types -extensions: ForeignFunctionInterface -extra-libraries: - "user32", "gdi32", "winmm", "kernel32", "advapi32" -include-dirs: include -includes: "HsWin32.h", "HsGDI.h", "WndProc.h" -install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h" -c-sources: - cbits/HsGDI.c, - cbits/HsWin32.c, - cbits/WndProc.c, - cbits/diatemp.c, - cbits/dumpBMP.c, - cbits/ellipse.c, - cbits/errors.c + +Library + build-depends: base >= 3 && < 5, bytestring + ghc-options: -Wall -fno-warn-name-shadowing + cc-options: -fno-strict-aliasing + exposed-modules: + Graphics.Win32.GDI + Graphics.Win32.GDI.Bitmap + Graphics.Win32.GDI.Brush + Graphics.Win32.GDI.Clip + Graphics.Win32.GDI.Font + Graphics.Win32.GDI.Graphics2D + Graphics.Win32.GDI.HDC + Graphics.Win32.GDI.Palette + Graphics.Win32.GDI.Path + Graphics.Win32.GDI.Pen + Graphics.Win32.GDI.Region + Graphics.Win32.GDI.Types + Graphics.Win32 + Graphics.Win32.Control + Graphics.Win32.Dialogue + Graphics.Win32.Icon + Graphics.Win32.Key + Graphics.Win32.Menu + Graphics.Win32.Message + Graphics.Win32.Misc + Graphics.Win32.Resource + Graphics.Win32.Window + System.Win32 + System.Win32.DebugApi + System.Win32.DLL + System.Win32.File + System.Win32.FileMapping + System.Win32.Info + System.Win32.Mem + System.Win32.NLS + System.Win32.Process + System.Win32.Registry + System.Win32.SimpleMAPI + System.Win32.Time + System.Win32.Console + System.Win32.Security + System.Win32.Types + System.Win32.Shell + extensions: ForeignFunctionInterface + extra-libraries: + "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder" + include-dirs: include + includes: "HsWin32.h", "HsGDI.h", "WndProc.h" + install-includes: "HsWin32.h", "HsGDI.h", "WndProc.h" + c-sources: + cbits/HsGDI.c + cbits/HsWin32.c + cbits/WndProc.c + cbits/diatemp.c + cbits/dumpBMP.c + cbits/ellipse.c + cbits/errors.c + +source-repository head + type: darcs + location: http://darcs.haskell.org/packages/Win32/ + diff --git a/cbits/dumpBMP.c b/cbits/dumpBMP.c --- a/cbits/dumpBMP.c +++ b/cbits/dumpBMP.c @@ -162,7 +162,8 @@ // Assume that the hDC is the DC where the bitmap would have been selected // if indeed it has been selected // - if (hTmpBmp = CreateCompatibleBitmap(hDC, pbmi->bmiHeader.biWidth, pbmi->bmiHeader.biHeight)) { + hTmpBmp = CreateCompatibleBitmap(hDC, pbmi->bmiHeader.biWidth, pbmi->bmiHeader.biHeight); + if (hTmpBmp) { hBmpOld = SelectObject(hDC, hTmpBmp); if ((GetDIBits(hDC, hBmp, 0, pbmi->bmiHeader.biHeight, (LPSTR)pBits, pbmi, DIB_RGB_COLORS))==0){ fprintf(stderr, "Failed in GetDIBits!");