git.iko.soy/vty
on 7448ab8 help sign in
vty/src/Graphics/Vty/Output/XTermColor.hs
115 lines 4.0 kB history raw
1{-# LANGUAGE CPP #-}
3#ifndef MIN_VERSION_base
4#defined MIN_VERSION_base(x,y,z) 1
5#endif
7-- Copyright 2009-2010 Corey O'Connor
8module Graphics.Vty.Output.XTermColor ( reserveTerminal )
9 where
11import Graphics.Vty.Output.Interface
12import Graphics.Vty.Input.Mouse
13import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased
15import Blaze.ByteString.Builder (writeToByteString)
16import Blaze.ByteString.Builder.Word (writeWord8)
18import Control.Monad (void, when)
19import Control.Monad.Trans
20import Data.IORef
22import System.Posix.IO (fdWrite)
23import System.Posix.Types (Fd)
24import System.Posix.Env (getEnv)
26#if !(MIN_VERSION_base(4,8,0))
27import Control.Applicative
28import Data.Foldable (foldMap)
29#endif
31import Data.List (isInfixOf)
32import Data.Maybe (catMaybes)
33import Data.Monoid ((<>))
35-- | Initialize the display to UTF-8.
36reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
37reserveTerminal variant outFd = liftIO $ do
38 let flushedPut = void . fdWrite outFd
39 -- If the terminal variant is xterm-color use xterm instead since, more often than not,
40 -- xterm-color is broken.
41 let variant' = if variant == "xterm-color" then "xterm" else variant
43 utf8a <- utf8Active
44 when (not utf8a) $ flushedPut setUtf8CharSet
45 t <- TerminfoBased.reserveTerminal variant' outFd
47 mouseModeStatus <- newIORef False
48 pasteModeStatus <- newIORef False
50 let xtermSetMode t' m newStatus = do
51 curStatus <- getModeStatus t' m
52 when (newStatus /= curStatus) $
53 case m of
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
65 xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus
66 xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus
68 let t' = t
69 { terminalID = terminalID t ++ " (xterm-color)"
70 , releaseTerminal = do
71 when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet
72 setMode t' BracketedPaste False
73 setMode t' Mouse False
74 releaseTerminal t
75 , mkDisplayContext = \tActual r -> do
76 dc <- mkDisplayContext t tActual r
77 return $ dc { inlineHack = xtermInlineHack t' }
78 , supportsMode = const True
79 , getModeStatus = xtermGetMode
80 , setMode = xtermSetMode t'
81 }
82 return t'
84utf8Active :: IO Bool
85utf8Active = do
86 let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
87 results <- catMaybes <$> mapM getEnv vars
88 let matches = filter ("UTF8" `isInfixOf`) results <>
89 filter ("UTF-8" `isInfixOf`) results
90 return $ not $ null matches
92-- | Enable bracketed paste mode:
93-- http://cirw.in/blog/bracketed-paste
94enableBracketedPastes :: String
95enableBracketedPastes = "\ESC[?2004h"
97-- | Disable bracketed paste mode:
98disableBracketedPastes :: String
99disableBracketedPastes = "\ESC[?2004l"
101-- | These sequences set xterm based terminals to UTF-8 output.
102--
103-- \todo I don't know of a terminfo cap that is equivalent to this.
104setUtf8CharSet, setDefaultCharSet :: String
105setUtf8CharSet = "\ESC%G"
106setDefaultCharSet = "\ESC%@"
108-- | I think xterm is broken: Reseting the background color as the first bytes serialized on a
109-- new line does not effect the background color xterm uses to clear the line. Which is used
110-- *after* the next newline.
111xtermInlineHack :: Output -> IO ()
112xtermInlineHack t = do
113 let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
114 outputByteBuffer t $ writeToByteString writeReset