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