#include "Common-Safe-Haskell.hs" {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} {-| "System.Win32.Console" is really very impoverished, so I have had to do all the FFI myself. -} module System.Console.ANSI.Windows.Foreign ( -- Re-exports from Win32.Types BOOL, WORD, DWORD, WCHAR, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, SHORT, -- 'Re-exports from System.Win32.Console.Extra' INPUT_RECORD (..), INPUT_RECORD_EVENT (..), kEY_EVENT, KEY_EVENT_RECORD (..), UNICODE_ASCII_CHAR (..), writeConsoleInput, getNumberOfConsoleInputEvents, readConsoleInput, charToWCHAR, cWcharsToChars, COLORREF, COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right, rect_width, rect_height, CONSOLE_CURSOR_INFO(..), CONSOLE_SCREEN_BUFFER_INFO(..), CONSOLE_SCREEN_BUFFER_INFOEX(..), CHAR_INFO(..), sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE, eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING, fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, fOREGROUND_WHITE, fOREGROUND_INTENSE_WHITE, bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, bACKGROUND_WHITE, bACKGROUND_INTENSE_WHITE, cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE, getStdHandle, getConsoleScreenBufferInfo, getConsoleScreenBufferInfoEx, getConsoleCursorInfo, getConsoleMode, setConsoleTextAttribute, setConsoleCursorPosition, setConsoleCursorInfo, setConsoleTitle, setConsoleMode, fillConsoleOutputAttribute, fillConsoleOutputCharacter, scrollConsoleScreenBuffer, withTString, withHandleToHANDLE, ConsoleException (..) ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif import Control.Exception (Exception, throw) import Data.Bits ((.|.), shiftL) import Data.Char (chr, ord) import Data.Typeable (Typeable) import Data.Word (Word32) import Foreign.C.Types (CInt (..), CWchar (..)) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Array (allocaArray, peekArray, pokeArray, withArrayLen) import Foreign.Marshal.Utils (maybeWith, with) import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (Storable (..)) -- `SHORT` and `withHandleToHANDLE` are not both available before Win32-2.5.1.0 import System.Win32.Compat (BOOL, DWORD, ErrCode, HANDLE, LPCTSTR, LPDWORD, SHORT, TCHAR, UINT, ULONG, WORD, failIfFalse_, getLastError, iNVALID_HANDLE_VALUE, nullHANDLE, withHandleToHANDLE, withTString) #if defined(i386_HOST_ARCH) #define WINDOWS_CCONV stdcall #elif defined(x86_64_HOST_ARCH) #define WINDOWS_CCONV ccall #else #error Unknown mingw32 arch #endif type WCHAR = CWchar charToWCHAR :: Char -> WCHAR charToWCHAR char = fromIntegral (ord char) -- This is a FFI hack. Some of the API calls take a Coord, but that isn't a -- built-in FFI type so I can't use it directly. Instead, I use UNPACKED_COORD -- and marshal COORDs into this manually. Note that we CAN'T just use two SHORTs -- directly because they get expanded to 4 bytes each instead of just boing 2 -- lots of 2 bytes by the stdcall convention, so linking fails. type UNPACKED_COORD = CInt -- Field packing order determined experimentally: I couldn't immediately find a -- specification for Windows struct layout anywhere. unpackCOORD :: COORD -> UNPACKED_COORD unpackCOORD (COORD x y) = (fromIntegral y) `shiftL` (sizeOf x * 8) .|. (fromIntegral x) peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b) peekAndOffset ptr = do item <- peek ptr return (item, ptr `plusPtr` sizeOf item) pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b) pokeAndOffset ptr item = do poke ptr item return (ptr `plusPtr` sizeOf item) data COORD = COORD { coord_x :: SHORT , coord_y :: SHORT } deriving (Read, Eq) instance Show COORD where show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")" instance Storable COORD where sizeOf ~(COORD x y) = sizeOf x + sizeOf y alignment ~(COORD x _) = alignment x peek ptr = do let ptr' = castPtr ptr :: Ptr SHORT x <- peekElemOff ptr' 0 y <- peekElemOff ptr' 1 return (COORD x y) poke ptr (COORD x y) = do let ptr' = castPtr ptr :: Ptr SHORT pokeElemOff ptr' 0 x pokeElemOff ptr' 1 y data SMALL_RECT = SMALL_RECT { rect_top_left :: COORD , rect_bottom_right :: COORD } rect_top, rect_left, rect_bottom, rect_right :: SMALL_RECT -> SHORT rect_top = coord_y . rect_top_left rect_left = coord_x . rect_top_left rect_bottom = coord_y . rect_bottom_right rect_right = coord_x . rect_bottom_right rect_width, rect_height :: SMALL_RECT -> SHORT rect_width rect = rect_right rect - rect_left rect + 1 rect_height rect = rect_bottom rect - rect_top rect + 1 instance Show SMALL_RECT where show (SMALL_RECT tl br) = show tl ++ "-" ++ show br instance Storable SMALL_RECT where sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br alignment ~(SMALL_RECT tl _) = alignment tl peek ptr = do let ptr' = castPtr ptr :: Ptr COORD tl <- peekElemOff ptr' 0 br <- peekElemOff ptr' 1 return (SMALL_RECT tl br) poke ptr (SMALL_RECT tl br) = do let ptr' = castPtr ptr :: Ptr COORD pokeElemOff ptr' 0 tl pokeElemOff ptr' 1 br data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO { cci_cursor_size :: DWORD , cci_cursor_visible :: BOOL } deriving (Show) instance Storable CONSOLE_CURSOR_INFO where sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size peek ptr = do (size, ptr') <- peekAndOffset (castPtr ptr) visible <- peek ptr' return (CONSOLE_CURSOR_INFO size visible) poke ptr (CONSOLE_CURSOR_INFO size visible) = do ptr' <- pokeAndOffset (castPtr ptr) size poke ptr' visible data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO { csbi_size :: COORD , csbi_cursor_position :: COORD , csbi_attributes :: WORD , csbi_window :: SMALL_RECT , csbi_maximum_window_size :: COORD } deriving (Show) instance Storable CONSOLE_SCREEN_BUFFER_INFO where sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + sizeOf maximum_window_size alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size peek ptr = do (size, ptr1) <- peekAndOffset (castPtr ptr) (cursor_position, ptr2) <- peekAndOffset ptr1 (attributes, ptr3) <- peekAndOffset ptr2 (window, ptr4) <- peekAndOffset ptr3 maximum_window_size <- peek ptr4 return (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) poke ptr (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) = do ptr1 <- pokeAndOffset (castPtr ptr) size ptr2 <- pokeAndOffset ptr1 cursor_position ptr3 <- pokeAndOffset ptr2 attributes ptr4 <- pokeAndOffset ptr3 window poke ptr4 maximum_window_size data CONSOLE_SCREEN_BUFFER_INFOEX = CONSOLE_SCREEN_BUFFER_INFOEX { csbix_size :: COORD , csbix_cursor_position :: COORD , csbix_attributes :: WORD , csbix_window :: SMALL_RECT , csbix_maximum_window_size :: COORD , csbix_popup_attributes :: WORD , csbix_fullscreen_supported :: BOOL , csbix_color_table :: [COLORREF] } deriving (Show) -- When specifying an explicit RGB color, the COLORREF value has the following -- hexadecimal form: -- 0x00bbggrr -- The low-order byte contains a value for the relative intensity of red; the -- second byte contains a value for green; and the third byte contains a value -- for blue. The high-order byte must be zero. The maximum value for a single -- byte is 0xFF. type COLORREF = Word32 instance Storable CONSOLE_SCREEN_BUFFER_INFOEX where sizeOf ~(CONSOLE_SCREEN_BUFFER_INFOEX size cursor_position attributes window maximum_window_size popup_attributes fullscreen_supported _) = sizeOf sizeCsbix + sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + sizeOf maximum_window_size + sizeOf popup_attributes + sizeOf fullscreen_supported + 16 * sizeOf (undefined :: COLORREF) alignment ~(CONSOLE_SCREEN_BUFFER_INFOEX _ _ _ _ _ _ _ _) = alignment sizeCsbix peek ptr = do let ptr0 = castPtr ptr `plusPtr` sizeOf sizeCsbix (size, ptr1) <- peekAndOffset ptr0 (cursor_position, ptr2) <- peekAndOffset ptr1 (attributes, ptr3) <- peekAndOffset ptr2 (window, ptr4) <- peekAndOffset ptr3 (maximum_window_size, ptr5) <- peekAndOffset ptr4 (popup_attributes, ptr6) <- peekAndOffset ptr5 (fullscreen_supported, ptr7) <- peekAndOffset ptr6 color_table <- peekArray 16 ptr7 return (CONSOLE_SCREEN_BUFFER_INFOEX size cursor_position attributes window maximum_window_size popup_attributes fullscreen_supported color_table) poke ptr (CONSOLE_SCREEN_BUFFER_INFOEX size cursor_position attributes window maximum_window_size popup_attributes fullscreen_supported color_table) = do ptr0 <- pokeAndOffset (castPtr ptr) sizeCsbix ptr1 <- pokeAndOffset ptr0 size ptr2 <- pokeAndOffset ptr1 cursor_position ptr3 <- pokeAndOffset ptr2 attributes ptr4 <- pokeAndOffset ptr3 window ptr5 <- pokeAndOffset ptr4 maximum_window_size ptr6 <- pokeAndOffset ptr5 popup_attributes ptr7 <- pokeAndOffset ptr6 fullscreen_supported pokeArray ptr7 color_table' where color_table' = take 16 $ color_table ++ repeat 0 sizeCsbix :: ULONG sizeCsbix = fromIntegral $ sizeOf (undefined :: CONSOLE_SCREEN_BUFFER_INFOEX) data CHAR_INFO = CHAR_INFO { ci_char :: WCHAR , ci_attributes :: WORD } deriving (Show) instance Storable CHAR_INFO where sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes alignment ~(CHAR_INFO char _) = alignment char peek ptr = do (char, ptr') <- peekAndOffset (castPtr ptr) attributes <- peek ptr' return (CHAR_INFO char attributes) poke ptr (CHAR_INFO char attributes) = do ptr' <- pokeAndOffset (castPtr ptr) char poke ptr' attributes eNABLE_VIRTUAL_TERMINAL_INPUT, eNABLE_VIRTUAL_TERMINAL_PROCESSING :: DWORD sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD eNABLE_VIRTUAL_TERMINAL_INPUT = 512 eNABLE_VIRTUAL_TERMINAL_PROCESSING = 4 sTD_INPUT_HANDLE = 0xFFFFFFF6 -- minus 10 sTD_OUTPUT_HANDLE = 0xFFFFFFF5 -- minus 11 sTD_ERROR_HANDLE = 0xFFFFFFF4 -- minus 12 fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE :: WORD fOREGROUND_BLUE = 0x1 fOREGROUND_GREEN = 0x2 fOREGROUND_RED = 0x4 fOREGROUND_INTENSITY = 0x8 bACKGROUND_BLUE = 0x10 bACKGROUND_GREEN = 0x20 bACKGROUND_RED = 0x40 bACKGROUND_INTENSITY = 0x80 cOMMON_LVB_REVERSE_VIDEO = 0x4000 cOMMON_LVB_UNDERSCORE = 0x8000 fOREGROUND_WHITE, bACKGROUND_WHITE, fOREGROUND_INTENSE_WHITE, bACKGROUND_INTENSE_WHITE :: WORD fOREGROUND_WHITE = fOREGROUND_RED .|. fOREGROUND_GREEN .|. fOREGROUND_BLUE bACKGROUND_WHITE = bACKGROUND_RED .|. bACKGROUND_GREEN .|. bACKGROUND_BLUE fOREGROUND_INTENSE_WHITE = fOREGROUND_WHITE .|. fOREGROUND_INTENSITY bACKGROUND_INTENSE_WHITE = bACKGROUND_WHITE .|. bACKGROUND_INTENSITY kEY_EVENT, mOUSE_EVENT, wINDOW_BUFFER_SIZE_EVENT, mENU_EVENT, fOCUS_EVENT :: WORD kEY_EVENT = 1 mOUSE_EVENT = 2 wINDOW_BUFFER_SIZE_EVENT = 4 mENU_EVENT = 8 fOCUS_EVENT = 16 foreign import WINDOWS_CCONV unsafe "windows.h GetStdHandle" getStdHandle :: DWORD -> IO HANDLE foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleScreenBufferInfo" cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleScreenBufferInfoEx" cGetConsoleScreenBufferInfoEx :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFOEX -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCursorInfo" cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleMode" cGetConsoleMode :: HANDLE -> Ptr DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTextAttribute" cSetConsoleTextAttribute :: HANDLE -> WORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorPosition" cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleCursorInfo" cSetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleTitleW" cSetConsoleTitle :: LPCTSTR -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h SetConsoleMode" cSetConsoleMode :: HANDLE -> DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputAttribute" cFillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputCharacterW" cFillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h ScrollConsoleScreenBufferW" cScrollConsoleScreenBuffer :: HANDLE -> Ptr SMALL_RECT -> Ptr SMALL_RECT -> UNPACKED_COORD -> Ptr CHAR_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h WriteConsoleInputW" cWriteConsoleInput :: HANDLE -> Ptr INPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetNumberOfConsoleInputEvents" cGetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW" cReadConsoleInput :: HANDLE -> Ptr INPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL data ConsoleException = ConsoleException !ErrCode deriving (Eq, Typeable) instance Show ConsoleException where show (ConsoleException 6) = "A fatal error has occurred.\n\n" ++ "An attempt has been made to send console virtual terminal sequences\n" ++ "(ANSI codes) to an output that has not been recognised as an\n" ++ "ANSI-capable terminal and also cannot be emulated as an ANSI-enabled\n" ++ "terminal (emulation needs a ConHost-based terminal, such as Command\n" ++ "Prompt or PowerShell). That may occur, for example, if output has\n" ++ "been redirected to a file.\n\n" ++ "If that is unexpected, please post an issue at:\n" ++ "https://github.com/UnkindPartition/ansi-terminal/issues\n" show (ConsoleException errCode) = "ConsoleException " ++ show errCode instance Exception ConsoleException throwIfFalse :: IO Bool -> IO () throwIfFalse action = do succeeded <- action if not succeeded then getLastError >>= throw . ConsoleException -- TODO: Check if last error -- is zero for some instructable reason (?) else return () getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO getConsoleScreenBufferInfo handle = alloca $ \ptr_console_screen_buffer_info -> do throwIfFalse $ cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info peek ptr_console_screen_buffer_info getConsoleScreenBufferInfoEx :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFOEX getConsoleScreenBufferInfoEx handle = alloca $ \ptr_console_screen_buffer_infoex -> do -- In the Windows Console API, the `CONSOLE_SCREEN_BUFFER_INFOEX` -- structure passed to the `GetConsoleScreenBufferInfoEx` function must -- include the size of the structure. poke (castPtr ptr_console_screen_buffer_infoex) sizeCsbix throwIfFalse $ cGetConsoleScreenBufferInfoEx handle ptr_console_screen_buffer_infoex peek ptr_console_screen_buffer_infoex getConsoleCursorInfo :: HANDLE -> IO CONSOLE_CURSOR_INFO getConsoleCursorInfo handle = alloca $ \ptr_console_cursor_info -> do throwIfFalse $ cGetConsoleCursorInfo handle ptr_console_cursor_info peek ptr_console_cursor_info getConsoleMode :: HANDLE -> IO DWORD getConsoleMode handle = alloca $ \ptr_mode -> do throwIfFalse $ cGetConsoleMode handle ptr_mode peek ptr_mode setConsoleTextAttribute :: HANDLE -> WORD -> IO () setConsoleTextAttribute handle attributes = throwIfFalse $ cSetConsoleTextAttribute handle attributes setConsoleCursorPosition :: HANDLE -> COORD -> IO () setConsoleCursorPosition handle cursor_position = throwIfFalse $ cSetConsoleCursorPosition handle (unpackCOORD cursor_position) setConsoleCursorInfo :: HANDLE -> CONSOLE_CURSOR_INFO -> IO () setConsoleCursorInfo handle console_cursor_info = with console_cursor_info $ \ptr_console_cursor_info -> do throwIfFalse $ cSetConsoleCursorInfo handle ptr_console_cursor_info setConsoleTitle :: LPCTSTR -> IO () setConsoleTitle title = throwIfFalse $ cSetConsoleTitle title setConsoleMode :: HANDLE -> DWORD -> IO () setConsoleMode handle attributes = throwIfFalse $ cSetConsoleMode handle attributes fillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> COORD -> IO DWORD fillConsoleOutputAttribute handle attribute fill_length write_origin = alloca $ \ptr_chars_written -> do throwIfFalse $ cFillConsoleOutputAttribute handle attribute fill_length (unpackCOORD write_origin) ptr_chars_written peek ptr_chars_written fillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> COORD -> IO DWORD fillConsoleOutputCharacter handle char fill_length write_origin = alloca $ \ptr_chars_written -> do throwIfFalse $ cFillConsoleOutputCharacter handle char fill_length (unpackCOORD write_origin) ptr_chars_written peek ptr_chars_written scrollConsoleScreenBuffer :: HANDLE -> SMALL_RECT -> Maybe SMALL_RECT -> COORD -> CHAR_INFO -> IO () scrollConsoleScreenBuffer handle scroll_rectangle mb_clip_rectangle destination_origin fill = with scroll_rectangle $ \ptr_scroll_rectangle -> maybeWith with mb_clip_rectangle $ \ptr_clip_rectangle -> with fill $ \ptr_fill -> throwIfFalse $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill -- The following is based on module System.Win32.Console.Extra from package -- Win32-console, cut down for the WCHAR version of writeConsoleInput. writeConsoleInput :: HANDLE -> [INPUT_RECORD] -> IO DWORD writeConsoleInput hdl evs = writeConsoleInputWith hdl $ \act -> withArrayLen evs $ \len ptr -> act (ptr, toEnum len) writeConsoleInputWith :: HANDLE -> InputHandler (Ptr INPUT_RECORD, DWORD) -> IO DWORD writeConsoleInputWith hdl withBuffer = returnWith_ $ \ptrN -> withBuffer $ \(ptrBuf, len) -> failIfFalse_ "WriteConsoleInputW" $ cWriteConsoleInput hdl ptrBuf len ptrN returnWith_ :: Storable a => (Ptr a -> IO b) -> IO a returnWith_ act = alloca $ \ptr -> act ptr >> peek ptr type InputHandler i = forall a. (i -> IO a) -> IO a {- typedef union _UNICODE_ASCII_CHAR { WCHAR UnicodeChar; CHAR AsciiChar; } UNICODE_ASCII_CHAR; -} newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar { unicodeAsciiChar :: WCHAR } deriving (Show, Read, Eq) instance Storable UNICODE_ASCII_CHAR where sizeOf _ = 2 alignment _ = 2 peek ptr = UnicodeAsciiChar <$> (`peekByteOff` 0) ptr poke ptr val = case val of UnicodeAsciiChar c -> (`pokeByteOff` 0) ptr c {- typedef struct _KEY_EVENT_RECORD { BOOL bKeyDown; WORD wRepeatCount; WORD wVirtualKeyCode; WORD wVirtualScanCode; union { WCHAR UnicodeChar; CHAR AsciiChar; } uChar; DWORD dwControlKeyState; } #ifdef __GNUC__ /* gcc's alignment is not what win32 expects */ PACKED #endif KEY_EVENT_RECORD; -} data KEY_EVENT_RECORD = KEY_EVENT_RECORD { keyEventKeyDown :: BOOL , keyEventRepeatCount :: WORD , keyEventVirtualKeyCode :: WORD , keyEventVirtualScanCode :: WORD , keyEventChar :: UNICODE_ASCII_CHAR , keyEventControlKeystate :: DWORD } deriving (Show, Read, Eq) instance Storable KEY_EVENT_RECORD where sizeOf _ = 16 alignment _ = 4 peek ptr = KEY_EVENT_RECORD <$> (`peekByteOff` 0) ptr <*> (`peekByteOff` 4) ptr <*> (`peekByteOff` 6) ptr <*> (`peekByteOff` 8) ptr <*> (`peekByteOff` 10) ptr <*> (`peekByteOff` 12) ptr poke ptr val = do (`pokeByteOff` 0) ptr $ keyEventKeyDown val (`pokeByteOff` 4) ptr $ keyEventRepeatCount val (`pokeByteOff` 6) ptr $ keyEventVirtualKeyCode val (`pokeByteOff` 8) ptr $ keyEventVirtualScanCode val (`pokeByteOff` 10) ptr $ keyEventChar val (`pokeByteOff` 12) ptr $ keyEventControlKeystate val {- typedef struct _MOUSE_EVENT_RECORD { COORD dwMousePosition; DWORD dwButtonState; DWORD dwControlKeyState; DWORD dwEventFlags; } MOUSE_EVENT_RECORD; -} data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD { mousePosition :: COORD , mouseButtonState :: DWORD , mouseControlKeyState :: DWORD , mouseEventFlags :: DWORD } deriving (Show, Read, Eq) instance Storable MOUSE_EVENT_RECORD where sizeOf _ = 16 alignment _ = 4 peek ptr = MOUSE_EVENT_RECORD <$> (`peekByteOff` 0) ptr <*> (`peekByteOff` 4) ptr <*> (`peekByteOff` 8) ptr <*> (`peekByteOff` 12) ptr poke ptr val = do (`pokeByteOff` 0) ptr $ mousePosition val (`pokeByteOff` 4) ptr $ mouseButtonState val (`pokeByteOff` 8) ptr $ mouseControlKeyState val (`pokeByteOff` 12) ptr $ mouseEventFlags val {- typedef struct _WINDOW_BUFFER_SIZE_RECORD { COORD dwSize; } WINDOW_BUFFER_SIZE_RECORD; -} data WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD { bufSizeNew :: COORD } deriving (Show, Read, Eq) instance Storable WINDOW_BUFFER_SIZE_RECORD where sizeOf _ = 4 alignment _ = 4 peek ptr = WINDOW_BUFFER_SIZE_RECORD <$> (`peekByteOff` 0) ptr poke ptr val = (`pokeByteOff` 0) ptr $ bufSizeNew val {- typedef struct _MENU_EVENT_RECORD { UINT dwCommandId; } MENU_EVENT_RECORD,*PMENU_EVENT_RECORD; -} data MENU_EVENT_RECORD = MENU_EVENT_RECORD { menuCommandId :: UINT } deriving (Show, Read, Eq) instance Storable MENU_EVENT_RECORD where sizeOf _ = 4 alignment _ = 4 peek ptr = MENU_EVENT_RECORD <$> (`peekByteOff` 0) ptr poke ptr val = (`pokeByteOff` 0) ptr $ menuCommandId val {- typedef struct _FOCUS_EVENT_RECORD { BOOL bSetFocus; } FOCUS_EVENT_RECORD; -} data FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD { focusSetFocus :: BOOL } deriving (Show, Read, Eq) instance Storable FOCUS_EVENT_RECORD where sizeOf _ = 4 alignment _ = 4 peek ptr = FOCUS_EVENT_RECORD <$> (`peekByteOff` 0) ptr poke ptr val = (`pokeByteOff` 0) ptr $ focusSetFocus val data INPUT_RECORD_EVENT = InputKeyEvent KEY_EVENT_RECORD | InputMouseEvent MOUSE_EVENT_RECORD | InputWindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD | InputMenuEvent MENU_EVENT_RECORD | InputFocusEvent FOCUS_EVENT_RECORD deriving (Show, Read, Eq) {- typedef struct _INPUT_RECORD { WORD EventType; union { KEY_EVENT_RECORD KeyEvent; MOUSE_EVENT_RECORD MouseEvent; WINDOW_BUFFER_SIZE_RECORD WindowBufferSizeEvent; MENU_EVENT_RECORD MenuEvent; FOCUS_EVENT_RECORD FocusEvent; } Event; } INPUT_RECORD,*PINPUT_RECORD; -} data INPUT_RECORD = INPUT_RECORD { inputEventType :: WORD , inputEvent :: INPUT_RECORD_EVENT } deriving (Show, Read, Eq) instance Storable INPUT_RECORD where sizeOf _ = 20 alignment _ = 4 peek ptr = do evType <- (`peekByteOff` 0) ptr event <- case evType of _ | evType == kEY_EVENT -> InputKeyEvent <$> (`peekByteOff` 4) ptr _ | evType == mOUSE_EVENT -> InputMouseEvent <$> (`peekByteOff` 4) ptr _ | evType == wINDOW_BUFFER_SIZE_EVENT -> InputWindowBufferSizeEvent <$> (`peekByteOff` 4) ptr _ | evType == mENU_EVENT -> InputMenuEvent <$> (`peekByteOff` 4) ptr _ | evType == fOCUS_EVENT -> InputFocusEvent <$> (`peekByteOff` 4) ptr _ -> error $ "peek (INPUT_RECORD): Unknown event type " ++ show evType return $ INPUT_RECORD evType event poke ptr val = do (`pokeByteOff` 0) ptr $ inputEventType val case inputEvent val of InputKeyEvent ev -> (`pokeByteOff` 4) ptr ev InputMouseEvent ev -> (`pokeByteOff` 4) ptr ev InputWindowBufferSizeEvent ev -> (`pokeByteOff` 4) ptr ev InputMenuEvent ev -> (`pokeByteOff` 4) ptr ev InputFocusEvent ev -> (`pokeByteOff` 4) ptr ev -- The following is based on module System.Win32.Console.Extra from package -- Win32-console. getNumberOfConsoleInputEvents :: HANDLE -> IO DWORD getNumberOfConsoleInputEvents hdl = returnWith_ $ \ptrN -> failIfFalse_ "GetNumberOfConsoleInputEvents" $ cGetNumberOfConsoleInputEvents hdl ptrN -- The following is based on module System.Win32.Console.Extra from package -- Win32-console, cut down for the WCHAR version of readConsoleInput. readConsoleInput :: HANDLE -> DWORD -> IO [INPUT_RECORD] readConsoleInput hdl len = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr readConsoleInputWith :: HANDLE -> DWORD -> OutputHandler (Ptr INPUT_RECORD, DWORD) readConsoleInputWith hdl len handler = allocaArray (fromEnum len) $ \ptrBuf -> alloca $ \ptrN -> do failIfFalse_ "ReadConsoleInputW" $ cReadConsoleInput hdl ptrBuf len ptrN n <- peek ptrN handler (ptrBuf, n) type OutputHandler o = forall a. (o -> IO a) -> IO a -- Replicated from module Foreign.C.String in package base because that module -- does not export the function. cWcharsToChars :: [CWchar] -> [Char] cWcharsToChars = map chr . fromUTF16 . map fromIntegral where fromUTF16 (c1:c2:wcs) | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs fromUTF16 (c:wcs) = c : fromUTF16 wcs fromUTF16 [] = []