{-# LANGUAGE CPP #-}
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 )
fdWrite :: Handle -> ByteString -> IO Int
fdWrite :: Handle -> ByteString -> IO Int
fdWrite Handle
fd ByteString
s =
ByteString -> (CStringLen -> IO Int) -> IO Int
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS8.useAsCStringLen ByteString
s ((CStringLen -> IO Int) -> IO Int)
-> (CStringLen -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
buf,Int
len) -> do
Handle -> Ptr Any -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hPutBufNonBlocking Handle
fd (Ptr CChar -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
buf) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> ColorMode -> m Output
reserveTerminal :: forall (m :: * -> *).
(Applicative m, MonadIO m) =>
String -> Handle -> ColorMode -> m Output
reserveTerminal String
variant Handle
outFd ColorMode
colorMode = IO Output -> m Output
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Output -> m Output) -> IO Output -> m Output
forall a b. (a -> b) -> a -> b
$ do
let flushedPut :: ByteString -> IO ()
flushedPut = IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> (ByteString -> IO Int) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> ByteString -> IO Int
fdWrite Handle
outFd
let variant' :: String
variant' = if String
variant String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"xterm-color" then String
"xterm" else String
variant
Output
t <- String -> Handle -> ColorMode -> IO Output
TerminfoBased.reserveTerminal String
variant' Handle
outFd ColorMode
colorMode
IORef Bool
mouseModeStatus <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
IORef Bool
focusModeStatus <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
IORef Bool
pasteModeStatus <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
let xtermSetMode :: Output -> Mode -> Bool -> IO ()
xtermSetMode Output
t' Mode
m Bool
newStatus = do
Bool
curStatus <- Output -> Mode -> IO Bool
getModeStatus Output
t' Mode
m
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
newStatus Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
curStatus) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
case Mode
m of
Mode
Focus -> IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString -> IO ()
flushedPut (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
newStatus then ByteString
requestFocusEvents else ByteString
disableFocusEvents
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
focusModeStatus Bool
newStatus
Mode
Mouse -> IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString -> IO ()
flushedPut (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
newStatus then ByteString
requestMouseEvents else ByteString
disableMouseEvents
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
mouseModeStatus Bool
newStatus
Mode
BracketedPaste -> IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString -> IO ()
flushedPut (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
newStatus then ByteString
enableBracketedPastes else ByteString
disableBracketedPastes
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
pasteModeStatus Bool
newStatus
Mode
Hyperlink -> Output -> Mode -> Bool -> IO ()
setMode Output
t Mode
Hyperlink Bool
newStatus
xtermGetMode :: Mode -> IO Bool
xtermGetMode Mode
Mouse = IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
mouseModeStatus
xtermGetMode Mode
Focus = IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
focusModeStatus
xtermGetMode Mode
BracketedPaste = IO Bool -> IO Bool
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
pasteModeStatus
xtermGetMode Mode
Hyperlink = Output -> Mode -> IO Bool
getModeStatus Output
t Mode
Hyperlink
let t' :: Output
t' = Output
t
{ terminalID :: String
terminalID = Output -> String
terminalID Output
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (xterm-color)"
, releaseTerminal :: IO ()
releaseTerminal = do
Output -> Mode -> Bool -> IO ()
setMode Output
t' Mode
BracketedPaste Bool
False
Output -> Mode -> Bool -> IO ()
setMode Output
t' Mode
Mouse Bool
False
Output -> Mode -> Bool -> IO ()
setMode Output
t' Mode
Focus Bool
False
Output -> IO ()
releaseTerminal Output
t
, mkDisplayContext :: Output -> DisplayRegion -> IO DisplayContext
mkDisplayContext = \Output
tActual DisplayRegion
r -> do
DisplayContext
dc <- Output -> Output -> DisplayRegion -> IO DisplayContext
mkDisplayContext Output
t Output
tActual DisplayRegion
r
DisplayContext -> IO DisplayContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DisplayContext -> IO DisplayContext)
-> DisplayContext -> IO DisplayContext
forall a b. (a -> b) -> a -> b
$ DisplayContext
dc { inlineHack :: IO ()
inlineHack = Output -> IO ()
xtermInlineHack Output
t' }
, supportsMode :: Mode -> Bool
supportsMode = Bool -> Mode -> Bool
forall a b. a -> b -> a
const Bool
True
, getModeStatus :: Mode -> IO Bool
getModeStatus = Mode -> IO Bool
xtermGetMode
, setMode :: Mode -> Bool -> IO ()
setMode = Output -> Mode -> Bool -> IO ()
xtermSetMode Output
t'
, setOutputWindowTitle :: String -> IO ()
setOutputWindowTitle = Output -> String -> IO ()
setWindowTitle Output
t
}
Output -> IO Output
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Output
t'
enableBracketedPastes :: ByteString
enableBracketedPastes :: ByteString
enableBracketedPastes = String -> ByteString
BS8.pack String
"\ESC[?2004h"
disableBracketedPastes :: ByteString
disableBracketedPastes :: ByteString
disableBracketedPastes = String -> ByteString
BS8.pack String
"\ESC[?2004l"
xtermInlineHack :: Output -> IO ()
xtermInlineHack :: Output -> IO ()
xtermInlineHack Output
t = do
let writeReset :: Write
writeReset = (Char -> Write) -> String -> Write
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Word8 -> Write
writeWord8(Word8 -> Write) -> (Char -> Word8) -> Char -> Write
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> Word8
forall a. Enum a => Int -> a
toEnum(Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Int
forall a. Enum a => a -> Int
fromEnum) String
"\ESC[K"
Output -> ByteString -> IO ()
outputByteBuffer Output
t (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Write -> ByteString
writeToByteString Write
writeReset
setWindowTitle :: Output -> String -> IO ()
setWindowTitle :: Output -> String -> IO ()
setWindowTitle Output
o String
title = do
let sanitize :: String -> String
sanitize :: String -> String
sanitize = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
sanitizeChar
sanitizeChar :: Char -> String
sanitizeChar Char
c | Bool -> Bool
not (Char -> Bool
isPrint Char
c) = Char -> String -> String
showLitChar Char
c String
""
| Bool
otherwise = [Char
c]
let buf :: ByteString
buf = String -> ByteString
BS8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"\ESC]2;" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
sanitize String
title String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\007"
Output -> ByteString -> IO ()
outputByteBuffer Output
o ByteString
buf