b07daca · vty · git.iko.soy

src/Graphics/Vty/Attributes.hs+4−5

compare with master

unifiedsplit

@@ -1,12 +1,11 @@

1{-# LANGUAGE StandaloneDeriving #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE RankNTypes #-}

5−-- Display attributes

4+-- | Display attributes

6--

5--

7−-- For efficiency this can be, in the future, encoded into a single 32 bit word. The 32 bit word is

6+-- For efficiency, this could be encoded into a single 32 bit word. The 32 bit word is first divided

8−-- first divided into 4 groups of 8 bits where:

9−-- The first group codes what action should be taken with regards to the other groups.

7+-- into 4 groups of 8 bits where: The first group codes what action should be taken with regards to

8+-- the other groups.

10-- XXYYZZ__

9-- XXYYZZ__

11-- XX - style action

10-- XX - style action

12-- 00 => reset to default

11-- 00 => reset to default

src/Graphics/Vty/DisplayAttributes.hs+18

@@ -25,6 +25,12 @@ fix_display_attr fattr attr

25 fix_color c KeepCurrent = c

26 fix_color _c (SetTo c) = Just c

27

28+-- | difference between two display attributes. Used in the calculation of the operations required

29+-- to go from one display attribute to the next.

30+--

31+-- Previously, vty would reset display attributes to default then apply the new display attributes.

32+-- This turned out to be very expensive: A *lot* more data would be sent to the terminal than

33+-- required.

28data DisplayAttrDiff = DisplayAttrDiff

34data DisplayAttrDiff = DisplayAttrDiff

29 { style_diffs :: [ StyleStateChange ]

35 { style_diffs :: [ StyleStateChange ]

30 , fore_color_diff :: DisplayColorDiff

36 , fore_color_diff :: DisplayColorDiff

@@ -40,20 +46,30 @@ instance Monoid DisplayAttrDiff where

40 bcd = simplify_color_diffs ( back_color_diff d_0 ) ( back_color_diff d_1 )

46 bcd = simplify_color_diffs ( back_color_diff d_0 ) ( back_color_diff d_1 )

41 in DisplayAttrDiff ds fcd bcd

47 in DisplayAttrDiff ds fcd bcd

42

48

49+-- | Used in the computation of a final style attribute change.

50+--

51+-- TODO(corey): not really a simplify but a monoid instance.

43simplify_style_diffs :: [ StyleStateChange ] -> [ StyleStateChange ] -> [ StyleStateChange ]

52simplify_style_diffs :: [ StyleStateChange ] -> [ StyleStateChange ] -> [ StyleStateChange ]

44simplify_style_diffs cs_0 cs_1 = cs_0 `mappend` cs_1

53simplify_style_diffs cs_0 cs_1 = cs_0 `mappend` cs_1

45

54

55+-- | Consider two display color attributes diffs. What display color attribute diff are these

56+-- equivalent to?

57+--

58+-- TODO(corey): not really a simplify but a monoid instance.

46simplify_color_diffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff

59simplify_color_diffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff

47simplify_color_diffs _cd ColorToDefault = ColorToDefault

60simplify_color_diffs _cd ColorToDefault = ColorToDefault

48simplify_color_diffs cd NoColorChange = cd

61simplify_color_diffs cd NoColorChange = cd

49simplify_color_diffs _cd ( SetColor !c ) = SetColor c

62simplify_color_diffs _cd ( SetColor !c ) = SetColor c

50

63

64+-- | Difference between two display color attribute changes.

51data DisplayColorDiff

65data DisplayColorDiff

52 = ColorToDefault

66 = ColorToDefault

53 | NoColorChange

67 | NoColorChange

54 | SetColor !Color

68 | SetColor !Color

55 deriving ( Show, Eq )

69 deriving ( Show, Eq )

56

70

71+-- | Style attribute changes are transformed into a sequence of apply/removes of the individual

72+-- attributes.

57data StyleStateChange

73data StyleStateChange

58 = ApplyStandout

74 = ApplyStandout

59 | RemoveStandout

75 | RemoveStandout

@@ -69,6 +85,8 @@ data StyleStateChange

69 | RemoveBold

85 | RemoveBold

70 deriving ( Show, Eq )

86 deriving ( Show, Eq )

71

87

88+-- | Determines the diff between two display&color attributes. This diff determines the operations

89+-- that actually get output to the terminal.

72display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff

90display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff

73display_attr_diffs attr attr' = DisplayAttrDiff

91display_attr_diffs attr attr' = DisplayAttrDiff

74 { style_diffs = diff_styles ( fixed_style attr ) ( fixed_style attr' )

92 { style_diffs = diff_styles ( fixed_style attr ) ( fixed_style attr' )

src/Graphics/Vty/DisplayRegion.hs+1

@@ -4,6 +4,7 @@ module Graphics.Vty.DisplayRegion

4

5import Data.Word

6

7+-- | Region of the terminal that vty will output to. Units are columns not characters.

7data DisplayRegion = DisplayRegion

8data DisplayRegion = DisplayRegion

8 { region_width :: !Word

9 { region_width :: !Word

9 , region_height :: !Word

10 , region_height :: !Word

src/Graphics/Vty/Picture.hs+1−1

@@ -28,7 +28,7 @@ import Graphics.Vty.Image hiding ( attr )

28

29import Data.Word

30

31−-- |The type of images to be displayed using 'update'.

31+-- | The type of images to be displayed using 'update'.

32-- Can be constructed directly or using `pic_for_image`. Which provides an initial instance with

33-- reasonable defaults for pic_cursor and pic_background.

34data Picture = Picture

src/Graphics/Vty/Span.hs+12−2

@@ -116,11 +116,14 @@ columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op

116spans_for_pic :: Picture -> DisplayRegion -> DisplayOps

117spans_for_pic pic r = DisplayOps r $ Vector.create (build_spans pic r)

118

119+-- | Builds a vector of row operations that will output the given picture to the terminal.

120+--

121+-- Crops to the given display region.

119build_spans :: Picture -> DisplayRegion -> ST s (MRowOps s)

122build_spans :: Picture -> DisplayRegion -> ST s (MRowOps s)

120build_spans pic region = do

123build_spans pic region = do

121− -- m for mutable! ;-)

124+ -- First we create a mutable vector for each rows output operations.

122 mrow_ops <- Vector.replicate (fromEnum $ region_height region) Vector.empty

125 mrow_ops <- Vector.replicate (fromEnum $ region_height region) Vector.empty

123− -- XXX: I think building the span operations in display order would provide better performance.

126+ -- \todo I think building the span operations in display order would provide better performance.

124 -- However, I got stuck trying to implement an algorithm that did this. This will be considered

127 -- However, I got stuck trying to implement an algorithm that did this. This will be considered

125 -- as a possible future optimization.

128 -- as a possible future optimization.

126 --

129 --

@@ -154,6 +157,7 @@ build_spans pic region = do

154 else return ()

157 else return ()

155 return mrow_ops

158 return mrow_ops

156

159

160+-- | Add the operations required to build a given image to the current set of row operations.

157row_ops_for_image :: MRowOps s -> Image -> Background -> DisplayRegion -> (Word, Word) -> Int -> Word -> Int -> ST s (Word, Word)

161row_ops_for_image :: MRowOps s -> Image -> Background -> DisplayRegion -> (Word, Word) -> Int -> Word -> Int -> ST s (Word, Word)

158row_ops_for_image mrow_ops -- the image to output the ops to

162row_ops_for_image mrow_ops -- the image to output the ops to

159 image -- the image to rasterize in column order to mrow_ops

163 image -- the image to rasterize in column order to mrow_ops

@@ -313,6 +317,11 @@ snoc_text_span a text_str mrow_ops columns_to_skip y remaining_columns = do

313 , used_char_count

317 , used_char_count

314 )

318 )

315

319

320+-- | Add a background fill of the given column width to the row display operations.

321+--

322+-- This has a fast path for background characters that are a single column and a single byte.

323+-- Otherwise this has to compute the width of the background character and replicate a sequence of

324+-- bytes to fill in the required width.

316snoc_bg_fill :: MRowOps s -> Background -> Word -> Int -> ST s ()

325snoc_bg_fill :: MRowOps s -> Background -> Word -> Int -> ST s ()

317snoc_bg_fill _row_ops _bg 0 _row

326snoc_bg_fill _row_ops _bg 0 _row

318 = return ()

327 = return ()

@@ -336,6 +345,7 @@ snoc_bg_fill mrow_ops (Background c back_attr) fill_length row

336 $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes)

345 $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes)

337 snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs)

346 snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs)

338

347

348+-- | snocs the operation to the operations for the given row.

339snoc_op :: MRowOps s -> Int -> SpanOp -> ST s ()

349snoc_op :: MRowOps s -> Int -> SpanOp -> ST s ()

340snoc_op !mrow_ops !row !op = do

350snoc_op !mrow_ops !row !op = do

341 ops <- Vector.read mrow_ops row

351 ops <- Vector.read mrow_ops row

src/Graphics/Vty/Terminal/Generic.hs+8−2

@@ -28,6 +28,7 @@ import qualified Data.Vector as Vector

28

29import System.IO

30

31+-- | An handle to a terminal that hides the implementation.

31data TerminalHandle where

32data TerminalHandle where

32 TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle

33 TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle

33

34

@@ -39,11 +40,12 @@ new_terminal_handle t = do

39 s_ref <- liftIO $ newIORef initial_terminal_state

40 s_ref <- liftIO $ newIORef initial_terminal_state

40 return $ TerminalHandle t s_ref

41 return $ TerminalHandle t s_ref

41

42

43+-- | The current terminal state. This may not exactly be known.

42data TerminalState = TerminalState

44data TerminalState = TerminalState

43− { -- | The current terminal display attributes or Nothing if they are not known.

44− known_fattr :: Maybe FixedAttr

45+ { known_fattr :: Maybe FixedAttr

45 }

46 }

46

47

48+-- | Initially we know nothing about a terminal's state.

47initial_terminal_state :: TerminalState

49initial_terminal_state :: TerminalState

48initial_terminal_state = TerminalState Nothing

50initial_terminal_state = TerminalState Nothing

49

51

@@ -352,6 +354,8 @@ marshall_to_terminal t c f = do

352 free start_ptr

354 free start_ptr

353 return ()

355 return ()

354

356

357+-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this

358+-- needs to be translated to column, row positions.

355data CursorOutputMap = CursorOutputMap

359data CursorOutputMap = CursorOutputMap

356 { char_to_output_pos :: (Word, Word) -> (Word, Word)

360 { char_to_output_pos :: (Word, Word) -> (Word, Word)

357 }

361 }

@@ -386,6 +390,8 @@ cursor_column_offset span_ops cx cy =

386 cursor_row_ops

390 cursor_row_ops

387 in out_offset

391 in out_offset

388

392

393+-- | Not all terminals support all display attributes. This filters a display attribute to what the

394+-- given terminal can display.

389limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr

395limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr

390limit_attr_for_display d attr

396limit_attr_for_display d attr

391 = attr { attr_fore_color = clamp_color $ attr_fore_color attr

397 = attr { attr_fore_color = clamp_color $ attr_fore_color attr

src/Graphics/Vty/Terminal/MacOSX.hs+8−3

@@ -22,12 +22,16 @@ import Control.Monad.Trans

22

23import System.IO

24

25+-- | A Mac terminal is assumed to be an xterm based terminal.

25data Term = Term

26data Term = Term

26 { super_term :: TerminalHandle

27 { super_term :: TerminalHandle

27 , term_app :: String

28 , term_app :: String

28 }

29 }

29

30

30−-- for Terminal.app use "xterm". For iTerm.app use "xterm-256color"

31+-- | for Terminal.app the terminal identifier "xterm" is used. For iTerm.app the terminal identifier

32+-- "xterm-256color" is used.

33+--

34+-- This effects the terminfo lookup.

31terminal_instance :: ( Applicative m, MonadIO m ) => String -> m Term

35terminal_instance :: ( Applicative m, MonadIO m ) => String -> m Term

32terminal_instance v = do

36terminal_instance v = do

33 let base_term "iTerm.app" = "xterm-256color"

37 let base_term "iTerm.app" = "xterm-256color"

@@ -40,12 +44,13 @@ flushed_put str = do

40 liftIO $ hPutStr stdout str

44 liftIO $ hPutStr stdout str

41 liftIO $ hFlush stdout

45 liftIO $ hFlush stdout

42

46

43−-- Terminal.app really does want the xterm-color smcup and rmcup caps. Not the generic xterm ones.

47+-- | Terminal.app requires the xterm-color smcup and rmcup caps. Not the generic xterm ones.

48+-- Otherwise, Terminal.app expects the xterm caps.

44smcup_str, rmcup_str :: String

49smcup_str, rmcup_str :: String

45smcup_str = "\ESC7\ESC[?47h"

50smcup_str = "\ESC7\ESC[?47h"

46rmcup_str = "\ESC[2J\ESC[?47l\ESC8"

51rmcup_str = "\ESC[2J\ESC[?47l\ESC8"

47

52

48−-- iTerm needs a clear screen after smcup as well?

53+-- | iTerm needs a clear screen after smcup as well.

49clear_screen_str :: String

54clear_screen_str :: String

50clear_screen_str = "\ESC[H\ESC[2J"

55clear_screen_str = "\ESC[H\ESC[2J"

51

56

src/Graphics/Vty/Terminal/TerminfoBased.hs+13−7

@@ -215,7 +215,7 @@ instance DisplayTerminal DisplayContext where

215 serialize_hide_cursor d out_ptr

216 = liftIO $ serialize_cap_expression (civis $ term d) [] out_ptr

217

218− -- Instead of evaluating all the rules related to setting display attributes twice (once in

218+ -- | Instead of evaluating all the rules related to setting display attributes twice (once in

219 -- required bytes and again in serialize) or some memoization scheme just return a size

220 -- requirement as big the longest possible control string.

221 --

@@ -224,14 +224,16 @@ instance DisplayTerminal DisplayContext where

224 -- \todo Not verified as safe and wastes memory.

225 attr_required_bytes _d _prev_attr _req_attr _diffs = 512

226

227− -- Portably setting the display attributes is a giant pain in the ass.

227+ -- | Portably setting the display attributes is a giant pain in the ass.

228+ --

228 -- If the terminal supports the sgr capability (which sets the on/off state of each style

229 -- If the terminal supports the sgr capability (which sets the on/off state of each style

229− -- directly ; and, for no good reason, resets the colors to the default) this always works:

230+ -- directly ; and, for no good reason, resets the colors to the default) this procedure is used:

231+ --

230 -- 0. set the style attributes. This resets the fore and back color.

232 -- 0. set the style attributes. This resets the fore and back color.

231 -- 1, If a foreground color is to be set then set the foreground color

233 -- 1, If a foreground color is to be set then set the foreground color

232 -- 2. likewise with the background color

234 -- 2. likewise with the background color

233 --

235 --

234− -- If the terminal does not support the sgr then

236+ -- If the terminal does not support the sgr cap then:

235 -- if there is a change from an applied color to the default (in either the fore or back color)

237 -- if there is a change from an applied color to the default (in either the fore or back color)

236 -- then:

238 -- then:

237 -- 0. reset all display attributes (sgr0)

239 -- 0. reset all display attributes (sgr0)

@@ -242,7 +244,7 @@ instance DisplayTerminal DisplayContext where

242 -- Entering the required style modes could require a reset of the display attributes. If this is

244 -- Entering the required style modes could require a reset of the display attributes. If this is

243 -- the case then the back and fore colors always need to be set if not default.

245 -- the case then the back and fore colors always need to be set if not default.

244 --

246 --

245− -- All this (I think) is satisfied by the following logic:

247+ -- This equation implements the above logic.

246 serialize_set_attr d prev_attr req_attr diffs out_ptr = do

248 serialize_set_attr d prev_attr req_attr diffs out_ptr = do

247 case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of

249 case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of

248 -- The only way to reset either color, portably, to the default is to use either the set

250 -- The only way to reset either color, portably, to the default is to use either the set

@@ -321,11 +323,16 @@ instance DisplayTerminal DisplayContext where

321 serialize_default_attr d out_ptr = do

323 serialize_default_attr d out_ptr = do

322 liftIO $ serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr

324 liftIO $ serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr

323

325

326+-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not

327+-- be supported by the terminal.

328+--

329+-- This takes a Color which clearly identifies which pallete to use and computes the index

330+-- into the full 256 color pallete.

324ansi_color_index :: Color -> Word

331ansi_color_index :: Color -> Word

325ansi_color_index (ISOColor v) = toEnum $ fromEnum v

332ansi_color_index (ISOColor v) = toEnum $ fromEnum v

326ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v )

333ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v )

327

334

328−{- The sequence of terminfo caps to apply a given style are determined according to these rules.

335+{- | The sequence of terminfo caps to apply a given style are determined according to these rules.

329 -

336 -

330 - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than

337 - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than

331 - the full set display attribute state capability.

338 - the full set display attribute state capability.

@@ -340,7 +347,6 @@ ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v )

340 - apply/remove.

347 - apply/remove.

341 -

348 -

342 -}

349 -}

343−

344data DisplayAttrSeq

350data DisplayAttrSeq

345 = EnterExitSeq [CapExpression]

351 = EnterExitSeq [CapExpression]

346 | SetState DisplayAttrState

352 | SetState DisplayAttrState

src/Graphics/Vty/Terminal/XTermColor.hs+14−6

@@ -18,13 +18,16 @@ import qualified Data.String.UTF8 as UTF8

18

19import System.IO

20

21+-- | An xterm color based terminal is some variant paired with a standard TerminfoBased terminal

22+-- interface.

23+--

24+-- For the most part, xterm terminals just use the TerminfoBased implementation.

21data XTermColor = XTermColor

25data XTermColor = XTermColor

22 { xterm_variant :: String

26 { xterm_variant :: String

23 , super_term :: TerminalHandle

27 , super_term :: TerminalHandle

24 }

28 }

25

29

26−-- Initialize the display to UTF-8

30+-- | 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

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

29terminal_instance variant = do

32terminal_instance variant = do

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

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

@@ -34,12 +37,17 @@ terminal_instance variant = do

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

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

35 return $ XTermColor variant' t

38 return $ XTermColor variant' t

36

39

40+-- | Output immediately followed by a flush.

41+--

42+-- \todo move out of this module.

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

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

38flushed_put str = do

44flushed_put str = do

39 liftIO $ hPutStr stdout str

45 liftIO $ hPutStr stdout str

40 liftIO $ hFlush stdout

46 liftIO $ hFlush stdout

41

47

48+-- | These sequences set xterm based terminals to UTF-8 output.

49+--

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

50+-- \todo I don't know of a terminfo cap that is equivalent to this.

43set_utf8_char_set, set_default_char_set :: String

51set_utf8_char_set, set_default_char_set :: String

44set_utf8_char_set = "\ESC%G"

52set_utf8_char_set = "\ESC%G"

45set_default_char_set = "\ESC%@"

53set_default_char_set = "\ESC%@"

@@ -89,9 +97,9 @@ instance DisplayTerminal DisplayContext where

89 default_attr_required_bytes d = default_attr_required_bytes (super_display d)

97 default_attr_required_bytes d = default_attr_required_bytes (super_display d)

90 serialize_default_attr d = serialize_default_attr (super_display d)

98 serialize_default_attr d = serialize_default_attr (super_display d)

91

99

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

100+ -- | I think xterm is broken: Reseting the background color as the first bytes serialized on a

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

101+ -- new line does not effect the background color xterm uses to clear the line. Which is used

94− -- the next newline.

102+ -- *after* the next newline.

95 inline_hack d = do

103 inline_hack d = do

96 let t = case super_display d of

104 let t = case super_display d of

97 DisplayHandle _ t_ _ -> t_

105 DisplayHandle _ t_ _ -> t_