DisplayAttributes.hs

-- Copyright 2009-2010 Corey O'Connor
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}

module Graphics.Vty.DisplayAttributes
  ( DisplayAttrDiff(..)
  , StyleStateChange(..)
  , DisplayColorDiff(..)
  , URLDiff(..)
  , fixDisplayAttr
  , displayAttrDiffs
  )
where

import Graphics.Vty.Attributes

import Data.Bits ((.&.))
import Data.ByteString (ByteString)
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup (Semigroup(..))
#endif
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)

-- | Given the previously applied display attributes as a FixedAttr and
-- the current display attributes as an Attr produces a FixedAttr that
-- represents the current display attributes. This is done by using the
-- previously applied display attributes to remove the "KeepCurrent"
-- abstraction.
fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr
fixDisplayAttr fattr attr
    = FixedAttr (fixStyle (fixedStyle fattr)     (attrStyle attr))
                (fixColor (fixedForeColor fattr) (attrForeColor attr))
                (fixColor (fixedBackColor fattr) (attrBackColor attr))
                (fixURL   (fixedURL fattr)       (attrURL attr))
    where
        fixStyle _s Default           = defaultStyleMask
        fixStyle s KeepCurrent        = s
        fixStyle _s (SetTo newStyle)  = newStyle
        fixColor _c Default           = Nothing
        fixColor c KeepCurrent        = c
        fixColor _c (SetTo c)         = Just c
        fixURL c KeepCurrent          = c
        fixURL _c (SetTo n)           = Just n
        fixURL _c Default             = Nothing

-- | difference between two display attributes. Used in the calculation
-- of the operations required to go from one display attribute to the
-- next.
--
-- Previously, vty would reset display attributes to default then apply
-- the new display attributes. This turned out to be very expensive: A
-- *lot* more data would be sent to the terminal than required.
data DisplayAttrDiff = DisplayAttrDiff
    { styleDiffs    :: [StyleStateChange]
    , foreColorDiff :: DisplayColorDiff
    , backColorDiff :: DisplayColorDiff
    , urlDiff       :: URLDiff
    }
    deriving (Show)

instance Semigroup DisplayAttrDiff where
    d0 <> d1 =
        let ds  = simplifyStyleDiffs (styleDiffs d0)    (styleDiffs d1)
            fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
            bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
            ud  = simplifyUrlDiffs (urlDiff d0) (urlDiff d1)
        in DisplayAttrDiff ds fcd bcd ud

instance Monoid DisplayAttrDiff where
    mempty = DisplayAttrDiff [] NoColorChange NoColorChange NoLinkChange
#if !(MIN_VERSION_base(4,11,0))
    mappend = (<>)
#endif

-- | Used in the computation of a final style attribute change.
simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1

-- | Consider two display color attributes diffs. What display color
-- attribute diff are these equivalent to?
simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
simplifyColorDiffs _cd             ColorToDefault = ColorToDefault
simplifyColorDiffs cd              NoColorChange  = cd
simplifyColorDiffs _cd             (SetColor !c)  = SetColor c

-- | Consider two URL changes, which are mostly going to be the latter
-- unless the latter specifies no change.
simplifyUrlDiffs :: URLDiff -> URLDiff -> URLDiff
simplifyUrlDiffs ud NoLinkChange = ud
simplifyUrlDiffs _ ud = ud

-- | Difference between two display color attribute changes.
data DisplayColorDiff
    = ColorToDefault
    | NoColorChange
    | SetColor !Color
    deriving (Show, Eq)

-- | Style attribute changes are transformed into a sequence of
-- apply/removes of the individual attributes.
data StyleStateChange
    = ApplyStandout
    | RemoveStandout
    | ApplyItalic
    | RemoveItalic
    | ApplyStrikethrough
    | RemoveStrikethrough
    | ApplyUnderline
    | RemoveUnderline
    | ApplyReverseVideo
    | RemoveReverseVideo
    | ApplyBlink
    | RemoveBlink
    | ApplyDim
    | RemoveDim
    | ApplyBold
    | RemoveBold
    deriving (Show, Eq)

-- Setting and unsetting hyperlinks
data URLDiff
    = LinkTo !ByteString
    | NoLinkChange
    | EndLink
    deriving (Show, Eq)

-- | Determines the diff between two display&color attributes. This diff
-- determines the operations that actually get output to the terminal.
displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
displayAttrDiffs attr attr' = DisplayAttrDiff
    { styleDiffs    = diffStyles (fixedStyle attr)      (fixedStyle attr')
    , foreColorDiff = diffColor  (fixedForeColor attr) (fixedForeColor attr')
    , backColorDiff = diffColor  (fixedBackColor attr) (fixedBackColor attr')
    , urlDiff       = diffURL    (fixedURL attr)       (fixedURL attr')
    }

diffURL :: Maybe Text -> Maybe Text -> URLDiff
diffURL Nothing Nothing = NoLinkChange
diffURL (Just _) Nothing = EndLink
diffURL _ (Just url) = LinkTo (encodeUtf8 url)

diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff
diffColor Nothing  (Just c') = SetColor c'
diffColor (Just c) (Just c')
    | c == c'   = NoColorChange
    | otherwise = SetColor c'
diffColor Nothing  Nothing = NoColorChange
diffColor (Just _) Nothing = ColorToDefault

diffStyles :: Style -> Style -> [StyleStateChange]
diffStyles prev cur
    = mconcat
    [ styleDiff standout      ApplyStandout     RemoveStandout
    , styleDiff underline     ApplyUnderline    RemoveUnderline
    , styleDiff italic        ApplyItalic       RemoveItalic
    , styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough
    , styleDiff reverseVideo  ApplyReverseVideo RemoveReverseVideo
    , styleDiff blink         ApplyBlink        RemoveBlink
    , styleDiff dim           ApplyDim          RemoveDim
    , styleDiff bold          ApplyBold         RemoveBold
    ]
    where
        styleDiff s sm rm
            = case (0 == prev .&. s, 0 == cur .&. s) of
                -- not set in either
                (True, True)   -> []
                -- set in both
                (False, False) -> []
                -- now set
                (True, False)  -> [sm]
                -- now unset
                (False, True)  -> [rm]