git.iko.soy/vty
on bcda3db help sign in
vty/src/Graphics/Vty/Inline.hs
65 lines 2.5 kB history raw
1{-# LANGUAGE BangPatterns #-}
2module Graphics.Vty.Inline ( module Graphics.Vty.Inline
3 )
4 where
6import Graphics.Vty.Attributes
7import Graphics.Vty.DisplayAttributes
8import Graphics.Vty.Terminal.Generic
10import Control.Applicative
11import Control.Monad.State.Strict
12import Control.Monad.Trans
14import Data.Bits ( (.&.), complement )
15import qualified Data.String.UTF8 as UTF8
16import Data.IORef
17import Data.Monoid ( mappend )
19type InlineM v = State Attr v
21back_color :: Color -> InlineM ()
22back_color c = modify $ flip mappend ( current_attr `with_back_color` c )
24fore_color :: Color -> InlineM ()
25fore_color c = modify $ flip mappend ( current_attr `with_fore_color` c )
27apply_style :: Style -> InlineM ()
28apply_style s = modify $ flip mappend ( current_attr `with_style` s )
30remove_style :: Style -> InlineM ()
31remove_style s_mask = modify $ \attr ->
32 let style' = case attr_style attr of
33 Default -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."
34 KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."
35 SetTo s -> s .&. complement s_mask
36 in attr { attr_style = SetTo style' }
38default_all :: InlineM ()
39default_all = put def_attr
41put_attr_change :: ( Applicative m, MonadIO m ) => TerminalHandle -> InlineM () -> m ()
42put_attr_change t c = do
43 bounds <- display_bounds t
44 d <- display_context t bounds
45 mfattr <- liftIO $ known_fattr <$> readIORef ( state_ref t )
46 fattr <- case mfattr of
47 Nothing -> do
48 liftIO $ marshall_to_terminal t (default_attr_required_bytes d) (serialize_default_attr d)
49 return $ FixedAttr default_style_mask Nothing Nothing
50 Just v -> return v
51 let attr = execState c current_attr
52 attr' = limit_attr_for_display d attr
53 fattr' = fix_display_attr fattr attr'
54 diffs = display_attr_diffs fattr fattr'
55 liftIO $ marshall_to_terminal t ( attr_required_bytes d fattr attr' diffs )
56 ( serialize_set_attr d fattr attr' diffs )
57 liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just fattr' }
58 inline_hack d
60put_string :: ( Applicative m, MonadIO m ) => TerminalHandle -> String -> m ()
61put_string t s = do
62 let s_utf8 = UTF8.fromString s
63 liftIO $ marshall_to_terminal t ( utf8_text_required_bytes s_utf8)
64 ( serialize_utf8_text s_utf8 )