    {-# 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.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 variant :: String
    variant outFd :: 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
    == "xterm-color" then "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 t' :: Output
    t' m :: Mode
    m newStatus :: 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
                      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
                              True -> String -> IO ()
    flushedPut String
    requestFocusEvents
                              False -> String -> IO ()
    flushedPut String
    disableFocusEvents
                          IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    focusModeStatus Bool
    newStatus
                      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
                              True -> String -> IO ()
    flushedPut String
    requestMouseEvents
                              False -> String -> IO ()
    flushedPut String
    disableMouseEvents
                          IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    mouseModeStatus Bool
    newStatus
                      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
                              True -> String -> IO ()
    flushedPut String
    enableBracketedPastes
                              False -> String -> IO ()
    flushedPut String
    disableBracketedPastes
                          IORef Bool -> Bool -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef IORef Bool
    pasteModeStatus Bool
    newStatus
                      Hyperlink -> Output -> Mode -> Bool -> IO ()
    setMode Output
    t Mode
    Hyperlink Bool
    newStatus

            xtermGetMode :: Mode -> IO Bool
    xtermGetMode 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 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 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 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]
    ++ " (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 = \tActual :: Output
    tActual r :: 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 = ["LC_ALL", "LANG", "LC_CTYPE"]
        [String]
    results <- [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 ("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 ("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 = "\ESC[?2004h"

    -- | Disable bracketed paste mode:
    disableBracketedPastes :: String
    disableBracketedPastes :: String
    disableBracketedPastes = "\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 = "\ESC%G"
    setDefaultCharSet :: String
    setDefaultCharSet = "\ESC%@"

    -- | I think xterm is broken: Reseting the background color as the first
    -- bytes serialized on a new line does not effect the background color
    -- xterm uses to clear the line. Which is used *after* the next newline.
    xtermInlineHack :: Output -> IO ()
    xtermInlineHack :: Output -> IO ()
    xtermInlineHack t :: 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) "\ESC[K"
        Output -> ByteString -> IO ()
    outputByteBuffer Output
    t (ByteString -> IO ()) -> ByteString -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Write -> ByteString
    writeToByteString Write
    writeReset