git.iko.soy/vty
on d64ff96 help sign in
vty/src/Graphics/Vty/Output/XTermColor.hs
118 lines 4.5 kB history raw
1-- Copyright 2009-2010 Corey O'Connor
2-- | Xterm output driver. This uses the Terminfo driver with some
3-- extensions for Xterm.
4module Graphics.Vty.Output.XTermColor
5 ( reserveTerminal
6 )
7where
9import Graphics.Vty.Output.Interface
10import Graphics.Vty.Input.Mouse
11import Graphics.Vty.Input.Focus
12import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
14import Blaze.ByteString.Builder (writeToByteString)
15import Blaze.ByteString.Builder.Word (writeWord8)
17import Control.Monad (void, when)
18import Control.Monad.Trans
19import Data.IORef
21import System.Posix.IO (fdWrite)
22import System.Posix.Types (Fd)
23import System.Posix.Env (getEnv)
25import Data.List (isInfixOf)
26import Data.Maybe (catMaybes)
27import Data.Monoid ((<>))
29-- | Construct an Xterm output driver. Initialize the display to UTF-8.
30reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
31reserveTerminal variant outFd = liftIO $ do
32 let flushedPut = void . fdWrite outFd
33 -- If the terminal variant is xterm-color use xterm instead since,
34 -- more often than not, xterm-color is broken.
35 let variant' = if variant == "xterm-color" then "xterm" else variant
37 utf8a <- utf8Active
38 when (not utf8a) $ flushedPut setUtf8CharSet
39 t <- TerminfoBased.reserveTerminal variant' outFd
41 mouseModeStatus <- newIORef False
42 focusModeStatus <- newIORef False
43 pasteModeStatus <- newIORef False
45 let xtermSetMode t' m newStatus = do
46 curStatus <- getModeStatus t' m
47 when (newStatus /= curStatus) $
48 case m of
49 Focus -> liftIO $ do
50 case newStatus of
51 True -> flushedPut requestFocusEvents
52 False -> flushedPut disableFocusEvents
53 writeIORef focusModeStatus newStatus
54 Mouse -> liftIO $ do
55 case newStatus of
56 True -> flushedPut requestMouseEvents
57 False -> flushedPut disableMouseEvents
58 writeIORef mouseModeStatus newStatus
59 BracketedPaste -> liftIO $ do
60 case newStatus of
61 True -> flushedPut enableBracketedPastes
62 False -> flushedPut disableBracketedPastes
63 writeIORef pasteModeStatus newStatus
64 Hyperlink -> setMode t Hyperlink newStatus
66 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
67 xtermGetMode Focus = liftIO $ readIORef focusModeStatus
68 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
69 xtermGetMode Hyperlink = getModeStatus t Hyperlink
71 let t' = t
72 { terminalID = terminalID t ++ " (xterm-color)"
73 , releaseTerminal = do
74 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
75 setMode t' BracketedPaste False
76 setMode t' Mouse False
77 setMode t' Focus False
78 releaseTerminal t
79 , mkDisplayContext = \tActual r -> do
80 dc <- mkDisplayContext t tActual r
81 return $ dc { inlineHack = xtermInlineHack t' }
82 , supportsMode = const True
83 , getModeStatus = xtermGetMode
84 , setMode = xtermSetMode t'
85 }
86 return t'
88utf8Active :: IO Bool
89utf8Active = do
90 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
91 results <- catMaybes <$> mapM getEnv vars
92 let matches = filter ("UTF8" `isInfixOf`) results <>
93 filter ("UTF-8" `isInfixOf`) results
94 return $ not $ null matches
96-- | Enable bracketed paste mode:
97-- http://cirw.in/blog/bracketed-paste
98enableBracketedPastes :: String
99enableBracketedPastes = "\ESC[?2004h"
101-- | Disable bracketed paste mode:
102disableBracketedPastes :: String
103disableBracketedPastes = "\ESC[?2004l"
105-- | These sequences set xterm based terminals to UTF-8 output.
106--
107-- There is no known terminfo capability equivalent to this.
108setUtf8CharSet, setDefaultCharSet :: String
109setUtf8CharSet = "\ESC%G"
110setDefaultCharSet = "\ESC%@"
112-- | I think xterm is broken: Reseting the background color as the first
113-- bytes serialized on a new line does not effect the background color
114-- xterm uses to clear the line. Which is used *after* the next newline.
115xtermInlineHack :: Output -> IO ()
116xtermInlineHack t = do
117 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
118 outputByteBuffer t $ writeToByteString writeReset