{-# Language CPP #-}
-- Copyright 2009-2010 Corey O'Connor
-- | Xterm output driver. This uses the Terminfo driver with some
-- extensions for Xterm.
module Graphics.Vty.Output.XTermColor
  ( reserveTerminal
  )
where

import Graphics.Vty.Output.Interface
import Graphics.Vty.Input.Mouse
import Graphics.Vty.Input.Focus
import Graphics.Vty.Attributes.Color (ColorMode)
import qualified Graphics.Vty.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)
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 =
    forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS8.useAsCStringLen ByteString
s forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
buf,Int
len) -> do
        Fd -> Ptr Word8 -> ByteCount -> IO ByteCount
fdWriteBuf Fd
fd (forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
buf) (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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    let flushedPut :: ByteString -> IO ()
flushedPut = forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 forall a. Eq a => a -> a -> Bool
== String
"xterm-color" then String
"xterm" else String
variant

    Bool
utf8a <- IO Bool
utf8Active
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
utf8a) forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
flushedPut ByteString
setUtf8CharSet
    Output
t <- String -> Fd -> ColorMode -> IO Output
TerminfoBased.reserveTerminal String
variant' Fd
outFd ColorMode
colorMode

    IORef Bool
mouseModeStatus <- forall a. a -> IO (IORef a)
newIORef Bool
False
    IORef Bool
focusModeStatus <- forall a. a -> IO (IORef a)
newIORef Bool
False
    IORef Bool
pasteModeStatus <- 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
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
newStatus forall a. Eq a => a -> a -> Bool
/= Bool
curStatus) forall a b. (a -> b) -> a -> b
$
              case Mode
m of
                  Mode
Focus -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
                      forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
focusModeStatus Bool
newStatus
                  Mode
Mouse -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
                      forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
mouseModeStatus Bool
newStatus
                  Mode
BracketedPaste -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
                      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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef Bool
mouseModeStatus
        xtermGetMode Mode
Focus = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef Bool
focusModeStatus
        xtermGetMode Mode
BracketedPaste = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 forall a. [a] -> [a] -> [a]
++ String
" (xterm-color)"
             , releaseTerminal :: IO ()
releaseTerminal = do
                 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
utf8a) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
flushedPut ByteString
setDefaultCharSet
                 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
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DisplayContext
dc { inlineHack :: IO ()
inlineHack = Output -> IO ()
xtermInlineHack Output
t' }
             , supportsMode :: Mode -> Bool
supportsMode = 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'
             }
    forall (m :: * -> *) a. Monad m => a -> m a
return Output
t'

utf8Active :: IO Bool
utf8Active :: IO Bool
utf8Active = do
    let vars :: [String]
vars = [String
"LC_ALL", String
"LANG", String
"LC_CTYPE"]
    [String]
results <- forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char
toLower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe String)
getEnv [String]
vars
    let matches :: [String]
matches = forall a. (a -> Bool) -> [a] -> [a]
filter (String
"utf8" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) [String]
results forall a. Semigroup a => a -> a -> a
<>
                  forall a. (a -> Bool) -> [a] -> [a]
filter (String
"utf-8" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) [String]
results
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
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 = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Word8 -> Write
writeWord8forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Enum a => Int -> a
toEnumforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Enum a => a -> Int
fromEnum) String
"\ESC[K"
    Output -> ByteString -> IO ()
outputByteBuffer Output
t forall a b. (a -> b) -> a -> b
$ Write -> ByteString
writeToByteString Write
writeReset