1183229 · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

start of implementing put_attr_change

1183229coreyoconnor17 years ago

src/Graphics/Vty/AttributeChange.hsnew file+29

compare with master

unifiedsplit

@@ -0,0 +1,29 @@

1+module Graphics.Vty.AttributeChange ( module Graphics.Vty.AttributeChange

2+ )

3+ where

5+import Graphics.Vty.Attributes

6+import Graphics.Vty.DisplayAttributes

7+import Graphics.Vty.Terminal.Generic

9+import Control.Monad.State.Strict

10+

11+data ChangeState = ChangeState

12+ { change_sequence :: ()

13+ }

14+

15+type AttrChange v = State ChangeState v

16+

17+back_color :: Color -> AttrChange ()

18+back_color c = return ()

19+

20+style :: Style -> AttrChange ()

21+style s = return ()

22+

23+default_all :: AttrChange ()

24+default_all = return ()

25+

26+put_attr_change :: TerminalHandle -> AttrChange () -> IO ()

27+put_attr_change t c = do

28+ return ()

29+

src/Graphics/Vty/DisplayAttributes.hsnew file+88

@@ -0,0 +1,88 @@

1+module Graphics.Vty.DisplayAttributes

2+ where

4+import Graphics.Vty.Attributes

6+import Data.Bits ( (.&.) )

7+import Data.Monoid ( mconcat )

9+-- | Given the previously applied display attributes as a FixedAttr and the current display

10+-- attributes as an Attr produces a FixedAttr that represents the current display attributes. This

11+-- is done by using the previously applied display attributes to remove the "KeepCurrent"

12+-- abstraction.

13+fix_display_attr :: FixedAttr -> Attr -> FixedAttr

14+fix_display_attr fattr attr

15+ = FixedAttr ( fix_style (fixed_style fattr) (attr_style attr) )

16+ ( fix_color (fixed_fore_color fattr) (attr_fore_color attr) )

17+ ( fix_color (fixed_back_color fattr) (attr_back_color attr) )

18+ where

19+ fix_style _s Default = default_style_mask

20+ fix_style s KeepCurrent = s

21+ fix_style _s (SetTo new_style) = new_style

22+ fix_color _c Default = Nothing

23+ fix_color c KeepCurrent = c

24+ fix_color _c (SetTo c) = Just c

25+

26+data DisplayAttrDiffs = DisplayAttrDiffs

27+ { style_diffs :: [ StyleStateChange ]

28+ , fore_color_diff :: DisplayColorDiff

29+ , back_color_diff :: DisplayColorDiff

30+ }

31+

32+data DisplayColorDiff

33+ = ColorToDefault

34+ | NoColorChange

35+ | SetColor !Color

36+ deriving Eq

37+

38+data StyleStateChange

39+ = ApplyStandout

40+ | RemoveStandout

41+ | ApplyUnderline

42+ | RemoveUnderline

43+ | ApplyReverseVideo

44+ | RemoveReverseVideo

45+ | ApplyBlink

46+ | RemoveBlink

47+ | ApplyDim

48+ | RemoveDim

49+ | ApplyBold

50+ | RemoveBold

51+

52+display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiffs

53+display_attr_diffs attr attr' = DisplayAttrDiffs

54+ { style_diffs = diff_styles ( fixed_style attr ) ( fixed_style attr' )

55+ , fore_color_diff = diff_color ( fixed_fore_color attr ) ( fixed_fore_color attr' )

56+ , back_color_diff = diff_color ( fixed_back_color attr ) ( fixed_back_color attr' )

57+ }

58+

59+diff_color :: Maybe Color -> Maybe Color -> DisplayColorDiff

60+diff_color Nothing (Just c') = SetColor c'

61+diff_color (Just c) (Just c')

62+ | c == c' = NoColorChange

63+ | otherwise = SetColor c'

64+diff_color Nothing Nothing = NoColorChange

65+diff_color (Just _) Nothing = ColorToDefault

66+

67+diff_styles :: Style -> Style -> [StyleStateChange]

68+diff_styles prev cur

69+ = mconcat

70+ [ style_diff standout ApplyStandout RemoveStandout

71+ , style_diff underline ApplyUnderline RemoveUnderline

72+ , style_diff reverse_video ApplyReverseVideo RemoveReverseVideo

73+ , style_diff blink ApplyBlink RemoveBlink

74+ , style_diff dim ApplyDim RemoveDim

75+ , style_diff bold ApplyBold RemoveBold

76+ ]

77+ where

78+ style_diff s sm rm

79+ = case ( 0 == prev .&. s, 0 == cur .&. s ) of

80+ -- not set in either

81+ ( True, True ) -> []

82+ -- set in both

83+ ( False, False ) -> []

84+ -- now set

85+ ( True, False) -> [ sm ]

86+ -- now unset

87+ ( False, True) -> [ rm ]

88+

src/Graphics/Vty/Terminal.hs−7

@@ -19,7 +19,6 @@ module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal

19 , TerminalHandle(..)

20 , DisplayHandle(..)

21 , output_picture

22− -- , put_attr_change

23 , display_context

22 , display_context

24 )

23 )

25 where

24 where

@@ -119,12 +118,6 @@ hide_cursor t = do

119 d <- display_context t bounds

118 d <- display_context t bounds

120 marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d)

119 marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d)

121

120

122−{-

123−put_attr_change :: TerminalHandle -> -> m ()

124−put_attr_change d img = do

125− return ()

126−-}

127−

128-- | Shows the cursor

121-- | Shows the cursor

129show_cursor :: TerminalHandle -> IO ()

122show_cursor :: TerminalHandle -> IO ()

130show_cursor t = do

123show_cursor t = do

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

@@ -15,15 +15,14 @@ import Graphics.Vty.Picture

15import Graphics.Vty.Span

16import Graphics.Vty.DisplayRegion

18+import Graphics.Vty.DisplayAttributes

19+

18import Control.Monad ( liftM )

20import Control.Monad ( liftM )

19−import Control.Monad.Trans

21import Data.Array

22import Data.Array

22−import Data.Bits ( (.&.) )

23import qualified Data.ByteString.Internal as BSCore

24import Data.Foldable

25import Data.IORef

26−import Data.Monoid ( mconcat )

27import Data.Word

26import Data.Word

28import Data.String.UTF8 hiding ( foldl )

27import Data.String.UTF8 hiding ( foldl )

@@ -334,86 +333,6 @@ marshall_to_terminal t c f = do

334 free start_ptr

333 free start_ptr

335 return ()

334 return ()

336

335

337−

338−-- | Given the previously applied display attributes as a FixedAttr and the current display

339−-- attributes as an Attr produces a FixedAttr that represents the current display attributes. This

340−-- is done by using the previously applied display attributes to remove the "KeepCurrent"

341−-- abstraction.

342−fix_display_attr :: FixedAttr -> Attr -> FixedAttr

343−fix_display_attr fattr attr

344− = FixedAttr ( fix_style (fixed_style fattr) (attr_style attr) )

345− ( fix_color (fixed_fore_color fattr) (attr_fore_color attr) )

346− ( fix_color (fixed_back_color fattr) (attr_back_color attr) )

347− where

348− fix_style _s Default = default_style_mask

349− fix_style s KeepCurrent = s

350− fix_style _s (SetTo new_style) = new_style

351− fix_color _c Default = Nothing

352− fix_color c KeepCurrent = c

353− fix_color _c (SetTo c) = Just c

354−

355−data DisplayAttrDiffs = DisplayAttrDiffs

356− { style_diffs :: [ StyleStateChange ]

357− , fore_color_diff :: DisplayColorDiff

358− , back_color_diff :: DisplayColorDiff

359− }

360−

361−data DisplayColorDiff

362− = ColorToDefault

363− | NoColorChange

364− | SetColor !Color

365− deriving Eq

366−

367−data StyleStateChange

368− = ApplyStandout

369− | RemoveStandout

370− | ApplyUnderline

371− | RemoveUnderline

372− | ApplyReverseVideo

373− | RemoveReverseVideo

374− | ApplyBlink

375− | RemoveBlink

376− | ApplyDim

377− | RemoveDim

378− | ApplyBold

379− | RemoveBold

380−

381−display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiffs

382−display_attr_diffs attr attr' = DisplayAttrDiffs

383− { style_diffs = diff_styles ( fixed_style attr ) ( fixed_style attr' )

384− , fore_color_diff = diff_color ( fixed_fore_color attr ) ( fixed_fore_color attr' )

385− , back_color_diff = diff_color ( fixed_back_color attr ) ( fixed_back_color attr' )

386− }

387−

388−diff_color Nothing (Just c') = SetColor c'

389−diff_color (Just c) (Just c')

390− | c == c' = NoColorChange

391− | otherwise = SetColor c'

392−diff_color Nothing Nothing = NoColorChange

393−diff_color (Just _) Nothing = ColorToDefault

394−

395−diff_styles :: Style -> Style -> [StyleStateChange]

396−diff_styles prev cur

397− = mconcat

398− [ style_diff standout ApplyStandout RemoveStandout

399− , style_diff underline ApplyUnderline RemoveUnderline

400− , style_diff reverse_video ApplyReverseVideo RemoveReverseVideo

401− , style_diff blink ApplyBlink RemoveBlink

402− , style_diff dim ApplyDim RemoveDim

403− , style_diff bold ApplyBold RemoveBold

404− ]

405− where

406− style_diff s sm rm

407− = case ( 0 == prev .&. s, 0 == cur .&. s ) of

408− -- not set in either

409− ( True, True ) -> []

410− -- set in both

411− ( False, False ) -> []

412− -- now set

413− ( True, False) -> [ sm ]

414− -- now unset

415− ( False, True) -> [ rm ]

416−

417data CursorOutputMap = CursorOutputMap

336data CursorOutputMap = CursorOutputMap

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

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

419 }

338 }

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

@@ -12,6 +12,7 @@ import Data.Terminfo.Parse

12import Data.Terminfo.Eval

14import Graphics.Vty.Attributes

15+import Graphics.Vty.DisplayAttributes

15import Graphics.Vty.Terminal.Generic

16import Graphics.Vty.Terminal.Generic

16import Graphics.Vty.DisplayRegion

17import Graphics.Vty.DisplayRegion

@@ -19,9 +20,8 @@ import Control.Applicative

19import Control.Monad ( foldM )

20import Control.Monad ( foldM )

21import Data.Bits ( (.&.) )

22import Data.Bits ( (.&.) )

22−import Data.List ( foldl' )

23import Data.Maybe ( fromJust )

24−import Data.Monoid

24+import Data.Monoid

25import Data.Word

27import Foreign.C.Types ( CLong )

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

197 -- Which is assumed to the be less than 512 for now.

198 --

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

200− attr_required_bytes d _prev_attr _req_attr _diffs = 512

200+ attr_required_bytes _d _prev_attr _req_attr _diffs = 512

201

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

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

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

230 EnterExitSeq caps

231 -- only way to reset a color to the defaults

232 -> serialize_default_attr d out_ptr

233− >>= (\ptr -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) ptr caps)

233+ >>= (\out_ptr' -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps)

234 >>= set_colors

235 SetState state

236 -- implicitly resets the colors to the defaults

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

284 return ptr''

285 apply_color_diff _f NoColorChange ptr

286 = return ptr

287− apply_color_diff _f ColorToDefault ptr

287+ apply_color_diff _f ColorToDefault _ptr

288 = fail "ColorToDefault is not a possible case for apply_color_diffs"

289 apply_color_diff f ( SetColor c ) ptr

290 = serialize_cap_expression ( f $ term d )

@@ -362,13 +362,13 @@ sgr_args_for_state attr_state = map (\b -> if b then 1 else 0)

362 ]

363

364req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq CapExpression

365−req_display_cap_seq_for caps style diffs =

365+req_display_cap_seq_for caps s diffs =

366 -- First pass: concat the monoid points that are implied by the diffs

367 let base = mconcat $ map diff_point diffs

368 -- Second pass: Apply the capability restrictions.

369 in apply_caps base

370 where

371− set_state = SetState $ state_for_style style

371+ set_state = SetState $ state_for_style s

372 diff_point ApplyStandout = EnterExitSeq [ApplyStandout]

373 diff_point ApplyUnderline = EnterExitSeq [ApplyUnderline]

374 diff_point ApplyReverseVideo = EnterExitSeq [ApplyReverseVideo]

test/interactive_terminal_test.hs+3−2

@@ -3,6 +3,7 @@

3module Main where

5import Graphics.Vty.Attributes

6+import Graphics.Vty.AttributeChange

6import Graphics.Vty.Image

7import Graphics.Vty.Image

7import Graphics.Vty.Picture

8import Graphics.Vty.Picture

8import Graphics.Vty.Terminal

9import Graphics.Vty.Terminal

@@ -853,9 +854,9 @@ inline_test_0 = Test

853 t <- terminal_handle

854 t <- terminal_handle

854 d <- display_bounds t >>= display_context t

855 d <- display_bounds t >>= display_context t

855 putStrLn "line 0."

856 putStrLn "line 0."

856− -- put_attr_change $ back_color red >> style underline

857+ put_attr_change t $ back_color red >> style underline

857 putStrLn "line 1."

858 putStrLn "line 1."

858− -- put_attr_change $ default_all

859+ put_attr_change t $ default_all

859 putStrLn "line 2."

860 putStrLn "line 2."

860 release_terminal t

861 release_terminal t

861 return ()

862 return ()

vty.cabal+1

@@ -37,6 +37,7 @@ Exposed-Modules: Graphics.Vty

37 Graphics.Vty.Terminal

38 Graphics.Vty.LLInput

39 Graphics.Vty.Attributes

40+ Graphics.Vty.AttributeChange

40 Graphics.Vty.Picture

41 Graphics.Vty.Picture

41 Graphics.Vty.DisplayRegion

42 Graphics.Vty.DisplayRegion