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