git.iko.soy/vty
on dc8be4e help sign in
vty/src/Graphics/Vty/Terminal/XTermColor.hs
110 lines 4.0 kB history raw
1-- Copyright 2009-2010 Corey O'Connor
2{-# LANGUAGE ForeignFunctionInterface #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE MagicHash #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE TypeFamilies #-}
7module Graphics.Vty.Terminal.XTermColor ( terminal_instance
8 )
9 where
11import Graphics.Vty.Terminal.Generic
12import qualified Graphics.Vty.Terminal.TerminfoBased as TerminfoBased
14import Control.Applicative
15import Control.Monad.Trans
17import qualified Data.Text as T
18import qualified Data.Text.Encoding as T
20import System.IO
22-- | An xterm color based terminal is some variant paired with a standard TerminfoBased terminal
23-- interface.
24--
25-- For the most part, xterm terminals just use the TerminfoBased implementation.
26data XTermColor = XTermColor
27 { xterm_variant :: String
28 , super_term :: TerminalHandle
29 }
31-- | Initialize the display to UTF-8.
32terminal_instance :: ( Applicative m, MonadIO m ) => String -> m XTermColor
33terminal_instance variant = do
34 -- If the terminal variant is xterm-color use xterm instead since, more often than not,
35 -- xterm-color is broken.
36 let variant' = if variant == "xterm-color" then "xterm" else variant
37 flushed_put set_utf8_char_set
38 t <- TerminfoBased.terminal_instance variant' >>= new_terminal_handle
39 return $ XTermColor variant' t
41-- | Output immediately followed by a flush.
42--
43-- \todo move out of this module.
44flushed_put :: MonadIO m => String -> m ()
45flushed_put str = do
46 liftIO $ hPutStr stdout str
47 liftIO $ hFlush stdout
49-- | These sequences set xterm based terminals to UTF-8 output.
50--
51-- \todo I don't know of a terminfo cap that is equivalent to this.
52set_utf8_char_set, set_default_char_set :: String
53set_utf8_char_set = "\ESC%G"
54set_default_char_set = "\ESC%@"
56instance Terminal XTermColor where
57 terminal_ID t = (show $ xterm_variant t) ++ " :: XTermColor"
59 release_terminal t = do
60 flushed_put set_default_char_set
61 release_terminal $ super_term t
63 reserve_display t = reserve_display (super_term t)
65 release_display t = release_display (super_term t)
67 display_terminal_instance t b c = do
68 d <- display_context (super_term t) b
69 return $ c (DisplayContext d)
71 display_bounds t = display_bounds (super_term t)
73 output_byte_buffer t = output_byte_buffer (super_term t)
75 output_handle t = output_handle (super_term t)
77data DisplayContext = DisplayContext
78 { super_display :: DisplayHandle
79 }
81instance DisplayTerminal DisplayContext where
82 context_region d = context_region (super_display d)
84 context_color_count d = context_color_count (super_display d)
86 move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)
87 serialize_move_cursor d = serialize_move_cursor (super_display d)
89 show_cursor_required_bytes d = show_cursor_required_bytes (super_display d)
90 serialize_show_cursor d = serialize_show_cursor (super_display d)
92 hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d)
93 serialize_hide_cursor d = serialize_hide_cursor (super_display d)
95 attr_required_bytes d = attr_required_bytes (super_display d)
96 serialize_set_attr d = serialize_set_attr (super_display d)
98 default_attr_required_bytes d = default_attr_required_bytes (super_display d)
99 serialize_default_attr d = serialize_default_attr (super_display d)
101 -- | I think xterm is broken: Reseting the background color as the first bytes serialized on a
102 -- new line does not effect the background color xterm uses to clear the line. Which is used
103 -- *after* the next newline.
104 inline_hack d = do
105 let t = case super_display d of
106 DisplayHandle _ t_ _ -> t_
107 let s_utf8 = T.encodeUtf8 $ T.pack "\ESC[K"
108 liftIO $ marshall_to_terminal t ( utf8_text_required_bytes s_utf8)
109 ( serialize_utf8_text s_utf8 )