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

-- | Construct an Xterm output driver. Initialize the display to UTF-8.

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
    -- If the terminal variant is xterm-color use xterm instead since,

    -- more often than not, xterm-color is broken.

    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'

-- | Enable bracketed paste mode:

-- http://cirw.in/blog/bracketed-paste

enableBracketedPastes :: ByteString
enableBracketedPastes :: ByteString
enableBracketedPastes = String -> ByteString
BS8.pack String
"\ESC[?2004h"

-- | Disable bracketed paste mode:

disableBracketedPastes :: ByteString
disableBracketedPastes :: ByteString
disableBracketedPastes = String -> ByteString
BS8.pack String
"\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 :: 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

-- 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 :: 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