git.iko.soy/vty
on ae06339 help sign in
vty/src/Graphics/Vty/Inline.hs
102 lines 4.1 kB history raw
1-- | The inline module provides a limited interface to changing the style of terminal output. The
2-- intention is for this interface to be used inline with other output systems.
3--
4-- The changes specified by the InlineM monad are applied to the terminals display attributes. These
5-- display attributes effect the display of all following text output to the terminal file
6-- descriptor.
7--
8-- For example, in an IO monad the following code with print the text \"Not styled. \" Followed by the
9-- text \" Styled! \" drawn over a red background and underlined.
10--
11-- @
12-- t <- terminal_handle
13-- putStr \"Not styled. \"
14-- put_attr_change t $ do
15-- back_color red
16-- apply_style underline
17-- putStr \" Styled! \"
18-- put_attr_change t $ default_all
19-- putStrLn \"Not styled.\"
20-- release_terminal t
21-- @
22--
23-- 'put_attr_change' outputs the control codes to the terminal device 'Handle'. This is a duplicate
24-- of the 'stdout' handle when the 'terminal_handle' was (first) acquired. If 'stdout' has since been
25-- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than
26-- 'put_attr_change'
27--
28-- Copyright 2009-2010 Corey O'Connor
29{-# LANGUAGE BangPatterns #-}
30module Graphics.Vty.Inline ( module Graphics.Vty.Inline
31 )
32 where
34import Graphics.Vty.Attributes
35import Graphics.Vty.DisplayAttributes
36import Graphics.Vty.Terminal.Generic
38import Control.Applicative
39import Control.Monad.State.Strict
41import Data.Bits ( (.&.), complement )
42import Data.IORef
43import Data.Monoid ( mappend )
45import System.IO
47type InlineM v = State Attr v
49-- | Set the background color to the provided 'Color'
50back_color :: Color -> InlineM ()
51back_color c = modify $ flip mappend ( current_attr `with_back_color` c )
53-- | Set the foreground color to the provided 'Color'
54fore_color :: Color -> InlineM ()
55fore_color c = modify $ flip mappend ( current_attr `with_fore_color` c )
57-- | Attempt to change the 'Style' of the following text.
58--
59-- If the terminal does not support the style change no error is produced. The style can still be
60-- removed.
61apply_style :: Style -> InlineM ()
62apply_style s = modify $ flip mappend ( current_attr `with_style` s )
64-- | Attempt to remove the specified 'Style' from the display of the following text.
65--
66-- This will fail if apply_style for the given style has not been previously called.
67remove_style :: Style -> InlineM ()
68remove_style s_mask = modify $ \attr ->
69 let style' = case attr_style attr of
70 Default -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."
71 KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."
72 SetTo s -> s .&. complement s_mask
73 in attr { attr_style = SetTo style' }
75-- | Reset the display attributes
76default_all :: InlineM ()
77default_all = put def_attr
79-- | Apply the provided display attribute changes to the terminal.
80--
81-- This also flushes the 'stdout' handle.
82put_attr_change :: ( Applicative m, MonadIO m ) => TerminalHandle -> InlineM () -> m ()
83put_attr_change t c = do
84 bounds <- display_bounds t
85 d <- display_context t bounds
86 mfattr <- liftIO $ known_fattr <$> readIORef ( state_ref t )
87 fattr <- case mfattr of
88 Nothing -> do
89 liftIO $ marshall_to_terminal t (default_attr_required_bytes d) (serialize_default_attr d)
90 return $ FixedAttr default_style_mask Nothing Nothing
91 Just v -> return v
92 let attr = execState c current_attr
93 attr' = limit_attr_for_display d attr
94 fattr' = fix_display_attr fattr attr'
95 diffs = display_attr_diffs fattr fattr'
96 liftIO $ hFlush stdout
97 liftIO $ marshall_to_terminal t ( attr_required_bytes d fattr attr' diffs )
98 ( serialize_set_attr d fattr attr' diffs )
99 liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just fattr' }
100 inline_hack d
101 liftIO $ hFlush stdout