{-# 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 qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased

import Blaze.ByteString.Builder (writeToByteString)
import Blaze.ByteString.Builder.Word (writeWord8)

import Control.Monad (void, when)
import Control.Monad.Trans
import Data.Char (toLower)
import Data.IORef

import System.Posix.IO (fdWrite)
import System.Posix.Types (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

-- | Construct an Xterm output driver. Initialize the display to UTF-8.
reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
reserveTerminal :: String -> Fd -> m Output
reserveTerminal String
variant Fd
outFd = IO Output -> m Output
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 :: String -> IO ()
flushedPut = IO ByteCount -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteCount -> IO ())
-> (String -> IO ByteCount) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fd -> String -> 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

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

    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 (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 -> String -> IO ()
flushedPut String
requestFocusEvents
                          Bool
False -> String -> IO ()
flushedPut String
disableFocusEvents
                      IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
focusModeStatus Bool
newStatus
                  Mode
Mouse -> IO () -> IO ()
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 -> String -> IO ()
flushedPut String
requestMouseEvents
                          Bool
False -> String -> IO ()
flushedPut String
disableMouseEvents
                      IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
mouseModeStatus Bool
newStatus
                  Mode
BracketedPaste -> IO () -> IO ()
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 -> String -> IO ()
flushedPut String
enableBracketedPastes
                          Bool
False -> String -> IO ()
flushedPut String
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 (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 (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 (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
                 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
utf8a) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
flushedPut String
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
                DisplayContext -> IO DisplayContext
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'
             }
    Output -> IO Output
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 <- (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)
mapM String -> IO (Maybe String)
getEnv [String]
vars
    let matches :: [String]
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
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
matches

-- | Enable bracketed paste mode:
-- http://cirw.in/blog/bracketed-paste
enableBracketedPastes :: String
enableBracketedPastes :: String
enableBracketedPastes = String
"\ESC[?2004h"

-- | Disable bracketed paste mode:
disableBracketedPastes :: String
disableBracketedPastes :: String
disableBracketedPastes = String
"\ESC[?2004l"

-- | These sequences set xterm based terminals to UTF-8 output.
--
-- There is no known terminfo capability equivalent to this.
setUtf8CharSet, setDefaultCharSet :: String
setUtf8CharSet :: String
setUtf8CharSet = String
"\ESC%G"
setDefaultCharSet :: String
setDefaultCharSet = String
"\ESC%@"

xtermInlineHack :: Output -> IO ()
xtermInlineHack :: Output -> IO ()
xtermInlineHack Output
t = do
    let writeReset :: Write
writeReset = (Char -> Write) -> String -> Write
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