git.iko.soy/vty
on 5edacaa help sign in
vty/src/Graphics/Vty/Terminal/TerminfoBased.hs
200 lines 7.5 kB history raw
1-- Copyright 2009 Corey O'Connor
2{-# LANGUAGE ForeignFunctionInterface #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE MagicHash #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE TypeFamilies #-}
7module Graphics.Vty.Terminal.TerminfoBased ( terminal_instance
8 )
9 where
11import Data.Terminfo.Parse
12import Data.Terminfo.Eval
14import Graphics.Vty.Attributes
15import Graphics.Vty.Terminal.Generic
16import Graphics.Vty.DisplayRegion
18import Data.Word
20import Foreign.C.Types ( CLong )
22import qualified System.Console.Terminfo as Terminfo
23import System.IO
25data Term = Term
26 { term_info_ID :: String
27 , smcup :: CapExpression
28 , rmcup :: CapExpression
29 , cup :: CapExpression
30 , cnorm :: CapExpression
31 , civis :: CapExpression
32 , set_fore_color :: CapExpression
33 , set_back_color :: CapExpression
34 , set_default_attr :: CapExpression
35 , set_attr :: CapExpression
36 }
38marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO ()
39marshall_cap_to_terminal t cap_selector cap_params = do
40 marshall_to_terminal t (cap_expression_required_bytes (cap_selector t) cap_params)
41 (serialize_cap_expression (cap_selector t) cap_params)
42 return ()
44{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
45 - terminfo does not support some features that would increase efficiency and improve compatibility:
46 - * determine the character encoding supported by the terminal. Should this be taken from the LANG
47 - environment variable?
48 - * Provide independent string capabilities for all display attributes.
49 -
50 -
51 - todo: Some display attributes like underline and bold have independent string capabilities that
52 - should be used instead of the generic "sgr" string capability.
53 -}
54terminal_instance :: String -> IO Term
55terminal_instance in_ID = do
56 term_info <- Terminfo.setupTerm in_ID
57 let str_cap str = case Terminfo.getCapability term_info (Terminfo.tiGetStr str) of
58 Nothing -> fail $ "Terminal does not define required capability \"" ++ str ++ "\""
59 Just cap_str -> case parse_cap_expression cap_str of
60 Left e -> fail $ show e
61 Right cap -> return cap
62 smcup_cap <- str_cap "smcup"
63 rmcup_cap <- str_cap "rmcup"
64 cup_cap <- str_cap "cup"
65 cnorm_cap <- str_cap "cnorm"
66 civis_cap <- str_cap "civis"
67 setaf_cap <- str_cap "setaf"
68 setab_cap <- str_cap "setab"
69 sgr0_cap <- str_cap "sgr0"
70 sgr_cap <- str_cap "sgr"
71 return $ Term in_ID
72 smcup_cap
73 rmcup_cap
74 cup_cap
75 cnorm_cap
76 civis_cap
77 setaf_cap
78 setab_cap
79 sgr0_cap
80 sgr_cap
82instance Terminal Term where
83 terminal_ID t = term_info_ID t ++ " :: TerminfoBased"
85 release_terminal _t = do
86 return ()
88 reserve_display t = do
89 marshall_cap_to_terminal t smcup []
90 marshall_cap_to_terminal t cup [0, 0]
91 return ()
93 release_display t = do
94 marshall_cap_to_terminal t rmcup []
95 marshall_cap_to_terminal t cnorm []
96 return ()
98 display_terminal_instance t b c = do
99 return $ c (DisplayContext b t)
101 display_bounds _t = do
102 raw_size <- get_window_size
103 case raw_size of
104 ( w, h ) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size
105 | otherwise -> return $ DisplayRegion (toEnum w) (toEnum h)
107 -- Output the byte buffer of the specified size to the terminal device.
108 output_byte_buffer _t out_ptr out_byte_count = do
109 hPutBuf stdout out_ptr (fromEnum out_byte_count)
110 hFlush stdout
112foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong
114get_window_size :: IO (Int,Int)
115get_window_size = do
116 (a,b) <- (`divMod` 65536) `fmap` c_get_window_size
117 return (fromIntegral b, fromIntegral a)
119data DisplayContext = DisplayContext
120 { bounds :: DisplayRegion
121 , term :: Term
122 }
124instance DisplayTerminal DisplayContext where
125 context_region d = bounds d
127 move_cursor_required_bytes d x y
128 = cap_expression_required_bytes (cup $ term d) [y, x]
129 serialize_move_cursor d x y out_ptr
130 = serialize_cap_expression (cup $ term d) [y, x] out_ptr
132 show_cursor_required_bytes d
133 = cap_expression_required_bytes (cnorm $ term d) []
134 serialize_show_cursor d out_ptr
135 = serialize_cap_expression (cnorm $ term d) [] out_ptr
137 hide_cursor_required_bytes d
138 = cap_expression_required_bytes (civis $ term d) []
139 serialize_hide_cursor d out_ptr
140 = serialize_cap_expression (civis $ term d) [] out_ptr
142 -- 0. set the style attributes. This resets the fore and back color.
143 -- 1, If a foreground color is to be set then set the foreground color
144 -- 2. likewise with the background color
145 --
146 --
147 -- todo: This process is accurate but inefficient. Optimize later.
148 attr_required_bytes d prev_attr req_attr =
149 let attr = fix_display_attr prev_attr req_attr
150 in cap_expression_required_bytes ( set_attr $ term d )
151 ( sgr_args_for_style (fixed_style attr) )
152 + case fixed_fore_color attr of
153 Just c -> cap_expression_required_bytes ( set_fore_color $ term d )
154 [ ansi_color_index c ]
155 Nothing -> 0
156 + case fixed_back_color attr of
157 Just c -> cap_expression_required_bytes ( set_back_color $ term d )
158 [ ansi_color_index c ]
159 Nothing -> 0
161 serialize_set_attr d prev_attr req_attr out_ptr = do
162 let attr = fix_display_attr prev_attr req_attr
163 out_ptr' <- serialize_cap_expression ( set_attr $ term d )
164 ( sgr_args_for_style (fixed_style attr) )
165 out_ptr
166 out_ptr'' <- case fixed_fore_color attr of
167 Just c -> serialize_cap_expression ( set_fore_color $ term d )
168 [ ansi_color_index c ]
169 out_ptr'
170 Nothing -> return out_ptr'
171 out_ptr''' <- case fixed_back_color attr of
172 Just c -> serialize_cap_expression ( set_back_color $ term d )
173 [ ansi_color_index c ]
174 out_ptr''
175 Nothing -> return out_ptr''
176 return out_ptr'''
178 default_attr_required_bytes d
179 = cap_expression_required_bytes (set_default_attr $ term d) []
180 serialize_default_attr d out_ptr = do
181 out_ptr' <- serialize_cap_expression (set_default_attr $ term d) [] out_ptr
182 return out_ptr'
184ansi_color_index :: Color -> Word
185ansi_color_index (ISOColor v) = toEnum $ fromEnum v
186ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v )
188sgr_args_for_style :: Style -> [CapParam]
189sgr_args_for_style s = map ( \b -> if b then 1 else 0 )
190 [ s `has_style` standout
191 , s `has_style` underline
192 , s `has_style` reverse_video
193 , s `has_style` blink
194 , s `has_style` dim
195 , s `has_style` bold
196 , False -- invis
197 , False -- protect
198 , False -- alt char set
199 ]