{-# LANGUAGE ForeignFunctionInterface, CPP #-}
-- | This module provides wrappers around Win32 API calls. These functions provide initialization,

-- shutdown, and input event handling.

module Graphics.Vty.Platform.Windows.WindowsInterfaces
  ( readBuf,
    configureInput,
    configureOutput
  ) where

#include "windows_cconv.h"

import Graphics.Vty.Platform.Windows.WindowsConsoleInput
import Graphics.Vty.Input.Events ( Event(EvResize), InternalEvent(InputEvent) )

import Control.Concurrent (yield)
import Control.Concurrent.STM ( TChan, atomically, writeTChan )
import Control.Monad (foldM)
import Data.Bits ((.|.), (.&.), shiftL)
import Codec.Binary.UTF8.String (encodeChar)
import Data.Word (Word8)
import Foreign.Storable (Storable(..))
import GHC.Ptr ( Ptr )
import System.IO ( Handle )
import System.Win32.Types ( HANDLE, withHandleToHANDLE, DWORD )
import System.Win32.Console

foreign import ccall "windows.h WaitForSingleObject" c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD

-- | Read the contents of the Windows input buffer. The contents are parsed and either written to

-- the TChan queue for Window size events, or written to the Word8 buffer for keyboard events and 

-- VT sequences. Returns the # of bytes written to the Word8 buffer.

readBuf :: TChan InternalEvent -> Ptr WinConsoleInputEvent -> Handle -> Ptr Word8 -> Int -> IO Int
readBuf :: TChan InternalEvent
-> Ptr WinConsoleInputEvent -> Handle -> Ptr Word8 -> Int -> IO Int
readBuf TChan InternalEvent
eventChannel Ptr WinConsoleInputEvent
inputEventPtr Handle
handle Ptr Word8
bufferPtr Int
maxInputRecords = do
    UINT
ret <- Handle -> (HANDLE -> IO UINT) -> IO UINT
forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE Handle
handle (HANDLE -> UINT -> IO UINT
`c_WaitForSingleObject` UINT
500)
    IO ()
yield -- otherwise, the above foreign call causes the loop to never

          -- respond to the killThread

    if UINT
ret UINT -> UINT -> Bool
forall a. Eq a => a -> a -> Bool
/= UINT
0
    then TChan InternalEvent
-> Ptr WinConsoleInputEvent -> Handle -> Ptr Word8 -> Int -> IO Int
readBuf TChan InternalEvent
eventChannel Ptr WinConsoleInputEvent
inputEventPtr Handle
handle Ptr Word8
bufferPtr Int
maxInputRecords
    else TChan InternalEvent
-> Ptr WinConsoleInputEvent -> Handle -> Ptr Word8 -> Int -> IO Int
readBuf' TChan InternalEvent
eventChannel Ptr WinConsoleInputEvent
inputEventPtr Handle
handle Ptr Word8
bufferPtr Int
maxInputRecords

readBuf' :: TChan InternalEvent -> Ptr WinConsoleInputEvent -> Handle -> Ptr Word8 -> Int -> IO Int
readBuf' :: TChan InternalEvent
-> Ptr WinConsoleInputEvent -> Handle -> Ptr Word8 -> Int -> IO Int
readBuf' TChan InternalEvent
eventChannel Ptr WinConsoleInputEvent
inputEventPtr Handle
handle Ptr Word8
bufferPtr Int
maxInputRecords = do
    [WinConsoleInputEvent]
inputEvents <- Ptr WinConsoleInputEvent
-> Int -> Handle -> IO [WinConsoleInputEvent]
readConsoleInput Ptr WinConsoleInputEvent
inputEventPtr Int
maxInputRecords Handle
handle
    (Int
offset, Maybe Int
_) <- ((Int, Maybe Int) -> WinConsoleInputEvent -> IO (Int, Maybe Int))
-> (Int, Maybe Int)
-> [WinConsoleInputEvent]
-> IO (Int, Maybe Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Int, Maybe Int) -> WinConsoleInputEvent -> IO (Int, Maybe Int)
handleInputEvent (Int
0, Maybe Int
forall a. Maybe a
Nothing) [WinConsoleInputEvent]
inputEvents
    Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
offset
    where
        handleInputEvent :: (Int, Maybe Int) -> WinConsoleInputEvent -> IO (Int, Maybe Int)
        handleInputEvent :: (Int, Maybe Int) -> WinConsoleInputEvent -> IO (Int, Maybe Int)
handleInputEvent (Int
offset, Maybe Int
mSurrogateVal) WinConsoleInputEvent
inputEvent = do
            case WinConsoleInputEvent
inputEvent of
                KeyEventRecordU (KeyEventRecordC Bool
isKeyDown WORD
_ WORD
_ WORD
_ CWchar
cwChar UINT
_) -> do
                    -- Process the character if this is a 'key down' event,

                    -- AND the char is not NULL

                    if Bool
isKeyDown Bool -> Bool -> Bool
&& CWchar
cwChar CWchar -> CWchar -> Bool
forall a. Eq a => a -> a -> Bool
/= CWchar
0
                    then (Int, Maybe Int) -> Int -> IO (Int, Maybe Int)
processCWChar (Int
offset, Maybe Int
mSurrogateVal) (Int -> IO (Int, Maybe Int)) -> Int -> IO (Int, Maybe Int)
forall a b. (a -> b) -> a -> b
$ CWchar -> Int
forall a. Enum a => a -> Int
fromEnum CWchar
cwChar
                    else (Int, Maybe Int) -> IO (Int, Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
offset, Maybe Int
forall a. Maybe a
Nothing)
                WindowBufferSizeRecordU (WindowBufferSizeRecordC (COORD SHORT
x SHORT
y)) -> do
                    let resize :: Event
resize = Int -> Int -> Event
EvResize (SHORT -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SHORT
x) (SHORT -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SHORT
y)
                    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan InternalEvent -> InternalEvent -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan InternalEvent
eventChannel (Event -> InternalEvent
InputEvent Event
resize)
                    (Int, Maybe Int) -> IO (Int, Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
offset, Maybe Int
forall a. Maybe a
Nothing)
                WinConsoleInputEvent
_ -> (Int, Maybe Int) -> IO (Int, Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
offset, Maybe Int
forall a. Maybe a
Nothing)

        processCWChar :: (Int, Maybe Int) -> Int -> IO (Int, Maybe Int)
        processCWChar :: (Int, Maybe Int) -> Int -> IO (Int, Maybe Int)
processCWChar (Int
offset, Maybe Int
Nothing) Int
charVal = do
            if Int -> Bool
isSurrogate Int
charVal
            then (Int, Maybe Int) -> IO (Int, Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
offset, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
charVal)
            else Int -> Int -> IO (Int, Maybe Int)
encodeAndWriteToBuf Int
offset Int
charVal
            where
                isSurrogate :: Int -> Bool
                isSurrogate :: Int -> Bool
isSurrogate Int
c = Int
0xD800 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
c Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xDC00
        processCWChar (Int
offset, Just Int
surogateVal) Int
charVal = do
            let charVal' :: Int
charVal' = (((Int
surogateVal Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3FF) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
10) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (Int
charVal Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3FF)) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0x10000
            Int -> Int -> IO (Int, Maybe Int)
encodeAndWriteToBuf Int
offset Int
charVal'

        encodeAndWriteToBuf :: Int -> Int -> IO (Int, Maybe Int)
        encodeAndWriteToBuf :: Int -> Int -> IO (Int, Maybe Int)
encodeAndWriteToBuf Int
offset Int
charVal = do
            let utf8Char :: [Word8]
utf8Char = Char -> [Word8]
encodeChar (Char -> [Word8]) -> Char -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> Char
forall a. Enum a => Int -> a
toEnum Int
charVal
            ((Word8, Int) -> IO ()) -> [(Word8, Int)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Word8
w, Int
offset') -> Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
bufferPtr (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset') Word8
w) ([(Word8, Int)] -> IO ()) -> [(Word8, Int)] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Word8] -> [Int] -> [(Word8, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word8]
utf8Char [Int
0..]
            (Int, Maybe Int) -> IO (Int, Maybe Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
utf8Char, Maybe Int
forall a. Maybe a
Nothing)


-- | Configure Windows to correctly handle input for a Vty application

configureInput :: Handle -> IO (IO (), IO ())
configureInput :: Handle -> IO (IO (), IO ())
configureInput Handle
inputHandle = do
    Handle -> (HANDLE -> IO (IO (), IO ())) -> IO (IO (), IO ())
forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE Handle
inputHandle ((HANDLE -> IO (IO (), IO ())) -> IO (IO (), IO ()))
-> (HANDLE -> IO (IO (), IO ())) -> IO (IO (), IO ())
forall a b. (a -> b) -> a -> b
$ \HANDLE
wh -> do
        UINT
original <- HANDLE -> IO UINT
getConsoleMode HANDLE
wh
        let setMode :: IO ()
setMode = HANDLE -> UINT -> IO ()
setConsoleMode HANDLE
wh (UINT -> IO ()) -> UINT -> IO ()
forall a b. (a -> b) -> a -> b
$ UINT
eNABLE_VIRTUAL_TERMINAL_INPUT UINT -> UINT -> UINT
forall a. Bits a => a -> a -> a
.|. UINT
eNABLE_EXTENDED_FLAGS
        (IO (), IO ()) -> IO (IO (), IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO ()
setMode,
              HANDLE -> UINT -> IO ()
setConsoleMode HANDLE
wh UINT
original)

-- | Configure Windows to correctly handle output for a Vty application

configureOutput :: Handle -> IO (IO ())
configureOutput :: Handle -> IO (IO ())
configureOutput Handle
outputHandle = do
    Handle -> (HANDLE -> IO (IO ())) -> IO (IO ())
forall a. Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE Handle
outputHandle ((HANDLE -> IO (IO ())) -> IO (IO ()))
-> (HANDLE -> IO (IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \HANDLE
wh -> do
        UINT
original <- HANDLE -> IO UINT
getConsoleMode HANDLE
wh
        UINT -> IO ()
setConsoleOutputCP UINT
65001
        HANDLE -> UINT -> IO ()
setConsoleMode HANDLE
wh (UINT -> IO ()) -> UINT -> IO ()
forall a b. (a -> b) -> a -> b
$ UINT
eNABLE_VIRTUAL_TERMINAL_PROCESSING UINT -> UINT -> UINT
forall a. Bits a => a -> a -> a
.|. UINT
eNABLE_PROCESSED_OUTPUT
        IO () -> IO (IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HANDLE -> UINT -> IO ()
setConsoleMode HANDLE
wh UINT
original)