git.iko.soy/vty
on master help sign in
changed the Graphics.Vty.AttributeChange.style to apply_style and remove_style. Implemented
bd0f87acoreyoconnor
src/Graphics/Vty/AttributeChange.hs+51−5
compare with master
unifiedsplit
@@ -1,3 +1,4 @@
1+{-# LANGUAGE BangPatterns #-}
1module Graphics.Vty.AttributeChange ( module Graphics.Vty.AttributeChange
2module Graphics.Vty.AttributeChange ( module Graphics.Vty.AttributeChange
2 )
3 )
3 where
4 where
@@ -8,18 +9,63 @@ import Graphics.Vty.Terminal.Generic
8
9
9import Control.Monad.State.Strict
10import Control.Monad.State.Strict
10
11
12+import Data.Bits ( (.&.), complement )
13+import Data.Monoid ( mappend )
14+
11type AttrChange v = State DisplayAttrDiff v
15type AttrChange v = State DisplayAttrDiff v
12
16
13back_color :: Color -> AttrChange ()
17back_color :: Color -> AttrChange ()
18+back_color c = modify $ flip mappend ( DisplayAttrDiff [] NoColorChange ( SetColor c ) )
19+
20+fore_color :: Color -> AttrChange ()
14−back_color c = modify $ \ChangeState cs -> cs `mappend` [ DisplayAttrDiff [] NoColorChange ( SetTo c ) ]
21+fore_color c = modify $ flip mappend ( DisplayAttrDiff [] ( SetColor c ) NoColorChange )
22+
23+apply_style :: Style -> AttrChange ()
24+apply_style s = modify $ flip mappend ( DisplayAttrDiff ( diff_for_apply_styles s )
25+ NoColorChange
26+ NoColorChange
27+ )
15
28
16−style :: Style -> AttrChange ()
29+remove_style :: Style -> AttrChange ()
17−style s = modify $ \ChangeState cs -> cs `mappend` [ DisplayAttrDiff NoColorChange NoColorChange ]
30+remove_style s = modify $ flip mappend ( DisplayAttrDiff ( diff_for_remove_styles s )
31+ NoColorChange
32+ NoColorChange
33+ )
18
34
35+diff_for_apply_styles :: Style -> [ StyleStateChange ]
36+diff_for_apply_styles !s
37+ | s == 0 = [ ]
38+ | ( s .&. standout ) /= 0 = ApplyStandout : ( diff_for_apply_styles $! s .&. ( complement standout ) )
39+ | ( s .&. underline ) /= 0 = ApplyUnderline : ( diff_for_apply_styles $! s .&. ( complement underline ) )
40+ | ( s .&. reverse_video ) /= 0 = ApplyReverseVideo : ( diff_for_apply_styles $! s .&. ( complement reverse_video ) )
41+ | ( s .&. blink ) /= 0 = ApplyBlink : ( diff_for_apply_styles $! s .&. ( complement blink ) )
42+ | ( s .&. dim ) /= 0 = ApplyDim : ( diff_for_apply_styles $! s .&. ( complement dim ) )
43+ | ( s .&. bold ) /= 0 = ApplyBold : ( diff_for_apply_styles $! s .&. ( complement bold ) )
44+ | otherwise = error "diff_for_apply_styles: impossible style mask"
45+
19−diff_styles :: Style -> Style -> [StyleStateChange]
46+diff_for_remove_styles :: Style -> [ StyleStateChange ]
47+diff_for_remove_styles !s
48+ | s == 0 = [ ]
49+ | ( s .&. standout ) /= 0 = RemoveStandout : ( diff_for_remove_styles $! s .&. ( complement standout ) )
50+ | ( s .&. underline ) /= 0 = RemoveUnderline : ( diff_for_remove_styles $! s .&. ( complement underline ) )
51+ | ( s .&. reverse_video ) /= 0 = RemoveReverseVideo : ( diff_for_remove_styles $! s .&. ( complement reverse_video ) )
52+ | ( s .&. blink ) /= 0 = RemoveBlink : ( diff_for_remove_styles $! s .&. ( complement blink ) )
53+ | ( s .&. dim ) /= 0 = RemoveDim : ( diff_for_remove_styles $! s .&. ( complement dim ) )
54+ | ( s .&. bold ) /= 0 = RemoveBold : ( diff_for_remove_styles $! s .&. ( complement bold ) )
55+ | otherwise = error "diff_for_remove_styles: impossible style mask"
20
56
21default_all :: AttrChange ()
57default_all :: AttrChange ()
22−default_all = modify $ \ChangeState cs -> cs `mappend` [ DisplayAttrDiff remove_all_styles ColorToDefault ColorToDefault ]
58+default_all = modify $ flip mappend ( DisplayAttrDiff remove_all_styles ColorToDefault ColorToDefault )
59+
60+remove_all_styles :: [ StyleStateChange ]
61+remove_all_styles =
62+ [ RemoveStandout
63+ , RemoveUnderline
64+ , RemoveReverseVideo
65+ , RemoveBlink
66+ , RemoveDim
67+ , RemoveBold
68+ ]
23
69
24put_attr_change :: TerminalHandle -> AttrChange () -> IO ()
70put_attr_change :: TerminalHandle -> AttrChange () -> IO ()
25put_attr_change t c = do
71put_attr_change t c = do
test/Makefile+3−1
@@ -8,7 +8,9 @@ verify_image_trans \
8verify_empty_image_props \
8verify_empty_image_props \
9verify_picture_ops \
9verify_picture_ops \
10verify_span_ops \
10verify_span_ops \
11−verify_debug_terminal
11+verify_debug_terminal \
12+verify_attribute_change \
13+
12
14
13TESTS :=\
15TESTS :=\
14Bench \
16Bench \
test/interactive_terminal_test.hs+1−1
@@ -853,7 +853,7 @@ inline_test_0 = Test
853 , test_action = do
853 , test_action = do
854 t <- terminal_handle
854 t <- terminal_handle
855 putStrLn "line 0."
855 putStrLn "line 0."
856− put_attr_change t $ back_color red >> style underline
856+ put_attr_change t $ back_color red >> apply_style underline
857 putStrLn "line 1."
857 putStrLn "line 1."
858 put_attr_change t $ default_all
858 put_attr_change t $ default_all
859 putStrLn "line 2."
859 putStrLn "line 2."
test/verify_attribute_change.hsnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Graphics.Vty.AttributeChange
4+import Graphics.Vty.Terminal
5+
6+import Verify
7+
8+main = run_test $ do
9+ t <- terminal_handle
10+ put_attr_change t $ default_all
11+ return ()