diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -38,4 +38,8 @@ 0.2.0.3 ------- * Now vty-windows supports running in MSYS/MSYS2 terminals. This was achieved by modifying - the way the input and output buffers are initialized. + the way the input and output buffers are initialized. + +0.2.0.4 +------- +* Use readConsoleInput API provided by Win32 library. diff --git a/src/Graphics/Vty/Platform/Windows/Input/Loop.hs b/src/Graphics/Vty/Platform/Windows/Input/Loop.hs --- a/src/Graphics/Vty/Platform/Windows/Input/Loop.hs +++ b/src/Graphics/Vty/Platform/Windows/Input/Loop.hs @@ -1,70 +1,69 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_HADDOCK hide #-} -- | The input layer forks a thread to read input data via the -- Windows console API. Key presses, mouse events, and window -- resize events are all obtained by calling ReadConsoleInputW. module Graphics.Vty.Platform.Windows.Input.Loop - ( initInput + ( initInput, ) where -import Graphics.Vty.Input - -import Graphics.Vty.Config (VtyUserConfig(..)) - -import Graphics.Vty.Platform.Windows.Input.Classify ( classify ) -import Graphics.Vty.Platform.Windows.Input.Classify.Types -import Graphics.Vty.Platform.Windows.WindowsConsoleInput ( WinConsoleInputEvent ) -import Graphics.Vty.Platform.Windows.WindowsInterfaces (readBuf) - -import Control.Applicative ( Alternative(many) ) +import Control.Applicative (Alternative (many)) import Control.Concurrent - ( ThreadId, forkOS, killThread, newEmptyMVar, putMVar, takeMVar ) -import Control.Concurrent.STM ( atomically, writeTChan, newTChan ) -import Control.Exception (mask, try, catch, SomeException) -import Lens.Micro ( over, ASetter, ASetter' ) -import Lens.Micro.Mtl ( (.=), use ) -import Control.Monad (unless, mzero, forM_) + ( ThreadId, + forkOS, + killThread, + newEmptyMVar, + putMVar, + takeMVar, + ) +import Control.Concurrent.STM (atomically, newTChan, writeTChan) +import Control.Exception (SomeException, catch, mask, try) +import Control.Monad (forM_, mzero, unless) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.State (StateT(..), evalStateT) import Control.Monad.State.Class (MonadState, modify) -import Control.Monad.Trans.Reader (ReaderT(..), asks, ask) - -import Lens.Micro.TH ( makeLenses ) - -import qualified Data.ByteString.Char8 as BS8 +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Reader (ReaderT (..), ask, asks) +import Control.Monad.Trans.State (StateT (..), evalStateT) import qualified Data.ByteString as BS import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS8 import Data.Word (Word8) - import Foreign (allocaArray) import Foreign.Ptr (Ptr, castPtr) - +import Graphics.Vty.Config (VtyUserConfig (..)) +import Graphics.Vty.Input +import Graphics.Vty.Platform.Windows.Input.Classify (classify) +import Graphics.Vty.Platform.Windows.Input.Classify.Types +import Graphics.Vty.Platform.Windows.WindowsInterfaces (readBuf) +import Lens.Micro (ASetter, ASetter', over) +import Lens.Micro.Mtl (use, (.=)) +import Lens.Micro.TH (makeLenses) import System.Environment (getEnv) -import System.IO ( Handle ) +import System.IO (Handle) +import System.Win32.Console (INPUT_RECORD) data InputBuffer = InputBuffer - { _ptr :: Ptr Word8 - , _inputRecordPtr :: Ptr WinConsoleInputEvent - , _consoleEventBufferSize :: Int - } + { _ptr :: Ptr Word8, + _inputRecordPtr :: Ptr INPUT_RECORD, + _consoleEventBufferSize :: Int + } makeLenses ''InputBuffer data InputState = InputState - { _unprocessedBytes :: ByteString - , _classifierState :: ClassifierState - , _inputHandle :: Handle - , _originalInput :: Input - , _inputBuffer :: InputBuffer - , _classifier :: ClassifierState -> ByteString -> KClass - } + { _unprocessedBytes :: ByteString, + _classifierState :: ClassifierState, + _inputHandle :: Handle, + _originalInput :: Input, + _inputBuffer :: InputBuffer, + _classifier :: ClassifierState -> ByteString -> KClass + } makeLenses ''InputState @@ -72,117 +71,128 @@ logMsg :: String -> InputM () logMsg msg = do - i <- use originalInput - liftIO $ inputLogMsg i msg + i <- use originalInput + liftIO $ inputLogMsg i msg -- this must be run on an OS thread dedicated to this input handling. -- otherwise the terminal timing read behavior will block the execution -- of the lightweight threads. loopInputProcessor :: InputM () loopInputProcessor = do - readFromDevice >>= addBytesToProcess - validEvents <- many parseEvent - forM_ validEvents emit - dropInvalid - loopInputProcessor + readFromDevice >>= addBytesToProcess + validEvents <- many parseEvent + forM_ validEvents emit + dropInvalid + loopInputProcessor addBytesToProcess :: ByteString -> InputM () addBytesToProcess block = unprocessedBytes <>= block emit :: Event -> InputM () emit event = do - logMsg $ "parsed event: " ++ show event - lift (asks eventChannel) >>= liftIO . atomically . flip writeTChan (InputEvent event) + logMsg $ "parsed event: " ++ show event + lift (asks eventChannel) >>= liftIO . atomically . flip writeTChan (InputEvent event) -- Precondition: Under the threaded runtime. Only current use is from a -- forkOS thread. That case satisfies precondition. readFromDevice :: InputM ByteString readFromDevice = do - handle <- use inputHandle + handle <- use inputHandle - bufferPtr <- use $ inputBuffer.ptr - winRecordPtr <- use $ inputBuffer.inputRecordPtr - maxInputRecords <- use $ inputBuffer.consoleEventBufferSize + bufferPtr <- use $ inputBuffer . ptr + winRecordPtr <- use $ inputBuffer . inputRecordPtr + maxInputRecords <- use $ inputBuffer . consoleEventBufferSize - input <- lift ask - stringRep <- liftIO $ do - bytesRead <- readBuf (eventChannel input) winRecordPtr handle bufferPtr maxInputRecords - if bytesRead > 0 - then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead) - else return BS.empty - unless (BS.null stringRep) $ logMsg $ "input bytes: " ++ show (BS8.unpack stringRep) - return stringRep + input <- lift ask + stringRep <- liftIO $ do + bytesRead <- readBuf (eventChannel input) winRecordPtr handle bufferPtr maxInputRecords + if bytesRead > 0 + then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead) + else return BS.empty + unless (BS.null stringRep) $ logMsg $ "input bytes: " ++ show (BS8.unpack stringRep) + return stringRep parseEvent :: InputM Event parseEvent = do - c <- use classifier - s <- use classifierState - b <- use unprocessedBytes - case c s b of - Valid e remaining -> do - logMsg $ "valid parse: " ++ show e - logMsg $ "remaining: " ++ show remaining - classifierState .= ClassifierStart - unprocessedBytes .= remaining - return e - _ -> mzero + c <- use classifier + s <- use classifierState + b <- use unprocessedBytes + case c s b of + Valid e remaining -> do + logMsg $ "valid parse: " ++ show e + logMsg $ "remaining: " ++ show remaining + classifierState .= ClassifierStart + unprocessedBytes .= remaining + return e + _ -> mzero dropInvalid :: InputM () dropInvalid = do - c <- use classifier - s <- use classifierState - b <- use unprocessedBytes - case c s b of - Chunk -> do - classifierState .= - case s of - ClassifierStart -> ClassifierInChunk b [] - ClassifierInChunk p bs -> ClassifierInChunk p (b:bs) - unprocessedBytes .= BS8.empty - Invalid -> do - logMsg "dropping input bytes" - classifierState .= ClassifierStart - unprocessedBytes .= BS8.empty - _ -> return () + c <- use classifier + s <- use classifierState + b <- use unprocessedBytes + case c s b of + Chunk -> do + classifierState + .= case s of + ClassifierStart -> ClassifierInChunk b [] + ClassifierInChunk p bs -> ClassifierInChunk p (b : bs) + unprocessedBytes .= BS8.empty + Invalid -> do + logMsg "dropping input bytes" + classifierState .= ClassifierStart + unprocessedBytes .= BS8.empty + _ -> return () runInputProcessorLoop :: ClassifyMap -> Input -> Handle -> IO () runInputProcessorLoop classifyTable input handle = do let bufferSize = 1024 -- A key event could require 4 bytes of UTF-8. let maxKeyEvents = bufferSize `div` 4 - allocaArray maxKeyEvents $ \(inputRecordBuf :: Ptr WinConsoleInputEvent) -> do - allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do - let s0 = InputState BS8.empty ClassifierStart - handle - input - (InputBuffer bufferPtr inputRecordBuf maxKeyEvents) - (classify classifyTable) - runReaderT (evalStateT loopInputProcessor s0) input + allocaArray maxKeyEvents $ \(inputRecordBuf :: Ptr INPUT_RECORD) -> do + allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do + let s0 = + InputState + BS8.empty + ClassifierStart + handle + input + (InputBuffer bufferPtr inputRecordBuf maxKeyEvents) + (classify classifyTable) + runReaderT (evalStateT loopInputProcessor s0) input initInput :: VtyUserConfig -> Handle -> ClassifyMap -> IO Input initInput userConfig handle classifyTable = do - stopSync <- newEmptyMVar - mDefaultLog <- catch - (do debugLog <- getEnv "VTY_DEBUG_LOG" - return $ Just debugLog) - (\(_ :: IOError) -> return Nothing) - input <- Input <$> atomically newTChan - <*> pure (return ()) - <*> pure (return ()) - <*> maybe (return $ append mDefaultLog) - (return . appendFile) - (configDebugLog userConfig) - inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input handle) - (\_ -> putMVar stopSync ()) - let killAndWait = do - killThread inputThread - takeMVar stopSync - return $ input { shutdownInput = killAndWait } - where - append mDebugLog msg = - case mDebugLog of - Just debugLog -> appendFile debugLog $ msg ++ "\n" - Nothing -> return () + stopSync <- newEmptyMVar + mDefaultLog <- + catch + ( do + debugLog <- getEnv "VTY_DEBUG_LOG" + return $ Just debugLog + ) + (\(_ :: IOError) -> return Nothing) + input <- + Input + <$> atomically newTChan + <*> pure (return ()) + <*> pure (return ()) + <*> maybe + (return $ append mDefaultLog) + (return . appendFile) + (configDebugLog userConfig) + inputThread <- + forkOSFinally + (runInputProcessorLoop classifyTable input handle) + (\_ -> putMVar stopSync ()) + let killAndWait = do + killThread inputThread + takeMVar stopSync + return $ input {shutdownInput = killAndWait} + where + append mDebugLog msg = + case mDebugLog of + Just debugLog -> appendFile debugLog $ msg ++ "\n" + Nothing -> return () forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId forkOSFinally action and_then = @@ -191,5 +201,5 @@ (<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m () l <>= a = modify (l <>~ a) -(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t -l <>~ n = over l (`mappend` n) +(<>~) :: (Monoid a) => ASetter s t a a -> a -> s -> t +l <>~ n = over l (`mappend` n) diff --git a/src/Graphics/Vty/Platform/Windows/WindowsConsoleInput.hsc b/src/Graphics/Vty/Platform/Windows/WindowsConsoleInput.hsc deleted file mode 100644 --- a/src/Graphics/Vty/Platform/Windows/WindowsConsoleInput.hsc +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} - --- | This module provides a function to obtain input events from the Win32 API -module Graphics.Vty.Platform.Windows.WindowsConsoleInput - (KeyEventRecord(..), - MouseEventRecord(..), - WindowBufferSizeRecord(..), - MenuEventRecord(..), - FocusEventRecord(..), - WinConsoleInputEvent(..), - readConsoleInput) where - -import Control.Monad (foldM) -import Foreign.C.Types ( CWchar(..) ) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Storable (Storable(..)) -import GHC.Ptr ( Ptr ) -import System.Win32.Console -import System.Win32.Types -import System.IO (Handle) - -#include - -foreign import ccall unsafe "windows.h ReadConsoleInputW" cReadConsoleInput :: HANDLE -> Ptr WinConsoleInputEvent -> DWORD -> LPDWORD -> IO BOOL - --- | This type represents a keyboard input event. The structure is documented here: --- https://learn.microsoft.com/en-us/windows/console/key-event-record-str -data KeyEventRecord = KeyEventRecordC - { keyDown :: BOOL - , repeatCount :: WORD - , virtualKeyCode :: WORD - , virtualScanCode :: WORD - , uChar :: CWchar - , controlKeyStateK :: DWORD - } deriving (Eq, Show) - --- | This type represents a mouse event. The structure is documented here: --- https://learn.microsoft.com/en-us/windows/console/mouse-event-record-str -data MouseEventRecord = MouseEventRecordC - { mousePosition :: COORD - , buttonState :: DWORD - , controlKeyStateM :: DWORD - , eventFlags :: DWORD - } deriving (Eq, Show) - --- | This type represents a window size change event. The structure is documented here: --- https://learn.microsoft.com/en-us/windows/console/window-buffer-size-record-str -newtype WindowBufferSizeRecord = WindowBufferSizeRecordC - { windowSize :: COORD - } deriving (Eq, Show) - --- | This type represents a window menu event. (Current ignored by VTY). The structure --- is documented here: https://learn.microsoft.com/en-us/windows/console/menu-event-record-str -newtype MenuEventRecord = MenuEventRecordC - { commandId :: UINT - } deriving (Eq, Show) - --- | This type represents a window focus change event. The structure is documented here: --- https://learn.microsoft.com/en-us/windows/console/focus-event-record-str -newtype FocusEventRecord = FocusEventRecordC - { setFocus :: BOOL - } deriving (Eq, Show) - --- | Description of a Windows console input event. Documented here: --- https://learn.microsoft.com/en-us/windows/console/input-record-str -data WinConsoleInputEvent = - KeyEventRecordU KeyEventRecord - | MouseEventRecordU MouseEventRecord - | WindowBufferSizeRecordU WindowBufferSizeRecord - | MenuEventRecordU MenuEventRecord - | FocusEventRecordU FocusEventRecord - deriving (Eq, Show) - --- | A wrapper for the ReadConsoleInput Win32 API as documented here: --- https://learn.microsoft.com/en-us/windows/console/readconsoleinput -readConsoleInput :: Ptr WinConsoleInputEvent -> Int -> Handle -> IO [WinConsoleInputEvent] -readConsoleInput inputRecordPtr maxEvents handle = withHandleToHANDLE handle (readConsoleInput' inputRecordPtr maxEvents) - -readConsoleInput' :: Ptr WinConsoleInputEvent -> Int -> HANDLE -> IO [WinConsoleInputEvent] -readConsoleInput' inputRecordPtr maxEvents handle' = - alloca $ \numEventsReadPtr -> do - poke numEventsReadPtr 1 - _ <- cReadConsoleInput handle' inputRecordPtr (fromIntegral maxEvents) numEventsReadPtr - numEvents <- peek numEventsReadPtr - foldM addNextRecord [] [(fromIntegral numEvents - 1), (fromIntegral numEvents - 2)..0] - where - addNextRecord inputRecords idx = do - inputRecord <- peekElemOff inputRecordPtr idx - return (inputRecord:inputRecords) - -instance Storable KeyEventRecord where - sizeOf = const #{size KEY_EVENT_RECORD} - alignment _ = #alignment KEY_EVENT_RECORD - poke buf input = do - (#poke KEY_EVENT_RECORD, bKeyDown) buf (keyDown input) - (#poke KEY_EVENT_RECORD, wRepeatCount) buf (repeatCount input) - (#poke KEY_EVENT_RECORD, wVirtualKeyCode) buf (virtualKeyCode input) - (#poke KEY_EVENT_RECORD, wVirtualScanCode) buf (virtualScanCode input) - (#poke KEY_EVENT_RECORD, uChar) buf (uChar input) - (#poke KEY_EVENT_RECORD, dwControlKeyState) buf (controlKeyStateK input) - peek buf = do - keyDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) buf - repeatCount' <- (#peek KEY_EVENT_RECORD, wRepeatCount) buf - virtualKeyCode' <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) buf - virtualScanCode' <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) buf - uChar' <- (#peek KEY_EVENT_RECORD, uChar) buf - controlKeyStateK' <- (#peek KEY_EVENT_RECORD, dwControlKeyState) buf - return $ KeyEventRecordC keyDown' repeatCount' virtualKeyCode' virtualScanCode' uChar' controlKeyStateK' - -instance Storable MouseEventRecord where - sizeOf = const #{size MOUSE_EVENT_RECORD} - alignment _ = #alignment MOUSE_EVENT_RECORD - poke buf input = do - (#poke MOUSE_EVENT_RECORD, dwMousePosition) buf (mousePosition input) - (#poke MOUSE_EVENT_RECORD, dwButtonState) buf (buttonState input) - (#poke MOUSE_EVENT_RECORD, dwControlKeyState) buf (controlKeyStateM input) - (#poke MOUSE_EVENT_RECORD, dwEventFlags) buf (eventFlags input) - peek buf = do - mousePosition' <- (#peek MOUSE_EVENT_RECORD, dwMousePosition) buf - buttonState' <- (#peek MOUSE_EVENT_RECORD, dwButtonState) buf - controlKeyStateM' <- (#peek MOUSE_EVENT_RECORD, dwControlKeyState) buf - eventFlags' <- (#peek MOUSE_EVENT_RECORD, dwEventFlags) buf - return $ MouseEventRecordC mousePosition' buttonState' controlKeyStateM' eventFlags' - -instance Storable WindowBufferSizeRecord where - sizeOf = const #{size WINDOW_BUFFER_SIZE_RECORD} - alignment _ = #alignment WINDOW_BUFFER_SIZE_RECORD - poke buf input = do - (#poke WINDOW_BUFFER_SIZE_RECORD, dwSize) buf (windowSize input) - peek buf = do - size' <- (#peek WINDOW_BUFFER_SIZE_RECORD, dwSize) buf - return $ WindowBufferSizeRecordC size' - -instance Storable MenuEventRecord where - sizeOf = const #{size MENU_EVENT_RECORD} - alignment _ = #alignment MENU_EVENT_RECORD - poke buf input = do - (#poke MENU_EVENT_RECORD, dwCommandId) buf (commandId input) - peek buf = do - commandId' <- (#peek MENU_EVENT_RECORD, dwCommandId) buf - return $ MenuEventRecordC commandId' - -instance Storable FocusEventRecord where - sizeOf = const #{size FOCUS_EVENT_RECORD} - alignment _ = #alignment FOCUS_EVENT_RECORD - poke buf input = do - (#poke FOCUS_EVENT_RECORD, bSetFocus) buf (setFocus input) - peek buf = do - setFocus' <- (#peek FOCUS_EVENT_RECORD, bSetFocus) buf - return $ FocusEventRecordC setFocus' - -instance Storable WinConsoleInputEvent where - sizeOf = const #{size INPUT_RECORD} - alignment _ = #alignment INPUT_RECORD - - poke buf (KeyEventRecordU key) = do - (#poke INPUT_RECORD, EventType) buf (#{const KEY_EVENT} :: WORD) - (#poke INPUT_RECORD, Event) buf key - poke buf (MouseEventRecordU mouse) = do - (#poke INPUT_RECORD, EventType) buf (#{const MOUSE_EVENT} :: WORD) - (#poke INPUT_RECORD, Event) buf mouse - poke buf (WindowBufferSizeRecordU window) = do - (#poke INPUT_RECORD, EventType) buf (#{const WINDOW_BUFFER_SIZE_EVENT} :: WORD) - (#poke INPUT_RECORD, Event) buf window - poke buf (MenuEventRecordU menu) = do - (#poke INPUT_RECORD, EventType) buf (#{const MENU_EVENT} :: WORD) - (#poke INPUT_RECORD, Event) buf menu - poke buf (FocusEventRecordU focus) = do - (#poke INPUT_RECORD, EventType) buf (#{const FOCUS_EVENT} :: WORD) - (#poke INPUT_RECORD, Event) buf focus - - peek buf = do - event <- (#peek INPUT_RECORD, EventType) buf :: IO WORD - case event of - #{const KEY_EVENT} -> - KeyEventRecordU `fmap` (#peek INPUT_RECORD, Event) buf - #{const MOUSE_EVENT} -> - MouseEventRecordU `fmap` (#peek INPUT_RECORD, Event) buf - #{const WINDOW_BUFFER_SIZE_EVENT} -> - WindowBufferSizeRecordU `fmap` (#peek INPUT_RECORD, Event) buf - #{const MENU_EVENT} -> - MenuEventRecordU `fmap` (#peek INPUT_RECORD, Event) buf - #{const FOCUS_EVENT} -> - FocusEventRecordU `fmap` (#peek INPUT_RECORD, Event) buf - _ -> error $ "Unknown input event type " ++ show event diff --git a/src/Graphics/Vty/Platform/Windows/WindowsInterfaces.hs b/src/Graphics/Vty/Platform/Windows/WindowsInterfaces.hs --- a/src/Graphics/Vty/Platform/Windows/WindowsInterfaces.hs +++ b/src/Graphics/Vty/Platform/Windows/WindowsInterfaces.hs @@ -1,103 +1,138 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} +{-# LANGUAGE 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, + ( writeBuf, + readBuf, configureInput, - configureOutput - ) where - -#include "windows_cconv.h" - -import Graphics.Vty.Platform.Windows.WindowsConsoleInput -import Graphics.Vty.Input.Events (Event(EvResize), InternalEvent(InputEvent)) + configureOutput, + configureHandle + ) +where import Codec.Binary.UTF8.String (encodeChar) import Control.Concurrent (yield) import Control.Concurrent.STM (TChan, atomically, writeTChan) -import Control.Monad (foldM, when) -import Data.Bits ((.|.), (.&.), shiftL) +import Control.Monad (foldM, when, void) +import Data.Bits (shiftL, (.&.), (.|.)) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS8 import Data.Word (Word8) -import Foreign.Storable (Storable(..)) +import Foreign.Ptr (castPtr) +import Foreign.Storable (Storable (..)) import GHC.Ptr (Ptr) -import System.IO (Handle) -import System.Win32.Types (DWORD, HANDLE, withHandleToHANDLE, iNVALID_HANDLE_VALUE) +import Graphics.Vty.Input.Events (Event (EvResize), InternalEvent (InputEvent)) +import System.IO (Handle, hPutBufNonBlocking) import System.Win32.Console -import System.Win32.File hiding (copyFile) + ( COORD (..), + eNABLE_EXTENDED_FLAGS, + eNABLE_PROCESSED_OUTPUT, + eNABLE_VIRTUAL_TERMINAL_INPUT, + eNABLE_VIRTUAL_TERMINAL_PROCESSING, + getConsoleMode, + setConsoleMode, + setConsoleOutputCP, + KEY_EVENT_RECORD(..), + WINDOW_BUFFER_SIZE_RECORD(..), + INPUT_RECORD(..), + readConsoleInput + ) +import System.Win32.Event (waitForSingleObject) +import System.Win32.File + ( createFile, + fILE_SHARE_WRITE, + gENERIC_READ, + gENERIC_WRITE, + oPEN_EXISTING, + ) +import System.Win32.Types (HANDLE, iNVALID_HANDLE_VALUE, withHandleToHANDLE) -foreign import ccall "windows.h WaitForSingleObject" c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD +-- | Write a 'ByteString' to a Handle +writeBuf :: Handle -> ByteString -> IO () +writeBuf handle s = + BS8.useAsCStringLen s $ \(buf, len) -> do + void $ hPutBufNonBlocking handle (castPtr buf) (fromIntegral len) -- | 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 +-- 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 INPUT_RECORD -> Handle -> Ptr Word8 -> Int -> IO Int readBuf eventChannel inputEventPtr handle bufferPtr maxInputRecords = do - ret <- withHandleToHANDLE handle (`c_WaitForSingleObject` 500) - yield -- otherwise, the above foreign call causes the loop to never - -- respond to the killThread - if ret /= 0 + ret <- withHandleToHANDLE handle (`waitForSingleObject` 500) + yield -- otherwise, the above foreign call causes the loop to never + -- respond to the killThread + if ret /= 0 then readBuf eventChannel inputEventPtr handle bufferPtr maxInputRecords else readBuf' eventChannel inputEventPtr handle bufferPtr maxInputRecords -readBuf' :: TChan InternalEvent -> Ptr WinConsoleInputEvent -> Handle -> Ptr Word8 -> Int -> IO Int -readBuf' eventChannel inputEventPtr handle bufferPtr maxInputRecords = do - inputEvents <- readConsoleInput inputEventPtr maxInputRecords handle - (offset, _) <- foldM handleInputEvent (0, Nothing) inputEvents - return offset +readBuf' :: TChan InternalEvent -> Ptr INPUT_RECORD -> Handle -> Ptr Word8 -> Int -> IO Int +readBuf' eventChannel inputRecordPtr handle bufferPtr maxInputRecords = do + withHandleToHANDLE handle $ \handle' -> do + numEvents <- readConsoleInput handle' maxInputRecords inputRecordPtr + (numBytes, _) <- foldM handleInputEvent (0, Nothing) [0 .. (fromIntegral numEvents - 1)] + return numBytes where - handleInputEvent :: (Int, Maybe Int) -> WinConsoleInputEvent -> IO (Int, Maybe Int) - handleInputEvent (offset, mSurrogateVal) inputEvent = do - case inputEvent of - KeyEventRecordU (KeyEventRecordC isKeyDown _ _ _ cwChar _) -> do - -- Process the character if this is a 'key down' event, - -- AND the char is not NULL - if isKeyDown && cwChar /= 0 - then processCWChar (offset, mSurrogateVal) $ fromEnum cwChar - else return (offset, Nothing) - WindowBufferSizeRecordU (WindowBufferSizeRecordC (COORD x y)) -> do - let resize = EvResize (fromIntegral x) (fromIntegral y) - atomically $ writeTChan eventChannel (InputEvent resize) - return (offset, Nothing) - _ -> return (offset, Nothing) + handleInputEvent :: (Int, Maybe Int) -> Int -> IO (Int, Maybe Int) + handleInputEvent (offset, mSurrogateVal) idx = do + inputRecord <- peekElemOff inputRecordPtr idx + case inputRecord of + KeyEvent (KEY_EVENT_RECORD isKeyDown _ _ _ cwChar _) -> do + -- Process the character if this is a 'key down' event, AND the char is not NULL + if isKeyDown && cwChar /= 0 + then processCWChar (offset, mSurrogateVal) $ fromEnum cwChar + else return (offset, Nothing) + WindowBufferSizeEvent (WINDOW_BUFFER_SIZE_RECORD (COORD x y)) -> do + let resize = EvResize (fromIntegral x) (fromIntegral y) + atomically $ writeTChan eventChannel (InputEvent resize) + return (offset, Nothing) + _ -> return (offset, Nothing) - processCWChar :: (Int, Maybe Int) -> Int -> IO (Int, Maybe Int) - processCWChar (offset, Nothing) charVal = do - if isSurrogate charVal - then return (offset, Just charVal) - else encodeAndWriteToBuf offset charVal - where - isSurrogate :: Int -> Bool - isSurrogate c = 0xD800 <= c && c < 0xDC00 - processCWChar (offset, Just surogateVal) charVal = do - let charVal' = (((surogateVal .&. 0x3FF) `shiftL` 10) .|. (charVal .&. 0x3FF)) + 0x10000 - encodeAndWriteToBuf offset charVal' + processCWChar :: (Int, Maybe Int) -> Int -> IO (Int, Maybe Int) + processCWChar (offset, Nothing) charVal = do + if isSurrogate charVal + then return (offset, Just charVal) + else encodeAndWriteToBuf offset charVal + where + isSurrogate :: Int -> Bool + isSurrogate c = 0xD800 <= c && c < 0xDC00 + processCWChar (offset, Just surogateVal) charVal = do + let charVal' = (((surogateVal .&. 0x3FF) `shiftL` 10) .|. (charVal .&. 0x3FF)) + 0x10000 + encodeAndWriteToBuf offset charVal' - encodeAndWriteToBuf :: Int -> Int -> IO (Int, Maybe Int) - encodeAndWriteToBuf offset charVal = do - let utf8Char = encodeChar $ toEnum charVal - mapM_ (\(w, offset') -> pokeElemOff bufferPtr (offset + offset') w) $ zip utf8Char [0..] - return (offset + length utf8Char, Nothing) + encodeAndWriteToBuf :: Int -> Int -> IO (Int, Maybe Int) + encodeAndWriteToBuf offset charVal = do + let utf8Char = encodeChar $ toEnum charVal + mapM_ (\(w, offset') -> pokeElemOff bufferPtr (offset + offset') w) $ zip utf8Char [0 ..] + return (offset + length utf8Char, Nothing) -- | Configure Windows to correctly handle input for a Vty application configureInput :: Handle -> IO (IO (), IO ()) configureInput _ = do - inHandle <- configureHandle "CONIN$" - original <- getConsoleMode inHandle - let setMode = setConsoleMode inHandle $ eNABLE_VIRTUAL_TERMINAL_INPUT .|. eNABLE_EXTENDED_FLAGS - pure (setMode, setConsoleMode inHandle original) + inHandle <- configureHandle "CONIN$" + original <- getConsoleMode inHandle + let setMode = setConsoleMode inHandle $ eNABLE_VIRTUAL_TERMINAL_INPUT .|. eNABLE_EXTENDED_FLAGS + pure (setMode, setConsoleMode inHandle original) -- | Configure Windows to correctly handle output for a Vty application configureOutput :: Handle -> IO (IO ()) configureOutput _ = do - outHandle <- configureHandle "CONOUT$" - original <- getConsoleMode outHandle - setConsoleOutputCP 65001 - setConsoleMode outHandle $ eNABLE_VIRTUAL_TERMINAL_PROCESSING .|. eNABLE_PROCESSED_OUTPUT - pure (setConsoleMode outHandle original) + outHandle <- configureHandle "CONOUT$" + original <- getConsoleMode outHandle + setConsoleOutputCP 65001 + setConsoleMode outHandle $ eNABLE_VIRTUAL_TERMINAL_PROCESSING .|. eNABLE_PROCESSED_OUTPUT + pure $ setConsoleMode outHandle original configureHandle :: String -> IO HANDLE configureHandle handleName = do - outHandle <- createFile handleName (gENERIC_WRITE .|. gENERIC_READ) - fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing - when (outHandle == iNVALID_HANDLE_VALUE) $ fail $ "Unable to configure terminal for input/output with handle: " ++ handleName - return outHandle + outHandle <- + createFile + handleName + (gENERIC_WRITE .|. gENERIC_READ) + fILE_SHARE_WRITE + Nothing + oPEN_EXISTING + 0 + Nothing + when (outHandle == iNVALID_HANDLE_VALUE) $ fail $ "Unable to configure terminal for input/output with handle: " ++ handleName + return outHandle diff --git a/vty-windows.cabal b/vty-windows.cabal --- a/vty-windows.cabal +++ b/vty-windows.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: vty-windows -version: 0.2.0.3 +version: 0.2.0.4 license: BSD-3-Clause license-file: LICENSE author: Chris hackett @@ -11,7 +11,6 @@ build-type: Simple extra-doc-files: CHANGELOG.md extra-source-files: cbits/win_pseudo_console.c --- documentation: True source-repository head type: git @@ -42,7 +41,6 @@ Graphics.Vty.Platform.Windows.Output.Color Graphics.Vty.Platform.Windows.Settings Graphics.Vty.Platform.Windows.WindowsCapabilities - Graphics.Vty.Platform.Windows.WindowsConsoleInput Graphics.Vty.Platform.Windows.WindowsInterfaces build-depends: base >= 4.9 && < 5, blaze-builder, @@ -61,6 +59,6 @@ utf8-string, vector, vty >= 6.1, - Win32 >= 2.8.5.0, + Win32 >= 2.14.2 && < 2.14.3, hs-source-dirs: src default-language: Haskell2010