1#include "Common-Safe-Haskell.hs"
2{-# OPTIONS_HADDOCK hide        #-}
3{-# LANGUAGE RankNTypes         #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5
6{-| "System.Win32.Console" is really very impoverished, so I have had to do all
7the FFI myself.
8-}
9module System.Console.ANSI.Windows.Foreign
10  (
11    -- Re-exports from Win32.Types
12    BOOL, WORD, DWORD, WCHAR, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, SHORT,
13
14    -- 'Re-exports from System.Win32.Console.Extra'
15    INPUT_RECORD (..), INPUT_RECORD_EVENT (..), kEY_EVENT,
16    KEY_EVENT_RECORD (..), UNICODE_ASCII_CHAR (..), writeConsoleInput,
17    getNumberOfConsoleInputEvents, readConsoleInput,
18
19    charToWCHAR, cWcharsToChars,
20
21    COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right,
22    rect_width, rect_height, CONSOLE_CURSOR_INFO(..),
23    CONSOLE_SCREEN_BUFFER_INFO(..), CHAR_INFO(..),
24
25    sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE,
26
27    eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING,
28
29    fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY,
30    fOREGROUND_WHITE, fOREGROUND_INTENSE_WHITE,
31    bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY,
32    bACKGROUND_WHITE, bACKGROUND_INTENSE_WHITE,
33    cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE,
34
35    getStdHandle,
36    getConsoleScreenBufferInfo,
37    getConsoleCursorInfo,
38    getConsoleMode,
39
40    setConsoleTextAttribute,
41    setConsoleCursorPosition,
42    setConsoleCursorInfo,
43    setConsoleTitle,
44    setConsoleMode,
45
46    fillConsoleOutputAttribute,
47    fillConsoleOutputCharacter,
48    scrollConsoleScreenBuffer,
49
50    withTString, withHandleToHANDLE,
51
52    ConsoleException (..)
53  ) where
54
55#if !MIN_VERSION_base(4,8,0)
56import Control.Applicative ((<$>), (<*>))
57#endif
58import Control.Exception (Exception, throw)
59import Data.Bits ((.|.), shiftL)
60import Data.Char (chr, ord)
61import Data.Typeable (Typeable)
62import Foreign.C.Types (CInt (..), CWchar (..))
63import Foreign.Marshal.Alloc (alloca)
64import Foreign.Marshal.Array (allocaArray, peekArray, withArrayLen)
65import Foreign.Marshal.Utils (maybeWith, with)
66import Foreign.Ptr (Ptr, castPtr, plusPtr)
67import Foreign.Storable (Storable (..))
68-- `SHORT` and `withHandleToHANDLE` are not both available before Win32-2.5.1.0
69import System.Win32.Compat (BOOL, DWORD, ErrCode, HANDLE, LPCTSTR, LPDWORD,
70  SHORT, TCHAR, UINT, WORD, failIfFalse_, getLastError, iNVALID_HANDLE_VALUE,
71  nullHANDLE, withHandleToHANDLE, withTString)
72
73#if defined(i386_HOST_ARCH)
74#define WINDOWS_CCONV stdcall
75#elif defined(x86_64_HOST_ARCH)
76#define WINDOWS_CCONV ccall
77#else
78#error Unknown mingw32 arch
79#endif
80
81type WCHAR = CWchar
82
83charToWCHAR :: Char -> WCHAR
84charToWCHAR char = fromIntegral (ord char)
85
86-- This is a FFI hack. Some of the API calls take a Coord, but that isn't a
87-- built-in FFI type so I can't use it directly. Instead, I use UNPACKED_COORD
88-- and marshal COORDs into this manually. Note that we CAN'T just use two SHORTs
89-- directly because they get expanded to 4 bytes each instead of just boing 2
90-- lots of 2 bytes by the stdcall convention, so linking fails.
91type UNPACKED_COORD = CInt
92
93-- Field packing order determined experimentally: I couldn't immediately find a
94-- specification for Windows struct layout anywhere.
95unpackCOORD :: COORD -> UNPACKED_COORD
96unpackCOORD (COORD x y)
97  = (fromIntegral y) `shiftL` (sizeOf x * 8) .|. (fromIntegral x)
98
99
100peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b)
101peekAndOffset ptr = do
102  item <- peek ptr
103  return (item, ptr `plusPtr` sizeOf item)
104
105pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b)
106pokeAndOffset ptr item = do
107  poke ptr item
108  return (ptr `plusPtr` sizeOf item)
109
110data COORD = COORD
111  { coord_x :: SHORT
112  , coord_y :: SHORT
113  } deriving (Read, Eq)
114
115instance Show COORD where
116  show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")"
117
118instance Storable COORD where
119  sizeOf ~(COORD x y) = sizeOf x + sizeOf y
120  alignment ~(COORD x _) = alignment x
121  peek ptr = do
122    let ptr' = castPtr ptr :: Ptr SHORT
123    x <- peekElemOff ptr' 0
124    y <- peekElemOff ptr' 1
125    return (COORD x y)
126  poke ptr (COORD x y) = do
127    let ptr' = castPtr ptr :: Ptr SHORT
128    pokeElemOff ptr' 0 x
129    pokeElemOff ptr' 1 y
130
131data SMALL_RECT = SMALL_RECT
132  { rect_top_left     :: COORD
133  , rect_bottom_right :: COORD
134  }
135
136rect_top, rect_left, rect_bottom, rect_right :: SMALL_RECT -> SHORT
137rect_top = coord_y . rect_top_left
138rect_left = coord_x . rect_top_left
139rect_bottom = coord_y . rect_bottom_right
140rect_right = coord_x . rect_bottom_right
141
142rect_width, rect_height :: SMALL_RECT -> SHORT
143rect_width rect = rect_right rect - rect_left rect + 1
144rect_height rect = rect_bottom rect - rect_top rect + 1
145
146instance Show SMALL_RECT where
147  show (SMALL_RECT tl br) = show tl ++ "-" ++ show br
148
149instance Storable SMALL_RECT where
150  sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br
151  alignment ~(SMALL_RECT tl _) = alignment tl
152  peek ptr = do
153    let ptr' = castPtr ptr :: Ptr COORD
154    tl <- peekElemOff ptr' 0
155    br <- peekElemOff ptr' 1
156    return (SMALL_RECT tl br)
157  poke ptr (SMALL_RECT tl br) = do
158    let ptr' = castPtr ptr :: Ptr COORD
159    pokeElemOff ptr' 0 tl
160    pokeElemOff ptr' 1 br
161
162data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO
163  { cci_cursor_size    :: DWORD
164  , cci_cursor_visible :: BOOL
165  } deriving (Show)
166
167instance Storable CONSOLE_CURSOR_INFO where
168  sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible
169  alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size
170  peek ptr = do
171    (size, ptr') <- peekAndOffset (castPtr ptr)
172    visible <- peek ptr'
173    return (CONSOLE_CURSOR_INFO size visible)
174  poke ptr (CONSOLE_CURSOR_INFO size visible) = do
175    ptr' <- pokeAndOffset (castPtr ptr) size
176    poke ptr' visible
177
178data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO
179  { csbi_size                :: COORD
180  , csbi_cursor_position     :: COORD
181  , csbi_attributes          :: WORD
182  , csbi_window              :: SMALL_RECT
183  , csbi_maximum_window_size :: COORD
184  } deriving (Show)
185
186instance Storable CONSOLE_SCREEN_BUFFER_INFO where
187  sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO
188    size cursor_position attributes window maximum_window_size)
189    = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window
190        + sizeOf maximum_window_size
191  alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size
192  peek ptr = do
193    (size, ptr1) <- peekAndOffset (castPtr ptr)
194    (cursor_position, ptr2) <- peekAndOffset ptr1
195    (attributes, ptr3) <- peekAndOffset ptr2
196    (window, ptr4) <- peekAndOffset ptr3
197    maximum_window_size <- peek ptr4
198    return (CONSOLE_SCREEN_BUFFER_INFO
199      size cursor_position attributes window maximum_window_size)
200  poke ptr (CONSOLE_SCREEN_BUFFER_INFO
201    size cursor_position attributes window maximum_window_size)
202    = do
203      ptr1 <- pokeAndOffset (castPtr ptr) size
204      ptr2 <- pokeAndOffset ptr1 cursor_position
205      ptr3 <- pokeAndOffset ptr2 attributes
206      ptr4 <- pokeAndOffset ptr3 window
207      poke ptr4 maximum_window_size
208
209data CHAR_INFO = CHAR_INFO
210  { ci_char       :: WCHAR
211  , ci_attributes :: WORD
212  } deriving (Show)
213
214instance Storable CHAR_INFO where
215  sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes
216  alignment ~(CHAR_INFO char _) = alignment char
217  peek ptr = do
218    (char, ptr') <- peekAndOffset (castPtr ptr)
219    attributes <- peek ptr'
220    return (CHAR_INFO char attributes)
221  poke ptr (CHAR_INFO char attributes) = do
222    ptr' <- pokeAndOffset (castPtr ptr) char
223    poke ptr' attributes
224
225eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD
226sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD
227eNABLE_VIRTUAL_TERMINAL_INPUT      = 512
228eNABLE_VIRTUAL_TERMINAL_PROCESSING =   4
229sTD_INPUT_HANDLE  = 0xFFFFFFF6 -- minus 10
230sTD_OUTPUT_HANDLE = 0xFFFFFFF5 -- minus 11
231sTD_ERROR_HANDLE  = 0xFFFFFFF4 -- minus 12
232
233fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY,
234  bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY,
235  cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE :: WORD
236fOREGROUND_BLUE          =    0x1
237fOREGROUND_GREEN         =    0x2
238fOREGROUND_RED           =    0x4
239fOREGROUND_INTENSITY     =    0x8
240bACKGROUND_BLUE          =   0x10
241bACKGROUND_GREEN         =   0x20
242bACKGROUND_RED           =   0x40
243bACKGROUND_INTENSITY     =   0x80
244cOMMON_LVB_REVERSE_VIDEO = 0x4000
245cOMMON_LVB_UNDERSCORE    = 0x8000
246
247fOREGROUND_WHITE, bACKGROUND_WHITE, fOREGROUND_INTENSE_WHITE,
248  bACKGROUND_INTENSE_WHITE :: WORD
249fOREGROUND_WHITE = fOREGROUND_RED .|. fOREGROUND_GREEN .|. fOREGROUND_BLUE
250bACKGROUND_WHITE = bACKGROUND_RED .|. bACKGROUND_GREEN .|. bACKGROUND_BLUE
251fOREGROUND_INTENSE_WHITE = fOREGROUND_WHITE .|. fOREGROUND_INTENSITY
252bACKGROUND_INTENSE_WHITE = bACKGROUND_WHITE .|. bACKGROUND_INTENSITY
253
254kEY_EVENT, mOUSE_EVENT, wINDOW_BUFFER_SIZE_EVENT, mENU_EVENT,
255  fOCUS_EVENT :: WORD
256kEY_EVENT                =  1
257mOUSE_EVENT              =  2
258wINDOW_BUFFER_SIZE_EVENT =  4
259mENU_EVENT               =  8
260fOCUS_EVENT              = 16
261
262foreign import WINDOWS_CCONV unsafe "windows.h GetStdHandle"
263  getStdHandle :: DWORD -> IO HANDLE
264foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleScreenBufferInfo"
265  cGetConsoleScreenBufferInfo :: HANDLE
266                              -> Ptr CONSOLE_SCREEN_BUFFER_INFO
267                              -> IO BOOL
268foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCursorInfo"
269  cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL
270foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode"
271  cGetConsoleMode :: HANDLE -> Ptr DWORD -> IO BOOL
272foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTextAttribute"
273  cSetConsoleTextAttribute :: HANDLE -> WORD -> IO BOOL
274foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorPosition"
275  cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL
276foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorInfo"
277  cSetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL
278foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTitleW"
279  cSetConsoleTitle :: LPCTSTR -> IO BOOL
280foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode"
281  cSetConsoleMode :: HANDLE -> DWORD -> IO BOOL
282foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputAttribute"
283  cFillConsoleOutputAttribute :: HANDLE
284                              -> WORD
285                              -> DWORD
286                              -> UNPACKED_COORD
287                              -> Ptr DWORD
288                              -> IO BOOL
289foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputCharacterW"
290  cFillConsoleOutputCharacter :: HANDLE
291                              -> TCHAR
292                              -> DWORD
293                              -> UNPACKED_COORD
294                              -> Ptr DWORD
295                              -> IO BOOL
296foreign import WINDOWS_CCONV unsafe "windows.h ScrollConsoleScreenBufferW"
297  cScrollConsoleScreenBuffer :: HANDLE
298                             -> Ptr SMALL_RECT
299                             -> Ptr SMALL_RECT
300                             -> UNPACKED_COORD
301                             -> Ptr CHAR_INFO
302                             -> IO BOOL
303foreign import WINDOWS_CCONV unsafe "windows.h WriteConsoleInputW"
304  cWriteConsoleInput :: HANDLE
305                     -> Ptr INPUT_RECORD
306                     -> DWORD
307                     -> LPDWORD
308                     -> IO BOOL
309foreign import WINDOWS_CCONV unsafe "windows.h GetNumberOfConsoleInputEvents"
310  cGetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO BOOL
311foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW"
312  cReadConsoleInput :: HANDLE
313                    -> Ptr INPUT_RECORD
314                    -> DWORD
315                    -> LPDWORD
316                    -> IO BOOL
317
318data ConsoleException = ConsoleException !ErrCode deriving (Eq, Typeable)
319
320instance Show ConsoleException where
321  show (ConsoleException 6) =
322    "A fatal error has occurred.\n\n" ++
323    "An attempt has been made to send console virtual terminal sequences\n" ++
324    "(ANSI codes) to an output that has not been recognised as an\n" ++
325    "ANSI-capable terminal and also cannot be emulated as an ANSI-enabled\n" ++
326    "terminal (emulation needs a ConHost-based terminal, such as Command\n" ++
327    "Prompt or PowerShell). That may occur, for example, if output has\n" ++
328    "been redirected to a file.\n\n" ++
329    "If that is unexpected, please post an issue at:\n" ++
330    "https://github.com/feuerbach/ansi-terminal/issues\n"
331  show (ConsoleException errCode) = "ConsoleException " ++ show errCode
332
333instance Exception ConsoleException
334
335throwIfFalse :: IO Bool -> IO ()
336throwIfFalse action = do
337  succeeded <- action
338  if not succeeded
339    then getLastError >>= throw . ConsoleException -- TODO: Check if last error
340    -- is zero for some instructable reason (?)
341    else return ()
342
343getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO
344getConsoleScreenBufferInfo handle
345  = alloca $ \ptr_console_screen_buffer_info -> do
346      throwIfFalse $
347        cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info
348      peek ptr_console_screen_buffer_info
349
350getConsoleCursorInfo :: HANDLE -> IO CONSOLE_CURSOR_INFO
351getConsoleCursorInfo handle = alloca $ \ptr_console_cursor_info -> do
352  throwIfFalse $ cGetConsoleCursorInfo handle ptr_console_cursor_info
353  peek ptr_console_cursor_info
354
355getConsoleMode :: HANDLE -> IO DWORD
356getConsoleMode handle = alloca $ \ptr_mode -> do
357  throwIfFalse $ cGetConsoleMode handle ptr_mode
358  peek ptr_mode
359
360setConsoleTextAttribute :: HANDLE -> WORD -> IO ()
361setConsoleTextAttribute handle attributes
362  = throwIfFalse $ cSetConsoleTextAttribute handle attributes
363
364setConsoleCursorPosition :: HANDLE -> COORD -> IO ()
365setConsoleCursorPosition handle cursor_position
366  = throwIfFalse $ cSetConsoleCursorPosition handle
367      (unpackCOORD cursor_position)
368
369setConsoleCursorInfo :: HANDLE -> CONSOLE_CURSOR_INFO -> IO ()
370setConsoleCursorInfo handle console_cursor_info
371  = with console_cursor_info $ \ptr_console_cursor_info -> do
372      throwIfFalse $ cSetConsoleCursorInfo handle ptr_console_cursor_info
373
374setConsoleTitle :: LPCTSTR -> IO ()
375setConsoleTitle title = throwIfFalse $ cSetConsoleTitle title
376
377setConsoleMode :: HANDLE -> DWORD -> IO ()
378setConsoleMode handle attributes
379  = throwIfFalse $ cSetConsoleMode handle attributes
380
381fillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> COORD -> IO DWORD
382fillConsoleOutputAttribute handle attribute fill_length write_origin
383  = alloca $ \ptr_chars_written -> do
384      throwIfFalse $ cFillConsoleOutputAttribute handle attribute
385        fill_length (unpackCOORD write_origin) ptr_chars_written
386      peek ptr_chars_written
387
388fillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> COORD -> IO DWORD
389fillConsoleOutputCharacter handle char fill_length write_origin
390  = alloca $ \ptr_chars_written -> do
391      throwIfFalse $ cFillConsoleOutputCharacter handle char fill_length
392        (unpackCOORD write_origin) ptr_chars_written
393      peek ptr_chars_written
394
395scrollConsoleScreenBuffer :: HANDLE
396                          -> SMALL_RECT
397                          -> Maybe SMALL_RECT
398                          -> COORD
399                          -> CHAR_INFO
400                          -> IO ()
401scrollConsoleScreenBuffer
402  handle scroll_rectangle mb_clip_rectangle destination_origin fill
403  = with scroll_rectangle $ \ptr_scroll_rectangle ->
404    maybeWith with mb_clip_rectangle $ \ptr_clip_rectangle ->
405    with fill $ \ptr_fill ->
406    throwIfFalse $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle
407      ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill
408
409-- The following is based on module System.Win32.Console.Extra from package
410-- Win32-console, cut down for the WCHAR version of writeConsoleInput.
411
412writeConsoleInput :: HANDLE -> [INPUT_RECORD] -> IO DWORD
413writeConsoleInput hdl evs
414  = writeConsoleInputWith hdl $ \act ->
415    withArrayLen evs $ \len ptr ->
416    act (ptr, toEnum len)
417
418writeConsoleInputWith :: HANDLE
419                      -> InputHandler (Ptr INPUT_RECORD, DWORD)
420                      -> IO DWORD
421writeConsoleInputWith hdl withBuffer
422  = returnWith_ $ \ptrN ->
423    withBuffer $ \(ptrBuf, len) ->
424    failIfFalse_ "WriteConsoleInputW" $ cWriteConsoleInput hdl ptrBuf len ptrN
425
426returnWith_ :: Storable a => (Ptr a -> IO b) -> IO a
427returnWith_ act = alloca $ \ptr -> act ptr >> peek ptr
428
429type InputHandler i = forall a. (i -> IO a) -> IO a
430
431{-
432typedef union _UNICODE_ASCII_CHAR {
433    WCHAR UnicodeChar;
434    CHAR  AsciiChar;
435} UNICODE_ASCII_CHAR;
436-}
437newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar
438  { unicodeAsciiChar :: WCHAR
439  } deriving (Show, Read, Eq)
440
441instance Storable UNICODE_ASCII_CHAR where
442  sizeOf _    = 2
443  alignment _ = 2
444  peek ptr = UnicodeAsciiChar <$> (`peekByteOff` 0) ptr
445  poke ptr val = case val of
446    UnicodeAsciiChar c -> (`pokeByteOff` 0) ptr c
447
448{-
449typedef struct _KEY_EVENT_RECORD {
450	BOOL bKeyDown;
451	WORD wRepeatCount;
452	WORD wVirtualKeyCode;
453	WORD wVirtualScanCode;
454	union {
455		WCHAR UnicodeChar;
456		CHAR AsciiChar;
457	} uChar;
458	DWORD dwControlKeyState;
459}
460#ifdef __GNUC__
461/* gcc's alignment is not what win32 expects */
462 PACKED
463#endif
464KEY_EVENT_RECORD;
465-}
466data KEY_EVENT_RECORD = KEY_EVENT_RECORD
467  { keyEventKeyDown         :: BOOL
468  , keyEventRepeatCount     :: WORD
469  , keyEventVirtualKeyCode  :: WORD
470  , keyEventVirtualScanCode :: WORD
471  , keyEventChar            :: UNICODE_ASCII_CHAR
472  , keyEventControlKeystate :: DWORD
473  } deriving (Show, Read, Eq)
474
475instance Storable KEY_EVENT_RECORD where
476  sizeOf _    = 16
477  alignment _ =  4
478  peek ptr = KEY_EVENT_RECORD <$> (`peekByteOff`  0) ptr
479                              <*> (`peekByteOff`  4) ptr
480                              <*> (`peekByteOff`  6) ptr
481                              <*> (`peekByteOff`  8) ptr
482                              <*> (`peekByteOff` 10) ptr
483                              <*> (`peekByteOff` 12) ptr
484  poke ptr val = do
485    (`pokeByteOff`  0) ptr $ keyEventKeyDown val
486    (`pokeByteOff`  4) ptr $ keyEventRepeatCount val
487    (`pokeByteOff`  6) ptr $ keyEventVirtualKeyCode val
488    (`pokeByteOff`  8) ptr $ keyEventVirtualScanCode val
489    (`pokeByteOff` 10) ptr $ keyEventChar val
490    (`pokeByteOff` 12) ptr $ keyEventControlKeystate val
491
492{-
493typedef struct _MOUSE_EVENT_RECORD {
494	COORD dwMousePosition;
495	DWORD dwButtonState;
496	DWORD dwControlKeyState;
497	DWORD dwEventFlags;
498} MOUSE_EVENT_RECORD;
499-}
500data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD
501  { mousePosition        :: COORD
502  , mouseButtonState     :: DWORD
503  , mouseControlKeyState :: DWORD
504  , mouseEventFlags      :: DWORD
505  } deriving (Show, Read, Eq)
506
507instance Storable MOUSE_EVENT_RECORD where
508  sizeOf _    = 16
509  alignment _ =  4
510  peek ptr = MOUSE_EVENT_RECORD <$> (`peekByteOff`  0) ptr
511                                <*> (`peekByteOff`  4) ptr
512                                <*> (`peekByteOff`  8) ptr
513                                <*> (`peekByteOff` 12) ptr
514  poke ptr val = do
515    (`pokeByteOff`  0) ptr $ mousePosition val
516    (`pokeByteOff`  4) ptr $ mouseButtonState val
517    (`pokeByteOff`  8) ptr $ mouseControlKeyState val
518    (`pokeByteOff` 12) ptr $ mouseEventFlags val
519
520{-
521typedef struct _WINDOW_BUFFER_SIZE_RECORD {
522    COORD dwSize;
523} WINDOW_BUFFER_SIZE_RECORD;
524-}
525data WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD
526  { bufSizeNew :: COORD
527  } deriving (Show, Read, Eq)
528
529instance Storable WINDOW_BUFFER_SIZE_RECORD where
530  sizeOf _    = 4
531  alignment _ = 4
532  peek ptr = WINDOW_BUFFER_SIZE_RECORD <$> (`peekByteOff` 0) ptr
533  poke ptr val = (`pokeByteOff` 0) ptr $ bufSizeNew val
534
535{-
536typedef struct _MENU_EVENT_RECORD {
537    UINT dwCommandId;
538} MENU_EVENT_RECORD,*PMENU_EVENT_RECORD;
539-}
540data MENU_EVENT_RECORD = MENU_EVENT_RECORD
541  { menuCommandId :: UINT
542  } deriving (Show, Read, Eq)
543
544instance Storable MENU_EVENT_RECORD where
545  sizeOf _    = 4
546  alignment _ = 4
547  peek ptr = MENU_EVENT_RECORD <$> (`peekByteOff` 0) ptr
548  poke ptr val = (`pokeByteOff` 0) ptr $ menuCommandId val
549
550{-
551typedef struct _FOCUS_EVENT_RECORD { BOOL bSetFocus; } FOCUS_EVENT_RECORD;
552-}
553data FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD
554  { focusSetFocus :: BOOL
555  } deriving (Show, Read, Eq)
556
557instance Storable FOCUS_EVENT_RECORD where
558  sizeOf _    = 4
559  alignment _ = 4
560  peek ptr = FOCUS_EVENT_RECORD <$> (`peekByteOff` 0) ptr
561  poke ptr val = (`pokeByteOff` 0) ptr $ focusSetFocus val
562
563data INPUT_RECORD_EVENT
564  = InputKeyEvent KEY_EVENT_RECORD
565  | InputMouseEvent MOUSE_EVENT_RECORD
566  | InputWindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD
567  | InputMenuEvent MENU_EVENT_RECORD
568  | InputFocusEvent FOCUS_EVENT_RECORD
569  deriving (Show, Read, Eq)
570
571{-
572typedef struct _INPUT_RECORD {
573	WORD EventType;
574	union {
575		KEY_EVENT_RECORD KeyEvent;
576		MOUSE_EVENT_RECORD MouseEvent;
577		WINDOW_BUFFER_SIZE_RECORD WindowBufferSizeEvent;
578		MENU_EVENT_RECORD MenuEvent;
579		FOCUS_EVENT_RECORD FocusEvent;
580	} Event;
581} INPUT_RECORD,*PINPUT_RECORD;
582-}
583data INPUT_RECORD = INPUT_RECORD
584  { inputEventType :: WORD
585  , inputEvent     :: INPUT_RECORD_EVENT
586  } deriving (Show, Read, Eq)
587
588instance Storable INPUT_RECORD where
589  sizeOf _    = 20
590  alignment _ =  4
591  peek ptr = do
592    evType <- (`peekByteOff` 0) ptr
593    event <- case evType of
594      _ | evType == kEY_EVENT
595          -> InputKeyEvent              <$> (`peekByteOff` 4) ptr
596      _ | evType == mOUSE_EVENT
597          -> InputMouseEvent            <$> (`peekByteOff` 4) ptr
598      _ | evType == wINDOW_BUFFER_SIZE_EVENT
599          -> InputWindowBufferSizeEvent <$> (`peekByteOff` 4) ptr
600      _ | evType == mENU_EVENT
601          -> InputMenuEvent             <$> (`peekByteOff` 4) ptr
602      _ | evType == fOCUS_EVENT
603          -> InputFocusEvent            <$> (`peekByteOff` 4) ptr
604      _ -> error $ "peek (INPUT_RECORD): Unknown event type " ++
605             show evType
606    return $ INPUT_RECORD evType event
607  poke ptr val = do
608    (`pokeByteOff` 0) ptr $ inputEventType val
609    case inputEvent val of
610      InputKeyEvent              ev -> (`pokeByteOff` 4) ptr ev
611      InputMouseEvent            ev -> (`pokeByteOff` 4) ptr ev
612      InputWindowBufferSizeEvent ev -> (`pokeByteOff` 4) ptr ev
613      InputMenuEvent             ev -> (`pokeByteOff` 4) ptr ev
614      InputFocusEvent            ev -> (`pokeByteOff` 4) ptr ev
615
616-- The following is based on module System.Win32.Console.Extra from package
617-- Win32-console.
618
619getNumberOfConsoleInputEvents :: HANDLE -> IO DWORD
620getNumberOfConsoleInputEvents hdl =
621  returnWith_ $ \ptrN ->
622    failIfFalse_ "GetNumberOfConsoleInputEvents" $
623      cGetNumberOfConsoleInputEvents hdl ptrN
624
625-- The following is based on module System.Win32.Console.Extra from package
626-- Win32-console, cut down for the WCHAR version of readConsoleInput.
627
628readConsoleInput :: HANDLE -> DWORD -> IO [INPUT_RECORD]
629readConsoleInput hdl len
630  = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr
631
632readConsoleInputWith :: HANDLE
633                     -> DWORD
634                     -> OutputHandler (Ptr INPUT_RECORD, DWORD)
635readConsoleInputWith hdl len handler =
636  allocaArray (fromEnum len) $ \ptrBuf ->
637    alloca $ \ptrN -> do
638      failIfFalse_ "ReadConsoleInputW" $
639        cReadConsoleInput hdl ptrBuf len ptrN
640      n <- peek ptrN
641      handler (ptrBuf, n)
642
643type OutputHandler o = forall a. (o -> IO a) -> IO a
644
645-- Replicated from module Foreign.C.String in package base because that module
646-- does not export the function.
647cWcharsToChars :: [CWchar] -> [Char]
648cWcharsToChars = map chr . fromUTF16 . map fromIntegral
649 where
650  fromUTF16 (c1:c2:wcs)
651    | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff =
652      ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs
653  fromUTF16 (c:wcs) = c : fromUTF16 wcs
654  fromUTF16 [] = []
655