    {-# 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 =
        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

        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
    $ ByteString -> IO ()
    flushedPut ByteString
    setUtf8CharSet
        Output
    t <- String -> Fd -> ColorMode -> IO Output
    TerminfoBased.reserveTerminal String
    variant' Fd
    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
                          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 -> 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
                     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 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
    $ 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
                    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'
                 }
        Output -> IO Output
    forall a. a -> IO a
    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)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> IO a
    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 a. [a] -> Bool
    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 = (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