1#if __GLASGOW_HASKELL__ >= 709 2{-# LANGUAGE Safe #-} 3#elif __GLASGOW_HASKELL__ >= 701 4{-# LANGUAGE Trustworthy #-} 5#endif 6----------------------------------------------------------------------------- 7-- | 8-- Module : Graphics.Win32.Dialogue 9-- Copyright : (c) Alastair Reid, 1997-2003 10-- License : BSD-style (see the file libraries/base/LICENSE) 11-- 12-- Maintainer : Esa Ilari Vuokko <ei@vuokko.info> 13-- Stability : provisional 14-- Portability : portable 15-- 16-- A collection of FFI declarations for interfacing with Win32. 17-- 18----------------------------------------------------------------------------- 19 20module Graphics.Win32.Dialogue where 21 22import Graphics.Win32.GDI.Types 23import Graphics.Win32.Control 24import Graphics.Win32.Message 25import Graphics.Win32.Window 26import System.Win32.Types 27 28import Foreign 29import Foreign.C 30 31##include "windows_cconv.h" 32 33#include <windows.h> 34 35type DTemplate = LPCTSTR 36 37type DTemplateMem = Ptr Stub_DTM 38newtype Stub_DTM = Stub_DTM DTemplateMem 39 40newtype DIA_TEMPLATE = DIA_TEMPLATE (Ptr DIA_TEMPLATE) 41 42type DialogStyle = WindowStyle 43 44mkDialogTemplate :: String -> IO DTemplate 45mkDialogTemplate = newTString 46 47type ResourceID = Int 48 49mkResource :: ResourceID -> IO (Ptr a) 50mkResource res = return (castUINTPtrToPtr (fromIntegral res)) 51 52mkDialogTemplateFromResource :: Int -> IO DTemplate 53mkDialogTemplateFromResource = mkResource 54 55type DialogProc = HWND -> WindowMessage -> WPARAM -> LPARAM -> IO Int 56 57marshall_dialogProc_ :: DialogProc -> IO (FunPtr DialogProc) 58marshall_dialogProc_ cl = mkDialogClosure cl 59 60-- ToDo: this was declared as a stdcall not a ccall - let's 61-- hope and pray that it makes no difference - ADR 62foreign import ccall "wrapper" 63 mkDialogClosure :: DialogProc -> IO (FunPtr DialogProc) 64 65dialogBox :: HINSTANCE -> DTemplate -> Maybe HWND -> DialogProc -> IO Int 66dialogBox inst template mb_parent dia_fn = 67 dialogBoxParam inst template mb_parent dia_fn 0 68 69dialogBoxParam :: HINSTANCE -> DTemplate -> Maybe HWND -> DialogProc -> LPARAM -> IO Int 70dialogBoxParam inst template mb_parent dia_fn init_val = do 71 c_dia_fn <- mkDialogClosure dia_fn 72 failIf (== -1) "DialogBoxParam" $ 73 c_DialogBoxParam inst template (maybePtr mb_parent) c_dia_fn init_val 74foreign import WINDOWS_CCONV "windows.h DialogBoxParamW" 75 c_DialogBoxParam :: HINSTANCE -> DTemplate -> HWND -> FunPtr DialogProc -> LPARAM -> IO Int 76 77dialogBoxIndirect :: HINSTANCE -> DTemplateMem -> Maybe HWND -> DialogProc -> IO Int 78dialogBoxIndirect inst template mb_parent dia_fn = 79 dialogBoxIndirectParam inst template mb_parent dia_fn 0 80 81dialogBoxIndirectParam :: HINSTANCE -> DTemplateMem -> Maybe HWND -> DialogProc -> LPARAM -> IO Int 82dialogBoxIndirectParam inst template mb_parent dia_fn init_val = do 83 c_dia_fn <- mkDialogClosure dia_fn 84 failIf (== -1) "DialogBoxIndirectParam" $ 85 c_DialogBoxIndirectParam inst template (maybePtr mb_parent) c_dia_fn init_val 86foreign import WINDOWS_CCONV "windows.h DialogBoxIndirectParamW" 87 c_DialogBoxIndirectParam :: HINSTANCE -> DTemplateMem -> HWND -> FunPtr DialogProc -> LPARAM -> IO Int 88 89 90data DialogTemplate 91 = DialogTemplate 92 Int Int Int Int -- x, y, cx, cy 93 WindowStyle 94 DWORD 95 (Either ResourceID String) -- menu 96 (Either ResourceID String) -- class 97 (Either ResourceID String) -- caption 98 (Either ResourceID String) -- fontname 99 Int -- font height 100 [DialogControl] 101 102data DialogControl 103 = DialogControl 104 Int Int Int Int -- x,y, cx, cy 105 (Either ResourceID String) -- text 106 (Either ResourceID String) -- classname 107 WindowStyle 108 DWORD 109 Int -- dia_id 110 111mkDialogFromTemplate :: DialogTemplate -> IO DTemplateMem 112mkDialogFromTemplate (DialogTemplate x y cx cy 113 wstyle extstyle 114 mb_menu mb_class caption 115 font font_height 116 controls) = do 117 prim_hmenu <- marshall_res mb_menu 118 prim_class <- marshall_res mb_class 119 prim_caption <- marshall_res caption 120 prim_font <- marshall_res font 121 dtemp <- mkDiaTemplate 0 x y cx cy wstyle extstyle 122 prim_hmenu prim_class 123 prim_caption prim_font 124 font_height 125 mapM_ (addControl dtemp) controls 126 getFinalDialog dtemp 127 128pushButtonControl :: Int -> Int -> Int -> Int 129 -> DWORD -> DWORD -> Int 130 -> String 131 -> DialogControl 132pushButtonControl x y cx cy style estyle dia_id lab = 133 DialogControl x y cx cy (Left 0x0080) (Right lab) 134 (style + bS_DEFPUSHBUTTON) estyle dia_id 135 136labelControl :: Int -> Int -> Int -> Int 137 -> DWORD -> DWORD -> Int 138 -> String 139 -> DialogControl 140labelControl x y cx cy style estyle dia_id lab = 141 DialogControl x y cx cy (Left 0x0082) (Right lab) 142 (style + sS_LEFT) estyle dia_id 143 144listBoxControl :: Int -> Int -> Int -> Int 145 -> DWORD -> DWORD -> Int 146 -> String 147 -> DialogControl 148listBoxControl x y cx cy style estyle dia_id lab = 149 DialogControl x y cx cy (Left 0x0083) (Right lab) 150 (style) estyle dia_id 151 152comboBoxControl :: Int -> Int -> Int -> Int 153 -> DWORD -> DWORD -> Int 154 -> String 155 -> DialogControl 156comboBoxControl x y cx cy style estyle dia_id lab = 157 DialogControl x y cx cy (Left 0x0085) (Right lab) 158 (style) estyle dia_id 159 160editControl :: Int -> Int -> Int -> Int 161 -> DWORD -> DWORD -> Int 162 -> String 163 -> DialogControl 164editControl x y cx cy style estyle dia_id lab = 165 DialogControl x y cx cy (Left 0x0081) (Right lab) 166 (style + eS_LEFT) estyle dia_id 167 168scrollBarControl :: Int -> Int -> Int -> Int 169 -> DWORD -> DWORD -> Int 170 -> String 171 -> DialogControl 172scrollBarControl x y cx cy style estyle dia_id lab = 173 DialogControl x y cx cy (Left 0x0084) (Right lab) 174 (style) estyle dia_id 175 176foreign import ccall unsafe "diatemp.h getFinalDialog" 177 getFinalDialog :: Ptr DIA_TEMPLATE -> IO DTemplateMem 178 179foreign import ccall unsafe "diatemp.h mkDiaTemplate" 180 mkDiaTemplate :: Int -> Int -> Int -> Int -> Int -> WindowStyle -> DWORD -> 181 LPCWSTR -> LPCWSTR -> LPCWSTR -> LPCWSTR -> Int -> IO (Ptr DIA_TEMPLATE) 182 183addControl :: Ptr DIA_TEMPLATE -> DialogControl -> IO () 184addControl dtemp (DialogControl x y cx cy mb_text mb_class 185 style exstyle 186 dia_id) = do 187 prim_text <- marshall_res mb_text 188 prim_class <- marshall_res mb_class 189 _ <- addDiaControl dtemp prim_text dia_id prim_class style 190 x y cx cy exstyle 191 return () 192 193foreign import ccall unsafe "diatemp.h addDiaControl" 194 addDiaControl :: Ptr DIA_TEMPLATE -> LPCWSTR -> Int -> LPCWSTR -> DWORD -> 195 Int -> Int -> Int -> Int -> DWORD -> IO (Ptr DIA_TEMPLATE) 196 197{-# CFILES cbits/diatemp.c #-} 198 199marshall_res :: Either ResourceID String -> IO LPCWSTR 200marshall_res (Left r) = mkResource r 201marshall_res (Right s) = newCWString s 202 203-- modeless dialogs 204 205createDialog :: HINSTANCE -> DTemplate -> Maybe HWND -> DialogProc -> IO HWND 206createDialog inst template mb_parent dia_fn = 207 createDialogParam inst template mb_parent dia_fn 0 208 209createDialogParam :: HINSTANCE -> DTemplate -> Maybe HWND -> DialogProc -> LPARAM -> IO HWND 210createDialogParam inst template mb_parent dia_fn init_val = do 211 c_dia_fn <- mkDialogClosure dia_fn 212 failIfNull "CreateDialogParam" $ 213 c_CreateDialogParam inst template (maybePtr mb_parent) c_dia_fn init_val 214foreign import WINDOWS_CCONV "windows.h CreateDialogParamW" 215 c_CreateDialogParam :: HINSTANCE -> DTemplate -> HWND -> FunPtr DialogProc -> LPARAM -> IO HWND 216 217createDialogIndirect :: HINSTANCE -> DTemplateMem -> Maybe HWND -> DialogProc -> IO HWND 218createDialogIndirect inst template mb_parent dia_fn = 219 createDialogIndirectParam inst template mb_parent dia_fn 0 220 221createDialogIndirectParam :: HINSTANCE -> DTemplateMem -> Maybe HWND -> DialogProc -> LPARAM -> IO HWND 222createDialogIndirectParam inst template mb_parent dia_fn init_val = do 223 c_dia_fn <- mkDialogClosure dia_fn 224 failIfNull "CreateDialogIndirectParam" $ 225 c_CreateDialogIndirectParam inst template (maybePtr mb_parent) c_dia_fn init_val 226foreign import WINDOWS_CCONV "windows.h CreateDialogIndirectParamW" 227 c_CreateDialogIndirectParam :: HINSTANCE -> DTemplateMem -> HWND -> FunPtr DialogProc -> LPARAM -> IO HWND 228 229foreign import WINDOWS_CCONV "windows.h DefDlgProcW" 230 defDlgProc :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT 231 232endDialog :: HWND -> Int -> IO () 233endDialog dlg res = 234 failIfFalse_ "EndDialog" $ c_EndDialog dlg res 235foreign import WINDOWS_CCONV "windows.h EndDialog" 236 c_EndDialog :: HWND -> Int -> IO BOOL 237 238foreign import WINDOWS_CCONV unsafe "windows.h GetDialogBaseUnits" 239 getDialogBaseUnits :: IO LONG 240 241getDlgCtrlID :: HWND -> IO Int 242getDlgCtrlID ctl = 243 failIfZero "GetDlgCtrlID" $ c_GetDlgCtrlID ctl 244foreign import WINDOWS_CCONV unsafe "windows.h GetDlgCtrlID" 245 c_GetDlgCtrlID :: HWND -> IO Int 246 247getDlgItem :: HWND -> Int -> IO HWND 248getDlgItem dlg item = 249 failIfNull "GetDlgItem" $ c_GetDlgItem dlg item 250foreign import WINDOWS_CCONV unsafe "windows.h GetDlgItem" 251 c_GetDlgItem :: HWND -> Int -> IO HWND 252 253getDlgItemInt :: HWND -> Int -> Bool -> IO Int 254getDlgItemInt dlg item signed = 255 alloca $ \ p_trans -> do 256 res <- c_GetDlgItemInt dlg item p_trans signed 257 failIfFalse_ "GetDlgItemInt" $ peek p_trans 258 return (fromIntegral res) 259foreign import WINDOWS_CCONV "windows.h GetDlgItemInt" 260 c_GetDlgItemInt :: HWND -> Int -> Ptr Bool -> Bool -> IO UINT 261 262getDlgItemText :: HWND -> Int -> Int -> IO String 263getDlgItemText dlg item size = 264 allocaArray size $ \ p_buf -> do 265 _ <- failIfZero "GetDlgItemInt" $ c_GetDlgItemText dlg item p_buf size 266 peekTString p_buf 267foreign import WINDOWS_CCONV "windows.h GetDlgItemTextW" 268 c_GetDlgItemText :: HWND -> Int -> LPTSTR -> Int -> IO Int 269 270getNextDlgGroupItem :: HWND -> HWND -> BOOL -> IO HWND 271getNextDlgGroupItem dlg ctl previous = 272 failIfNull "GetNextDlgGroupItem" $ c_GetNextDlgGroupItem dlg ctl previous 273foreign import WINDOWS_CCONV unsafe "windows.h GetNextDlgGroupItem" 274 c_GetNextDlgGroupItem :: HWND -> HWND -> BOOL -> IO HWND 275 276getNextDlgTabItem :: HWND -> HWND -> BOOL -> IO HWND 277getNextDlgTabItem dlg ctl previous = 278 failIfNull "GetNextDlgTabItem" $ c_GetNextDlgTabItem dlg ctl previous 279foreign import WINDOWS_CCONV unsafe "windows.h GetNextDlgTabItem" 280 c_GetNextDlgTabItem :: HWND -> HWND -> BOOL -> IO HWND 281 282foreign import WINDOWS_CCONV "windows.h IsDialogMessageW" 283 isDialogMessage :: HWND -> LPMSG -> IO BOOL 284 285mapDialogRect :: HWND -> LPRECT -> IO () 286mapDialogRect dlg p_rect = 287 failIfFalse_ "MapDialogRect" $ c_MapDialogRect dlg p_rect 288foreign import WINDOWS_CCONV unsafe "windows.h MapDialogRect" 289 c_MapDialogRect :: HWND -> LPRECT -> IO Bool 290 291-- No MessageBox* funs in here just yet. 292 293foreign import WINDOWS_CCONV "windows.h SendDlgItemMessageW" 294 sendDlgItemMessage :: HWND -> Int -> WindowMessage -> WPARAM -> LPARAM -> IO LONG 295 296setDlgItemInt :: HWND -> Int -> UINT -> BOOL -> IO () 297setDlgItemInt dlg item value signed = 298 failIfFalse_ "SetDlgItemInt" $ c_SetDlgItemInt dlg item value signed 299foreign import WINDOWS_CCONV "windows.h SetDlgItemInt" 300 c_SetDlgItemInt :: HWND -> Int -> UINT -> BOOL -> IO Bool 301 302setDlgItemText :: HWND -> Int -> String -> IO () 303setDlgItemText dlg item str = 304 withTString str $ \ c_str -> 305 failIfFalse_ "SetDlgItemText" $ c_SetDlgItemText dlg item c_str 306foreign import WINDOWS_CCONV "windows.h SetDlgItemTextW" 307 c_SetDlgItemText :: HWND -> Int -> LPCTSTR -> IO Bool 308 309#{enum WindowStyle, 310 , dS_3DLOOK = DS_3DLOOK 311 , dS_ABSALIGN = DS_ABSALIGN 312 , dS_CENTER = DS_CENTER 313 , dS_CENTERMOUSE = DS_CENTERMOUSE 314 , dS_CONTEXTHELP = DS_CONTEXTHELP 315 , dS_CONTROL = DS_CONTROL 316 , dS_FIXEDSYS = DS_FIXEDSYS 317 , dS_LOCALEDIT = DS_LOCALEDIT 318 , dS_MODALFRAME = DS_MODALFRAME 319 , dS_NOFAILCREATE = DS_NOFAILCREATE 320 , dS_NOIDLEMSG = DS_NOIDLEMSG 321 , dS_SETFONT = DS_SETFONT 322 , dS_SETFOREGROUND = DS_SETFOREGROUND 323 , dS_SYSMODAL = DS_SYSMODAL 324 } 325 326#{enum WindowMessage, 327 , dM_GETDEFID = DM_GETDEFID 328 , dM_REPOSITION = DM_REPOSITION 329 , dM_SETDEFID = DM_SETDEFID 330 , wM_CTLCOLORDLG = WM_CTLCOLORDLG 331 , wM_CTLCOLORMSGBOX = WM_CTLCOLORMSGBOX 332 } 333 334---------------------------------------------------------------- 335-- End 336---------------------------------------------------------------- 337