git.iko.soy/vty
on 033acfa help sign in
vty/src/Graphics/Vty/Inline.hs
68 lines 2.6 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
13import Data.Bits ( (.&.), complement )
14import qualified Data.String.UTF8 as UTF8
15import Data.IORef
16import Data.Monoid ( mappend )
18import System.IO
20type InlineM v = State Attr v
22back_color :: Color -> InlineM ()
23back_color c = modify $ flip mappend ( current_attr `with_back_color` c )
25fore_color :: Color -> InlineM ()
26fore_color c = modify $ flip mappend ( current_attr `with_fore_color` c )
28apply_style :: Style -> InlineM ()
29apply_style s = modify $ flip mappend ( current_attr `with_style` s )
31remove_style :: Style -> InlineM ()
32remove_style s_mask = modify $ \attr ->
33 let style' = case attr_style attr of
34 Default -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."
35 KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."
36 SetTo s -> s .&. complement s_mask
37 in attr { attr_style = SetTo style' }
39default_all :: InlineM ()
40default_all = put def_attr
42put_attr_change :: ( Applicative m, MonadIO m ) => TerminalHandle -> InlineM () -> m ()
43put_attr_change t c = do
44 bounds <- display_bounds t
45 d <- display_context t bounds
46 mfattr <- liftIO $ known_fattr <$> readIORef ( state_ref t )
47 fattr <- case mfattr of
48 Nothing -> do
49 liftIO $ marshall_to_terminal t (default_attr_required_bytes d) (serialize_default_attr d)
50 return $ FixedAttr default_style_mask Nothing Nothing
51 Just v -> return v
52 let attr = execState c current_attr
53 attr' = limit_attr_for_display d attr
54 fattr' = fix_display_attr fattr attr'
55 diffs = display_attr_diffs fattr fattr'
56 liftIO $ hFlush stdout
57 liftIO $ marshall_to_terminal t ( attr_required_bytes d fattr attr' diffs )
58 ( serialize_set_attr d fattr attr' diffs )
59 liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just fattr' }
60 inline_hack d
62put_string :: ( Applicative m, MonadIO m ) => TerminalHandle -> String -> m ()
63put_string t s = do
64 let s_utf8 = UTF8.fromString s
65 liftIO $ hFlush stdout
66 liftIO $ marshall_to_terminal t ( utf8_text_required_bytes s_utf8)
67 ( serialize_utf8_text s_utf8 )