7f75f0d · vty · git.iko.soy

git.iko.soy/vty

Ignore-this: db643dff6f295a4d363b4e8634a8393a darcs-hash:20091109070521-f0a0d-0e657824eb6eabe8f94ce117baecae4a853f0d5f.gz

commit7f75f0d0af0c3b8a456b8e4c3e1768e23243636b authorcoreyoconnor <coreyoconnor@gmail.com> dateSun 8 Nov 2009, 23:05 (17 years ago) parent0aa8302

6 files changed+75−63

compare with master

unifiedsplit

src/Graphics/Vty/Attributes.hs+20−1 src/Graphics/Vty/DisplayAttributes.hs+3−1 src/Graphics/Vty/Inline.hs+36−49 src/Graphics/Vty/Terminal/Generic.hs+11−10 src/Graphics/Vty/Terminal/TerminfoBased.hs+3−1 test/interactive_terminal_test.hs+2−1

src/Graphics/Vty/Attributes.hs+20−1

@@ -36,7 +36,7 @@ module Graphics.Vty.Attributes

3636 where

3737

3838import Data.Bits

39−

39+import Data.Monoid

4040import Data.Word

4141

4242-- | A display attribute defines the Color and Style of all the characters rendered after the

@@ -51,6 +51,13 @@ data Attr = Attr

5151 , attr_back_color :: !(MaybeDefault Color)

5252 } deriving ( Eq, Show )

5353

54+instance Monoid Attr where

55+ mempty = Attr mempty mempty mempty

56+ mappend attr_0 attr_1 =

57+ Attr ( attr_style attr_0 `mappend` attr_style attr_1 )

58+ ( attr_fore_color attr_0 `mappend` attr_fore_color attr_1 )

59+ ( attr_back_color attr_0 `mappend` attr_back_color attr_1 )

60+

5461-- | Specifies the display attributes such that the final style and color values do not depend on

5562-- the previously applied display attribute. The display attributes can still depend on the

5663-- terminal's default colors (unfortunately).

@@ -65,6 +72,18 @@ data FixedAttr = FixedAttr

6572data Eq v => MaybeDefault v = Default | KeepCurrent | SetTo !v

6673 deriving ( Eq, Show )

6774

75+instance Eq v => Monoid ( MaybeDefault v ) where

76+ mempty = KeepCurrent

77+ mappend Default Default = Default

78+ mappend Default KeepCurrent = Default

79+ mappend Default ( SetTo v ) = SetTo v

80+ mappend KeepCurrent Default = Default

81+ mappend KeepCurrent KeepCurrent = KeepCurrent

82+ mappend KeepCurrent ( SetTo v ) = SetTo v

83+ mappend ( SetTo _v ) Default = Default

84+ mappend ( SetTo v ) KeepCurrent = SetTo v

85+ mappend ( SetTo _ ) ( SetTo v ) = SetTo v

86+

6887-- | Abstract data type representing a color.

6988--

7089-- Currently the foreground and background color are specified as points in either a:

src/Graphics/Vty/DisplayAttributes.hs+3−1

@@ -29,6 +29,7 @@ data DisplayAttrDiff = DisplayAttrDiff

2929 , fore_color_diff :: DisplayColorDiff

3030 , back_color_diff :: DisplayColorDiff

3131 }

32+ deriving ( Show )

3233

3334instance Monoid DisplayAttrDiff where

3435 mempty = DisplayAttrDiff [] NoColorChange NoColorChange

@@ -49,7 +50,7 @@ data DisplayColorDiff

4950 = ColorToDefault

5051 | NoColorChange

5152 | SetColor !Color

52− deriving Eq

53+ deriving ( Show, Eq )

5354

5455data StyleStateChange

5556 = ApplyStandout

@@ -64,6 +65,7 @@ data StyleStateChange

6465 | RemoveDim

6566 | ApplyBold

6667 | RemoveBold

68+ deriving ( Show, Eq )

6769

6870display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff

6971display_attr_diffs attr attr' = DisplayAttrDiff

src/Graphics/Vty/Inline.hs+36−49

@@ -12,64 +12,51 @@ import Control.Monad.State.Strict

1212import Control.Monad.Trans

1313

1414import Data.Bits ( (.&.), complement )

15+import Data.IORef

1516import Data.Monoid ( mappend )

1617

17−type AttrChange v = State DisplayAttrDiff v

18+type AttrChange v = State Attr v

1819

1920back_color :: Color -> AttrChange ()

20−back_color c = modify $ flip mappend ( DisplayAttrDiff [] NoColorChange ( SetColor c ) )

21+back_color c = modify $ flip mappend ( current_attr `with_back_color` c )

2122

2223fore_color :: Color -> AttrChange ()

23−fore_color c = modify $ flip mappend ( DisplayAttrDiff [] ( SetColor c ) NoColorChange )

24+fore_color c = modify $ flip mappend ( current_attr `with_fore_color` c )

2425

2526apply_style :: Style -> AttrChange ()

26−apply_style s = modify $ flip mappend ( DisplayAttrDiff ( diff_for_apply_styles s )

27− NoColorChange

28− NoColorChange

29− )

27+apply_style s = modify $ flip mappend ( current_attr `with_style` s )

3028

3129remove_style :: Style -> AttrChange ()

32−remove_style s = modify $ flip mappend ( DisplayAttrDiff ( diff_for_remove_styles s )

33− NoColorChange

34− NoColorChange

35− )

36−

37−diff_for_apply_styles :: Style -> [ StyleStateChange ]

38−diff_for_apply_styles !s

39− | s == 0 = [ ]

40− | ( s .&. standout ) /= 0 = ApplyStandout : ( diff_for_apply_styles $! s .&. ( complement standout ) )

41− | ( s .&. underline ) /= 0 = ApplyUnderline : ( diff_for_apply_styles $! s .&. ( complement underline ) )

42− | ( s .&. reverse_video ) /= 0 = ApplyReverseVideo : ( diff_for_apply_styles $! s .&. ( complement reverse_video ) )

43− | ( s .&. blink ) /= 0 = ApplyBlink : ( diff_for_apply_styles $! s .&. ( complement blink ) )

44− | ( s .&. dim ) /= 0 = ApplyDim : ( diff_for_apply_styles $! s .&. ( complement dim ) )

45− | ( s .&. bold ) /= 0 = ApplyBold : ( diff_for_apply_styles $! s .&. ( complement bold ) )

46− | otherwise = error "diff_for_apply_styles: impossible style mask"

47−

48−diff_for_remove_styles :: Style -> [ StyleStateChange ]

49−diff_for_remove_styles !s

50− | s == 0 = [ ]

51− | ( s .&. standout ) /= 0 = RemoveStandout : ( diff_for_remove_styles $! s .&. ( complement standout ) )

52− | ( s .&. underline ) /= 0 = RemoveUnderline : ( diff_for_remove_styles $! s .&. ( complement underline ) )

53− | ( s .&. reverse_video ) /= 0 = RemoveReverseVideo : ( diff_for_remove_styles $! s .&. ( complement reverse_video ) )

54− | ( s .&. blink ) /= 0 = RemoveBlink : ( diff_for_remove_styles $! s .&. ( complement blink ) )

55− | ( s .&. dim ) /= 0 = RemoveDim : ( diff_for_remove_styles $! s .&. ( complement dim ) )

56− | ( s .&. bold ) /= 0 = RemoveBold : ( diff_for_remove_styles $! s .&. ( complement bold ) )

57− | otherwise = error "diff_for_remove_styles: impossible style mask"

58−

59−default_all :: AttrChange ()

60−default_all = modify $ flip mappend ( DisplayAttrDiff remove_all_styles ColorToDefault ColorToDefault )

61−

62−remove_all_styles :: [ StyleStateChange ]

63−remove_all_styles =

64− [ RemoveStandout

65− , RemoveUnderline

66− , RemoveReverseVideo

67− , RemoveBlink

68− , RemoveDim

69− , RemoveBold

70− ]

71−

72−put_attr_change :: MonadIO m => TerminalHandle -> AttrChange () -> m ()

30+remove_style s_mask = modify $ \attr ->

31+ let style' = case attr_style attr of

32+ Default -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."

33+ KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."

34+ SetTo s -> s .&. complement s_mask

35+ in attr { attr_style = SetTo style' }

36+

37+put_default_attr :: ( Applicative m, MonadIO m ) => TerminalHandle -> m ()

38+put_default_attr t = do

39+ bounds <- display_bounds t

40+ d <- display_context t bounds

41+ marshall_to_terminal t ( default_attr_required_bytes d )

42+ ( serialize_default_attr d )

43+ liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just $ FixedAttr default_style_mask Nothing Nothing }

44+

45+put_attr_change :: ( Applicative m, MonadIO m ) => TerminalHandle -> AttrChange () -> m ()

7346put_attr_change t c = do

74− return ()

47+ bounds <- display_bounds t

48+ d <- display_context t bounds

49+ mfattr <- liftIO $ known_fattr <$> readIORef ( state_ref t )

50+ fattr <- case mfattr of

51+ Nothing -> do

52+ marshall_to_terminal t (default_attr_required_bytes d) (serialize_default_attr d)

53+ return $ FixedAttr default_style_mask Nothing Nothing

54+ Just v -> return v

55+ let attr = execState c current_attr

56+ attr' = limit_attr_for_display d attr

57+ fattr' = fix_display_attr fattr attr'

58+ diffs = display_attr_diffs fattr fattr'

59+ marshall_to_terminal t ( attr_required_bytes d fattr attr' diffs )

60+ ( serialize_set_attr d fattr attr' diffs )

61+ liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just fattr' }

7562

src/Graphics/Vty/Terminal/Generic.hs+11−10

@@ -27,24 +27,24 @@ import Data.IORef

2727import Data.Word

2828import Data.String.UTF8 hiding ( foldl )

2929

30−import System.IO

31−

3230data TerminalHandle where

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

31+ TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle

3432

35−terminal_state :: TerminalHandle -> TerminalState

36−terminal_state (TerminalHandle _ s) = s

33+state_ref :: TerminalHandle -> IORef TerminalState

34+state_ref (TerminalHandle _ s_ref) = s_ref

3735

3836new_terminal_handle :: forall m t. ( MonadIO m, Terminal t ) => t -> m TerminalHandle

39−new_terminal_handle t = liftM (TerminalHandle t) initial_terminal_state

37+new_terminal_handle t = do

38+ s_ref <- liftIO $ newIORef initial_terminal_state

39+ return $ TerminalHandle t s_ref

4040

4141data TerminalState = TerminalState

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

43− current_attr :: Maybe FixedAttr

43+ known_fattr :: Maybe FixedAttr

4444 }

4545

46−initial_terminal_state :: MonadIO m => m TerminalState

47−initial_terminal_state = return $ TerminalState Nothing

46+initial_terminal_state :: TerminalState

47+initial_terminal_state = TerminalState Nothing

4848

4949class Terminal t where

5050 -- | Text identifier for the terminal. Used for debugging.

@@ -269,7 +269,8 @@ span_ops_required_bytes d y in_fattr span_ops =

269269span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr)

270270span_op_required_bytes d fattr (AttributeChange attr) =

271271 let attr' = limit_attr_for_display d attr

272− c = attr_required_bytes d fattr attr' (display_attr_diffs fattr fattr')

272+ diffs = display_attr_diffs fattr fattr'

273+ c = attr_required_bytes d fattr attr' diffs

273274 fattr' = fix_display_attr fattr attr'

274275 in (c, fattr')

275276span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)

src/Graphics/Vty/Terminal/TerminfoBased.hs+3−1

@@ -157,7 +157,9 @@ instance Terminal Term where

157157

158158 -- Output the byte buffer of the specified size to the terminal device.

159159 output_byte_buffer _t out_ptr out_byte_count = do

160− liftIO $ hPutBuf stdout out_ptr (fromEnum out_byte_count)

160+ if out_byte_count == 0

161+ then return ()

162+ else liftIO $ hPutBuf stdout out_ptr (fromEnum out_byte_count)

161163 liftIO $ hFlush stdout

162164

163165foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong

test/interactive_terminal_test.hs+2−1

@@ -855,8 +855,9 @@ inline_test_0 = Test

855855 putStrLn "line 0."

856856 put_attr_change t $ back_color red >> apply_style underline

857857 putStrLn "line 1."

858− put_attr_change t $ default_all

858+ put_default_attr t

859859 putStrLn "line 2."

860+ putStrLn "line 3."

860861 release_terminal t

861862 return ()

862863 , print_summary = putStr $ [$heredoc|