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

git.iko.soy/vty

on bcda3db help sign in

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

94 lines 3.4 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 System.IO

19data XTermColor = XTermColor

20 { xterm_variant :: String

21 , super_term :: TerminalHandle

22 }

24-- Initialize the display to UTF-8

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

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

27terminal_instance variant = do

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

29 -- xterm-color is broken.

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

31 flushed_put set_utf8_char_set

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

33 return $ XTermColor variant' t

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

36flushed_put str = do

37 liftIO $ hPutStr stdout str

38 liftIO $ hFlush stdout

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

41set_utf8_char_set, set_default_char_set :: String

42set_utf8_char_set = "\ESC%G"

43set_default_char_set = "\ESC%@"

45instance Terminal XTermColor where

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

48 release_terminal t = do

49 flushed_put set_default_char_set

50 release_terminal $ super_term t

52 reserve_display t = reserve_display (super_term t)

54 release_display t = release_display (super_term t)

56 display_terminal_instance t b c = do

57 d <- display_context (super_term t) b

58 return $ c (DisplayContext d)

60 display_bounds t = display_bounds (super_term t)

62 output_byte_buffer t = output_byte_buffer (super_term t)

64data DisplayContext = DisplayContext

65 { super_display :: DisplayHandle

66 }

68instance DisplayTerminal DisplayContext where

69 context_region d = context_region (super_display d)

71 context_color_count d = context_color_count (super_display d)

73 move_cursor_required_bytes d = move_cursor_required_bytes (super_display d)

74 serialize_move_cursor d = serialize_move_cursor (super_display d)

76 show_cursor_required_bytes d = show_cursor_required_bytes (super_display d)

77 serialize_show_cursor d = serialize_show_cursor (super_display d)

79 hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d)

80 serialize_hide_cursor d = serialize_hide_cursor (super_display d)

82 attr_required_bytes d = attr_required_bytes (super_display d)

83 serialize_set_attr d = serialize_set_attr (super_display d)

85 default_attr_required_bytes d = default_attr_required_bytes (super_display d)

86 serialize_default_attr d = serialize_default_attr (super_display d)

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

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

90 -- the next newline.

91 inline_hack _d = do

92 liftIO $ hPutStr stdout "\ESC[K"

93 liftIO $ hFlush stdout