← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to libraries/Win32/Graphics/Win32/Misc.hsc

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libraries/Win32/Graphics/Win32/Misc.hsc
 
1
-----------------------------------------------------------------------------
 
2
-- |
 
3
-- Module      :  Graphics.Win32.Misc
 
4
-- Copyright   :  (c) Alastair Reid, 1997-2003
 
5
-- License     :  BSD-style (see the file libraries/base/LICENSE)
 
6
--
 
7
-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>
 
8
-- Stability   :  provisional
 
9
-- Portability :  portable
 
10
--
 
11
-- A collection of FFI declarations for interfacing with Win32.
 
12
--
 
13
-----------------------------------------------------------------------------
 
14
 
 
15
module Graphics.Win32.Misc where
 
16
 
 
17
import Graphics.Win32.GDI.Types
 
18
import System.Win32.Types
 
19
 
 
20
import Data.Maybe
 
21
import Foreign
 
22
 
 
23
#include <windows.h>
 
24
#include "gettime.h"
 
25
 
 
26
----------------------------------------------------------------
 
27
-- Resources
 
28
-- (should probably be distributed between
 
29
--  Graphics.Win32.{Icon,Cursor,Accelerator,Menu,...})
 
30
----------------------------------------------------------------
 
31
 
 
32
type Accelerator = LPCTSTR
 
33
-- intToAccelerator :: Int -> Accelerator
 
34
-- intToAccelerator i = makeIntResource (toWord i)
 
35
 
 
36
-- cursor and icon should not be const pointer; GSL ???
 
37
type Cursor = LPTSTR
 
38
-- intToCursor :: Int -> Cursor
 
39
-- intToCursor i = makeIntResource (toWord i)
 
40
 
 
41
type Icon = LPTSTR
 
42
-- intToIcon :: Int -> Icon
 
43
-- intToIcon i = makeIntResource (toWord i)
 
44
 
 
45
loadAccelerators :: Maybe HINSTANCE -> Accelerator -> IO HACCEL
 
46
loadAccelerators mb_inst accel =
 
47
  failIfNull "LoadAccelerators" $ c_LoadAccelerators (maybePtr mb_inst) accel
 
48
foreign import stdcall unsafe "windows.h LoadAcceleratorsW"
 
49
  c_LoadAccelerators :: HINSTANCE -> Accelerator -> IO HACCEL
 
50
 
 
51
loadCursor :: Maybe HINSTANCE -> Cursor -> IO HCURSOR
 
52
loadCursor mb_inst cursor =
 
53
  failIfNull "LoadCursor" $ c_LoadCursor (maybePtr mb_inst) cursor
 
54
foreign import stdcall unsafe "windows.h LoadCursorW"
 
55
  c_LoadCursor :: HINSTANCE -> Cursor -> IO HCURSOR
 
56
 
 
57
loadIcon :: Maybe HINSTANCE -> Icon -> IO HICON
 
58
loadIcon mb_inst icon =
 
59
  failIfNull "LoadIcon" $ c_LoadIcon (maybePtr mb_inst) icon
 
60
foreign import stdcall unsafe "windows.h LoadIconW"
 
61
  c_LoadIcon :: HINSTANCE -> Icon -> IO HICON
 
62
 
 
63
#{enum Cursor, castUINTToPtr
 
64
 , iDC_ARROW        = (UINT)IDC_ARROW
 
65
 , iDC_IBEAM        = (UINT)IDC_IBEAM
 
66
 , iDC_WAIT         = (UINT)IDC_WAIT
 
67
 , iDC_CROSS        = (UINT)IDC_CROSS
 
68
 , iDC_UPARROW      = (UINT)IDC_UPARROW
 
69
 , iDC_SIZENWSE     = (UINT)IDC_SIZENWSE
 
70
 , iDC_SIZENESW     = (UINT)IDC_SIZENESW
 
71
 , iDC_SIZEWE       = (UINT)IDC_SIZEWE
 
72
 , iDC_SIZENS       = (UINT)IDC_SIZENS
 
73
 }
 
74
 
 
75
#{enum Icon, castUINTToPtr
 
76
 , iDI_APPLICATION  = (UINT)IDI_APPLICATION
 
77
 , iDI_HAND         = (UINT)IDI_HAND
 
78
 , iDI_QUESTION     = (UINT)IDI_QUESTION
 
79
 , iDI_EXCLAMATION  = (UINT)IDI_EXCLAMATION
 
80
 , iDI_ASTERISK     = (UINT)IDI_ASTERISK
 
81
 }
 
82
 
 
83
----------------------------------------------------------------
 
84
-- Message Boxes
 
85
----------------------------------------------------------------
 
86
 
 
87
type MBStyle = UINT
 
88
 
 
89
#{enum MBStyle,
 
90
 , mB_OK                = MB_OK
 
91
 , mB_OKCANCEL          = MB_OKCANCEL
 
92
 , mB_ABORTRETRYIGNORE  = MB_ABORTRETRYIGNORE
 
93
 , mB_YESNOCANCEL       = MB_YESNOCANCEL
 
94
 , mB_YESNO             = MB_YESNO
 
95
 , mB_RETRYCANCEL       = MB_RETRYCANCEL
 
96
 , mB_ICONHAND          = MB_ICONHAND
 
97
 , mB_ICONQUESTION      = MB_ICONQUESTION
 
98
 , mB_ICONEXCLAMATION   = MB_ICONEXCLAMATION
 
99
 , mB_ICONASTERISK      = MB_ICONASTERISK
 
100
 , mB_ICONINFORMATION   = MB_ICONINFORMATION
 
101
 , mB_ICONSTOP          = MB_ICONSTOP
 
102
 , mB_DEFBUTTON1        = MB_DEFBUTTON1
 
103
 , mB_DEFBUTTON2        = MB_DEFBUTTON2
 
104
 , mB_DEFBUTTON3        = MB_DEFBUTTON3
 
105
 , mB_APPLMODAL         = MB_APPLMODAL
 
106
 , mB_SYSTEMMODAL       = MB_SYSTEMMODAL
 
107
 , mB_TASKMODAL         = MB_TASKMODAL
 
108
 , mB_SETFOREGROUND     = MB_SETFOREGROUND
 
109
 }
 
110
 
 
111
type MBStatus = UINT
 
112
 
 
113
#{enum MBStatus,
 
114
 , iDABORT      = IDABORT
 
115
 , iDCANCEL     = IDCANCEL
 
116
 , iDIGNORE     = IDIGNORE
 
117
 , iDNO         = IDNO
 
118
 , iDOK         = IDOK
 
119
 , iDRETRY      = IDRETRY
 
120
 , iDYES        = IDYES
 
121
 }
 
122
 
 
123
-- Note: if the error is ever raised, we're in a very sad way!
 
124
 
 
125
messageBox :: HWND -> String -> String -> MBStyle -> IO MBStatus
 
126
messageBox wnd text caption style =
 
127
  withTString text $ \ c_text ->
 
128
  withTString caption $ \ c_caption ->
 
129
  failIfZero "MessageBox" $ c_MessageBox wnd c_text c_caption style
 
130
foreign import stdcall unsafe "windows.h MessageBoxW"
 
131
  c_MessageBox :: HWND -> LPCTSTR -> LPCTSTR -> MBStyle -> IO MBStatus
 
132
 
 
133
----------------------------------------------------------------
 
134
--
 
135
----------------------------------------------------------------
 
136
 
 
137
type StdHandleId   = DWORD
 
138
 
 
139
#{enum StdHandleId,
 
140
 , sTD_INPUT_HANDLE     = STD_INPUT_HANDLE
 
141
 , sTD_OUTPUT_HANDLE    = STD_OUTPUT_HANDLE
 
142
 , sTD_ERROR_HANDLE     = STD_ERROR_HANDLE
 
143
 }
 
144
 
 
145
getStdHandle :: StdHandleId -> IO HANDLE
 
146
getStdHandle hid =
 
147
  failIf (== iNVALID_HANDLE_VALUE) "GetStdHandle" $ c_GetStdHandle hid
 
148
foreign import stdcall unsafe "windows.h GetStdHandle"
 
149
  c_GetStdHandle :: StdHandleId -> IO HANDLE
 
150
 
 
151
----------------------------------------------------------------
 
152
-- Rotatable Ellipse hack
 
153
--
 
154
-- Win95 (Win32?) doesn't support rotating ellipses - so we
 
155
-- implement them with polygons.
 
156
--
 
157
-- We use a fixed number of edges rather than varying the number
 
158
-- according to the radius of the ellipse.
 
159
-- If anyone feels like improving the code (to vary the number),
 
160
-- they should place a fixed upper bound on the number of edges
 
161
-- since it takes a relatively long time to draw 1000 edges.
 
162
----------------------------------------------------------------
 
163
 
 
164
transformedEllipse :: HDC -> POINT -> POINT -> POINT -> IO ()
 
165
transformedEllipse dc (x0,y0) (x1,y1) (x2,y2) =
 
166
  failIfFalse_ "transformedEllipse" $ c_transformedEllipse dc x0 y0 x1 y1 x2 y2
 
167
foreign import ccall unsafe "ellipse.h transformedEllipse"
 
168
  c_transformedEllipse :: HDC -> LONG -> LONG -> LONG -> LONG -> LONG -> LONG -> IO Bool
 
169
 
 
170
{-# CFILES cbits/ellipse.c #-}
 
171
 
 
172
----------------------------------------------------------------
 
173
-- Cursor
 
174
----------------------------------------------------------------
 
175
 
 
176
getCursorPos :: IO POINT
 
177
getCursorPos =
 
178
  allocaPOINT $ \ p_pt -> do
 
179
  failIfFalse_ "GetCursorPos" $ c_GetCursorPos p_pt
 
180
  peekPOINT p_pt
 
181
foreign import stdcall unsafe "windows.h GetCursorPos"
 
182
  c_GetCursorPos :: Ptr POINT -> IO Bool
 
183
 
 
184
setCursorPos :: POINT -> IO ()
 
185
setCursorPos (x,y) =
 
186
  failIfFalse_ "setCursorPos" $ c_SetCursorPos x y
 
187
foreign import stdcall unsafe "windows.h SetCursorPos"
 
188
  c_SetCursorPos :: LONG -> LONG -> IO Bool
 
189
 
 
190
clipCursor :: RECT -> IO ()
 
191
clipCursor rect =
 
192
  withRECT rect $ \ p_rect ->
 
193
  failIfFalse_ "ClipCursor" $ c_ClipCursor p_rect
 
194
foreign import stdcall unsafe "windows.h ClipCursor"
 
195
  c_ClipCursor :: Ptr RECT -> IO Bool
 
196
 
 
197
getClipCursor :: IO RECT
 
198
getClipCursor =
 
199
  allocaRECT $ \ p_rect -> do
 
200
  failIfFalse_ "GetClipCursor" $ c_GetClipCursor p_rect
 
201
  peekRECT p_rect
 
202
foreign import stdcall unsafe "windows.h GetClipCursor"
 
203
  c_GetClipCursor :: Ptr RECT -> IO Bool
 
204
 
 
205
----------------------------------------------------------------
 
206
-- Exit/shutdown
 
207
----------------------------------------------------------------
 
208
 
 
209
type ExitOption = UINT
 
210
 
 
211
#{enum ExitOption,
 
212
 , eWX_FORCE    = EWX_FORCE
 
213
 , eWX_LOGOFF   = EWX_LOGOFF
 
214
 , eWX_POWEROFF = EWX_POWEROFF
 
215
 , eWX_REBOOT   = EWX_REBOOT
 
216
 , eWX_SHUTDOWN = EWX_SHUTDOWN
 
217
 }
 
218
 
 
219
exitWindowsEx :: ExitOption -> IO ()
 
220
exitWindowsEx opt =
 
221
  failIfFalse_ "ExitWindowsEx" $ c_ExitWindowsEx opt 0
 
222
foreign import stdcall unsafe "windows.h ExitWindowsEx"
 
223
  c_ExitWindowsEx :: ExitOption -> DWORD -> IO Bool
 
224
 
 
225
exitWindows :: IO ()
 
226
exitWindows = exitWindowsEx 0
 
227
 
 
228
----------------------------------------------------------------
 
229
-- Beeping
 
230
----------------------------------------------------------------
 
231
 
 
232
type Beep = UINT
 
233
type MbBeep = Maybe Beep
 
234
 
 
235
maybeBeep :: Maybe Beep -> Beep
 
236
maybeBeep = fromMaybe 0xffffffff
 
237
 
 
238
type Duration   = Int
 
239
 
 
240
type MbDuration   = Maybe Duration
 
241
 
 
242
maybeDuration :: Maybe Duration -> Duration
 
243
maybeDuration = fromMaybe (-1)
 
244
 
 
245
messageBeep :: Maybe Beep -> IO ()
 
246
messageBeep mb_beep =
 
247
  c_MessageBeep (maybeBeep mb_beep)
 
248
foreign import stdcall unsafe "windows.h MessageBeep"
 
249
  c_MessageBeep :: Beep -> IO ()
 
250
 
 
251
beep :: WORD -> MbDuration -> IO ()
 
252
beep freq mb_dur =
 
253
  failIfFalse_ "Beep" $ c_Beep freq (maybeDuration mb_dur)
 
254
foreign import stdcall unsafe "windows.h Beep"
 
255
  c_Beep :: WORD -> Duration -> IO Bool
 
256
 
 
257
----------------------------------------------------------------
 
258
-- Timers
 
259
----------------------------------------------------------------
 
260
 
 
261
type TimerId   = UINT
 
262
 
 
263
type TIMERPROC = FunPtr (HWND -> UINT -> TimerId -> DWORD -> IO ())
 
264
 
 
265
-- ToDo: support the other two forms of timer initialisation
 
266
 
 
267
-- Cause WM_TIMER events to be sent to window callback
 
268
 
 
269
setWinTimer :: HWND -> TimerId -> UINT -> IO TimerId
 
270
setWinTimer wnd timer elapse =
 
271
  failIfZero "SetTimer" $ c_SetTimer wnd timer elapse nullFunPtr
 
272
foreign import stdcall unsafe "windows.h SetTimer"
 
273
  c_SetTimer :: HWND -> TimerId -> UINT -> TIMERPROC -> IO TimerId
 
274
 
 
275
killTimer :: Maybe HWND -> TimerId -> IO ()
 
276
killTimer mb_wnd timer =
 
277
  failIfFalse_ "KillTimer" $ c_KillTimer (maybePtr mb_wnd) timer
 
278
foreign import stdcall unsafe "windows.h KillTimer"
 
279
  c_KillTimer :: HWND -> TimerId -> IO Bool
 
280
 
 
281
-- For documentation purposes:
 
282
type MilliSeconds = DWORD
 
283
 
 
284
foreign import stdcall unsafe "windows.h timeGetTime"
 
285
  timeGetTime :: IO MilliSeconds
 
286
 
 
287
----------------------------------------------------------------
 
288
 
 
289
-- %fun ezCreateFont :: Unknown
 
290
-- %result BITMAP({ getBitmapInfo(x) })
 
291
 
 
292
----------------------------------------------------------------
 
293
-- End
 
294
----------------------------------------------------------------