-

Ignore-this: db643dff6f295a4d363b4e8634a8393a

darcs-hash:20091109070521-f0a0d-0e657824eb6eabe8f94ce117baecae4a853f0d5f.gz

src/Graphics/Vty/Attributes.hs

@@ -36,7 +36,7 @@ module Graphics.Vty.Attributes
     where
 
 import Data.Bits
-
+import Data.Monoid
 import Data.Word
 
 -- | A display attribute defines the Color and Style of all the characters rendered after the
@@ -51,6 +51,13 @@ data Attr = Attr
     , attr_back_color :: !(MaybeDefault Color)
     } deriving ( Eq, Show )
 
+instance Monoid Attr where
+    mempty = Attr mempty mempty mempty
+    mappend attr_0 attr_1 = 
+        Attr ( attr_style attr_0 `mappend` attr_style attr_1 )
+             ( attr_fore_color attr_0 `mappend` attr_fore_color attr_1 )
+             ( attr_back_color attr_0 `mappend` attr_back_color attr_1 )
+
 -- | Specifies the display attributes such that the final style and color values do not depend on
 -- the previously applied display attribute. The display attributes can still depend on the
 -- terminal's default colors (unfortunately).
@@ -65,6 +72,18 @@ data FixedAttr = FixedAttr
 data Eq v => MaybeDefault v = Default | KeepCurrent | SetTo !v
     deriving ( Eq, Show )
 
+instance Eq v => Monoid ( MaybeDefault v ) where
+    mempty = KeepCurrent
+    mappend Default Default = Default
+    mappend Default KeepCurrent = Default
+    mappend Default ( SetTo v ) = SetTo v
+    mappend KeepCurrent Default = Default
+    mappend KeepCurrent KeepCurrent = KeepCurrent
+    mappend KeepCurrent ( SetTo v ) = SetTo v
+    mappend ( SetTo _v ) Default = Default
+    mappend ( SetTo v ) KeepCurrent = SetTo v
+    mappend ( SetTo _ ) ( SetTo v ) = SetTo v
+
 -- | Abstract data type representing a color.
 --  
 -- Currently the foreground and background color are specified as points in either a:

src/Graphics/Vty/DisplayAttributes.hs

@@ -29,6 +29,7 @@ data DisplayAttrDiff = DisplayAttrDiff
     , fore_color_diff :: DisplayColorDiff
     , back_color_diff :: DisplayColorDiff
     }
+    deriving ( Show )
 
 instance Monoid DisplayAttrDiff where
     mempty = DisplayAttrDiff [] NoColorChange NoColorChange
@@ -49,7 +50,7 @@ data DisplayColorDiff
     = ColorToDefault
     | NoColorChange
     | SetColor !Color
-    deriving Eq
+    deriving ( Show, Eq )
 
 data StyleStateChange 
     = ApplyStandout
@@ -64,6 +65,7 @@ data StyleStateChange
     | RemoveDim
     | ApplyBold
     | RemoveBold
+    deriving ( Show, Eq )
 
 display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
 display_attr_diffs attr attr' = DisplayAttrDiff

src/Graphics/Vty/Inline.hs

@@ -12,64 +12,51 @@ import Control.Monad.State.Strict
 import Control.Monad.Trans
 
 import Data.Bits ( (.&.), complement )
+import Data.IORef
 import Data.Monoid ( mappend )
 
-type AttrChange v = State DisplayAttrDiff v
+type AttrChange v = State Attr v
 
 back_color :: Color -> AttrChange ()
-back_color c = modify $ flip mappend ( DisplayAttrDiff [] NoColorChange ( SetColor c ) )
+back_color c = modify $ flip mappend ( current_attr `with_back_color` c )
 
 fore_color :: Color -> AttrChange ()
-fore_color c = modify $ flip mappend ( DisplayAttrDiff [] ( SetColor c ) NoColorChange )
+fore_color c = modify $ flip mappend ( current_attr `with_fore_color` c )
 
 apply_style :: Style -> AttrChange ()
-apply_style s = modify $ flip mappend ( DisplayAttrDiff ( diff_for_apply_styles s  ) 
-                                                        NoColorChange 
-                                                        NoColorChange 
-                                      )
+apply_style s = modify $ flip mappend ( current_attr `with_style` s )
 
 remove_style :: Style -> AttrChange ()
-remove_style s = modify $ flip mappend ( DisplayAttrDiff ( diff_for_remove_styles s  ) 
-                                                         NoColorChange 
-                                                         NoColorChange 
-                                       )
+remove_style s_mask = modify $ \attr -> 
+    let style' = case attr_style attr of
+                    Default -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."
+                    KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."
+                    SetTo s -> s .&. complement s_mask
+    in attr { attr_style = SetTo style' } 
 
-diff_for_apply_styles :: Style -> [ StyleStateChange ]
-diff_for_apply_styles !s 
-    | s == 0               = [ ]
-    | ( s .&.  standout ) /= 0      = ApplyStandout : ( diff_for_apply_styles $! s .&. ( complement standout ) )
-    | ( s .&.  underline ) /= 0     = ApplyUnderline : ( diff_for_apply_styles $! s .&. ( complement underline ) )
-    | ( s .&.  reverse_video ) /= 0 = ApplyReverseVideo : ( diff_for_apply_styles $! s .&. ( complement reverse_video ) )
-    | ( s .&.  blink ) /= 0         = ApplyBlink : ( diff_for_apply_styles $! s .&. ( complement blink ) )
-    | ( s .&.  dim ) /= 0           = ApplyDim : ( diff_for_apply_styles $! s .&. ( complement dim ) )
-    | ( s .&.  bold ) /= 0          = ApplyBold : ( diff_for_apply_styles $! s .&. ( complement bold ) )
-    | otherwise            = error "diff_for_apply_styles: impossible style mask"
+put_default_attr :: ( Applicative m, MonadIO m ) => TerminalHandle -> m () 
+put_default_attr t = do
+    bounds <- display_bounds t
+    d <- display_context t bounds
+    marshall_to_terminal t ( default_attr_required_bytes d )
+                           ( serialize_default_attr d )
+    liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just $ FixedAttr default_style_mask Nothing Nothing }
 
-diff_for_remove_styles :: Style -> [ StyleStateChange ]
-diff_for_remove_styles !s 
-    | s == 0               = [ ]
-    | ( s .&.  standout ) /= 0      = RemoveStandout : ( diff_for_remove_styles $! s .&. ( complement standout ) )
-    | ( s .&.  underline ) /= 0     = RemoveUnderline : ( diff_for_remove_styles $! s .&. ( complement underline ) )
-    | ( s .&.  reverse_video ) /= 0 = RemoveReverseVideo : ( diff_for_remove_styles $! s .&. ( complement reverse_video ) )
-    | ( s .&.  blink ) /= 0         = RemoveBlink : ( diff_for_remove_styles $! s .&. ( complement blink ) )
-    | ( s .&.  dim ) /= 0           = RemoveDim : ( diff_for_remove_styles $! s .&. ( complement dim ) )
-    | ( s .&.  bold ) /= 0          = RemoveBold : ( diff_for_remove_styles $! s .&. ( complement bold ) )
-    | otherwise            = error "diff_for_remove_styles: impossible style mask"
-
-default_all :: AttrChange ()
-default_all = modify $ flip mappend ( DisplayAttrDiff remove_all_styles ColorToDefault ColorToDefault )
-
-remove_all_styles :: [ StyleStateChange ]
-remove_all_styles = 
-    [ RemoveStandout
-    , RemoveUnderline
-    , RemoveReverseVideo
-    , RemoveBlink
-    , RemoveDim
-    , RemoveBold
-    ]
-
-put_attr_change :: MonadIO m => TerminalHandle -> AttrChange () -> m ()
+put_attr_change :: ( Applicative m, MonadIO m ) => TerminalHandle -> AttrChange () -> m ()
 put_attr_change t c = do
-    return ()
+    bounds <- display_bounds t
+    d <- display_context t bounds
+    mfattr <- liftIO $ known_fattr <$> readIORef ( state_ref t )
+    fattr <- case mfattr of
+                Nothing -> do
+                    marshall_to_terminal t (default_attr_required_bytes d) (serialize_default_attr d) 
+                    return $ FixedAttr default_style_mask Nothing Nothing
+                Just v -> return v
+    let attr = execState c current_attr
+        attr' = limit_attr_for_display d attr
+        fattr' = fix_display_attr fattr attr'
+        diffs = display_attr_diffs fattr fattr'
+    marshall_to_terminal t ( attr_required_bytes d fattr attr' diffs )
+                           ( serialize_set_attr d fattr attr' diffs )
+    liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just fattr' }
 

src/Graphics/Vty/Terminal/Generic.hs

@@ -27,24 +27,24 @@ import Data.IORef
 import Data.Word
 import Data.String.UTF8 hiding ( foldl )
 
-import System.IO
-
 data TerminalHandle where
-    TerminalHandle :: Terminal t => t -> TerminalState -> TerminalHandle
+    TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle
 
-terminal_state :: TerminalHandle -> TerminalState
-terminal_state (TerminalHandle _ s) = s
+state_ref :: TerminalHandle -> IORef TerminalState
+state_ref (TerminalHandle _ s_ref) = s_ref
 
 new_terminal_handle :: forall m t. ( MonadIO m, Terminal t ) => t -> m TerminalHandle
-new_terminal_handle t = liftM (TerminalHandle t) initial_terminal_state
+new_terminal_handle t = do
+    s_ref <- liftIO $ newIORef initial_terminal_state
+    return $ TerminalHandle t s_ref
 
 data TerminalState = TerminalState
     { -- | The current terminal display attributes or Nothing if they are not known.
-      current_attr :: Maybe FixedAttr
+      known_fattr :: Maybe FixedAttr
     }
 
-initial_terminal_state :: MonadIO m => m TerminalState
-initial_terminal_state = return $ TerminalState Nothing
+initial_terminal_state :: TerminalState
+initial_terminal_state = TerminalState Nothing
 
 class Terminal t where
     -- | Text identifier for the terminal. Used for debugging.
@@ -269,7 +269,8 @@ span_ops_required_bytes d y in_fattr span_ops =
 span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr)
 span_op_required_bytes d fattr (AttributeChange attr) = 
     let attr' = limit_attr_for_display d attr
-        c = attr_required_bytes d fattr attr' (display_attr_diffs fattr fattr')
+        diffs = display_attr_diffs fattr fattr'
+        c = attr_required_bytes d fattr attr' diffs
         fattr' = fix_display_attr fattr attr'
     in (c, fattr')
 span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)

src/Graphics/Vty/Terminal/TerminfoBased.hs

@@ -157,7 +157,9 @@ instance Terminal Term where
 
     -- Output the byte buffer of the specified size to the terminal device.
     output_byte_buffer _t out_ptr out_byte_count = do
-        liftIO $ hPutBuf stdout out_ptr (fromEnum out_byte_count) 
+        if out_byte_count == 0
+            then return ()
+            else liftIO $ hPutBuf stdout out_ptr (fromEnum out_byte_count) 
         liftIO $ hFlush stdout
 
 foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong

test/interactive_terminal_test.hs

@@ -855,8 +855,9 @@ inline_test_0 = Test
         putStrLn "line 0."
         put_attr_change t $ back_color red >> apply_style underline
         putStrLn "line 1."
-        put_attr_change t $ default_all
+        put_default_attr t
         putStrLn "line 2."
+        putStrLn "line 3."
         release_terminal t
         return ()
     , print_summary = putStr $ [$heredoc|