{-# LANGUAGE CPP #-}
-- | Output implementation for xterm-like terminals.
--
-- This module is exposed for testing purposes only; applications should
-- never need to import this directly.
module Graphics.Vty.Platform.Unix.Output.XTermColor
  ( reserveTerminal
  )
where

import Graphics.Vty.Output
import Graphics.Vty.Platform.Unix.Input.Mouse
import Graphics.Vty.Platform.Unix.Input.Focus
import Graphics.Vty.Attributes.Color (ColorMode)
import qualified Graphics.Vty.Platform.Unix.Output.TerminfoBased as TerminfoBased

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
import Data.Char (toLower, isPrint, showLitChar)
import Data.IORef

import System.Posix.IO (fdWriteBuf)
import System.Posix.Types (ByteCount, Fd)
import System.Posix.Env (getEnv)

import Data.List (isInfixOf)
import Data.Maybe (catMaybes)

#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif

-- | Write a 'ByteString' to an 'Fd'.
fdWrite :: Fd -> ByteString -> IO ByteCount
fdWrite :: Fd -> ByteString -> IO ByteCount
fdWrite Fd
fd ByteString
s =
    ByteString -> (CStringLen -> IO ByteCount) -> IO ByteCount
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS8.useAsCStringLen ByteString
s ((CStringLen -> IO ByteCount) -> IO ByteCount)
-> (CStringLen -> IO ByteCount) -> IO ByteCount
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
buf,Int
len) -> do
        Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdWriteBuf Fd
fd (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
buf) (Int -> ByteCount
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 -> Fd -> ColorMode -> m Output
reserveTerminal :: forall (m :: * -> *).
(Applicative m, MonadIO m) =>
String -> Fd -> ColorMode -> m Output
reserveTerminal String
variant Fd
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 ByteCount -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteCount -> IO ())
-> (ByteString -> IO ByteCount) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fd -> ByteString -> IO ByteCount
fdWrite Fd
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

    utf8a <- IO Bool
utf8Active
    when (not utf8a) $ flushedPut setUtf8CharSet
    t <- TerminfoBased.reserveTerminal variant' outFd colorMode

    mouseModeStatus <- newIORef False
    focusModeStatus <- newIORef False
    pasteModeStatus <- newIORef False

    let xtermSetMode Output
t' Mode
m Bool
newStatus = do
          curStatus <- Output -> Mode -> IO Bool
getModeStatus Output
t' Mode
m
          when (newStatus /= curStatus) $
              case 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
                      case Bool
newStatus of
                          Bool
True -> ByteString -> IO ()
flushedPut ByteString
requestFocusEvents
                          Bool
False -> ByteString -> IO ()
flushedPut 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
                      case Bool
newStatus of
                          Bool
True -> ByteString -> IO ()
flushedPut ByteString
requestMouseEvents
                          Bool
False -> ByteString -> IO ()
flushedPut 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
                      case Bool
newStatus of
                          Bool
True -> ByteString -> IO ()
flushedPut ByteString
enableBracketedPastes
                          Bool
False -> ByteString -> IO ()
flushedPut 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
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
             { terminalID = terminalID t ++ " (xterm-color)"
             , releaseTerminal = do
                 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
                 setMode t' BracketedPaste False
                 setMode t' Mouse False
                 setMode t' Focus False
                 releaseTerminal t
             , mkDisplayContext = \Output
tActual DisplayRegion
r -> do
                dc <- Output -> Output -> DisplayRegion -> IO DisplayContext
mkDisplayContext Output
t Output
tActual DisplayRegion
r
                return $ dc { inlineHack = xtermInlineHack t' }
             , supportsMode = const True
             , getModeStatus = xtermGetMode
             , setMode = xtermSetMode t'
             , setOutputWindowTitle = setWindowTitle t
             }
    return t'

utf8Active :: IO Bool
utf8Active :: IO Bool
utf8Active = do
    let vars :: [String]
vars = [String
"LC_ALL", String
"LANG", String
"LC_CTYPE"]
    results <- (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char
toLower (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ([String] -> [String])
-> ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe String)) -> [String] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO (Maybe String)
getEnv [String]
vars
    let matches = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"utf8" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) [String]
results [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<>
                  (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"utf-8" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) [String]
results
    return $ not $ null matches

-- | 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 :: ByteString
setUtf8CharSet = String -> ByteString
BS8.pack String
"\ESC%G"
setDefaultCharSet :: ByteString
setDefaultCharSet = String -> ByteString
BS8.pack String
"\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