{-# 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,

    COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right,
    rect_width, rect_height, CONSOLE_CURSOR_INFO(..),
    CONSOLE_SCREEN_BUFFER_INFO(..), 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,
    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 Foreign.C.Types (CInt (..), CWchar (..))
import Foreign.Marshal (alloca, allocaArray, maybeWith, peekArray, with,
  withArrayLen)
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, 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 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 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/feuerbach/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

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 [] = []
