7f75f0d · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

7f75f0dcoreyoconnor17 years ago

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

compare with master

unifiedsplit

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

36 where

38import Data.Bits

39−

39+import Data.Monoid

40import Data.Word

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

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

51 , attr_back_color :: !(MaybeDefault Color)

52 } deriving ( Eq, Show )

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+

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

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

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

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

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

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

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

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

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

66 deriving ( Eq, Show )

73 deriving ( Eq, Show )

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+

68-- | Abstract data type representing a color.

87-- | Abstract data type representing a color.

69--

88--

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

89-- 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

29 , fore_color_diff :: DisplayColorDiff

30 , back_color_diff :: DisplayColorDiff

31 }

32+ deriving ( Show )

33instance Monoid DisplayAttrDiff where

34instance Monoid DisplayAttrDiff where

34 mempty = DisplayAttrDiff [] NoColorChange NoColorChange

35 mempty = DisplayAttrDiff [] NoColorChange NoColorChange

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

49 = ColorToDefault

50 = ColorToDefault

50 | NoColorChange

51 | NoColorChange

51 | SetColor !Color

52 | SetColor !Color

52− deriving Eq

53+ deriving ( Show, Eq )

54data StyleStateChange

55data StyleStateChange

55 = ApplyStandout

56 = ApplyStandout

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

64 | RemoveDim

65 | RemoveDim

65 | ApplyBold

66 | ApplyBold

66 | RemoveBold

67 | RemoveBold

68+ deriving ( Show, Eq )

68display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff

70display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff

69display_attr_diffs attr attr' = DisplayAttrDiff

71display_attr_diffs attr attr' = DisplayAttrDiff

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

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

12import Control.Monad.Trans

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

15+import Data.IORef

15import Data.Monoid ( mappend )

16import Data.Monoid ( mappend )

17−type AttrChange v = State DisplayAttrDiff v

18+type AttrChange v = State Attr v

19back_color :: Color -> AttrChange ()

20back_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 )

22fore_color :: Color -> AttrChange ()

23fore_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 )

25apply_style :: Style -> AttrChange ()

26apply_style :: Style -> AttrChange ()

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

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

27− NoColorChange

28− NoColorChange

29− )

31remove_style :: Style -> AttrChange ()

29remove_style :: Style -> AttrChange ()

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

30+remove_style s_mask = modify $ \attr ->

33− NoColorChange

31+ let style' = case attr_style attr of

34− NoColorChange

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

35− )

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

36−

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

37−diff_for_apply_styles :: Style -> [ StyleStateChange ]

35+ in attr { attr_style = SetTo style' }

38−diff_for_apply_styles !s

36+

39− | s == 0 = [ ]

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

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

38+put_default_attr t = do

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

39+ bounds <- display_bounds t

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

40+ d <- display_context t bounds

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

41+ marshall_to_terminal t ( default_attr_required_bytes d )

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

42+ ( serialize_default_attr d )

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

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

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

44+

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 ()

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

73put_attr_change t c = do

46put_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' }

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

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

27import Data.Word

28import Data.String.UTF8 hiding ( foldl )

30−import System.IO

31−

32data TerminalHandle where

30data TerminalHandle where

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

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

35−terminal_state :: TerminalHandle -> TerminalState

33+state_ref :: TerminalHandle -> IORef TerminalState

36−terminal_state (TerminalHandle _ s) = s

34+state_ref (TerminalHandle _ s_ref) = s_ref

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

36new_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

41data TerminalState = TerminalState

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

43− current_attr :: Maybe FixedAttr

43+ known_fattr :: Maybe FixedAttr

44 }

46−initial_terminal_state :: MonadIO m => m TerminalState

46+initial_terminal_state :: TerminalState

47−initial_terminal_state = return $ TerminalState Nothing

47+initial_terminal_state = TerminalState Nothing

49class Terminal t where

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

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

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

270span_op_required_bytes d fattr (AttributeChange attr) =

271 let attr' = limit_attr_for_display d attr

272+ diffs = display_attr_diffs fattr fattr'

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

273+ c = attr_required_bytes d fattr attr' diffs

273 fattr' = fix_display_attr fattr attr'

274 fattr' = fix_display_attr fattr attr'

274 in (c, fattr')

275 in (c, fattr')

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

276span_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

157

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

159 output_byte_buffer _t out_ptr out_byte_count = do

160+ if out_byte_count == 0

161+ then return ()

160− liftIO $ hPutBuf stdout out_ptr (fromEnum out_byte_count)

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

161 liftIO $ hFlush stdout

163 liftIO $ hFlush stdout

162

164

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

165foreign 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

855 putStrLn "line 0."

856 put_attr_change t $ back_color red >> apply_style underline

857 putStrLn "line 1."

858− put_attr_change t $ default_all

858+ put_default_attr t

859 putStrLn "line 2."

860+ putStrLn "line 3."

860 release_terminal t

861 release_terminal t

861 return ()

862 return ()

862 , print_summary = putStr $ [$heredoc|

863 , print_summary = putStr $ [$heredoc|