DisplayAttributes.hs

-- Copyright 2009-2010 Corey O'Connor
{-# LANGUAGE BangPatterns #-}
module Graphics.Vty.DisplayAttributes
    where

import Graphics.Vty.Attributes

import Data.Bits ((.&.))
import Data.Monoid (Monoid(..), mconcat)

-- | 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))
    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

-- | 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
    }
    deriving (Show)

instance Monoid DisplayAttrDiff where
    mempty = DisplayAttrDiff [] NoColorChange NoColorChange
    mappend d0 d1 =
        let ds  = simplifyStyleDiffs (styleDiffs d0)    (styleDiffs d1)
            fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1)
            bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1)
        in DisplayAttrDiff ds fcd bcd

-- | Used in the computation of a final style attribute change.
--
-- TODO(corey): not really a simplify but a monoid instance.
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?
--
-- TODO(corey): not really a simplify but a monoid instance.
simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
simplifyColorDiffs _cd             ColorToDefault = ColorToDefault
simplifyColorDiffs cd              NoColorChange  = cd
simplifyColorDiffs _cd             (SetColor !c)  = SetColor c

-- | 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
    | ApplyUnderline
    | RemoveUnderline
    | ApplyReverseVideo
    | RemoveReverseVideo
    | ApplyBlink
    | RemoveBlink
    | ApplyDim
    | RemoveDim
    | ApplyBold
    | RemoveBold
    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')
    }

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 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]