1-- Copyright 2009-2010 Corey O'Connor
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE CPP #-}
4
5module Graphics.Vty.DisplayAttributes where
6
7import Graphics.Vty.Attributes
8
9import Data.Bits ((.&.))
10import Data.ByteString (ByteString)
11#if !(MIN_VERSION_base(4,11,0))
12import Data.Semigroup (Semigroup(..))
13#endif
14import Data.Text (Text)
15import Data.Text.Encoding (encodeUtf8)
16
17-- | Given the previously applied display attributes as a FixedAttr and
18-- the current display attributes as an Attr produces a FixedAttr that
19-- represents the current display attributes. This is done by using the
20-- previously applied display attributes to remove the "KeepCurrent"
21-- abstraction.
22fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr
23fixDisplayAttr fattr attr
24    = FixedAttr (fixStyle (fixedStyle fattr)     (attrStyle attr))
25                (fixColor (fixedForeColor fattr) (attrForeColor attr))
26                (fixColor (fixedBackColor fattr) (attrBackColor attr))
27                (fixURL   (fixedURL fattr)       (attrURL attr))
28    where
29        fixStyle _s Default           = defaultStyleMask
30        fixStyle s KeepCurrent        = s
31        fixStyle _s (SetTo newStyle)  = newStyle
32        fixColor _c Default           = Nothing
33        fixColor c KeepCurrent        = c
34        fixColor _c (SetTo c)         = Just c
35        fixURL c KeepCurrent          = c
36        fixURL _c (SetTo n)           = Just n
37        fixURL _c Default             = Nothing
38
39-- | difference between two display attributes. Used in the calculation
40-- of the operations required to go from one display attribute to the
41-- next.
42--
43-- Previously, vty would reset display attributes to default then apply
44-- the new display attributes. This turned out to be very expensive: A
45-- *lot* more data would be sent to the terminal than required.
46data DisplayAttrDiff = DisplayAttrDiff
47    { styleDiffs    :: [StyleStateChange]
48    , foreColorDiff :: DisplayColorDiff
49    , backColorDiff :: DisplayColorDiff
50    , urlDiff       :: URLDiff
51    }
52    deriving (Show)
53
54instance Semigroup DisplayAttrDiff where
55    d0 <> d1 =
56        let ds  = simplifyStyleDiffs (styleDiffs d0)    (styleDiffs d1)
57            fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
58            bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
59            ud  = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)
60        in DisplayAttrDiff ds fcd bcd ud
61
62instance Monoid DisplayAttrDiff where
63    mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange
64#if !(MIN_VERSION_base(4,11,0))
65    mappend = (<>)
66#endif
67
68-- | Used in the computation of a final style attribute change.
69simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
70simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1
71
72-- | Consider two display color attributes diffs. What display color
73-- attribute diff are these equivalent to?
74simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
75simplifyColorDiffs _cd             ColorToDefault = ColorToDefault
76simplifyColorDiffs cd              NoColorChange  = cd
77simplifyColorDiffs _cd             (SetColor !c)  = SetColor c
78
79-- | Consider two URL changes, which are mostly going to be the latter
80-- unless the latter specifies no change.
81simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff
82simplifyUrlDiffs ud NoLinkChange = ud
83simplifyUrlDiffs _ ud = ud
84
85-- | Difference between two display color attribute changes.
86data DisplayColorDiff
87    = ColorToDefault
88    | NoColorChange
89    | SetColor !Color
90    deriving (Show, Eq)
91
92-- | Style attribute changes are transformed into a sequence of
93-- apply/removes of the individual attributes.
94data StyleStateChange
95    = ApplyStandout
96    | RemoveStandout
97    | ApplyItalic
98    | RemoveItalic
99    | ApplyStrikethrough
100    | RemoveStrikethrough
101    | ApplyUnderline
102    | RemoveUnderline
103    | ApplyReverseVideo
104    | RemoveReverseVideo
105    | ApplyBlink
106    | RemoveBlink
107    | ApplyDim
108    | RemoveDim
109    | ApplyBold
110    | RemoveBold
111    deriving (Show, Eq)
112
113-- Setting and unsetting hyperlinks
114data URLDiff
115    = LinkTo !ByteString
116    | NoLinkChange
117    | EndLink
118    deriving (Show, Eq)
119
120-- | Determines the diff between two display&color attributes. This diff
121-- determines the operations that actually get output to the terminal.
122displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
123displayAttrDiffs attr attr' = DisplayAttrDiff
124    { styleDiffs    = diffStyles (fixedStyle attr)      (fixedStyle attr')
125    , foreColorDiff = diffColor  (fixedForeColor attr) (fixedForeColor attr')
126    , backColorDiff = diffColor  (fixedBackColor attr) (fixedBackColor attr')
127    , urlDiff       = diffURL    (fixedURL attr)       (fixedURL attr')
128    }
129
130diffURL :: Maybe Text -> Maybe Text -> URLDiff
131diffURL Nothing Nothing = NoLinkChange
132diffURL (Just _) Nothing = EndLink
133diffURL _ (Just url) = LinkTo (encodeUtf8 url)
134
135diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
136diffColor Nothing  (Just c') = SetColor c'
137diffColor (Just c) (Just c')
138    | c == c'   = NoColorChange
139    | otherwise = SetColor c'
140diffColor Nothing  Nothing = NoColorChange
141diffColor (Just _) Nothing = ColorToDefault
142
143diffStyles :: Style -> Style -> [StyleStateChange]
144diffStyles prev cur
145    = mconcat
146    [ styleDiff standout      ApplyStandout     RemoveStandout
147    , styleDiff underline     ApplyUnderline    RemoveUnderline
148    , styleDiff italic        ApplyItalic       RemoveItalic
149    , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough
150    , styleDiff reverseVideo  ApplyReverseVideo RemoveReverseVideo
151    , styleDiff blink         ApplyBlink        RemoveBlink
152    , styleDiff dim           ApplyDim          RemoveDim
153    , styleDiff bold          ApplyBold         RemoveBold
154    ]
155    where
156        styleDiff s sm rm
157            = case (0 == prev .&. s, 0 == cur .&. s) of
158                -- not set in either
159                (True, True)   -> []
160                -- set in both
161                (False, False) -> []
162                -- now set
163                (True, False)  -> [sm]
164                -- now unset
165                (False, True)  -> [rm]
166