vty-4.7.0.12: src/Graphics/Vty/Terminal/TerminfoBased.hs
-- Copyright 2009-2010 Corey O'Connor
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-}
module Graphics.Vty.Terminal.TerminfoBased ( terminal_instance
)
where
import Data.Terminfo.Parse
import Data.Terminfo.Eval
import Graphics.Vty.Attributes
import Graphics.Vty.DisplayAttributes
import Graphics.Vty.Terminal.Generic
import Graphics.Vty.DisplayRegion
import Control.Applicative
import Control.Monad ( foldM )
import Control.Monad.Trans
import Data.Bits ( (.&.) )
import Data.Maybe ( isJust, isNothing, fromJust )
import Data.Word
import Foreign.C.Types ( CLong )
import GHC.IO.Handle
import qualified System.Console.Terminfo as Terminfo
import System.IO
data Term = Term
{ term_info_ID :: String
, term_info :: Terminfo.Terminal
, smcup :: Maybe CapExpression
, rmcup :: Maybe CapExpression
, cup :: CapExpression
, cnorm :: CapExpression
, civis :: CapExpression
, set_fore_color :: CapExpression
, set_back_color :: CapExpression
, set_default_attr :: CapExpression
, clear_screen :: CapExpression
, display_attr_caps :: DisplayAttrCaps
, term_handle :: Handle
}
data DisplayAttrCaps = DisplayAttrCaps
{ set_attr_states :: Maybe CapExpression
, enter_standout :: Maybe CapExpression
, exit_standout :: Maybe CapExpression
, enter_underline :: Maybe CapExpression
, exit_underline :: Maybe CapExpression
, enter_reverse_video :: Maybe CapExpression
, enter_dim_mode :: Maybe CapExpression
, enter_bold_mode :: Maybe CapExpression
}
marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO ()
marshall_cap_to_terminal t cap_selector cap_params = do
marshall_to_terminal t ( cap_expression_required_bytes (cap_selector t) cap_params )
( serialize_cap_expression (cap_selector t) cap_params )
return ()
{- | Uses terminfo for all control codes. While this should provide the most compatible terminal
- terminfo does not support some features that would increase efficiency and improve compatibility:
- * determine the character encoding supported by the terminal. Should this be taken from the LANG
- environment variable?
- * Provide independent string capabilities for all display attributes.
-
-
- todo: Some display attributes like underline and bold have independent string capabilities that
- should be used instead of the generic "sgr" string capability.
-}
terminal_instance :: ( Applicative m, MonadIO m ) => String -> m Term
terminal_instance in_ID = do
ti <- liftIO $ Terminfo.setupTerm in_ID
let require_cap str
= case Terminfo.getCapability ti (Terminfo.tiGetStr str) of
Nothing -> fail $ "Terminal does not define required capability \"" ++ str ++ "\""
Just cap_str -> do
parse_result <- parse_cap_expression cap_str
case parse_result of
Left e -> fail $ show e
Right cap -> return cap
probe_cap cap_name
= case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
Nothing -> return Nothing
Just cap_str -> do
parse_result <- parse_cap_expression cap_str
case parse_result of
Left e -> fail $ show e
Right cap -> return $ Just cap
the_handle <- liftIO $ hDuplicate stdout
pure Term
<*> pure in_ID
<*> pure ti
<*> probe_cap "smcup"
<*> probe_cap "rmcup"
<*> require_cap "cup"
<*> require_cap "cnorm"
<*> require_cap "civis"
<*> require_cap "setaf"
<*> require_cap "setab"
<*> require_cap "sgr0"
<*> require_cap "clear"
<*> current_display_attr_caps ti
<*> pure the_handle
current_display_attr_caps :: ( Applicative m, MonadIO m )
=> Terminfo.Terminal
-> m DisplayAttrCaps
current_display_attr_caps ti
= pure DisplayAttrCaps
<*> probe_cap "sgr"
<*> probe_cap "smso"
<*> probe_cap "rmso"
<*> probe_cap "smul"
<*> probe_cap "rmul"
<*> probe_cap "rev"
<*> probe_cap "dim"
<*> probe_cap "bold"
where probe_cap cap_name
= case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of
Nothing -> return Nothing
Just cap_str -> do
parse_result <- parse_cap_expression cap_str
case parse_result of
Left e -> fail $ show e
Right cap -> return $ Just cap
instance Terminal Term where
terminal_ID t = term_info_ID t ++ " :: TerminfoBased"
release_terminal t = do
liftIO $ marshall_cap_to_terminal t set_default_attr []
liftIO $ marshall_cap_to_terminal t cnorm []
liftIO $ hClose $ term_handle t
return ()
reserve_display t = do
if (isJust $ smcup t)
then liftIO $ marshall_cap_to_terminal t (fromJust . smcup) []
else return ()
-- Screen on OS X does not appear to support smcup?
-- To approximate the expected behavior: clear the screen and then move the mouse to the
-- home position.
liftIO $ hFlush stdout
liftIO $ marshall_cap_to_terminal t clear_screen []
return ()
release_display t = do
if (isJust $ rmcup t)
then liftIO $ marshall_cap_to_terminal t (fromJust . rmcup) []
else return ()
liftIO $ marshall_cap_to_terminal t cnorm []
return ()
display_terminal_instance t b c = do
let color_count
= case Terminfo.getCapability (term_info t) (Terminfo.tiGetNum "colors" ) of
Nothing -> 8
Just v -> toEnum v
return $ c (DisplayContext b t color_count)
display_bounds _t = do
raw_size <- liftIO $ get_window_size
case raw_size of
( w, h ) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size
| otherwise -> return $ DisplayRegion (toEnum w) (toEnum h)
-- | Output the byte buffer of the specified size to the terminal device.
output_byte_buffer t out_ptr out_byte_count = do
-- if the out fd is actually the same as stdout's then a
-- flush is required *before* the c_output_byte_buffer call
-- otherwise there may still be data in GHC's internal stdout buffer.
-- _ <- handleToFd stdout
hPutBuf (term_handle t) out_ptr (fromEnum out_byte_count)
hFlush (term_handle t)
output_handle t = return (term_handle t)
foreign import ccall "gwinsz.h vty_c_get_window_size" c_get_window_size
:: IO CLong
get_window_size :: IO (Int,Int)
get_window_size = do
(a,b) <- (`divMod` 65536) `fmap` c_get_window_size
return (fromIntegral b, fromIntegral a)
data DisplayContext = DisplayContext
{ bounds :: DisplayRegion
, term :: Term
, supported_colors :: Word
}
instance DisplayTerminal DisplayContext where
context_region d = bounds d
context_color_count d = supported_colors d
move_cursor_required_bytes d x y
= cap_expression_required_bytes (cup $ term d) [y, x]
serialize_move_cursor d x y out_ptr
= liftIO $ serialize_cap_expression (cup $ term d) [y, x] out_ptr
show_cursor_required_bytes d
= cap_expression_required_bytes (cnorm $ term d) []
serialize_show_cursor d out_ptr
= liftIO $ serialize_cap_expression (cnorm $ term d) [] out_ptr
hide_cursor_required_bytes d
= cap_expression_required_bytes (civis $ term d) []
serialize_hide_cursor d out_ptr
= liftIO $ serialize_cap_expression (civis $ term d) [] out_ptr
-- Instead of evaluating all the rules related to setting display attributes twice (once in
-- required bytes and again in serialize) or some memoization scheme just return a size
-- requirement as big the longest possible control string.
--
-- Which is assumed to the be less than 512 for now.
--
-- \todo Not verified as safe and wastes memory.
attr_required_bytes _d _prev_attr _req_attr _diffs = 512
-- Portably setting the display attributes is a giant pain in the ass.
-- If the terminal supports the sgr capability (which sets the on/off state of each style
-- directly ; and, for no good reason, resets the colors to the default) this always works:
-- 0. set the style attributes. This resets the fore and back color.
-- 1, If a foreground color is to be set then set the foreground color
-- 2. likewise with the background color
--
-- If the terminal does not support the sgr then
-- if there is a change from an applied color to the default (in either the fore or back color)
-- then:
-- 0. reset all display attributes (sgr0)
-- 1. enter required style modes
-- 2. set the fore color if required
-- 3. set the back color if required
--
-- Entering the required style modes could require a reset of the display attributes. If this is
-- the case then the back and fore colors always need to be set if not default.
--
-- All this (I think) is satisfied by the following logic:
serialize_set_attr d prev_attr req_attr diffs out_ptr = do
case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of
-- The only way to reset either color, portably, to the default is to use either the set
-- state capability or the set default capability.
True -> do
case req_display_cap_seq_for ( display_attr_caps $ term d )
( fixed_style attr )
( style_to_apply_seq $ fixed_style attr )
of
EnterExitSeq caps
-- only way to reset a color to the defaults
-> serialize_default_attr d out_ptr
>>= (\out_ptr' -> liftIO $ foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps)
>>= set_colors
SetState state
-- implicitly resets the colors to the defaults
-> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states
$ display_attr_caps
$ term d
)
( sgr_args_for_state state )
out_ptr
>>= set_colors
-- Otherwise the display colors are not changing or changing between two non-default
-- points.
False -> do
-- Still, it could be the case that the change in display attributes requires the
-- colors to be reset because the required capability was not available.
case req_display_cap_seq_for ( display_attr_caps $ term d )
( fixed_style attr )
( style_diffs diffs )
of
-- Really, if terminals were re-implemented with modern concepts instead of
-- bowing down to 40 yr old dumb terminal requirements this would be the
-- only case ever reached!
-- Changes the style and color states according to the differences with the
-- currently applied states.
EnterExitSeq caps
-> liftIO ( foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps )
>>= apply_color_diff set_fore_color ( fore_color_diff diffs )
>>= apply_color_diff set_back_color ( back_color_diff diffs )
SetState state
-- implicitly resets the colors to the defaults
-> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states
$ display_attr_caps
$ term d
)
( sgr_args_for_state state )
out_ptr
>>= set_colors
where
attr = fix_display_attr prev_attr req_attr
set_colors ptr = do
ptr' <- case fixed_fore_color attr of
Just c -> liftIO $ serialize_cap_expression ( set_fore_color $ term d )
[ ansi_color_index c ]
ptr
Nothing -> return ptr
ptr'' <- case fixed_back_color attr of
Just c -> liftIO $ serialize_cap_expression ( set_back_color $ term d )
[ ansi_color_index c ]
ptr'
Nothing -> return ptr'
return ptr''
apply_color_diff _f NoColorChange ptr
= return ptr
apply_color_diff _f ColorToDefault _ptr
= fail "ColorToDefault is not a possible case for apply_color_diffs"
apply_color_diff f ( SetColor c ) ptr
= liftIO $ serialize_cap_expression ( f $ term d )
[ ansi_color_index c ]
ptr
default_attr_required_bytes d
= cap_expression_required_bytes (set_default_attr $ term d) []
serialize_default_attr d out_ptr = do
liftIO $ serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr
ansi_color_index :: Color -> Word
ansi_color_index (ISOColor v) = toEnum $ fromEnum v
ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v )
{- The sequence of terminfo caps to apply a given style are determined according to these rules.
-
- 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
- the full set display attribute state capability.
-
- 2. If a mode is supposed to be removed but there is not an exit capability defined then the
- display attributes are reset to defaults then the display attribute state is set.
-
- 3. If a mode is supposed to be applied but there is not an enter capability defined then then
- display attribute state is set if possible. Otherwise the mode is not applied.
-
- 4. If the display attribute state is being set then just update the arguments to that for any
- apply/remove.
-
-}
data DisplayAttrSeq
= EnterExitSeq [CapExpression]
| SetState DisplayAttrState
data DisplayAttrState = DisplayAttrState
{ apply_standout :: Bool
, apply_underline :: Bool
, apply_reverse_video :: Bool
, apply_blink :: Bool
, apply_dim :: Bool
, apply_bold :: Bool
}
sgr_args_for_state :: DisplayAttrState -> [CapParam]
sgr_args_for_state attr_state = map (\b -> if b then 1 else 0)
[ apply_standout attr_state
, apply_underline attr_state
, apply_reverse_video attr_state
, apply_blink attr_state
, apply_dim attr_state
, apply_bold attr_state
, False -- invis
, False -- protect
, False -- alt char set
]
req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
req_display_cap_seq_for caps s diffs
-- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
-- then either the state needs to be set or the attribute change ignored.
= case (any no_enter_exit_cap diffs, isJust $ set_attr_states caps) of
-- If all the diffs have an enter-exit cap then just use those
( False, _ ) -> EnterExitSeq $ map enter_exit_cap diffs
-- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
-- all unsupported diffs and just apply the rest
( True, False ) -> EnterExitSeq $ map enter_exit_cap
$ filter (not . no_enter_exit_cap) diffs
-- if not all the diffs have an enter-exit can and there is a set state cap then just use
-- the set state cap.
( True, True ) -> SetState $ state_for_style s
where
no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps
no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps
no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps
no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps
no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps
no_enter_exit_cap RemoveReverseVideo = True
no_enter_exit_cap ApplyBlink = True
no_enter_exit_cap RemoveBlink = True
no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps
no_enter_exit_cap RemoveDim = True
no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps
no_enter_exit_cap RemoveBold = True
enter_exit_cap ApplyStandout = fromJust $ enter_standout caps
enter_exit_cap RemoveStandout = fromJust $ exit_standout caps
enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps
enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps
enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps
enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps
enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps
enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one."
state_for_style :: Style -> DisplayAttrState
state_for_style s = DisplayAttrState
{ apply_standout = is_style_set standout
, apply_underline = is_style_set underline
, apply_reverse_video = is_style_set reverse_video
, apply_blink = is_style_set blink
, apply_dim = is_style_set dim
, apply_bold = is_style_set bold
}
where is_style_set = has_style s
style_to_apply_seq :: Style -> [StyleStateChange]
style_to_apply_seq s = concat
[ apply_if_required ApplyStandout standout
, apply_if_required ApplyUnderline underline
, apply_if_required ApplyReverseVideo reverse_video
, apply_if_required ApplyBlink blink
, apply_if_required ApplyDim dim
, apply_if_required ApplyBlink bold
]
where
apply_if_required ap flag
= if 0 == ( flag .&. s )
then []
else [ ap ]