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