git.iko.soy/vty
on 033acfa help sign in
vty/src/Graphics/Vty/DisplayAttributes.hs
107 lines 3.9 kB history raw
1{-# LANGUAGE BangPatterns #-}
2module Graphics.Vty.DisplayAttributes
3 where
5import Graphics.Vty.Attributes
7import Data.Bits ( (.&.) )
8import Data.Monoid ( Monoid(..), mconcat )
10-- | Given the previously applied display attributes as a FixedAttr and the current display
11-- attributes as an Attr produces a FixedAttr that represents the current display attributes. This
12-- is done by using the previously applied display attributes to remove the "KeepCurrent"
13-- abstraction.
14fix_display_attr :: FixedAttr -> Attr -> FixedAttr
15fix_display_attr fattr attr
16 = FixedAttr ( fix_style (fixed_style fattr) (attr_style attr) )
17 ( fix_color (fixed_fore_color fattr) (attr_fore_color attr) )
18 ( fix_color (fixed_back_color fattr) (attr_back_color attr) )
19 where
20 fix_style _s Default = default_style_mask
21 fix_style s KeepCurrent = s
22 fix_style _s (SetTo new_style) = new_style
23 fix_color _c Default = Nothing
24 fix_color c KeepCurrent = c
25 fix_color _c (SetTo c) = Just c
27data DisplayAttrDiff = DisplayAttrDiff
28 { style_diffs :: [ StyleStateChange ]
29 , fore_color_diff :: DisplayColorDiff
30 , back_color_diff :: DisplayColorDiff
31 }
32 deriving ( Show )
34instance Monoid DisplayAttrDiff where
35 mempty = DisplayAttrDiff [] NoColorChange NoColorChange
36 mappend d_0 d_1 =
37 let ds = simplify_style_diffs ( style_diffs d_0 ) ( style_diffs d_1 )
38 fcd = simplify_color_diffs ( fore_color_diff d_0 ) ( fore_color_diff d_1 )
39 bcd = simplify_color_diffs ( back_color_diff d_0 ) ( back_color_diff d_1 )
40 in DisplayAttrDiff ds fcd bcd
42simplify_style_diffs :: [ StyleStateChange ] -> [ StyleStateChange ] -> [ StyleStateChange ]
43simplify_style_diffs cs_0 cs_1 = cs_0 `mappend` cs_1
45simplify_color_diffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
46simplify_color_diffs _cd ColorToDefault = ColorToDefault
47simplify_color_diffs cd NoColorChange = cd
48simplify_color_diffs _cd ( SetColor !c ) = SetColor c
50data DisplayColorDiff
51 = ColorToDefault
52 | NoColorChange
53 | SetColor !Color
54 deriving ( Show, Eq )
56data StyleStateChange
57 = ApplyStandout
58 | RemoveStandout
59 | ApplyUnderline
60 | RemoveUnderline
61 | ApplyReverseVideo
62 | RemoveReverseVideo
63 | ApplyBlink
64 | RemoveBlink
65 | ApplyDim
66 | RemoveDim
67 | ApplyBold
68 | RemoveBold
69 deriving ( Show, Eq )
71display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
72display_attr_diffs attr attr' = DisplayAttrDiff
73 { style_diffs = diff_styles ( fixed_style attr ) ( fixed_style attr' )
74 , fore_color_diff = diff_color ( fixed_fore_color attr ) ( fixed_fore_color attr' )
75 , back_color_diff = diff_color ( fixed_back_color attr ) ( fixed_back_color attr' )
76 }
78diff_color :: Maybe Color -> Maybe Color -> DisplayColorDiff
79diff_color Nothing (Just c') = SetColor c'
80diff_color (Just c) (Just c')
81 | c == c' = NoColorChange
82 | otherwise = SetColor c'
83diff_color Nothing Nothing = NoColorChange
84diff_color (Just _) Nothing = ColorToDefault
86diff_styles :: Style -> Style -> [StyleStateChange]
87diff_styles prev cur
88 = mconcat
89 [ style_diff standout ApplyStandout RemoveStandout
90 , style_diff underline ApplyUnderline RemoveUnderline
91 , style_diff reverse_video ApplyReverseVideo RemoveReverseVideo
92 , style_diff blink ApplyBlink RemoveBlink
93 , style_diff dim ApplyDim RemoveDim
94 , style_diff bold ApplyBold RemoveBold
95 ]
96 where
97 style_diff s sm rm
98 = case ( 0 == prev .&. s, 0 == cur .&. s ) of
99 -- not set in either
100 ( True, True ) -> []
101 -- set in both
102 ( False, False ) -> []
103 -- now set
104 ( True, False) -> [ sm ]
105 -- now unset
106 ( False, True) -> [ rm ]