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