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

import Foreign.C.Types
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable

import Data.Bits
import Data.Char

import System.Win32.Types

import Control.Exception (Exception, throw)

#if __GLASGOW_HASKELL__ >= 612
import Data.Typeable
#endif

#if !MIN_VERSION_Win32(2,5,1)
import Control.Concurrent.MVar
import Foreign.StablePtr
import Control.Exception (bracket)
#if __GLASGOW_HASKELL__ >= 612
import GHC.IO.Handle.Types (Handle(..), Handle__(..))
import GHC.IO.FD (FD(..)) -- A wrapper around an Int32
import Data.Typeable
#else
import GHC.IOBase (Handle(..), Handle__(..))
import qualified GHC.IOBase as IOBase (FD) -- Just an Int32
#endif
#endif

#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

--import System.Console.ANSI.Windows.Foreign.Compat
#if !MIN_VERSION_Win32(2,5,0)
-- Some Windows types missing from System.Win32 prior version 2.5.0.0
type SHORT = CShort
#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 = -10
sTD_OUTPUT_HANDLE = -11
sTD_ERROR_HANDLE = -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 (Show, Eq, Typeable)

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


#if !MIN_VERSION_Win32(2,5,1)
-- | This bit is all highly dubious.  The problem is that we want to output ANSI to arbitrary Handles rather than forcing
-- people to use stdout.  However, the Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need to be able
-- to extract one of those from the Haskell Handle.
--
-- This code accomplishes this, albeit at the cost of only being compatible with GHC.
-- withHandleToHANDLE was added in Win32-2.5.1.0
withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE haskell_handle action =
    -- Create a stable pointer to the Handle. This prevents the garbage collector
    -- getting to it while we are doing horrible manipulations with it, and hence
    -- stops it being finalized (and closed).
    withStablePtr haskell_handle $ const $ do
        -- Grab the write handle variable from the Handle
        let write_handle_mvar = case haskell_handle of
                FileHandle _ handle_mvar     -> handle_mvar
                DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, we could also take the "read" one

        -- Get the FD from the algebraic data type
#if __GLASGOW_HASKELL__ < 612
        fd <- fmap haFD $ readMVar write_handle_mvar
#else
        --readMVar write_handle_mvar >>= \(Handle__ { haDevice = dev }) -> print (typeOf dev)
        Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) $ readMVar write_handle_mvar
#endif

        -- Finally, turn that (C-land) FD into a HANDLE using msvcrt
        windows_handle <- cget_osfhandle fd

        -- Do what the user originally wanted
        action windows_handle

-- This essential function comes from the C runtime system. It is certainly provided by msvcrt, and also seems to be provided by the mingw C library - hurrah!
#if __GLASGOW_HASKELL__ >= 612
foreign import WINDOWS_CCONV unsafe "_get_osfhandle" cget_osfhandle :: CInt -> IO HANDLE
#else
foreign import WINDOWS_CCONV unsafe "_get_osfhandle" cget_osfhandle :: IOBase.FD -> IO HANDLE
#endif

-- withStablePtr was added in Win32-2.5.1.0
withStablePtr :: a -> (StablePtr a -> IO b) -> IO b
withStablePtr value = bracket (newStablePtr value) freeStablePtr
#endif

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