{-# Language CPP #-}
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
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)
reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output
reserveTerminal :: String -> Fd -> ColorMode -> m Output
reserveTerminal String
variant Fd
outFd ColorMode
colorMode = 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 :: 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
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 (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 (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 (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 (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
$ 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 (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
enableBracketedPastes :: ByteString
enableBracketedPastes :: ByteString
enableBracketedPastes = String -> ByteString
BS8.pack String
"\ESC[?2004h"
disableBracketedPastes :: ByteString
disableBracketedPastes :: ByteString
disableBracketedPastes = String -> ByteString
BS8.pack String
"\ESC[?2004l"
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 (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