reactivity-0.3.0.0: src/Graphics/Win32Extras.hs
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
module Graphics.Win32Extras where
import Graphics.Win32
import System.Win32.DLL
import Data.Int
import Data.Word
import Data.Bits
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.C.Types
import Data.IORef
import System.IO.Unsafe
import Control.Monad
import Control.Monad.Loops
import Codec.BMP
foreign import stdcall "windows.h GetWindowTextW" c_GetWindowText :: HWND -> LPTSTR -> Int32 -> IO LRESULT
-- | A wrapper for 'c_GetWindowText' which fails if the string is too long.
getWindowText wnd = do
fp <- mallocForeignPtrBytes 1024
withForeignPtr fp $ \p -> do
pokeByteOff p 1021 '\0'
failIfZero "GetWindowText" $ c_GetWindowText wnd p 1024
ch :: Word8 <- peekByteOff p 1021
failIf_ id "GetWindowText" $ return $ ch /= 0 -- Test if string was truncated
peekTString p
foreign import stdcall "windows.h GetClassNameW" c_GetClassName :: HWND -> LPTSTR -> Int32 -> IO LRESULT
getClassName wnd = do
fp <- mallocForeignPtrBytes 1024
withForeignPtr fp $ \p -> do
pokeByteOff p 1021 '\0'
failIfZero "GetClassName" $ c_GetClassName wnd p 1024
ch :: Word8 <- peekByteOff p 1021
failIf_ id "GetClassName" $ return $ ch /= 0 -- Test if string was truncated
peekTString p
foreign import stdcall "windows.h SetFocus" setFocus :: HWND -> IO HWND
------------------------------
-- Drawing
foreign import stdcall unsafe "windows.h SetPixel" set :: HDC -> Int32 -> Int32 -> COLORREF -> IO COLORREF
dT_TOP :: Word32
dT_TOP = 0
dT_LEFT :: Word32
dT_LEFT = 0
dT_CENTER :: Word32
dT_CENTER = 1
dT_RIGHT :: Word32
dT_RIGHT = 2
dT_VCENTER :: Word32
dT_VCENTER = 4
dT_BOTTOM :: Word32
dT_BOTTOM = 8
dT_WORDBREAK :: Word32
dT_WORDBREAK = 16
dT_SINGLELINE :: Word32
dT_SINGLELINE = 32
dT_EXPANDTABS :: Word32
dT_EXPANDTABS = 64
dT_TABSTOP :: Word32
dT_TABSTOP = 128
dT_NOCLIP :: Word32
dT_NOCLIP = 256
dT_EXTERNALLEADING :: Word32
dT_EXTERNALLEADING = 512
dT_CALCRECT :: Word32
dT_CALCRECT = 1024
dT_NOPREFIX :: Word32
dT_NOPREFIX = 2048
dT_INTERNAL :: Word32
dT_INTERNAL = 4096
dT_EDITCONTROL :: Word32
dT_EDITCONTROL = 8192
dT_PATH_ELLIPSIS :: Word32
dT_PATH_ELLIPSIS = 16384
dT_END_ELLIPSIS :: Word32
dT_END_ELLIPSIS = 32768
dT_MODIFYSTRING :: Word32
dT_MODIFYSTRING = 65536
dT_RTLREADING :: Word32
dT_RTLREADING = 131072
dT_WORD_ELLIPSIS :: Word32
dT_WORD_ELLIPSIS = 262144
dT_NOFULLWIDTHCHARBREAK :: Word32
dT_NOFULLWIDTHCHARBREAK = 524288
dT_HIDEPREFIX :: Word32
dT_HIDEPREFIX = 1048576
dT_PREFIXONLY :: Word32
dT_PREFIXONLY = 2097152
foreign import stdcall "windows.h DrawTextW" c_DrawText :: HDC -> LPTSTR -> Int32 -> LPRECT -> UINT -> IO Int32
drawText dc s rt format = withTString s $ \ps ->
withRECT rt $ \pr ->
failIfZero "DrawText" $ c_DrawText dc ps (-1) pr format
foreign import stdcall "windows.h SetDIBitsToDevice"
c_SetDIBitsToDevice :: HDC -> Int32 -> Int32 -> Word32 -> Word32 -> Int32 -> Int32 -> Word32 -> Word32 -> Ptr CChar -> LPBITMAPINFO -> Word32 -> IO Int32
withBITMAP :: BitmapInfo -> (Ptr () -> IO a) -> IO a
withBITMAP (InfoV3 bi) f = do
fp <- mallocForeignPtrBytes 40
withForeignPtr fp $ \p -> do
pokeByteOff p 0 (dib3Size bi)
pokeByteOff p 4 (dib3Width bi)
pokeByteOff p 8 (dib3Height bi)
pokeByteOff p 12 (dib3Planes bi)
pokeByteOff p 14 (dib3BitCount bi)
pokeByteOff p 16 bI_RGB
pokeByteOff p 20 (dib3ImageSize bi)
pokeByteOff p 24 (dib3PelsPerMeterX bi)
pokeByteOff p 28 (dib3PelsPerMeterY bi)
pokeByteOff p 32 (dib3ColorsUsed bi)
pokeByteOff p 36 (dib3ColorsImportant bi)
f p
type XFORM = Ptr ()
foreign import stdcall "windows.h SetWorldTransform" setWorldTransform :: HDC -> XFORM -> IO Bool
withXFORM :: (Float, Float, Float, Float, Float, Float) -> (XFORM -> IO t) -> IO t
withXFORM (eM11, eM12, eM21, eM22, eDx, eDy) f = do
fp <- mallocForeignPtrBytes 24
withForeignPtr fp $ \p -> do
pokeByteOff p 0 eM11
pokeByteOff p 4 eM12
pokeByteOff p 8 eM21
pokeByteOff p 12 eM22
pokeByteOff p 16 eDx
pokeByteOff p 20 eDy
f p
oDT_BUTTON :: Word32
oDT_BUTTON = 4
oDA_DRAWENTIRE :: Word32
oDA_DRAWENTIRE = 1
oDA_SELECT :: Word32
oDA_SELECT = 2
oDA_FOCUS :: Word32
oDA_FOCUS = 4
oDS_SELECTED :: Word32
oDS_SELECTED = 1
oDS_DISABLED :: Word32
oDS_DISABLED = 4
oDS_FOCUS :: Word32
oDS_FOCUS = 16
foreign import stdcall "windows.h DrawFocusRect" c_DrawFocusRect :: HDC -> LPRECT -> IO Bool
drawFocusRect dc rt = withRECT rt $ c_DrawFocusRect dc
foreign import stdcall "windows.h SetWindowPos" c_SetWindowPos :: HWND -> HWND -> LONG -> LONG -> LONG -> LONG -> Word32 -> IO Bool
setWindowPos hwnd hwndAfter x y wd ht flags = failIfFalse_ "SetWindowPos" $ c_SetWindowPos hwnd hwndAfter x y wd ht flags
foreign import stdcall "windows.h SetWindowLongW" setWindowLong :: HWND -> LONG -> LONG -> IO LONG
------------------------------
-- Scroll bars
foreign import stdcall "windows.h SetScrollInfo" c_SetScrollInfo :: HWND -> Int32 -> Ptr SCROLLINFO -> BOOL -> IO BOOL
foreign import stdcall "windows.h GetScrollInfo" c_GetScrollInfo :: HWND -> Int32 -> Ptr SCROLLINFO -> IO Int32
setScrollInfo wnd bar si = withSCROLLINFO si $ \p -> c_SetScrollInfo wnd bar p True
getScrollInfo wnd bar = withSCROLLINFO (SCROLLINFO sIF_ALL 0 0 0 0 0) $ \p -> do
c_GetScrollInfo wnd bar p
readSCROLLINFO p
data SCROLLINFO = SCROLLINFO { fMask :: Word32, nMin :: Int32, nMax :: Int32, nPage :: Word32, nPos :: Int32, nTrackPos :: Int32 } deriving (Eq, Show)
withSCROLLINFO :: SCROLLINFO -> (Ptr SCROLLINFO -> IO t) -> IO t
withSCROLLINFO si f = do
fp <- mallocForeignPtrBytes 28
withForeignPtr fp $ \p -> do
pokeByteOff p 0 (28 :: Word32)
pokeByteOff p 4 (fMask si)
pokeByteOff p 8 (nMin si)
pokeByteOff p 12 (nMax si)
pokeByteOff p 16 (nPage si)
pokeByteOff p 20 (nPos si)
pokeByteOff p 24 (nTrackPos si)
f p
readSCROLLINFO :: Ptr SCROLLINFO -> IO SCROLLINFO
readSCROLLINFO p = do
fMask <- peekByteOff p 4
nMin <- peekByteOff p 8
nMax <- peekByteOff p 12
nPage <- peekByteOff p 16
nPos <- peekByteOff p 20
nTrackPos <- peekByteOff p 24
return (SCROLLINFO fMask nMin nMax nPage nPos nTrackPos)
sB_HORZ :: Int32
sB_HORZ = 0
sB_VERT :: Int32
sB_VERT = 1
sB_CTL :: Word32
sB_CTL = 2
sIF_ALL :: Word32
sIF_ALL = 31
sB_PAGEDOWN :: Word32
sB_PAGEDOWN = 3
sB_PAGEUP :: Word32
sB_PAGEUP = 2
sB_LINEUP :: Word32
sB_LINEUP = 0
sB_LINEDOWN :: Word32
sB_LINEDOWN = 1
sB_BOTTOM :: Word32
sB_BOTTOM = 7
sB_TOP :: Word32
sB_TOP = 6
sB_THUMBPOSITION :: Word32
sB_THUMBPOSITION = 4
sB_THUMBTRACK :: Word32
sB_THUMBTRACK = 5
loWord x = x .&. 65535
hiWord x = shiftR x 16
foreign import stdcall "windows.h CallWindowProcW" callWindowProc :: FunPtr WindowClosure -> HWND -> UINT -> WPARAM -> LPARAM -> IO LRESULT
gWLP_WNDPROC :: Int32
gWLP_WNDPROC = -4
gWLP_WNDPARENT :: Int32
gWLP_WNDPARENT = -8
gWLP_ID :: Int32
gWLP_ID = -12
gWLP_USERDATA :: Int32
gWLP_USERDATA = -21
gWLP_STYLE :: Int32
gWLP_STYLE = -16
cB_ADDSTRING :: Word32
cB_ADDSTRING = 323
cB_GETCURSEL :: Word32
cB_GETCURSEL = 327
cB_SETCURSEL :: Word32
cB_SETCURSEL = 334
-- ...
sIF_RANGE :: Word32
sIF_RANGE = 1
sIF_POS :: Word32
sIF_POS = 2
sIF_PAGE :: Word32
sIF_PAGE = 4
--------------------------------
-- System colors
foreign import stdcall "windows.h GetSysColorBrush" getSysColorBrush :: Word32 -> IO HBRUSH
foreign import stdcall "windows.h GetSysColor" getSysColor :: Word32 -> IO Word32
foreign import stdcall "windows.h GetDeviceCaps" getDeviceCaps :: HDC -> Int32 -> IO Int32
lOGPIXELSX :: Int32
lOGPIXELSX = 88
lOGPIXELSY :: Int32
lOGPIXELSY = 90
dLGC_WANTCHARS :: Int32
dLGC_WANTCHARS = 128
dLGC_WANTARROWS :: Int32
dLGC_WANTARROWS = 1
dLGC_DEFPUSHBUTTON :: Int32
dLGC_DEFPUSHBUTTON = 16
wM_CTLCOLORSTATIC :: Word32
wM_CTLCOLORSTATIC = 312
------------------------------
-- Threads
foreign import stdcall "windows.h GetCurrentThreadId" getCurrentThreadId :: IO DWORD
foreign import stdcall "windows.h PostThreadMessageW" postThreadMessage :: DWORD -> UINT -> WPARAM -> LPARAM -> IO Bool
foreign import stdcall "windows.h MsgWaitForMultipleObjects" c_MsgWaitForMultipleObjects :: DWORD -> Ptr HANDLE -> Bool -> DWORD -> DWORD -> IO DWORD
msgWaitForMultipleObjects :: [HANDLE] -> Bool -> DWORD -> DWORD -> IO DWORD
msgWaitForMultipleObjects handles b n1 n2 = do
fp <- mallocForeignPtrBytes (4 * length handles)
withForeignPtr fp $ \p -> do
mapM_ (\(n, hdl) -> pokeByteOff p n hdl) (zip [0,4..] handles)
c_MsgWaitForMultipleObjects (fromIntegral $ length handles) p b n1 n2
wAIT_TIMEOUT :: DWORD
wAIT_TIMEOUT = 258
pM_NOREMOVE :: DWORD
pM_NOREMOVE = 0
pM_REMOVE :: DWORD
pM_REMOVE = 1
pM_NOYIELD :: DWORD
pM_NOYIELD = 2
qS_ALLEVENTS :: DWORD
qS_ALLEVENTS = 1215
------------------------------
-- Common dialog boxes
foreign import stdcall "windows.h ChooseColorW" c_ChooseColor :: Ptr () -> IO Bool
cC_ANYCOLOR :: Word32
cC_ANYCOLOR = 256
cC_FULLOPEN :: Word32
cC_FULLOPEN = 2
cC_PREVENTFULLOPEN :: Word32
cC_PREVENTFULLOPEN = 4
cC_RGBINIT :: Word32
cC_RGBINIT = 1
cC_SHOWHELP :: Word32
cC_SHOWHELP = 8
cC_SOLIDCOLOR :: Word32
cC_SOLIDCOLOR = 128
type CHOOSECOLOR = ()
foreign import ccall "wrapper" mkFinalizer :: (Ptr a -> IO ()) -> IO (FinalizerPtr a)
allocaChooseColor :: Word32 -> Word32 -> IO (ForeignPtr CHOOSECOLOR)
allocaChooseColor clr flags = do
hdl <- getModuleHandle Nothing
cc <- mallocForeignPtrBytes 36
p2 <- mallocBytes 64
withForeignPtr cc $ \p -> do
pokeByteOff p 0 (36 :: Word32)
pokeByteOff p 4 (0 :: Word32)
pokeByteOff p 8 hdl
pokeByteOff p 12 clr
pokeByteOff p 16 p2
pokeByteOff p 20 flags
pokeByteOff p 24 (0 :: Word32)
pokeByteOff p 28 (0 :: Word32)
pokeByteOff p 32 (0 :: Word32)
fin <- mkFinalizer (\_ -> free p2)
addForeignPtrFinalizer fin cc
return cc
-- | Open a choose colour dialog. Use 'allocaChooseColor' to create the parameter structure.
chooseColor :: HWND -> ForeignPtr CHOOSECOLOR -> IO (Maybe COLORREF)
chooseColor wnd fp = do
withForeignPtr fp $ \p -> do
b <- c_ChooseColor p
if b then do
clr <- peekByteOff p 12
return (Just clr)
else
return Nothing
type OPENFILENAME = ()
foreign import stdcall "windows.h GetOpenFileNameW" getOpenFileName :: Ptr OPENFILENAME -> IO Bool
foreign import stdcall "windows.h GetSaveFileNameW" getSaveFileName :: Ptr OPENFILENAME -> IO Bool
oFN_ALLOWMULTISELECT :: Word32
oFN_ALLOWMULTISELECT = 512
oFN_CREATEPROMPT :: Word32
oFN_CREATEPROMPT = 8192
oFN_DONTADDTORECENT :: Word32
oFN_DONTADDTORECENT = 33554432
oFN_EXPLORER :: Word32
oFN_EXPLORER = 524288
oFN_FILEMUSTEXIST :: Word32
oFN_FILEMUSTEXIST = 4096
oFN_HIDEREADONLY :: Word32
oFN_HIDEREADONLY = 4
oFN_OVERWRITEPROMPT :: Word32
oFN_OVERWRITEPROMPT = 2
--etc..
data Action = Open | Save deriving Eq
-- | Open or save a file.
fileOpenOrSave :: Action -> HWND -> String -> String -> IO (Maybe String)
fileOpenOrSave action wnd filter extension = do
hdl <- getModuleHandle Nothing
fp <- mallocForeignPtrBytes 76
fp2 <- mallocForeignPtrBytes 1000
withForeignPtr fp $ \p ->
withForeignPtr fp2 $ \p2 ->
withTString filter $ \flt ->
withTString extension $ \ext -> do
pokeByteOff p2 0 (0 :: Word16)
pokeByteOff p 0 (76 :: Word32)
pokeByteOff p 4 wnd
pokeByteOff p 8 hdl
pokeByteOff p 12 flt
pokeByteOff p 16 nullPtr
pokeByteOff p 24 (1 :: Word32)
pokeByteOff p 28 p2
pokeByteOff p 32 (1000 :: Word32)
pokeByteOff p 36 nullPtr
pokeByteOff p 44 nullPtr
pokeByteOff p 48 nullPtr
pokeByteOff p 52 (oFN_EXPLORER .|. if action == Open then oFN_FILEMUSTEXIST else oFN_OVERWRITEPROMPT)
pokeByteOff p 60 ext
b <- (if action == Open then getOpenFileName else getSaveFileName) p
if b then do
liftM Just (peekTString p2)
else
return Nothing
fileOpen = fileOpenOrSave Open
fileSave = fileOpenOrSave Save
-- | Display a message box. This fixes the Win32 package MessageBox.
messageBox' :: HWND -> String -> String -> MBStyle -> IO MBStatus
messageBox' wnd text caption style =
withTString text $ \ c_text ->
withTString caption $ \ c_caption ->
failIfZero "MessageBox" $ c_MessageBox' wnd c_text c_caption style
foreign import stdcall safe "windows.h MessageBoxW"
c_MessageBox' :: HWND -> LPCTSTR -> LPCTSTR -> MBStyle -> IO MBStatus
------------------------------
-- Printing
foreign import stdcall "windows.h GlobalUnlock" globalUnlock' :: HANDLE -> IO Bool
foreign import stdcall "windows.h OpenPrinterW" openPrinter :: LPTSTR -> Ptr HANDLE -> Ptr () -> IO Bool
foreign import stdcall "windows.h DocumentPropertiesW" documentProperties :: HWND -> HANDLE -> LPTSTR -> Ptr () -> Ptr () -> Word32 -> IO LONG
foreign import stdcall "windows.h CreateDCW" createDC :: LPCTSTR -> LPCTSTR -> LPCSTR -> Ptr () -> IO HDC
foreign import stdcall "windows.h StartDocW" startDoc :: HDC -> Ptr () -> IO Int32
foreign import stdcall "windows.h EndDoc" endDoc :: HDC -> IO Int32
foreign import stdcall "windows.h StartPage" startPage :: HDC -> IO Int32
foreign import stdcall "windows.h EndPage" endPage :: HDC -> IO Int32
foreign import stdcall "windows.h ClosePrinter" closePrinter :: HANDLE -> IO Bool
foreign import stdcall "windows.h GetDefaultPrinterW" getDefaultPrinter :: LPTSTR -> Ptr DWORD -> IO Bool
dM_OUT_BUFFER :: Word32
dM_OUT_BUFFER = 2
dM_IN_PROMPT :: Word32
dM_IN_PROMPT = 4
-- etc..
foreign import stdcall "windows.h PostMessageW" postMessage :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO Bool
eN_GETSEL :: Word32
eN_GETSEL = 176
eN_SETSEL :: Word32
eN_SETSEL = 177
eN_UPDATE :: Word32
eN_UPDATE = 1024
cBN_EDITUPDATE :: Word32
cBN_EDITUPDATE = 6
cBN_SELENDOK :: Word32
cBN_SELENDOK = 9
lBN_SELCHANGE :: Word32
lBN_SELCHANGE = 1
bN_PUSHED :: Word32
bN_PUSHED = 2
bN_CLICKED :: Word32
bN_CLICKED = 0
hTBOTTOM :: Word32
hTBOTTOM = 15
hTBOTTOMLEFT :: Word32
hTBOTTOMLEFT = 16
hTBOTTOMRIGHT :: Word32
hTBOTTOMRIGHT = 17
hTCAPTION :: Word32
hTCAPTION = 2
hTLEFT :: Word32
hTLEFT = 10
hTRIGHT :: Word32
hTRIGHT = 11
hTTOP :: Word32
hTTOP = 12
hTTOPLEFT :: Word32
hTTOPLEFT = 13
hTTOPRIGHT :: Word32
hTTOPRIGHT = 14
hTCLOSE :: Word32
hTCLOSE = 20
hTMAXBUTTON :: Word32
hTMAXBUTTON = 9
hTMINBUTTON :: Word32
hTMINBUTTON = 8
foreign import stdcall "windows.h SetCapture" setCapture :: HWND -> IO HWND
foreign import stdcall "windows.h ReleaseCapture" releaseCapture :: IO Bool
sS_OWNERDRAW :: Word32
sS_OWNERDRAW = 13
foreign import stdcall "windows.h EnableWindow"
enableWindow' :: HWND -> Bool -> IO Bool
------------------------------
-- Menus
-- | Fixes TrackPopupMenu to supply the selection as a return value.
foreign import stdcall "windows.h TrackPopupMenu" trackPopupMenu' :: HMENU -> UINT -> LONG -> LONG -> LONG -> HWND -> Ptr RECT -> IO LONG
------------------------------
-- Common controls
wC_LISTVIEW = "SysListView32"
lVS_REPORT :: Word32
lVS_REPORT = 1
lVS_SINGLESEL :: Word32
lVS_SINGLESEL = 4
wC_TREEVIEW = "SysTreeView32"
lVM_FIRST :: Word32
lVM_FIRST = 4096
lVM_GETITEMCOUNT = lVM_FIRST + 4
lVM_DELETEITEM = lVM_FIRST + 8
lVM_INSERTITEM = lVM_FIRST + 77
lVM_GETITEMSTATE = lVM_FIRST + 44
lVM_GETITEMTEXT = lVM_FIRST + 45
lVM_SETITEMTEXT = lVM_FIRST + 116
lVM_GETCOLUMN = lVM_FIRST + 95
lVM_DELETECOLUMN = lVM_FIRST + 28
lVM_INSERTCOLUMN = lVM_FIRST + 97
lVM_SETCOLUMN = lVM_FIRST + 26
lVIF_STATE :: Word32
lVIF_STATE = 8
lVIF_TEXT :: Word32
lVIF_TEXT = 1
lVCF_TEXT :: Word32
lVCF_TEXT = 4
lVCF_WIDTH :: Word32
lVCF_WIDTH = 2
lVIS_SELECTED :: Word32
lVIS_SELECTED = 2
tVM_FIRST :: Word32
tVM_FIRST = 4352
tVM_INSERTITEM = tVM_FIRST + 50
tVM_DELETEITEM = tVM_FIRST + 1
tVM_GETNEXTITEM = tVM_FIRST + 10
tVM_GETITEM = tVM_FIRST + 62
tVM_SETITEM = tVM_FIRST + 63
tVGN_NEXT :: Word32
tVGN_NEXT = 1
tVGN_CHILD :: Word32
tVGN_CHILD = 4
tVIF_TEXT :: Word32
tVIF_TEXT = 1
tVIF_HANDLE :: Word32
tVIF_HANDLE = 16
tVS_HASLINES :: Word32
tVS_HASLINES = 2
foreign import stdcall "windows.h InitCommonControls" initCommonControls :: IO ()
foreign import stdcall "windows.h TranslateAccelerator" translateAccelerator :: HGLOBAL -> HWND -> LPMSG -> IO Bool
foreign import stdcall "windows.h GetWindowLongW" c_GetWindowLong :: HWND -> LONG -> IO LONG
type LPCTBBUTTON = Ptr ()
tb_addbuttons_size :: UINT
tb_addbuttons_size = 20
tB_ADDBITMAP :: UINT
tB_ADDBITMAP = wM_USER + 19
tB_ADDBUTTONSA :: UINT
tB_ADDBUTTONSA = wM_USER + 20
tB_INSERTBUTTONA :: UINT
tB_INSERTBUTTONA = wM_USER + 21
tB_DELETEBUTTON :: UINT
tB_DELETEBUTTON = wM_USER + 22
tB_REPLACEBITMAP :: UINT
tB_REPLACEBITMAP = wM_USER + 46
tB_BUTTONSTRUCTSIZE :: UINT
tB_BUTTONSTRUCTSIZE = wM_USER + 30
tB_SETBUTTONSIZE :: UINT
tB_SETBUTTONSIZE = wM_USER + 31
tB_SETBITMAPSIZE :: UINT
tB_SETBITMAPSIZE = wM_USER + 32
tB_AUTOSIZE :: UINT
tB_AUTOSIZE = wM_USER + 33
tB_BUTTONCOUNT :: UINT
tB_BUTTONCOUNT = wM_USER + 24
tB_SETIMAGELIST :: UINT
tB_SETIMAGELIST = wM_USER + 48
tB_GETTOOLTIPS :: UINT
tB_GETTOOLTIPS = wM_USER + 35
tB_SETTOOLTIPS :: UINT
tB_SETTOOLTIPS = wM_USER + 36
foreign import stdcall "mmsystem.h timeBeginPeriod" timeBeginPeriod :: UINT -> IO UINT
foreign import stdcall "mmsystem.h timeEndPeriod" timeEndPeriod :: UINT -> IO UINT
foreign import stdcall "mmsystem.h timeSetEvent" timeSetEvent :: UINT -> UINT -> LPVOID -> UINT -> UINT -> IO UINT
foreign import stdcall "windows.h CreateEventW" createEvent :: LPVOID -> BOOL -> BOOL -> LPTSTR -> IO HANDLE
tIMER_ONESHOT :: UINT
tIMER_ONESHOT = 1
tIMER_PERIODIC :: UINT
tIMER_PERIODIC = 64
tIME_CALLBACK_FUNCTION :: UINT
tIME_CALLBACK_FUNCTION = 0
tIME_CALLBACK_EVENT_SET :: UINT
tIME_CALLBACK_EVENT_SET = 16
tIME_CALLBACK_EVENT_PULSE :: UINT
tIME_CALLBACK_EVENT_PULSE = 32
--- The following functions are utilities, not part of the Win32 API.
-- | Helper to add buttons from a bitmap already present.
{-
addExistingBitmaps :: HWND -> [(LONG, UINT, BYTE)] -> IO ()
addExistingBitmaps toolbar whichbuttons = do
let nButtons = length whichbuttons
fp <- mallocForeignPtrBytes (8 `max` (nButtons * tb_addbuttons_size))
withForeignPtr fp $ \p -> do
mapM_ (\(i, (n, id, state)) -> do
pokeByteOff p i n
pokeByteOff p (i + 4) id
pokeByteOff p (i + 8) 0
pokeByteOff (castPtr p) (i + 8) state
pokeByteOff p (i + 16) 0)
whichbuttons
sendMessage toolbar tB_ADDBUTTONSA nButtons (toLPARAM p)
sendMessage toolbar tB_AUTOSIZE 0 0
addButtonsFromModule :: HINSTANCE -> HWND -> HRESOURCE -> [(LONG, UINT, BYTE)] -> IO ()
addButtonsFromModule mod toolbar bitmap whichbuttons = do
sendMessage toolbar tB_BUTTONSTRUCTSIZE tb_addbuttons_size 0
fp <- mallocForeignPtrBytes 8
withForeignPtr fp $ \p => do
pokeByteOff p 0 mod
pokeByteoff p 4 bitmap
sendMessage toolbar tB_ADDBITMAP (maximum whichbuttons + 1) (toLPARAM p)
addExistingButtons toolbar whichbuttons clearToolbar
-- | Add buttons to a toolbar directly out of a resource. The elements of the third
-- parameter indicate for each button, its position in the bitmap, its control ID,
-- and its button state respectively.
addButtons :: HWND -> HRESOURCE -> [(LONG, UINT, BYTE)] -> IO ()
addButtons toolbar bitmap whichbuttons = do
mod <- getModuleHandle nullPtr
addButtonsFromModule mod toolbar bitmap whichbuttons
-- | Remove all buttons from a toolbar.
clearToolbar toolbar = whileM_ (return ()) (liftM (/=0) $ sendMessage toolbar tB_DELETEBUTTON 0 0)
-- | Add toolbar buttons from an imagelist. Returns the former imagelist.
setImageList :: HWND -> HIMAGELIST -> [(LONG, UINT, BYTE)] -> IO HIMAGELIST
setImageList toolbar imagelist whichbuttons = do
sendMessage toolbar tB_BUTTONSTRUCTSIZE tb_addbuttons_size 0
clearToolbar toolbar
oldlist <- sendMessage toolbar tS_SETIMAGELIST 0 imagelist
addExistingButtons toolbar whichbuttons
return oldlist-}
-- | Create a frame window with reasonable defaults. A null background brush is used to prevent flicker.
frameWindow icon menu parent title closure = do
hdl <- getModuleHandle Nothing
cursor <- loadCursor Nothing iDC_ARROW
null <- getStockBrush nULL_BRUSH
let name = mkClassName "Frame"
registerClass (0, hdl, icon, Just cursor, Just null, Nothing, name)
createWindowEx 0 name title (wS_OVERLAPPEDWINDOW .|. wS_VISIBLE .|. wS_CLIPCHILDREN) Nothing Nothing Nothing Nothing Nothing menu parent closure