src/Graphics/Vty/Terminal/XTermColor.hs · vty

git.iko.soy/vty

on ae06339 help sign in

vty/src/Graphics/Vty/Terminal/XTermColor.hs

101 lines 3.7 kB history raw

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.String.UTF8 as UTF8

19import System.IO

21data XTermColor = XTermColor

22 { xterm_variant :: String

23 , super_term :: TerminalHandle

24 }

26-- Initialize the display to UTF-8

27-- Regardless of what is output the text encoding is assumed to be UTF-8

28terminal_instance :: ( Applicative m, MonadIO m ) => String -> m XTermColor

29terminal_instance variant = do

30 -- If the terminal variant is xterm-color use xterm instead since, more often than not,

31 -- xterm-color is broken.

32 let variant' = if variant == "xterm-color" then "xterm" else variant

33 flushed_put set_utf8_char_set

34 t <- TerminfoBased.terminal_instance variant' >>= new_terminal_handle

35 return $ XTermColor variant' t

37flushed_put :: MonadIO m => String -> m ()

38flushed_put str = do

39 liftIO $ hPutStr stdout str

40 liftIO $ hFlush stdout

42-- Since I don't know of a terminfo string cap that produces these strings these are hardcoded.

43set_utf8_char_set, set_default_char_set :: String

44set_utf8_char_set = "\ESC%G"

45set_default_char_set = "\ESC%@"

47instance Terminal XTermColor where

48 terminal_ID t = (show $ xterm_variant t) ++ " :: XTermColor"

50 release_terminal t = do

51 flushed_put set_default_char_set

52 release_terminal $ super_term t

54 reserve_display t = reserve_display (super_term t)

56 release_display t = release_display (super_term t)

58 display_terminal_instance t b c = do

59 d <- display_context (super_term t) b

60 return $ c (DisplayContext d)

62 display_bounds t = display_bounds (super_term t)

64 output_byte_buffer t = output_byte_buffer (super_term t)

66 output_handle t = output_handle (super_term t)

68data DisplayContext = DisplayContext

69 { super_display :: DisplayHandle

70 }

72instance DisplayTerminal DisplayContext where

73 context_region d = context_region (super_display d)

75 context_color_count d = context_color_count (super_display d)

77 move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)

78 serialize_move_cursor d = serialize_move_cursor (super_display d)

80 show_cursor_required_bytes d = show_cursor_required_bytes (super_display d)

81 serialize_show_cursor d = serialize_show_cursor (super_display d)

83 hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d)

84 serialize_hide_cursor d = serialize_hide_cursor (super_display d)

86 attr_required_bytes d = attr_required_bytes (super_display d)

87 serialize_set_attr d = serialize_set_attr (super_display d)

89 default_attr_required_bytes d = default_attr_required_bytes (super_display d)

90 serialize_default_attr d = serialize_default_attr (super_display d)

92 -- I think xterm is broken: Reseting the background color as the first bytes serialized on a new

93 -- line does not effect the background color xterm uses to clear the line. Which is used *after*

94 -- the next newline.

95 inline_hack d = do

96 let t = case super_display d of

97 DisplayHandle _ t_ _ -> t_

98 let s_utf8 = UTF8.fromString "\ESC[K"

99 liftIO $ marshall_to_terminal t ( utf8_text_required_bytes s_utf8)

100 ( serialize_utf8_text s_utf8 )

101