packages feed

vty-windows (empty) → 0.1.0.0

raw patch · 26 files changed

+2855/−0 lines, 26 filesdep +Win32dep +basedep +blaze-builder

Dependencies added: Win32, base, blaze-builder, bytestring, containers, deepseq, directory, filepath, microlens, microlens-mtl, microlens-th, mtl, parsec, stm, transformers, utf8-string, vector, vty

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for vty-windows
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License
+
+Copyright (c) 2023, Chris Hackett
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this
+   list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+   this list of conditions and the following disclaimer in the documentation
+   and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its
+   contributors may be used to endorse or promote products derived from
+   this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ cbits/win_commands.c view
@@ -0,0 +1,10 @@+#include <windows.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <wchar.h>
+
+int set_screen_size(int x, int y, HANDLE hOut)
+{
+    COORD coord = { x, y };
+    return SetConsoleScreenBufferSize(hOut, coord);
+}
+ cbits/win_pseudo_console.c view
@@ -0,0 +1,33 @@+#include <Windows.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <wchar.h>
+
+int create_pseudo_console(COORD size, HANDLE outputReadHandle, HANDLE inputWriteHandle)
+{
+    int result = S_OK;
+
+    // Create communication channels
+
+    // - Close these after CreateProcess of child application with pseudoconsole object.
+    HANDLE inputReadSide, outputWriteSide;
+
+    if (!CreatePipe(&inputReadSide, &inputWriteHandle, NULL, 0))
+    {
+        return result;
+        // return HRESULT_FROM_WIN32(GetLastError());
+    }
+
+    if (!CreatePipe(&outputReadHandle, &outputWriteSide, NULL, 0))
+    {
+        return result;
+        // return HRESULT_FROM_WIN32(GetLastError());
+    }
+
+    // TODO: Figure out how to call the CreatePseudoConsole function! Haskell compiler can't find HPCON and 
+    // CreatePseudoConsole. Maybe add HPCON and CreatePseudoConsole to the Win32 API?
+    // HPCON hPC;
+    // result = CreatePseudoConsole(size, inputReadSide, outputWriteSide, 0, &hPC);
+
+    return result;
+}
+ src/Data/Terminfo/Eval.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+-- | Evaluates the paramaterized terminfo string capability with the
+-- given parameters.
+module Data.Terminfo.Eval
+  ( writeCapExpr
+  )
+where
+
+import Blaze.ByteString.Builder.Word ( writeWord8 )
+import Blaze.ByteString.Builder ( Write )
+import Data.Terminfo.Parse
+
+import Control.Monad ( forM_ )
+import Control.Monad.State.Strict
+    ( MonadState(get, put), StateT(runStateT) )
+import Control.Monad.Writer
+    ( Writer, runWriter, MonadWriter(tell) )
+
+import Data.Bits ((.|.), (.&.), xor)
+import Data.List ( genericIndex )
+
+import qualified Data.Vector.Unboxed as Vector
+
+-- | capability evaluator state
+data EvalState = EvalState
+    { evalStack :: ![CapParam]
+    , evalExpression :: !CapExpression
+    , evalParams :: ![CapParam]
+    }
+
+type Eval a = StateT EvalState (Writer Write) a
+
+pop :: Eval CapParam
+pop = do
+    s <- get
+    (v, stack') <- case evalStack s of
+        [] -> error "BUG: Data.Terminfo.Eval.pop: failed to pop from empty stack"
+        v:s' -> return (v, s')
+    put s { evalStack = stack' }
+    return v
+
+readParam :: Word -> Eval CapParam
+readParam pn = do
+    !params <- evalParams <$> get
+    return $! genericIndex params pn
+
+push :: CapParam -> Eval ()
+push !v = do
+    s <- get
+    let s' = s { evalStack = v : evalStack s }
+    put s'
+
+applyParamOps :: CapExpression -> [CapParam] -> [CapParam]
+applyParamOps cap params = foldl applyParamOp params (paramOps cap)
+
+applyParamOp :: [CapParam] -> ParamOp -> [CapParam]
+applyParamOp params IncFirstTwo = map (+ 1) params
+
+writeCapExpr :: CapExpression -> [CapParam] -> Write
+writeCapExpr cap params =
+    let params' = applyParamOps cap params
+        s0 = EvalState [] cap params'
+    in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0)
+
+writeCapOps :: CapOps -> Eval ()
+writeCapOps = mapM_ writeCapOp
+
+writeCapOp :: CapOp -> Eval ()
+writeCapOp (Bytes !offset !count) = do
+    !cap <- evalExpression <$> get
+    let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
+    Vector.forM_ bytes $ tell.writeWord8
+writeCapOp DecOut = do
+    p <- pop
+    forM_ (show p) $ tell.writeWord8.toEnum.fromEnum
+writeCapOp CharOut = do
+    pop >>= tell.writeWord8.toEnum.fromEnum
+writeCapOp (PushParam pn) = do
+    readParam pn >>= push
+writeCapOp (PushValue v) = do
+    push v
+writeCapOp (Conditional expr parts) = do
+    writeCapOps expr
+    writeContitionalParts parts
+    where
+        writeContitionalParts [] = return ()
+        writeContitionalParts ((trueOps, falseOps) : falseParts) = do
+            -- (man 5 terminfo)
+            -- Usually the %? expr part pushes a value onto the stack,
+            -- and %t pops it from the stack, testing if it is nonzero
+            -- (true). If it is zero (false), control passes to the %e
+            -- (else) part.
+            v <- pop
+            if v /= 0
+                then writeCapOps trueOps
+                else do
+                    writeCapOps falseOps
+                    writeContitionalParts falseParts
+
+writeCapOp BitwiseOr = do
+    v0 <- pop
+    v1 <- pop
+    push $ v0 .|. v1
+writeCapOp BitwiseAnd = do
+    v0 <- pop
+    v1 <- pop
+    push $ v0 .&. v1
+writeCapOp BitwiseXOr = do
+    v1 <- pop
+    v0 <- pop
+    push $ v0 `xor` v1
+writeCapOp ArithPlus = do
+    v1 <- pop
+    v0 <- pop
+    push $ v0 + v1
+writeCapOp ArithMinus = do
+    v1 <- pop
+    v0 <- pop
+    push $ v0 - v1
+writeCapOp CompareEq = do
+    v1 <- pop
+    v0 <- pop
+    push $ if v0 == v1 then 1 else 0
+writeCapOp CompareLt = do
+    v1 <- pop
+    v0 <- pop
+    push $ if v0 < v1 then 1 else 0
+writeCapOp CompareGt = do
+    v1 <- pop
+    v0 <- pop
+    push $ if v0 > v1 then 1 else 0
+ src/Data/Terminfo/Parse.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -funbox-strict-fields -O #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+module Data.Terminfo.Parse
+  ( module Data.Terminfo.Parse
+  , Text.Parsec.ParseError
+  )
+where
+
+import Control.Monad ( liftM )
+import Control.DeepSeq
+
+#if !(MIN_VERSION_base(4,11,0))
+import Data.Semigroup (Semigroup(..))
+#endif
+import Data.Word
+import qualified Data.Vector.Unboxed as Vector
+
+import Numeric (showHex)
+
+import Text.Parsec
+
+data CapExpression = CapExpression
+    { capOps :: !CapOps
+    , capBytes :: !(Vector.Vector Word8)
+    , sourceString :: !String
+    , paramCount :: !Int
+    , paramOps :: !ParamOps
+    } deriving (Eq)
+
+instance Show CapExpression where
+    show c
+        = "CapExpression { " ++ show (capOps c) ++ " }"
+        ++ " <- [" ++ hexDump ( map ( toEnum . fromEnum ) $! sourceString c ) ++ "]"
+        ++ " <= " ++ show (sourceString c)
+        where
+            hexDump :: [Word8] -> String
+            hexDump = foldr showHex ""
+
+instance NFData CapExpression where
+    rnf (CapExpression ops !_bytes !str !c !pOps)
+        = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps
+
+type CapParam = Word
+
+type CapOps = [CapOp]
+data CapOp =
+      Bytes !Int !Int -- offset count
+    | DecOut | CharOut
+    -- This stores a 0-based index to the parameter. However the
+    -- operation that implies this op is 1-based
+    | PushParam !Word | PushValue !Word
+    -- The conditional parts are the sequence of (%t expression, %e
+    -- The expression) pairs. %e expression may be NOP
+    | Conditional
+      { conditionalExpr :: !CapOps
+      , conditionalParts :: ![(CapOps, CapOps)]
+      }
+    | BitwiseOr | BitwiseXOr | BitwiseAnd
+    | ArithPlus | ArithMinus
+    | CompareEq | CompareLt | CompareGt
+    deriving (Show, Eq)
+
+instance NFData CapOp where
+    rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount
+    rnf (PushParam pn) = rnf pn
+    rnf (PushValue v) = rnf v
+    rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts
+    rnf BitwiseOr = ()
+    rnf BitwiseXOr = ()
+    rnf BitwiseAnd = ()
+    rnf ArithPlus = ()
+    rnf ArithMinus = ()
+    rnf CompareEq = ()
+    rnf CompareLt = ()
+    rnf CompareGt = ()
+    rnf DecOut = ()
+    rnf CharOut = ()
+
+type ParamOps = [ParamOp]
+data ParamOp =
+      IncFirstTwo
+    deriving (Show, Eq)
+
+instance NFData ParamOp where
+    rnf IncFirstTwo = ()
+
+parseCapExpression :: String -> Either ParseError CapExpression
+parseCapExpression capString =
+    let v = runParser capExpressionParser
+                      initialBuildState
+                      "terminfo cap"
+                      capString
+    in case v of
+        Left e -> Left e
+        Right buildResults -> Right $ constructCapExpression capString buildResults
+
+constructCapExpression :: String -> BuildResults -> CapExpression
+constructCapExpression capString buildResults =
+    let expr = CapExpression
+                { capOps = outCapOps buildResults
+                -- The cap bytes are the lower 8 bits of the input
+                -- string's characters.
+                , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString
+                , sourceString = capString
+                , paramCount = outParamCount buildResults
+                , paramOps = outParamOps buildResults
+                }
+    in rnf expr `seq` expr
+
+type CapParser a = Parsec String BuildState a
+
+capExpressionParser :: CapParser BuildResults
+capExpressionParser = do
+    rs <- many $ paramEscapeParser <|> bytesOpParser
+    return $ mconcat rs
+
+paramEscapeParser :: CapParser BuildResults
+paramEscapeParser = do
+    _ <- char '%'
+    incOffset 1
+    literalPercentParser <|> paramOpParser
+
+literalPercentParser :: CapParser BuildResults
+literalPercentParser = do
+    _ <- char '%'
+    startOffset <- nextOffset <$> getState
+    incOffset 1
+    return $ BuildResults 0 [Bytes startOffset 1] []
+
+paramOpParser :: CapParser BuildResults
+paramOpParser
+    = incrementOpParser
+    <|> pushOpParser
+    <|> decOutParser
+    <|> charOutParser
+    <|> conditionalOpParser
+    <|> bitwiseOpParser
+    <|> arithOpParser
+    <|> literalIntOpParser
+    <|> compareOpParser
+    <|> charConstParser
+
+incrementOpParser :: CapParser BuildResults
+incrementOpParser = do
+    _ <- char 'i'
+    incOffset 1
+    return $ BuildResults 0 [] [ IncFirstTwo ]
+
+pushOpParser :: CapParser BuildResults
+pushOpParser = do
+    _ <- char 'p'
+    paramN <- read . pure <$> digit
+    incOffset 2
+    return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []
+
+decOutParser :: CapParser BuildResults
+decOutParser = do
+    _ <- char 'd'
+    incOffset 1
+    return $ BuildResults 0 [ DecOut ] []
+
+charOutParser :: CapParser BuildResults
+charOutParser = do
+    _ <- char 'c'
+    incOffset 1
+    return $ BuildResults 0 [ CharOut ] []
+
+conditionalOpParser :: CapParser BuildResults
+conditionalOpParser = do
+    _ <- char '?'
+    incOffset 1
+    condPart <- manyExpr conditionalTrueParser
+    parts <- manyP
+             ( do
+                truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser
+                                              , conditionalFalseParser
+                                              ]
+                falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser
+                                               , conditionalTrueParser
+                                               ]
+                return ( truePart, falsePart )
+             )
+             conditionalEndParser
+
+    let trueParts = map fst parts
+        falseParts = map snd parts
+        BuildResults n cond condParamOps = condPart
+
+    let n' = maximum $ n : map outParamCount trueParts
+        n'' = maximum $ n' : map outParamCount falseParts
+
+    let trueOps = map outCapOps trueParts
+        falseOps = map outCapOps falseParts
+        condParts = zip trueOps falseOps
+
+    let trueParamOps = mconcat $ map outParamOps trueParts
+        falseParamOps = mconcat $ map outParamOps falseParts
+        pOps = mconcat [condParamOps, trueParamOps, falseParamOps]
+
+    return $ BuildResults n'' [ Conditional cond condParts ] pOps
+
+    where
+        manyP !p !end = choice
+            [ try end >> return []
+            , do !v <- p
+                 !vs <- manyP p end
+                 return $! v : vs
+            ]
+        manyExpr end = liftM mconcat $ manyP ( paramEscapeParser <|> bytesOpParser ) end
+
+conditionalTrueParser :: CapParser ()
+conditionalTrueParser = do
+    _ <- string "%t"
+    incOffset 2
+
+conditionalFalseParser :: CapParser ()
+conditionalFalseParser = do
+    _ <- string "%e"
+    incOffset 2
+
+conditionalEndParser :: CapParser ()
+conditionalEndParser = do
+    _ <- string "%;"
+    incOffset 2
+
+bitwiseOpParser :: CapParser BuildResults
+bitwiseOpParser
+    =   bitwiseOrParser
+    <|> bitwiseAndParser
+    <|> bitwiseXorParser
+
+bitwiseOrParser :: CapParser BuildResults
+bitwiseOrParser = do
+    _ <- char '|'
+    incOffset 1
+    return $ BuildResults 0 [ BitwiseOr ] [ ]
+
+bitwiseAndParser :: CapParser BuildResults
+bitwiseAndParser = do
+    _ <- char '&'
+    incOffset 1
+    return $ BuildResults 0 [ BitwiseAnd ] [ ]
+
+bitwiseXorParser :: CapParser BuildResults
+bitwiseXorParser = do
+    _ <- char '^'
+    incOffset 1
+    return $ BuildResults 0 [ BitwiseXOr ] [ ]
+
+arithOpParser :: CapParser BuildResults
+arithOpParser
+    =   plusOp
+    <|> minusOp
+    where
+        plusOp = do
+            _ <- char '+'
+            incOffset 1
+            return $ BuildResults 0 [ ArithPlus ] [ ]
+        minusOp = do
+            _ <- char '-'
+            incOffset 1
+            return $ BuildResults 0 [ ArithMinus ] [ ]
+
+literalIntOpParser :: CapParser BuildResults
+literalIntOpParser = do
+    _ <- char '{'
+    incOffset 1
+    nStr <- many1 digit
+    incOffset $ toEnum $ length nStr
+    let n :: Word = read nStr
+    _ <- char '}'
+    incOffset 1
+    return $ BuildResults 0 [ PushValue n ] [ ]
+
+compareOpParser :: CapParser BuildResults
+compareOpParser
+    =   compareEqOp
+    <|> compareLtOp
+    <|> compareGtOp
+    where
+        compareEqOp = do
+            _ <- char '='
+            incOffset 1
+            return $ BuildResults 0 [ CompareEq ] [ ]
+        compareLtOp = do
+            _ <- char '<'
+            incOffset 1
+            return $ BuildResults 0 [ CompareLt ] [ ]
+        compareGtOp = do
+            _ <- char '>'
+            incOffset 1
+            return $ BuildResults 0 [ CompareGt ] [ ]
+
+bytesOpParser :: CapParser BuildResults
+bytesOpParser = do
+    bytes <- many1 $ satisfy (/= '%')
+    startOffset <- nextOffset <$> getState
+    let !c = length bytes
+    !s <- getState
+    let s' = s { nextOffset = startOffset + c }
+    setState s'
+    return $ BuildResults 0 [Bytes startOffset c] []
+
+charConstParser :: CapParser BuildResults
+charConstParser = do
+    _ <- char '\''
+    charValue <- liftM (toEnum . fromEnum) anyChar
+    _ <- char '\''
+    incOffset 3
+    return $ BuildResults 0 [ PushValue charValue ] [ ]
+
+data BuildState = BuildState
+    { nextOffset :: Int
+    }
+
+incOffset :: Int -> CapParser ()
+incOffset n = do
+    s <- getState
+    let s' = s { nextOffset = nextOffset s + n }
+    setState s'
+
+initialBuildState :: BuildState
+initialBuildState = BuildState 0
+
+data BuildResults = BuildResults
+    { outParamCount :: !Int
+    , outCapOps :: !CapOps
+    , outParamOps :: !ParamOps
+    }
+
+instance Semigroup BuildResults where
+    v0 <> v1
+        = BuildResults
+        { outParamCount = outParamCount v0 `max` outParamCount v1
+        , outCapOps = outCapOps v0 <> outCapOps v1
+        , outParamOps = outParamOps v0 <> outParamOps v1
+        }
+
+instance Monoid BuildResults where
+    mempty = BuildResults 0 [] []
+#if !(MIN_VERSION_base(4,11,0))
+    mappend = (<>)
+#endif
+ src/Graphics/Vty/Platform/Windows.hs view
@@ -0,0 +1,42 @@+-- | Provides function to initialize the Vty data structure. This is the entry
+-- point for Vty applications developed for Windows. In cross-platform
+-- development however, users should use the Graphics.Vty.CrossPlatform module
+-- instead.
+module Graphics.Vty.Platform.Windows
+  ( mkVty,
+    mkVtyWithSettings
+  )
+where
+
+import Control.Monad (when)
+
+import Graphics.Vty (Vty, installCustomWidthTable, mkVtyFromPair)
+
+import Graphics.Vty.Config (VtyUserConfig(..))
+import Graphics.Vty.Platform.Windows.Settings
+    ( defaultSettings, WindowsSettings(settingTermName) )
+import Graphics.Vty.Platform.Windows.Input ( buildInput )
+import Graphics.Vty.Platform.Windows.Output ( buildOutput )
+
+-- | Given a user configuration, initialize the Vty environment
+mkVty :: VtyUserConfig -> IO Vty
+mkVty userConfig = mkVtyWithSettings userConfig =<< defaultSettings
+
+-- | Create a Vty handle. At most one handle should be created at a time
+-- for a given terminal device.
+--
+-- The specified configuration is added to the the configuration
+-- loaded by 'userConfig' with the 'userConfig' configuration taking
+-- precedence. See "Graphics.Vty.Config".
+--
+-- For most applications @mkVty defaultConfig@ is sufficient.
+mkVtyWithSettings :: VtyUserConfig -> WindowsSettings -> IO Vty
+mkVtyWithSettings userConfig settings = do
+    when (configAllowCustomUnicodeWidthTables userConfig /= Just False) $
+        installCustomWidthTable (configDebugLog userConfig)
+                                (Just $ settingTermName settings)
+                                (configTermWidthMaps userConfig)
+
+    input <- buildInput userConfig settings
+    out <- buildOutput settings
+    mkVtyFromPair input out
+ src/Graphics/Vty/Platform/Windows/Input.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE RecordWildCards, CPP #-}
+
+-- | This module provides the input layer for Vty, including methods
+-- for initializing an 'Input' structure and reading 'Event's from the
+-- terminal.
+--
+-- Note that due to the evolution of terminal emulators, some keys
+-- and combinations will not reliably map to the expected events by
+-- any terminal program. There is no 1:1 mapping from key events to
+-- bytes read from the terminal input device. In very limited cases the
+-- terminal and vty's input process can be customized to resolve these
+-- issues; see "Graphics.Vty.Config" for how to configure vty's input
+-- processing.
+--
+-- = VTY's Implementation
+--
+-- There are two input modes:
+--
+--  1. 7-bit
+--
+--  2. 8-bit
+--
+-- The 7-bit input mode is the default and the expected mode in most use
+-- cases. This is what Vty uses.
+--
+-- == 7-bit input encoding
+--
+-- Control key combinations are represented by masking the two high bits
+-- of the 7-bit input. Historically the control key actually grounded
+-- the two high bit wires: 6 and 7. This is why control key combos
+-- map to single character events: the input bytes are identical. The
+-- input byte is the bit encoding of the character with bits 6 and 7
+-- masked. Bit 6 is set by shift. Bit 6 and 7 are masked by control. For
+-- example,
+--
+-- * Control-I is 'i', `01101001`, and has bit 6 and 7 masked to become
+-- `00001001`, which is the ASCII and UTF-8 encoding of the Tab key.
+--
+-- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero
+-- which is `0000011` and is the "End of Text" code.
+--
+-- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: this
+-- is the value 1 with bit 7 set and 6 unset.
+--
+-- * Hypothesis: Bit 6 is unset by upper case letters because,
+-- initially, there were only upper case letters used and a 5 bit
+-- encoding.
+--
+-- == 8-bit encoding
+--
+-- The 8th bit was originally used for parity checking which is useless
+-- for terminal emulators. Some terminal emulators support an 8-bit
+-- input encoding. While this provides some advantages, the actual usage
+-- is low. Most systems use 7-bit mode but recognize 8-bit control
+-- characters when escaped. This is what Vty does.
+--
+-- == Escaped Control Keys
+--
+-- Using 7-bit input encoding, the @ESC@ byte can signal the start of
+-- an encoded control key. To differentiate a single @ESC@ event from a
+-- control key, the timing of the input is used.
+--
+-- 1. @ESC@ individually: @ESC@ byte; no bytes following for a period of
+-- 'VMIN' milliseconds.
+--
+-- 2. Control keys that contain @ESC@ in their encoding: The @ESC byte
+-- is followed by more bytes read within 'VMIN' milliseconds. All bytes
+-- up until the next valid input block are passed to the classifier.
+--
+-- If the current runtime is the threaded runtime then the terminal's
+-- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If
+-- the current runtime does not support 'forkOS' then there is currently
+-- no implementation.
+--
+-- == Unicode Input and Escaped Control Key Sequences
+--
+-- The input encoding determines how UTF-8 encoded characters are
+-- recognized.
+--
+-- * 7-bit mode: UTF-8 can be input unambiguously. UTF-8 input is
+-- a superset of ASCII. UTF-8 does not overlap escaped control key
+-- sequences. However, the escape key must be differentiated from
+-- escaped control key sequences by the timing of the input bytes.
+--
+-- * 8-bit mode: UTF-8 cannot be input unambiguously. This does not
+-- require using the timing of input bytes to differentiate the escape
+-- key. Many terminals do not support 8-bit mode.
+--
+-- == Terminfo
+--
+-- The terminfo system is used to determine how some keys are encoded.
+-- Terminfo is incomplete and in some cases terminfo is incorrect. Vty
+-- assumes terminfo is correct but provides a mechanism to override
+-- terminfo; see "Graphics.Vty.Config", specifically 'inputOverrides'.
+--
+-- == Terminal Input is Broken
+--
+-- Clearly terminal input has fundamental issues. There is no easy way
+-- to reliably resolve these issues.
+--
+-- One resolution would be to ditch standard terminal interfaces
+-- entirely and just go directly to scancodes. This would be a
+-- reasonable option for Vty if everybody used the linux kernel console
+-- but for obvious reasons this is not possible.
+--
+-- The "Graphics.Vty.Config" module supports customizing the
+-- input-byte-to-event mapping and xterm supports customizing the
+-- scancode-to-input-byte mapping. With a lot of work a user's system
+-- can be set up to encode all the key combos in an almost-sane manner.
+--
+-- == See also
+--
+-- * http://www.leonerd.org.uk/hacks/fixterms/
+module Graphics.Vty.Platform.Windows.Input
+  ( buildInput
+  )
+where
+
+import Graphics.Vty.Config ( VtyUserConfig(..) )
+import Graphics.Vty.Input ( Input(restoreInputState, shutdownInput) )
+import Graphics.Vty.Platform.Windows.Input.Loop ( initInput )
+import Graphics.Vty.Platform.Windows.Input.Terminfo ( classifyMapForTerm )
+import Graphics.Vty.Platform.Windows.Settings
+    ( WindowsSettings(settingInputFd, settingTermName) )
+import Graphics.Vty.Platform.Windows.WindowsInterfaces ( configureInput )
+
+import Data.Maybe ( isNothing )
+
+-- | Set up the terminal with file descriptor `inputFd` for input.
+-- Returns an 'Input'.
+--
+-- The table used to determine the 'Events' to produce for the input
+-- bytes comes from 'classifyMapForTerm' which is then overridden by
+-- the the applicable entries from the configuration's 'inputMap'.
+--
+-- The terminal device's mode flags are configured by the
+-- 'attributeControl' function.
+buildInput :: VtyUserConfig -> WindowsSettings -> IO Input
+buildInput userConfig settings = do
+    let tName = settingTermName settings
+        handle = settingInputFd settings
+
+    let inputOverrides = [(s,e) | (t,s,e) <- configInputMap userConfig, isNothing t || t == Just tName]
+        activeInputMap = classifyMapForTerm `mappend` inputOverrides
+    (setAttrs, unsetAttrs) <- configureInput handle
+    setAttrs
+    input <- initInput userConfig handle activeInputMap
+
+    return $ input
+        { shutdownInput = do
+            shutdownInput input
+            unsetAttrs
+        , restoreInputState = restoreInputState input >> unsetAttrs
+        }
+ src/Graphics/Vty/Platform/Windows/Input/Classify.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_HADDOCK hide #-}
+-- This makes a kind of trie. Has space efficiency issues with large
+-- input blocks. Likely building a parser and just applying that would
+-- be better.
+module Graphics.Vty.Platform.Windows.Input.Classify
+  ( classify
+  )
+where
+
+import Graphics.Vty.Input.Events
+
+import Graphics.Vty.Platform.Windows.Input.Classify.Types
+import Graphics.Vty.Platform.Windows.Input.Mouse
+import Graphics.Vty.Platform.Windows.Input.Focus
+import Graphics.Vty.Platform.Windows.Input.Paste
+
+import Codec.Binary.UTF8.Generic (decode)
+
+import Control.Arrow (first)
+import qualified Data.Map as M( fromList, lookup )
+import Data.Maybe ( mapMaybe )
+import qualified Data.Set as S( fromList, member )
+
+import Data.Word
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import Data.ByteString.Char8 (ByteString)
+
+compile :: ClassifyMap -> ByteString -> KClass
+compile table = cl' where
+    -- take all prefixes and create a set of these
+    prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table
+    maxValidInputLength = maximum (map (length . fst) table)
+    eventForInput = M.fromList $ map (first BS8.pack) table
+    cl' inputBlock | BS8.null inputBlock = Prefix
+    cl' inputBlock = case M.lookup inputBlock eventForInput of
+            -- if the inputBlock is exactly what is expected for an
+            -- event then consume the whole block and return the event
+            Just e -> Valid e BS8.empty
+            Nothing ->
+                if S.member inputBlock prefixSet
+                then Prefix
+                -- look up progressively smaller tails of the input
+                -- block until an event is found The assumption is that
+                -- the event that consumes the most input bytes should
+                -- be produced.
+                -- The test verifyFullSynInputToEvent2x verifies this.
+                -- H: There will always be one match. The prefixSet
+                -- contains, by definition, all prefixes of an event.
+                else
+                    let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock
+                    in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
+                        (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)
+                        -- neither a prefix or a full event.
+                        [] -> Invalid
+
+classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass
+classify table = process
+    where
+        standardClassifier = compile table
+
+        process ClassifierStart s =
+            case BS.uncons s of
+                _ | bracketedPasteStarted s ->
+                    if bracketedPasteFinished s
+                    then parseBracketedPaste s
+                    else Chunk
+                _ | isMouseEvent s      -> classifyMouseEvent s
+                _ | isFocusEvent s      -> classifyFocusEvent s
+                Just (c,cs) | c >= 0xC2 -> classifyUtf8 c cs
+                _                       -> standardClassifier s
+
+        process (ClassifierInChunk p ps) s | bracketedPasteStarted p =
+            if bracketedPasteFinished s
+            then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)
+            else Chunk
+        process ClassifierInChunk{} _ = Invalid
+
+classifyUtf8 :: Word8 -> ByteString -> KClass
+classifyUtf8 c cs =
+  let n = utf8Length c
+      (codepoint,rest) = BS8.splitAt (n - 1) cs
+
+      codepoint8 :: [Word8]
+      codepoint8 = c:BS.unpack codepoint
+
+  in case decode codepoint8 of
+       _ | n < BS.length codepoint + 1 -> Prefix
+       Just (unicodeChar, _)           -> Valid (EvKey (KChar unicodeChar) []) rest
+       -- something bad happened; just ignore and continue.
+       Nothing                         -> Invalid
+
+utf8Length :: Word8 -> Int
+utf8Length c
+    | c < 0x80 = 1
+    | c < 0xE0 = 2
+    | c < 0xF0 = 3
+    | otherwise = 4
+ src/Graphics/Vty/Platform/Windows/Input/Classify/Parse.hs view
@@ -0,0 +1,64 @@+-- | This module provides a simple parser for parsing input event
+-- control sequences.
+module Graphics.Vty.Platform.Windows.Input.Classify.Parse
+  ( Parser
+  , runParser
+  , failParse
+  , readInt
+  , readChar
+  , expectChar
+  )
+where
+
+import Control.Monad (unless)
+import Control.Monad.Trans.Maybe ( MaybeT(runMaybeT) )
+import Control.Monad.State
+    ( MonadState(put, get), State, runState )
+
+import qualified Data.ByteString.Char8 as BS8
+import Data.ByteString.Char8 (ByteString)
+import Graphics.Vty.Input.Events ( Event )
+import Graphics.Vty.Platform.Windows.Input.Classify.Types
+    ( KClass(Valid, Invalid) )
+
+-- | Represents current state of parsing input data
+type Parser a = MaybeT (State ByteString) a
+
+-- | Run a parser on a given input string. If the parser fails, return
+-- 'Invalid'. Otherwise return the valid event ('Valid') and the
+-- remaining unparsed characters.
+runParser :: ByteString -> Parser Event -> KClass
+runParser s parser =
+    case runState (runMaybeT parser) s of
+        (Nothing, _)        -> Invalid
+        (Just e, remaining) -> Valid e remaining
+
+-- | Fail a parsing operation.
+failParse :: Parser a
+failParse = fail "invalid parse"
+
+-- | Read an integer from the input stream. If an integer cannot be
+-- read, fail parsing. E.g. calling readInt on an input of "123abc" will
+-- return '123' and consume those characters.
+readInt :: Parser Int
+readInt = do
+    s <- BS8.unpack <$> get
+    case (reads :: ReadS Int) s of
+        [(i, rest)] -> put (BS8.pack rest) >> return i
+        _ -> failParse
+
+-- | Read a character from the input stream. If one cannot be read (e.g.
+-- we are out of characters), fail parsing.
+readChar :: Parser Char
+readChar = do
+    s <- get
+    case BS8.uncons s of
+        Just (c,rest) -> put rest >> return c
+        Nothing -> failParse
+
+-- | Read a character from the input stream and fail parsing if it is
+-- not the specified character.
+expectChar :: Char -> Parser ()
+expectChar c = do
+    c' <- readChar
+    unless (c' == c) failParse
+ src/Graphics/Vty/Platform/Windows/Input/Classify/Types.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE StrictData #-}
+
+-- | This module exports the input classification type to avoid import
+-- cycles between other modules that need this.
+module Graphics.Vty.Platform.Windows.Input.Classify.Types
+  ( KClass(..)
+  , ClassifierState(..)
+  )
+where
+
+import Data.ByteString.Char8 (ByteString)
+import Graphics.Vty.Input.Events ( Event )
+
+-- | Whether the classifier is currently processing a chunked format.
+-- Currently, only bracketed pastes use this.
+data ClassifierState
+    = ClassifierStart
+    -- ^ Not processing a chunked format.
+    | ClassifierInChunk ByteString [ByteString]
+    -- ^ Currently processing a chunked format. The initial chunk is in the
+    -- first argument and a reversed remainder of the chunks is collected in
+    -- the second argument. At the end of the processing, the chunks are
+    -- reversed and concatenated with the final chunk.
+
+-- | Description of parsed input sequences, including state for valid key,
+-- mouse, and window events plus invalid and partial events.
+data KClass
+    = Valid Event ByteString
+    -- ^ A valid event was parsed. Any unused characters from the input
+    -- stream are also provided.
+    | Invalid
+    -- ^ The input characters did not represent a valid event.
+    | Prefix
+    -- ^ The input characters form the prefix of a valid event character
+    -- sequence.
+    | Chunk
+    -- ^ The input characters are either start of a bracketed paste chunk
+    -- or in the middle of a bracketed paste chunk.
+    deriving(Show, Eq)
+ src/Graphics/Vty/Platform/Windows/Input/Focus.hs view
@@ -0,0 +1,53 @@+-- | Escape sequences for focus events and some focus related functions
+module Graphics.Vty.Platform.Windows.Input.Focus
+  ( requestFocusEvents
+  , disableFocusEvents
+  , isFocusEvent
+  , classifyFocusEvent
+  )
+where
+
+import Graphics.Vty.Input.Events
+    ( Event(EvLostFocus, EvGainedFocus) )
+import Graphics.Vty.Platform.Windows.Input.Classify.Types
+    ( KClass )
+import Graphics.Vty.Platform.Windows.Input.Classify.Parse
+    ( expectChar, failParse, readChar, runParser )
+
+import Control.Monad ( when )
+
+import qualified Data.ByteString.Char8 as BS8
+import Data.ByteString.Char8 (ByteString)
+
+-- | These sequences set xterm-based terminals to send focus event
+-- sequences.
+requestFocusEvents :: ByteString
+requestFocusEvents = BS8.pack "\ESC[?1004h"
+
+-- | These sequences disable focus events.
+disableFocusEvents :: ByteString
+disableFocusEvents = BS8.pack "\ESC[?1004l"
+
+-- | Does the specified string begin with a focus event?
+isFocusEvent :: ByteString -> Bool
+isFocusEvent s = BS8.isPrefixOf focusIn s ||
+                 BS8.isPrefixOf focusOut s
+
+focusIn :: ByteString
+focusIn = BS8.pack "\ESC[I"
+
+focusOut :: ByteString
+focusOut = BS8.pack "\ESC[O"
+
+-- | Attempt to classify an input string as a focus event.
+classifyFocusEvent :: ByteString -> KClass
+classifyFocusEvent s = runParser s $ do
+    when (not $ isFocusEvent s) failParse
+
+    expectChar '\ESC'
+    expectChar '['
+    ty <- readChar
+    case ty of
+        'I' -> return EvGainedFocus
+        'O' -> return EvLostFocus
+        _   -> failParse
+ src/Graphics/Vty/Platform/Windows/Input/Loop.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# 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
+  )
+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.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_)
+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 qualified Data.ByteString as BS
+import Data.ByteString.Char8 (ByteString)
+import Data.Word (Word8)
+
+import Foreign (allocaArray)
+import Foreign.Ptr (Ptr, castPtr)
+
+import System.Environment (getEnv)
+import System.IO ( Handle )
+
+data InputBuffer = InputBuffer
+    { _ptr :: Ptr Word8
+    , _inputRecordPtr :: Ptr WinConsoleInputEvent
+    , _consoleEventBufferSize :: Int
+    }
+
+makeLenses ''InputBuffer
+
+data InputState = InputState
+    { _unprocessedBytes :: ByteString
+    , _classifierState :: ClassifierState
+    , _inputHandle :: Handle
+    , _originalInput :: Input
+    , _inputBuffer :: InputBuffer
+    , _classifier :: ClassifierState -> ByteString -> KClass
+    }
+
+makeLenses ''InputState
+
+type InputM a = StateT InputState (ReaderT Input IO) a
+
+logMsg :: String -> InputM ()
+logMsg msg = do
+    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
+
+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)
+
+-- 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
+
+    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
+
+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
+
+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 ()
+
+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
+
+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 ()
+
+forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
+forkOSFinally action and_then =
+  mask $ \restore -> forkOS $ try (restore action) >>= and_then
+
+(<>=) :: (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)
+ src/Graphics/Vty/Platform/Windows/Input/Mouse.hs view
@@ -0,0 +1,163 @@+-- | This module provides parsers for mouse events for both "normal" and
+-- "extended" modes. This implementation was informed by
+--
+-- http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking
+module Graphics.Vty.Platform.Windows.Input.Mouse
+  ( requestMouseEvents
+  , disableMouseEvents
+  , isMouseEvent
+  , classifyMouseEvent
+  )
+where
+
+import Graphics.Vty.Input.Events
+import Graphics.Vty.Platform.Windows.Input.Classify.Types
+import Graphics.Vty.Platform.Windows.Input.Classify.Parse
+
+import Control.Monad
+import Data.Maybe (catMaybes)
+import Data.Bits ((.&.))
+
+import qualified Data.ByteString.Char8 as BS8
+import Data.ByteString.Char8 (ByteString)
+
+-- A mouse event in SGR extended mode is
+--
+-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')
+--
+-- where
+--
+-- * B is the number with button and modifier bits set,
+-- * X is the X coordinate of the event starting at 1
+-- * Y is the Y coordinate of the event starting at 1
+-- * the final character is 'M' for a press, 'm' for a release
+
+-- | These sequences set xterm-based terminals to send mouse event
+-- sequences.
+requestMouseEvents :: ByteString
+requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h"
+
+-- | These sequences disable mouse events.
+disableMouseEvents :: ByteString
+disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l"
+
+-- | Does the specified string begin with a mouse event?
+isMouseEvent :: ByteString -> Bool
+isMouseEvent s = isSGREvent s || isNormalEvent s
+
+isSGREvent :: ByteString -> Bool
+isSGREvent = BS8.isPrefixOf sgrPrefix
+
+sgrPrefix :: ByteString
+sgrPrefix = BS8.pack "\ESC[M"
+
+isNormalEvent :: ByteString -> Bool
+isNormalEvent = BS8.isPrefixOf normalPrefix
+
+normalPrefix :: ByteString
+normalPrefix = BS8.pack "\ESC[<"
+
+-- Modifier bits:
+shiftBit :: Int
+shiftBit = 4
+
+metaBit :: Int
+metaBit = 8
+
+ctrlBit :: Int
+ctrlBit = 16
+
+-- These bits indicate the buttons involved:
+buttonMask :: Int
+buttonMask = 67
+
+leftButton :: Int
+leftButton = 0
+
+middleButton :: Int
+middleButton = 1
+
+rightButton :: Int
+rightButton = 2
+
+scrollUp :: Int
+scrollUp = 64
+
+scrollDown :: Int
+scrollDown = 65
+
+hasBitSet :: Int -> Int -> Bool
+hasBitSet val bit = val .&. bit > 0
+
+-- | Attempt to classify an input string as a mouse event.
+classifyMouseEvent :: ByteString -> KClass
+classifyMouseEvent s = runParser s $ do
+    when (not $ isMouseEvent s) failParse
+
+    expectChar '\ESC'
+    expectChar '['
+    ty <- readChar
+    case ty of
+        '<' -> classifySGRMouseEvent
+        'M' -> classifyNormalMouseEvent
+        _   -> failParse
+
+-- Given a modifier/button value, determine which button was indicated
+getSGRButton :: Int -> Parser Button
+getSGRButton mods =
+    let buttonMap = [ (leftButton,   BLeft)
+                    , (middleButton, BMiddle)
+                    , (rightButton,  BRight)
+                    , (scrollUp,     BScrollUp)
+                    , (scrollDown,   BScrollDown)
+                    ]
+    in case lookup (mods .&. buttonMask) buttonMap of
+        Nothing -> failParse
+        Just b -> return b
+
+getModifiers :: Int -> [Modifier]
+getModifiers mods =
+    catMaybes [ if mods `hasBitSet` shiftBit then Just MShift else Nothing
+              , if mods `hasBitSet` metaBit  then Just MMeta  else Nothing
+              , if mods `hasBitSet` ctrlBit  then Just MCtrl  else Nothing
+              ]
+
+-- Attempt to classify a control sequence as a "normal" mouse event. To
+-- get here we should have already read "\ESC[M" so that will not be
+-- included in the string to be parsed.
+classifyNormalMouseEvent :: Parser Event
+classifyNormalMouseEvent = do
+    statusChar <- readChar
+    xCoordChar <- readChar
+    yCoordChar <- readChar
+
+    let xCoord = fromEnum xCoordChar - 32
+        yCoord = fromEnum yCoordChar - 32
+        status = fromEnum statusChar
+        modifiers = getModifiers status
+
+    let press = status .&. buttonMask /= 3
+    case press of
+            True -> do
+                button <- getSGRButton status
+                return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers
+            False -> return $ EvMouseUp (xCoord-1) (yCoord-1) Nothing
+
+-- Attempt to classify a control sequence as an SGR mouse event. To
+-- get here we should have already read "\ESC[<" so that will not be
+-- included in the string to be parsed.
+classifySGRMouseEvent :: Parser Event
+classifySGRMouseEvent = do
+    mods <- readInt
+    expectChar ';'
+    xCoord <- readInt
+    expectChar ';'
+    yCoord <- readInt
+    final <- readChar
+
+    let modifiers = getModifiers mods
+    button <- getSGRButton mods
+    case final of
+        'M' -> return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers
+        'm' -> return $ EvMouseUp   (xCoord-1) (yCoord-1) (Just button)
+        _ -> failParse
+ src/Graphics/Vty/Platform/Windows/Input/Paste.hs view
@@ -0,0 +1,41 @@+-- | This module provides bracketed paste support as described at
+--
+-- http://cirw.in/blog/bracketed-paste
+module Graphics.Vty.Platform.Windows.Input.Paste
+  ( parseBracketedPaste
+  , bracketedPasteStarted
+  , bracketedPasteFinished
+  )
+where
+
+import qualified Data.ByteString.Char8 as BS8
+import Data.ByteString.Char8 (ByteString)
+
+import Graphics.Vty.Input.Events
+import Graphics.Vty.Platform.Windows.Input.Classify.Types
+
+bracketedPasteStart :: ByteString
+bracketedPasteStart = BS8.pack "\ESC[200~"
+
+bracketedPasteEnd :: ByteString
+bracketedPasteEnd = BS8.pack "\ESC[201~"
+
+-- | Does the input start a bracketed paste?
+bracketedPasteStarted :: ByteString -> Bool
+bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart
+
+-- | Does the input contain a complete bracketed paste?
+bracketedPasteFinished :: ByteString -> Bool
+bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd
+
+-- | Parse a bracketed paste. This should only be called on a string if
+-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return
+-- 'True'.
+parseBracketedPaste :: ByteString -> KClass
+parseBracketedPaste s =
+    Valid (EvPaste p) (BS8.drop endLen rest')
+    where
+        startLen = BS8.length bracketedPasteStart
+        endLen   = BS8.length bracketedPasteEnd
+        (_, rest ) = BS8.breakSubstring bracketedPasteStart s
+        (p, rest') = BS8.breakSubstring bracketedPasteEnd . BS8.drop startLen $ rest
+ src/Graphics/Vty/Platform/Windows/Input/Terminfo.hs view
@@ -0,0 +1,81 @@+-- | This module provides mappings for keyboard characters and modification keys to VTY event values
+module Graphics.Vty.Platform.Windows.Input.Terminfo
+  ( classifyMapForTerm
+  , universalTable
+  , commonVisibleChars
+  , specialSupportKeys
+  )
+where
+
+import Data.Maybe (mapMaybe)
+import Graphics.Vty.Input.Events
+import qualified Graphics.Vty.Platform.Windows.Input.Terminfo.ANSIVT as ANSIVT
+
+-- | Builds input sequences for all VT sequences available on Windows
+classifyMapForTerm :: ClassifyMap
+classifyMapForTerm =
+    concat $ universalTable
+           : ANSIVT.classifyTable
+
+-- | Combined tables.
+universalTable :: ClassifyMap
+universalTable = concat
+    [ commonVisibleChars
+    , metaChars
+    , otherVisibleChars
+    , ctrlChars
+    , ctrlMetaChars
+    , specialSupportKeys
+    ]
+
+-- | Visible characters in the ISO-8859-1 and UTF-8 common set up to
+-- but not including those in the range 0xA1 to 0xC1
+commonVisibleChars :: ClassifyMap
+commonVisibleChars =
+    [ ([x], EvKey (KChar x) [])
+    | x <- [' ' .. toEnum 0x7F]
+    ]
+
+metaChars :: ClassifyMap
+metaChars = mapMaybe f commonVisibleChars
+  where
+    f ([c], _) = Just ('\ESC':[c], EvKey (KChar c) [MMeta])
+    f _ = Nothing
+
+otherVisibleChars :: ClassifyMap
+otherVisibleChars =
+    [ ([x], EvKey (KChar x) [])
+    | x <- [toEnum 0x8A .. toEnum 0xC1]
+    ]
+
+-- | Non-printable characters in the ISO-8859-1 and UTF-8 common set
+-- translated to ctrl + char.
+--
+-- This treats CTRL-i the same as tab.
+ctrlChars :: ClassifyMap
+ctrlChars =
+    [ ([toEnum x], EvKey (KChar y) [MCtrl])
+    | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_'])
+    , y /= 'i'  -- Resolve issue #3 where CTRL-i hides TAB.
+    , y /= 'h'  -- CTRL-h should not hide BS
+    ]
+
+-- | Ctrl+Meta+Char
+ctrlMetaChars :: ClassifyMap
+ctrlMetaChars = mapMaybe f ctrlChars
+  where
+    f (s, EvKey c m) = Just ('\ESC':s, EvKey c (MMeta:m))
+    f _ = Nothing
+
+-- | Escape, backspace, enter, tab.
+specialSupportKeys :: ClassifyMap
+specialSupportKeys =
+    -- special support for ESC
+    [ ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
+    -- Special support for backspace
+    , ("\DEL", EvKey KBS []), ("\ESC\DEL", EvKey KBS [MMeta]), ("\b", EvKey KBS [MCtrl])
+    -- Special support for Enter
+    , ("\r",EvKey KEnter []), ("\ESC\^J",EvKey KEnter [MMeta]), ("\n", EvKey KEnter [MCtrl])
+    -- explicit support for tab
+    , ("\t", EvKey (KChar '\t') []), ("\ESC[Z", EvKey (KChar '\t') [MShift])
+    ]
+ src/Graphics/Vty/Platform/Windows/Input/Terminfo/ANSIVT.hs view
@@ -0,0 +1,81 @@+-- | Input mappings for Windows terminals 
+-- pulled directly from https://learn.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences#input-sequences
+module Graphics.Vty.Platform.Windows.Input.Terminfo.ANSIVT
+  ( classifyTable
+  )
+where
+
+import Graphics.Vty.Input.Events
+
+-- | Encoding for all special keys
+classifyTable :: [ClassifyMap]
+classifyTable =
+    [ cursorKeysMap
+    , numpadAndF5ToF12
+    , functionKeys1To4
+    ]
+
+-- | Encoding for cursor keys.
+cursorKeysMap :: ClassifyMap
+cursorKeysMap =
+  [("\ESC[" ++ prefix mods ++ infx ++ name, EvKey key mods)
+    | (name, key) <-
+        [ ("A", KUp)
+        , ("B", KDown)
+        , ("C", KRight)
+        , ("D", KLeft)
+        , ("F", KEnd)
+        , ("H", KHome)
+        ]
+    , (infx, mods) <- modMap
+  ]
+  where
+    prefix mods = if null mods then "" else "1"
+
+-- | encoding for numpad keys and F5 through F12
+numpadAndF5ToF12 :: ClassifyMap
+numpadAndF5ToF12 =
+  [ ("\ESC[" ++ name ++ infx ++ "~", EvKey key mods)
+    | (name, key) <-
+        [ ("2", KIns)
+        , ("3", KDel)
+        , ("5", KPageUp)
+        , ("6", KPageDown)
+        , ("15", KFun 5)
+        , ("17", KFun 6)
+        , ("18", KFun 7)
+        , ("19", KFun 8)
+        , ("20", KFun 9)
+        , ("21", KFun 10)
+        , ("23", KFun 11)
+        , ("24", KFun 12)
+        ]
+    , (infx, mods) <- modMap
+  ]
+
+-- | encoding for F1 through F4
+functionKeys1To4 :: ClassifyMap
+functionKeys1To4 =
+  [ ("\ESC" ++ prefix mods ++ infx ++ name, EvKey key mods)
+  | (name, key) <-
+      [ ("P", KFun 1),
+        ("Q", KFun 2),
+        ("R", KFun 3),
+        ("S", KFun 4)
+      ]
+  , (infx, mods) <- modMap
+  ]
+  where
+    prefix mods = if null mods then "O" else "[1"
+
+modMap :: [(String, [Modifier])]
+modMap =
+  [ ("", []),
+    (";2", [MShift]),
+    (";3", [MMeta]),
+    (";4", [MMeta, MShift]),
+    (";5", [MCtrl]),
+    (";6", [MCtrl, MShift]),
+    (";7", [MMeta, MCtrl]),
+    (";8", [MMeta, MCtrl, MShift])
+  ]
+ src/Graphics/Vty/Platform/Windows/Output.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE RecordWildCards, CPP #-}
+-- | This module provides a function to build an 'Output' for Windows
+-- terminals.
+--
+-- This module is exposed for testing purposes only; applications should
+-- never need to import this directly.
+module Graphics.Vty.Platform.Windows.Output
+  ( buildOutput
+  )
+where
+
+import Graphics.Vty.Platform.Windows.Settings
+import Graphics.Vty.Platform.Windows.Output.XTermColor as XTermColor
+import Graphics.Vty.Platform.Windows.Output.TerminfoBased as TerminfoBased
+import Graphics.Vty.Output
+
+import Data.List (isPrefixOf)
+
+-- | Returns an `Output` for the terminal specified in `WindowsSettings`.
+--
+-- The specific Output implementation used is hidden from the API user.
+-- All terminal implementations are assumed to perform more, or less,
+-- the same. Currently, all implementations use terminfo for at least
+-- some terminal specific information.
+--
+-- If a terminal implementation is developed for a terminal without
+-- terminfo support then Vty should work as expected on that terminal.
+--
+-- Selection of a terminal is done as follows:
+--
+--      * If TERM starts with "xterm", "screen" or "tmux", use XTermColor.
+--      * otherwise use the TerminfoBased driver.
+buildOutput :: WindowsSettings -> IO Output
+buildOutput settings = do
+    let outHandle = settingOutputFd settings
+        termName = settingTermName settings
+        colorMode = settingColorMode settings
+
+    if isXtermLike termName
+        then XTermColor.reserveTerminal termName outHandle colorMode
+        -- Not an xterm-like terminal. try for generic terminfo.
+        else TerminfoBased.reserveTerminal termName outHandle colorMode
+
+
+isXtermLike :: String -> Bool
+isXtermLike termName =
+    any (`isPrefixOf` termName) xtermLikeTerminalNamePrefixes
+
+xtermLikeTerminalNamePrefixes :: [String]
+xtermLikeTerminalNamePrefixes =
+    [ "xterm"
+    , "screen"
+    , "tmux"
+    , "rxvt"
+    ]
+ src/Graphics/Vty/Platform/Windows/Output/Color.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | This module provides functions to detect the most appropriate color mode for the 
+-- current environment.
+module Graphics.Vty.Platform.Windows.Output.Color
+  ( detectColorMode
+  , defaultColorMode
+  )
+where
+
+import Control.Exception (Exception(..))
+import Data.Typeable (Typeable)
+import Graphics.Vty.Attributes.Color ( ColorMode(..) )
+
+-- | Type of errors that can be thrown when configuring VTY
+newtype VtyConfigurationError =
+    VtyUnsupportedTermType String
+    -- ^ Terminal type not supported by vty
+    deriving (Show, Eq, Typeable)
+
+instance Exception VtyConfigurationError where
+    displayException (VtyUnsupportedTermType name) = "TERM type [" ++ name ++ "] is not supported at this time"
+
+-- | Windows console supports full color.
+detectColorMode :: String -> IO ColorMode
+detectColorMode termType =
+  case termType of
+    "xterm-256color" -> return FullColor
+    "xterm"          -> return FullColor
+    _                -> return FullColor
+
+-- | The default color mode for Windows
+defaultColorMode :: IO ColorMode
+defaultColorMode = return FullColor
+ src/Graphics/Vty/Platform/Windows/Output/TerminfoBased.hs view
@@ -0,0 +1,612 @@+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Provides functions for configuring the terminal for VT processing, and to 
+-- change the window size
+module Graphics.Vty.Platform.Windows.Output.TerminfoBased
+  ( reserveTerminal
+  , setWindowSize
+  )
+where
+
+import Control.Monad (when)
+import Data.Bits ((.&.))
+import qualified Data.ByteString as BS
+import Data.ByteString.Internal (toForeignPtr)
+import Data.Terminfo.Parse
+    ( CapParam, CapExpression, parseCapExpression )
+import Data.Terminfo.Eval ( writeCapExpr )
+
+import Graphics.Vty.Attributes
+import Graphics.Vty.Image (DisplayRegion)
+import Graphics.Vty.DisplayAttributes
+import Graphics.Vty.Platform.Windows.WindowsCapabilities (getStringCapability)
+import Graphics.Vty.Platform.Windows.WindowsInterfaces ( configureOutput )
+import Graphics.Vty.Output
+
+import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8)
+
+import Data.IORef ( newIORef, readIORef, writeIORef )
+import Data.Maybe (isJust, isNothing, fromJust)
+import Data.Word
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Foldable (foldMap)
+#endif
+
+import Foreign.C.Types (CInt(..))
+import Foreign.ForeignPtr (withForeignPtr)
+import Foreign.Ptr (Ptr, plusPtr)
+
+import System.IO ( Handle, hPutBufNonBlocking )
+import System.Win32.Types ( HANDLE, withHandleToHANDLE )
+import System.Win32.Console
+
+data TerminfoCaps = TerminfoCaps
+    { smcup :: Maybe CapExpression
+    , rmcup :: Maybe CapExpression
+    , cup :: CapExpression
+    , cnorm :: Maybe CapExpression
+    , civis :: Maybe CapExpression
+    , useAltColorMap :: Bool
+    , setForeColor :: CapExpression
+    , setBackColor :: CapExpression
+    , setDefaultAttr :: CapExpression
+    , clearScreen :: CapExpression
+    , clearEol :: CapExpression
+    , displayAttrCaps :: DisplayAttrCaps
+    , ringBellAudio :: Maybe CapExpression
+    }
+
+data DisplayAttrCaps = DisplayAttrCaps
+    { setAttrStates :: Maybe CapExpression
+    , enterStandout :: Maybe CapExpression
+    , exitStandout :: Maybe CapExpression
+    , enterItalic :: Maybe CapExpression
+    , exitItalic :: Maybe CapExpression
+    , enterStrikethrough :: Maybe CapExpression
+    , exitStrikethrough :: Maybe CapExpression
+    , enterUnderline :: Maybe CapExpression
+    , exitUnderline :: Maybe CapExpression
+    , enterReverseVideo :: Maybe CapExpression
+    , enterDimMode :: Maybe CapExpression
+    , enterBoldMode :: Maybe CapExpression
+    }
+
+-- kinda like:
+-- https://code.google.com/p/vim/source/browse/src/fileio.c#10422
+-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR
+-- the write will be retried.
+fdWriteAll :: Handle -> Ptr Word8 -> Int -> Int -> IO Int
+fdWriteAll outHandle ptr len count
+    | len <  0  = fail "fdWriteAll: len is less than 0"
+    | len == 0  = return count
+    | otherwise = do
+        writeCount <- fromEnum <$> hPutBufNonBlocking outHandle ptr (toEnum len)
+        let len' = len - writeCount
+            ptr' = ptr `plusPtr` writeCount
+            count' = count + writeCount
+        fdWriteAll outHandle ptr' len' count'
+
+sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()
+sendCapToTerminal t cap capParams = do
+    outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams
+
+-- | Constructs an output driver that uses terminfo for all control
+-- codes. While this should provide the most compatible terminal,
+-- terminfo does not support some features that would increase
+-- efficiency and improve compatibility:
+--
+--  * determining the character encoding supported by the terminal.
+--    Should this be taken from the LANG environment variable?
+--
+--  * Providing independent string capabilities for all display
+--    attributes.
+reserveTerminal :: String -> Handle -> ColorMode -> IO Output
+reserveTerminal termName outHandle colorMode = do
+    restoreMode <- configureOutput outHandle
+
+    -- assumes set foreground always implies set background exists.
+    -- if set foreground is not set then all color changing style
+    -- attributes are filtered.
+    let msetaf = probeCap "setaf"
+        msetf  = probeCap "setf"
+        (useAlt, setForeCap)
+            = case msetaf of
+                Just setaf -> (False, setaf)
+                Nothing -> case msetf of
+                    Just setf -> (True, setf)
+                    Nothing -> (True, error $ "no fore color support for terminal " ++ termName)
+        msetab = probeCap "setab"
+        msetb = probeCap "setb"
+    let setBackCap
+            = case msetab of
+                Just setab -> setab
+                Nothing -> case msetb of
+                    Just setb -> setb
+                    Nothing -> error $ "no back color support for terminal " ++ termName
+
+    hyperlinkModeStatus <- newIORef False
+    newAssumedStateRef <- newIORef initialAssumedState
+
+    let terminfoSetMode m newStatus = do
+          curStatus <- terminfoModeStatus m
+          when (newStatus /= curStatus) $
+              case m of
+                  Hyperlink -> do
+                      writeIORef hyperlinkModeStatus newStatus
+                      writeIORef newAssumedStateRef initialAssumedState
+                  _ -> return ()
+        terminfoModeStatus m =
+            case m of
+                Hyperlink -> readIORef hyperlinkModeStatus
+                _ -> return False
+        terminfoModeSupported Hyperlink = True
+        terminfoModeSupported _ = False
+
+        terminfoCaps = TerminfoCaps
+            { smcup = probeCap "smcup"
+            , rmcup = probeCap "rmcup"
+            , cup = requireCap "cup"
+            , cnorm = probeCap "cnorm"
+            , civis = probeCap "civis"
+            , useAltColorMap = useAlt
+            , setForeColor = setForeCap
+            , setBackColor = setBackCap
+            , setDefaultAttr = requireCap "sgr0"
+            , clearScreen = requireCap "clear"
+            , clearEol = requireCap "el"
+            , displayAttrCaps = currentDisplayAttrCaps
+            , ringBellAudio = probeCap "bel"
+            }
+    let t = Output
+            { terminalID = termName
+            , releaseTerminal = do
+                sendCap setDefaultAttr []
+                maybeSendCap cnorm []
+                restoreMode
+            , supportsBell = return $ isJust $ ringBellAudio terminfoCaps
+            , supportsItalics = return $ isJust (enterItalic (displayAttrCaps terminfoCaps)) &&
+                                         isJust (exitItalic (displayAttrCaps terminfoCaps))
+            , supportsStrikethrough = return $ isJust (enterStrikethrough (displayAttrCaps terminfoCaps)) &&
+                                               isJust (exitStrikethrough (displayAttrCaps terminfoCaps))
+            , ringTerminalBell = maybeSendCap ringBellAudio []
+            , reserveDisplay = do
+                -- If there is no support for smcup: Clear the screen
+                -- and then move the mouse to the home position to
+                -- approximate the behavior.
+                maybeSendCap smcup []
+                sendCap clearScreen []
+            , releaseDisplay = do
+                maybeSendCap rmcup []
+                maybeSendCap cnorm []
+            , setDisplayBounds = \(w, h) ->
+                setWindowSize outHandle (w, h)
+            , displayBounds = do
+                rawSize <- getWindowSize outHandle
+                case rawSize of
+                    (w, h)  | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize
+                            | otherwise      -> return (w,h)
+            , outputByteBuffer = \outBytes -> do
+                let (fptr, offset, len) = toForeignPtr outBytes
+                actualLen <- withForeignPtr fptr
+                             $ \ptr -> fdWriteAll outHandle (ptr `plusPtr` offset) len 0
+                when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer "
+                  ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen
+                  ++ " Please report this bug to vty project."
+            , supportsCursorVisibility = isJust $ civis terminfoCaps
+            , supportsMode = terminfoModeSupported
+            , setMode = terminfoSetMode
+            , getModeStatus = terminfoModeStatus
+            , assumedStateRef = newAssumedStateRef
+            , outputColorMode = colorMode
+            -- I think fix would help assure tActual is the only
+            -- reference. I was having issues tho.
+            , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
+            , setOutputWindowTitle = const $ return ()
+            }
+        sendCap s = sendCapToTerminal t (s terminfoCaps)
+        maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
+    return t
+
+requireCap :: String -> CapExpression
+requireCap capName
+    = case getStringCapability capName of
+        Nothing     -> error $ "Terminal does not define required capability \"" ++ capName ++ "\""
+        Just capStr -> parseCap capStr
+
+probeCap :: String -> Maybe CapExpression
+probeCap capName
+    = case getStringCapability capName of
+        Nothing     -> Nothing
+        Just capStr -> Just $ parseCap capStr
+
+parseCap :: String -> CapExpression
+parseCap capStr = do
+    case parseCapExpression capStr of
+        Left e -> error $ show e
+        Right cap -> cap
+
+currentDisplayAttrCaps :: DisplayAttrCaps
+currentDisplayAttrCaps
+    = DisplayAttrCaps
+    { setAttrStates = probeCap "sgr"
+    , enterStandout = probeCap "smso"
+    , exitStandout = probeCap "rmso"
+    , enterItalic = probeCap "sitm"
+    , exitItalic = probeCap "ritm"
+    , enterStrikethrough = probeCap "smxx"
+    , exitStrikethrough = probeCap "rmxx"
+    , enterUnderline = probeCap "smul"
+    , exitUnderline = probeCap "rmul"
+    , enterReverseVideo = probeCap "rev"
+    , enterDimMode = probeCap "dim"
+    , enterBoldMode = probeCap "bold"
+    }
+
+getWindowSize :: Handle -> IO (Int,Int)
+getWindowSize handle = do
+    bufferInfo <- withHandleToHANDLE handle getConsoleScreenBufferInfo
+    let coord = dwSize bufferInfo
+    return (fromIntegral $ xPos coord, fromIntegral $ yPos coord)
+
+foreign import ccall "set_screen_size" cSetScreenSize :: CInt -> CInt -> HANDLE -> IO CInt
+
+-- | Resize the console window to the specified size. Throws error on failure.
+setWindowSize :: Handle -> (Int, Int) -> IO ()
+setWindowSize hOut (w, h) = do
+  result <- withHandleToHANDLE hOut $ cSetScreenSize (fromIntegral w) (fromIntegral h)
+  if result == 0
+      then return ()
+      else error $ "Unable to setup window size. Got error code: " ++ show result
+
+terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext
+terminfoDisplayContext tActual terminfoCaps r = return dc
+    where dc = DisplayContext
+            { contextDevice = tActual
+            , contextRegion = r
+            , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x]
+            , writeShowCursor = case cnorm terminfoCaps of
+                Nothing -> error "this terminal does not support show cursor"
+                Just c -> writeCapExpr c []
+            , writeHideCursor = case civis terminfoCaps of
+                Nothing -> error "this terminal does not support hide cursor"
+                Just c -> writeCapExpr c []
+            , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
+            , writeDefaultAttr = \urlsEnabled ->
+                writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
+                (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend`
+                (case exitStrikethrough $ displayAttrCaps terminfoCaps of
+                    Just cap -> writeCapExpr cap []
+                    Nothing -> mempty
+                )
+            , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []
+            , inlineHack = return ()
+            }
+
+-- | Write the escape sequences that are used in some terminals to
+-- include embedded hyperlinks. As of yet, this information isn't
+-- included in termcap or terminfo, so this writes them directly
+-- instead of looking up the appropriate capabilities.
+writeURLEscapes :: URLDiff -> Write
+writeURLEscapes (LinkTo url) =
+    foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend`
+    foldMap writeStorable (BS.unpack url) `mappend`
+    writeStorable (0x07 :: Word8)
+writeURLEscapes EndLink =
+    foldMap writeStorable (BS.unpack "\x1b]8;;\a")
+writeURLEscapes NoLinkChange =
+    mempty
+
+-- | Portably setting the display attributes is a giant pain in the ass.
+--
+-- If the terminal supports the sgr capability (which sets the on/off
+-- state of each style directly; and, for no good reason, resets the
+-- colors to the default) this procedure is used:
+--
+--  0. set the style attributes. This resets the fore and back color.
+--
+--  1, If a foreground color is to be set then set the foreground color
+--
+--  2. likewise with the background color
+--
+-- If the terminal does not support the sgr cap then: if there is a
+-- change from an applied color to the default (in either the fore or
+-- back color) then:
+--
+--  0. reset all display attributes (sgr0)
+--
+--  1. enter required style modes
+--
+--  2. set the fore color if required
+--
+--  3. set the back color if required
+--
+-- Entering the required style modes could require a reset of the
+-- display attributes. If this is the case then the back and fore colors
+-- always need to be set if not default.
+--
+-- This equation implements the above logic.
+--
+-- Note that this assumes the removal of color changes in the
+-- display attributes is done as expected with noColors == True. See
+-- `limitAttrForDisplay`.
+--
+-- Note that this optimizes for fewer state changes followed by fewer
+-- bytes.
+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write
+terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
+    urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of
+        -- The only way to reset either color, portably, to the default
+        -- is to use either the set state capability or the set default
+        -- capability.
+        True -> do
+            case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
+                                     (fixedStyle attr)
+                                     (styleToApplySeq $ fixedStyle attr) of
+                -- only way to reset a color to the defaults
+                EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled
+                                     `mappend`
+                                     foldMap (\cap -> writeCapExpr cap []) caps
+                                     `mappend`
+                                     setColors
+                -- implicitly resets the colors to the defaults
+                SetState state -> writeCapExpr (fromJust $ setAttrStates
+                                                         $ displayAttrCaps terminfoCaps
+                                               )
+                                               (sgrArgsForState state)
+                                  `mappend` setItalics
+                                  `mappend` setStrikethrough
+                                  `mappend` setColors
+        -- Otherwise the display colors are not changing or changing
+        -- between two non-default points.
+        False -> do
+            -- Still, it could be the case that the change in display
+            -- attributes requires the colors to be reset because the
+            -- required capability was not available.
+            case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)
+                                     (fixedStyle attr)
+                                     (styleDiffs diffs) of
+                -- Really, if terminals were re-implemented with modern
+                -- concepts instead of bowing down to 40 yr old dumb
+                -- terminal requirements this would be the only case
+                -- ever reached! Changes the style and color states
+                -- according to the differences with the currently
+                -- applied states.
+                EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps
+                                     `mappend`
+                                     writeColorDiff Foreground (foreColorDiff diffs)
+                                     `mappend`
+                                     writeColorDiff Background (backColorDiff diffs)
+                -- implicitly resets the colors to the defaults
+                SetState state -> writeCapExpr (fromJust $ setAttrStates
+                                                         $ displayAttrCaps terminfoCaps
+                                               )
+                                               (sgrArgsForState state)
+                                  `mappend` setItalics
+                                  `mappend` setStrikethrough
+                                  `mappend` setColors
+    where
+        urlAttrs True = writeURLEscapes (urlDiff diffs)
+        urlAttrs False = mempty
+        colorMap = if useAltColorMap terminfoCaps
+                   then altColorIndex
+                   else ansiColorIndex
+        attr = fixDisplayAttr prevAttr reqAttr
+
+        -- italics can't be set via SGR, so here we manually
+        -- apply the enter and exit sequences as needed after
+        -- changing the SGR
+        setItalics
+          | hasStyle (fixedStyle attr) italic
+          , Just sitm <- enterItalic (displayAttrCaps terminfoCaps)
+          = writeCapExpr sitm []
+          | otherwise = mempty
+        setStrikethrough
+          | hasStyle (fixedStyle attr) strikethrough
+          , Just smxx <- enterStrikethrough (displayAttrCaps terminfoCaps)
+          = writeCapExpr smxx []
+          | otherwise = mempty
+        setColors =
+            (case fixedForeColor attr of
+                Just c -> writeColor Foreground c
+                Nothing -> mempty)
+            `mappend`
+            (case fixedBackColor attr of
+                Just c -> writeColor Background c
+                Nothing -> mempty)
+        writeColorDiff _side NoColorChange
+            = mempty
+        writeColorDiff _side ColorToDefault
+            = error "ColorToDefault is not a possible case for applyColorDiffs"
+        writeColorDiff side (SetColor c)
+            = writeColor side c
+
+        writeColor side (RGBColor r g b) =
+            case outputColorMode (contextDevice dc) of
+                FullColor ->
+                    hardcodeColor side (r, g, b)
+                _ ->
+                    error "clampColor should remove rgb colors in standard mode"
+        writeColor side c =
+            writeCapExpr (setSideColor side terminfoCaps) [toEnum $ colorMap c]
+
+-- a color can either be in the foreground or the background
+data ColorSide = Foreground | Background
+
+-- get the capability for drawing a color on a specific side
+setSideColor :: ColorSide -> TerminfoCaps -> CapExpression
+setSideColor Foreground = setForeColor
+setSideColor Background = setBackColor
+
+hardcodeColor :: ColorSide -> (Word8, Word8, Word8) -> Write
+hardcodeColor side (r, g, b) =
+    -- hardcoded color codes are formatted as "\x1b[{side};2;{r};{g};{b}m"
+    mconcat [ writeStr "\x1b[", sideCode, delimiter, writeChar '2', delimiter
+            , writeColor r, delimiter, writeColor g, delimiter, writeColor b
+            , writeChar 'm']
+    where
+        writeChar = writeWord8 . fromIntegral . fromEnum
+        writeStr = mconcat . map writeChar
+        writeColor = writeStr . show
+        delimiter = writeChar ';'
+        -- 38/48 are used to set whether we should write to the
+        -- foreground/background. I really don't want to know why.
+        sideCode = case side of
+            Foreground -> writeStr "38"
+            Background -> writeStr "48"
+
+-- | The color table used by a terminal is a 16 color set followed by a
+-- 240 color set that might not be supported by the terminal.
+--
+-- This takes a Color which clearly identifies which palette to use and
+-- computes the index into the full 256 color palette.
+ansiColorIndex :: Color -> Int
+ansiColorIndex (ISOColor v) = fromEnum v
+ansiColorIndex (Color240 v) = 16 + fromEnum v
+ansiColorIndex (RGBColor _ _ _) =
+    error $ unlines [ "Attempted to create color index from rgb color."
+                    , "This is currently unsupported, and shouldn't ever happen"
+                    ]
+
+-- | For terminals without setaf/setab
+--
+-- See table in `man terminfo`
+-- Will error if not in table.
+altColorIndex :: Color -> Int
+altColorIndex (ISOColor 0) = 0
+altColorIndex (ISOColor 1) = 4
+altColorIndex (ISOColor 2) = 2
+altColorIndex (ISOColor 3) = 6
+altColorIndex (ISOColor 4) = 1
+altColorIndex (ISOColor 5) = 5
+altColorIndex (ISOColor 6) = 3
+altColorIndex (ISOColor 7) = 7
+altColorIndex (ISOColor v) = fromEnum v
+altColorIndex (Color240 v) = 16 + fromEnum v
+altColorIndex (RGBColor _ _ _) =
+    error $ unlines [ "Attempted to create color index from rgb color."
+                    , "This is currently unsupported, and shouldn't ever happen"
+                    ]
+
+{- | The sequence of terminfo caps to apply a given style are determined
+ - according to these rules.
+ -
+ -  1. The assumption is that it's preferable to use the simpler
+ -  enter/exit mode capabilities than the full set display attribute
+ -  state capability.
+ -
+ -  2. If a mode is supposed to be removed but there is not an exit
+ -  capability defined then the display attributes are reset to defaults
+ -  then the display attribute state is set.
+ -
+ -  3. If a mode is supposed to be applied but there is not an enter
+ -  capability defined then then display attribute state is set if
+ -  possible. Otherwise the mode is not applied.
+ -
+ -  4. If the display attribute state is being set then just update the
+ -  arguments to that for any apply/remove.
+ -}
+data DisplayAttrSeq
+    = EnterExitSeq [CapExpression]
+    | SetState DisplayAttrState
+
+data DisplayAttrState = DisplayAttrState
+    { applyStandout :: Bool
+    , applyUnderline :: Bool
+    , applyItalic :: Bool
+    , applyStrikethrough :: Bool
+    , applyReverseVideo :: Bool
+    , applyBlink :: Bool
+    , applyDim :: Bool
+    , applyBold :: Bool
+    }
+
+sgrArgsForState :: DisplayAttrState -> [CapParam]
+sgrArgsForState attrState = map (\b -> if b then 1 else 0)
+    [ applyStandout attrState
+    , applyUnderline attrState
+    , applyReverseVideo attrState
+    , applyBlink attrState
+    , applyDim attrState
+    , applyBold attrState
+    , False -- invis
+    , False -- protect
+    , False -- alt char set
+    ]
+
+reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
+reqDisplayCapSeqFor caps s diffs
+    -- if the state transition implied by any diff cannot be supported
+    -- with an enter/exit mode cap then either the state needs to be set
+    -- or the attribute change ignored.
+    = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of
+        -- If all the diffs have an enter-exit cap then just use those
+        ( False, _    ) -> EnterExitSeq $ map enterExitCap diffs
+        -- If not all the diffs have an enter-exit cap and there is no
+        -- set state cap then filter out all unsupported diffs and just
+        -- apply the rest
+        ( True, False ) -> EnterExitSeq $ map enterExitCap
+                                        $ filter (not . noEnterExitCap) diffs
+        -- if not all the diffs have an enter-exit can and there is a
+        -- set state cap then just use the set state cap.
+        ( True, True  ) -> SetState $ stateForStyle s
+    where
+        noEnterExitCap ApplyStrikethrough = isNothing $ enterStrikethrough caps
+        noEnterExitCap RemoveStrikethrough = isNothing $ exitStrikethrough caps
+        noEnterExitCap ApplyItalic = isNothing $ enterItalic caps
+        noEnterExitCap RemoveItalic = isNothing $ exitItalic caps
+        noEnterExitCap ApplyStandout = isNothing $ enterStandout caps
+        noEnterExitCap RemoveStandout = isNothing $ exitStandout caps
+        noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps
+        noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps
+        noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps
+        noEnterExitCap RemoveReverseVideo = True
+        noEnterExitCap ApplyBlink = True
+        noEnterExitCap RemoveBlink = True
+        noEnterExitCap ApplyDim = isNothing $ enterDimMode caps
+        noEnterExitCap RemoveDim = True
+        noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps
+        noEnterExitCap RemoveBold = True
+        enterExitCap ApplyStrikethrough = fromJust $ enterStrikethrough caps
+        enterExitCap RemoveStrikethrough = fromJust $ exitStrikethrough caps
+        enterExitCap ApplyItalic = fromJust $ enterItalic caps
+        enterExitCap RemoveItalic = fromJust $ exitItalic caps
+        enterExitCap ApplyStandout = fromJust $ enterStandout caps
+        enterExitCap RemoveStandout = fromJust $ exitStandout caps
+        enterExitCap ApplyUnderline = fromJust $ enterUnderline caps
+        enterExitCap RemoveUnderline = fromJust $ exitUnderline caps
+        enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps
+        enterExitCap ApplyDim = fromJust $ enterDimMode caps
+        enterExitCap ApplyBold = fromJust $ enterBoldMode caps
+        enterExitCap _ = error "enterExitCap applied to diff that was known not to have one."
+
+stateForStyle :: Style -> DisplayAttrState
+stateForStyle s = DisplayAttrState
+    { applyStandout = isStyleSet standout
+    , applyUnderline = isStyleSet underline
+    , applyItalic = isStyleSet italic
+    , applyStrikethrough = isStyleSet strikethrough
+    , applyReverseVideo = isStyleSet reverseVideo
+    , applyBlink = isStyleSet blink
+    , applyDim = isStyleSet dim
+    , applyBold = isStyleSet bold
+    }
+    where isStyleSet = hasStyle s
+
+styleToApplySeq :: Style -> [StyleStateChange]
+styleToApplySeq s = concat
+    [ applyIfRequired ApplyStandout standout
+    , applyIfRequired ApplyUnderline underline
+    , applyIfRequired ApplyItalic italic
+    , applyIfRequired ApplyStrikethrough strikethrough
+    , applyIfRequired ApplyReverseVideo reverseVideo
+    , applyIfRequired ApplyBlink blink
+    , applyIfRequired ApplyDim dim
+    , applyIfRequired ApplyBold bold
+    ]
+    where
+        applyIfRequired op flag
+            = if 0 == (flag .&. s)
+                then []
+                else [op]
+ src/Graphics/Vty/Platform/Windows/Output/XTermColor.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE CPP #-}
+
+-- | Provides function to reserve and configure a terminal for a Vty application
+module Graphics.Vty.Platform.Windows.Output.XTermColor
+  ( reserveTerminal
+  )
+where
+
+import Graphics.Vty.Platform.Windows.Input.Mouse
+import Graphics.Vty.Platform.Windows.Input.Focus
+import Graphics.Vty.Attributes.Color (ColorMode)
+import qualified Graphics.Vty.Platform.Windows.Output.TerminfoBased as TerminfoBased
+import Graphics.Vty.Output
+
+import Blaze.ByteString.Builder (writeToByteString)
+import Blaze.ByteString.Builder.Word (writeWord8)
+
+import qualified Data.ByteString.Char8 as BS8
+import Data.ByteString.Char8 (ByteString)
+import Foreign.Ptr (castPtr)
+
+import Control.Monad (void, when)
+import Control.Monad.Trans ( MonadIO(..) )
+import Data.Char (isPrint, showLitChar)
+import Data.IORef ( newIORef, readIORef, writeIORef )
+
+#if !MIN_VERSION_base(4,11,0)
+import Data.Monoid ((<>))
+#endif
+
+import System.IO ( Handle, hPutBufNonBlocking )
+
+-- | Write a 'ByteString' to an 'Fd'.
+fdWrite :: Handle -> ByteString -> IO Int
+fdWrite fd s =
+    BS8.useAsCStringLen s $ \(buf,len) -> do
+        hPutBufNonBlocking fd (castPtr buf) (fromIntegral len)
+
+-- | Construct an Xterm output driver. Initialize the display to UTF-8.
+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> ColorMode -> m Output
+reserveTerminal variant outFd colorMode = liftIO $ do
+    let flushedPut = void . fdWrite outFd
+    -- If the terminal variant is xterm-color use xterm instead since,
+    -- more often than not, xterm-color is broken.
+    let variant' = if variant == "xterm-color" then "xterm" else variant
+
+    t <- TerminfoBased.reserveTerminal variant' outFd colorMode
+
+    mouseModeStatus <- newIORef False
+    focusModeStatus <- newIORef False
+    pasteModeStatus <- newIORef False
+
+    let xtermSetMode t' m newStatus = do
+          curStatus <- getModeStatus t' m
+          when (newStatus /= curStatus) $
+              case m of
+                  Focus -> liftIO $ do
+                      flushedPut $ if newStatus then requestFocusEvents else disableFocusEvents
+                      writeIORef focusModeStatus newStatus
+                  Mouse -> liftIO $ do
+                      flushedPut $ if newStatus then requestMouseEvents else disableMouseEvents
+                      writeIORef mouseModeStatus newStatus
+                  BracketedPaste -> liftIO $ do
+                      flushedPut $ if newStatus then enableBracketedPastes else disableBracketedPastes
+                      writeIORef pasteModeStatus newStatus
+                  Hyperlink -> setMode t Hyperlink newStatus
+
+        xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
+        xtermGetMode Focus = liftIO $ readIORef focusModeStatus
+        xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
+        xtermGetMode Hyperlink = getModeStatus t Hyperlink
+
+    let t' = t
+             { terminalID = terminalID t ++ " (xterm-color)"
+             , releaseTerminal = do
+                 setMode t' BracketedPaste False
+                 setMode t' Mouse False
+                 setMode t' Focus False
+                 releaseTerminal t
+             , mkDisplayContext = \tActual r -> do
+                dc <- mkDisplayContext t tActual r
+                return $ dc { inlineHack = xtermInlineHack t' }
+             , supportsMode = const True
+             , getModeStatus = xtermGetMode
+             , setMode = xtermSetMode t'
+             , setOutputWindowTitle = setWindowTitle t
+             }
+    return t'
+
+-- | Enable bracketed paste mode:
+-- http://cirw.in/blog/bracketed-paste
+enableBracketedPastes :: ByteString
+enableBracketedPastes = BS8.pack "\ESC[?2004h"
+
+-- | Disable bracketed paste mode:
+disableBracketedPastes :: ByteString
+disableBracketedPastes = BS8.pack "\ESC[?2004l"
+
+-- | These sequences set xterm based terminals to UTF-8 output.
+--
+-- There is no known terminfo capability equivalent to this.
+-- setUtf8CharSet, setDefaultCharSet :: ByteString
+-- setUtf8CharSet = BS8.pack "\ESC%G"
+-- setDefaultCharSet = BS8.pack "\ESC%@"
+
+xtermInlineHack :: Output -> IO ()
+xtermInlineHack t = do
+    let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
+    outputByteBuffer t $ writeToByteString writeReset
+
+-- This function emits an Xterm-compatible escape sequence that we
+-- anticipate will work for essentially all modern terminal emulators.
+-- Ideally we'd use a terminal capability for this, but there does not
+-- seem to exist a termcap for setting window titles. If you find that
+-- this function does not work for a given terminal emulator, please
+-- report the issue.
+--
+-- For details, see:
+--
+-- https://tldp.org/HOWTO/Xterm-Title-3.html
+setWindowTitle :: Output -> String -> IO ()
+setWindowTitle o title = do
+    let sanitize :: String -> String
+        sanitize = concatMap sanitizeChar
+        sanitizeChar c | not (isPrint c) = showLitChar c ""
+                       | otherwise = [c]
+    let buf = BS8.pack $ "\ESC]2;" <> sanitize title <> "\007"
+    outputByteBuffer o buf
+ src/Graphics/Vty/Platform/Windows/Settings.hs view
@@ -0,0 +1,44 @@+-- | This module provides data type to describe runtime terminal settings,
+-- and a function to obtain default values for those settings.
+module Graphics.Vty.Platform.Windows.Settings
+  ( WindowsSettings(..)
+  , defaultSettings
+  )
+where
+
+import Data.Maybe ( fromMaybe ) 
+import Graphics.Vty.Attributes.Color ( ColorMode(..) )
+import Graphics.Vty.Platform.Windows.Output.Color ( detectColorMode, defaultColorMode )
+import System.Environment ( lookupEnv )
+import System.IO ( Handle, stdin, stdout )
+
+-- | Runtime library settings for interacting with Windows terminals.
+data WindowsSettings = WindowsSettings
+  { settingInputFd :: Handle
+  -- ^ The input file descriptor to use.
+  , settingOutputFd :: Handle
+  -- ^ The output file descriptor to use.
+  , settingTermName :: String
+  -- ^ The terminal name used to look up terminfo capabilities.
+  , settingColorMode :: ColorMode
+  -- ^ The color mode used to know how many colors the terminal
+  -- supports.
+  }
+  deriving (Show, Eq)
+
+-- | Description of reasonable default settings for a Windows environment
+defaultSettings :: IO WindowsSettings
+defaultSettings = do
+    mb <- lookupEnv termVariable
+    let termName = fromMaybe "xterm-256color" mb
+    colorMode <- maybe defaultColorMode detectColorMode mb
+
+    return $ WindowsSettings { settingInputFd  = stdin
+                             , settingOutputFd  = stdout
+                             , settingTermName  = termName
+                             , settingColorMode = colorMode
+                             }
+
+-- | The TERM environment variable
+termVariable :: String
+termVariable = "TERM"
+ src/Graphics/Vty/Platform/Windows/WindowsCapabilities.hs view
@@ -0,0 +1,67 @@+-- | This module provides functions to obtain VT escape sequences for the Windows platform
+module Graphics.Vty.Platform.Windows.WindowsCapabilities
+    ( getStringCapability,
+      getIntCapability
+    ) where
+
+import qualified Data.Map as M
+
+-- | Lookup for terminal capabilities that have a string value.
+-- All Windows supported escape sequences are described here:
+-- https://learn.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences
+getStringCapability :: String -> Maybe String
+getStringCapability cap = M.lookup cap windowsStringCaps
+
+-- | Lookup a terminal capability that has an integer value
+getIntCapability :: String -> Maybe Int
+getIntCapability cap = M.lookup cap windowsIntCaps
+
+esc :: String -> String
+esc code = '\ESC' : code
+
+csi :: String -> String
+csi code = esc $ '[' : code
+
+-- | Mapping of capability names to VT escape sequences for the Windows platform
+-- All Windows supported escape sequences are described here:
+-- https://learn.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences
+windowsStringCaps :: M.Map String String
+windowsStringCaps = M.fromList
+    [ ("bold", csi "1m")
+    , ("clear", csi "H" ++ csi "J")
+    , ("cup", csi "%i%p1%d;%p2%dH")
+    , ("civis", csi "?25l")
+    , ("cnorm", csi "34h" ++ csi "?25h")
+    , ("dim", csi "2m")
+    , ("ed", csi "J")
+    , ("el", csi "K")
+    -- , ("el1", csi "1K")
+    , ("home", csi "H")
+    , ("invis", csi "8m")
+    , ("kbs", "^H")
+    , ("rev", csi "7m")
+    , ("rmso", csi "27m")
+    , ("rmul", csi "m")
+    , ("setab", csi "%?%p1%{8}%<%t4%p1%d%e%p1%{16}%<%t10%p1%{8}%-%d%e48;5;%p1%d%;m")
+    , ("setaf", csi "%?%p1%{8}%<%t3%p1%d%e%p1%{16}%<%t9%p1%{8}%-%d%e38;5;%p1%d%;m")
+    , ("sgr", csi "0%?%p6%t;1%;%?%p2%t;4%;%?%p1%p3%|%t;7%;%?%p4%t;5%;%?%p5%t;2%;%?%p7%t;8%;m%?%p9%t\SO%e\SI%;")
+    , ("sgr0", csi "m\SI")
+    , ("smso", csi "7m")
+    , ("rmcup", csi "?1049l")
+    , ("smcup", csi "?1049h")
+    , ("el", csi "K")
+    , ("sitm", csi "3m")
+    , ("ritm", csi "23m")
+    , ("smxx", csi "9m")
+    , ("rmxx", csi "29m")
+    , ("smul", csi "4m")
+    , ("rmul", csi "24m")
+    , ("rev", csi "7m")
+    , ("dim", csi "2m")
+    , ("bold", csi "1m")
+    ]
+
+windowsIntCaps :: M.Map String Int
+windowsIntCaps = M.fromList 
+    [ ("colors", 256)
+    ]
+ src/Graphics/Vty/Platform/Windows/WindowsConsoleInput.hsc view
@@ -0,0 +1,185 @@+{-# 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 <windows.h>
+
+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} :: DWORD)
+        (#poke INPUT_RECORD, Event) buf key
+    poke buf (MouseEventRecordU mouse) = do
+        (#poke INPUT_RECORD, EventType) buf (#{const MOUSE_EVENT} :: DWORD)
+        (#poke INPUT_RECORD, Event) buf mouse
+    poke buf (WindowBufferSizeRecordU window) = do
+        (#poke INPUT_RECORD, EventType) buf (#{const WINDOW_BUFFER_SIZE_EVENT} :: DWORD)
+        (#poke INPUT_RECORD, Event) buf window
+    poke buf (MenuEventRecordU menu) = do
+        (#poke INPUT_RECORD, EventType) buf (#{const MENU_EVENT} :: DWORD)
+        (#poke INPUT_RECORD, Event) buf menu
+    poke buf (FocusEventRecordU focus) = do
+        (#poke INPUT_RECORD, EventType) buf (#{const FOCUS_EVENT} :: DWORD)
+        (#poke INPUT_RECORD, Event) buf focus
+
+    peek buf = do
+        event <- (#peek INPUT_RECORD, EventType) buf :: IO DWORD
+        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
+ src/Graphics/Vty/Platform/Windows/WindowsInterfaces.hs view
@@ -0,0 +1,97 @@+{-# 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 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
+    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
+    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)
+
+        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)
+
+
+-- | Configure Windows to correctly handle input for a Vty application
+configureInput :: Handle -> IO (IO (), IO ())
+configureInput inputHandle = do
+    withHandleToHANDLE inputHandle $ \wh -> do
+        original <- getConsoleMode wh
+        let setMode = setConsoleMode wh $ eNABLE_VIRTUAL_TERMINAL_INPUT .|. eNABLE_EXTENDED_FLAGS
+        pure (setMode,
+              setConsoleMode wh original)
+
+-- | Configure Windows to correctly handle output for a Vty application
+configureOutput :: Handle -> IO (IO ())
+configureOutput outputHandle = do
+    withHandleToHANDLE outputHandle $ \wh -> do
+        original <- getConsoleMode wh
+        setConsoleOutputCP 65001
+        setConsoleMode wh $ eNABLE_VIRTUAL_TERMINAL_PROCESSING .|. eNABLE_PROCESSED_OUTPUT
+        pure (setConsoleMode wh original)
+ vty-windows.cabal view
@@ -0,0 +1,61 @@+cabal-version:      3.0
+name:               vty-windows
+version:            0.1.0.0
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Chris hackett
+maintainer:         chris.h.hackett@gmail.com
+category:           Graphics
+synopsis:           Windows backend for Vty
+description:        This package provides Windows terminal support for Vty.
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+extra-source-files: cbits/win_pseudo_console.c
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    c-sources:        cbits/win_commands.c
+    exposed-modules:  Data.Terminfo.Eval
+                      Data.Terminfo.Parse
+                      Graphics.Vty.Platform.Windows
+                      Graphics.Vty.Platform.Windows.Input
+                      Graphics.Vty.Platform.Windows.Input.Loop
+                      Graphics.Vty.Platform.Windows.Input.Terminfo
+                      Graphics.Vty.Platform.Windows.Input.Terminfo.ANSIVT
+                      Graphics.Vty.Platform.Windows.Input.Focus
+                      Graphics.Vty.Platform.Windows.Input.Paste
+                      Graphics.Vty.Platform.Windows.Input.Mouse
+                      Graphics.Vty.Platform.Windows.Input.Classify
+                      Graphics.Vty.Platform.Windows.Input.Classify.Parse
+                      Graphics.Vty.Platform.Windows.Input.Classify.Types
+                      Graphics.Vty.Platform.Windows.Output
+                      Graphics.Vty.Platform.Windows.Output.TerminfoBased
+                      Graphics.Vty.Platform.Windows.Output.XTermColor
+                      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.0.0 && < 5.0,
+                      Win32               >= 2.8.5.0 && < 3.0,
+                      bytestring          >= 0.11.4 && < 1.0,
+                      deepseq             >= 1.4.2 && < 2.0,
+                      filepath            >= 1.4.2 && < 2.0,
+                      blaze-builder       >= 0.4.2 && < 1.0,
+                      containers          >= 0.5.7 && < 1.0,
+                      directory           >= 1.3.7 && < 2.0,
+                      microlens           >= 0.4.13 && < 1.0,
+                      microlens-mtl       >= 0.2.0 && < 1.0,
+                      mtl                 >= 2.2.2 && < 3.0,
+                      transformers        >= 0.5.6 && < 1.0,
+                      microlens-th        >= 0.4.3 && < 1.0,
+                      parsec              >= 3.1.16 && < 4.0,
+                      stm                 >= 2.5.1 && < 3.0,
+                      utf8-string         >= 1.0.2 && < 2.0,
+                      vector              >= 0.13.0 && < 1.0,
+                      vty                 >= 5.38 && < 6.0,
+    hs-source-dirs:   src
+    default-language: Haskell2010