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