-- 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 :: FixedAttr -> Attr -> FixedAttr
fixDisplayAttr FixedAttr
fattr Attr
attr
    = Style -> Maybe Color -> Maybe Color -> Maybe Text -> FixedAttr
FixedAttr (Style -> MaybeDefault Style -> Style
fixStyle (FixedAttr -> Style
fixedStyle FixedAttr
fattr)     (Attr -> MaybeDefault Style
attrStyle Attr
attr))
                (forall {a}. Maybe a -> MaybeDefault a -> Maybe a
fixColor (FixedAttr -> Maybe Color
fixedForeColor FixedAttr
fattr) (Attr -> MaybeDefault Color
attrForeColor Attr
attr))
                (forall {a}. Maybe a -> MaybeDefault a -> Maybe a
fixColor (FixedAttr -> Maybe Color
fixedBackColor FixedAttr
fattr) (Attr -> MaybeDefault Color
attrBackColor Attr
attr))
                (forall {a}. Maybe a -> MaybeDefault a -> Maybe a
fixURL   (FixedAttr -> Maybe Text
fixedURL FixedAttr
fattr)       (Attr -> MaybeDefault Text
attrURL Attr
attr))
    where
        fixStyle :: Style -> MaybeDefault Style -> Style
fixStyle Style
_s MaybeDefault Style
Default           = Style
defaultStyleMask
        fixStyle Style
s MaybeDefault Style
KeepCurrent        = Style
s
        fixStyle Style
_s (SetTo Style
newStyle)  = Style
newStyle
        fixColor :: Maybe a -> MaybeDefault a -> Maybe a
fixColor Maybe a
_c MaybeDefault a
Default           = forall a. Maybe a
Nothing
        fixColor Maybe a
c MaybeDefault a
KeepCurrent        = Maybe a
c
        fixColor Maybe a
_c (SetTo a
c)         = forall a. a -> Maybe a
Just a
c
        fixURL :: Maybe a -> MaybeDefault a -> Maybe a
fixURL Maybe a
c MaybeDefault a
KeepCurrent          = Maybe a
c
        fixURL Maybe a
_c (SetTo a
n)           = forall a. a -> Maybe a
Just a
n
        fixURL Maybe a
_c MaybeDefault a
Default             = forall a. Maybe a
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
    { DisplayAttrDiff -> [StyleStateChange]
styleDiffs    :: [StyleStateChange]
    , DisplayAttrDiff -> DisplayColorDiff
foreColorDiff :: DisplayColorDiff
    , DisplayAttrDiff -> DisplayColorDiff
backColorDiff :: DisplayColorDiff
    , DisplayAttrDiff -> URLDiff
urlDiff       :: URLDiff
    }
    deriving (Int -> DisplayAttrDiff -> ShowS
[DisplayAttrDiff] -> ShowS
DisplayAttrDiff -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DisplayAttrDiff] -> ShowS
$cshowList :: [DisplayAttrDiff] -> ShowS
show :: DisplayAttrDiff -> String
$cshow :: DisplayAttrDiff -> String
showsPrec :: Int -> DisplayAttrDiff -> ShowS
$cshowsPrec :: Int -> DisplayAttrDiff -> ShowS
Show)

instance Semigroup DisplayAttrDiff where
    DisplayAttrDiff
d0 <> :: DisplayAttrDiff -> DisplayAttrDiff -> DisplayAttrDiff
<> DisplayAttrDiff
d1 =
        let ds :: [StyleStateChange]
ds  = [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
simplifyStyleDiffs (DisplayAttrDiff -> [StyleStateChange]
styleDiffs DisplayAttrDiff
d0)    (DisplayAttrDiff -> [StyleStateChange]
styleDiffs DisplayAttrDiff
d1)
            fcd :: DisplayColorDiff
fcd = DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
simplifyColorDiffs (DisplayAttrDiff -> DisplayColorDiff
foreColorDiff DisplayAttrDiff
d0) (DisplayAttrDiff -> DisplayColorDiff
foreColorDiff DisplayAttrDiff
d1)
            bcd :: DisplayColorDiff
bcd = DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
simplifyColorDiffs (DisplayAttrDiff -> DisplayColorDiff
backColorDiff DisplayAttrDiff
d0) (DisplayAttrDiff -> DisplayColorDiff
backColorDiff DisplayAttrDiff
d1)
            ud :: URLDiff
ud  = URLDiff -> URLDiff -> URLDiff
simplifyUrlDiffs (DisplayAttrDiff -> URLDiff
urlDiff DisplayAttrDiff
d0) (DisplayAttrDiff -> URLDiff
urlDiff DisplayAttrDiff
d1)
        in [StyleStateChange]
-> DisplayColorDiff
-> DisplayColorDiff
-> URLDiff
-> DisplayAttrDiff
DisplayAttrDiff [StyleStateChange]
ds DisplayColorDiff
fcd DisplayColorDiff
bcd URLDiff
ud

instance Monoid DisplayAttrDiff where
    mempty :: DisplayAttrDiff
mempty = [StyleStateChange]
-> DisplayColorDiff
-> DisplayColorDiff
-> URLDiff
-> DisplayAttrDiff
DisplayAttrDiff [] DisplayColorDiff
NoColorChange DisplayColorDiff
NoColorChange URLDiff
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 :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
simplifyStyleDiffs [StyleStateChange]
cs0 [StyleStateChange]
cs1 = [StyleStateChange]
cs0 forall a. Monoid a => a -> a -> a
`mappend` [StyleStateChange]
cs1

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

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

-- | Difference between two display color attribute changes.
data DisplayColorDiff
    = ColorToDefault
    | NoColorChange
    | SetColor !Color
    deriving (Int -> DisplayColorDiff -> ShowS
[DisplayColorDiff] -> ShowS
DisplayColorDiff -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DisplayColorDiff] -> ShowS
$cshowList :: [DisplayColorDiff] -> ShowS
show :: DisplayColorDiff -> String
$cshow :: DisplayColorDiff -> String
showsPrec :: Int -> DisplayColorDiff -> ShowS
$cshowsPrec :: Int -> DisplayColorDiff -> ShowS
Show, DisplayColorDiff -> DisplayColorDiff -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DisplayColorDiff -> DisplayColorDiff -> Bool
$c/= :: DisplayColorDiff -> DisplayColorDiff -> Bool
== :: DisplayColorDiff -> DisplayColorDiff -> Bool
$c== :: DisplayColorDiff -> DisplayColorDiff -> Bool
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 (Int -> StyleStateChange -> ShowS
[StyleStateChange] -> ShowS
StyleStateChange -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StyleStateChange] -> ShowS
$cshowList :: [StyleStateChange] -> ShowS
show :: StyleStateChange -> String
$cshow :: StyleStateChange -> String
showsPrec :: Int -> StyleStateChange -> ShowS
$cshowsPrec :: Int -> StyleStateChange -> ShowS
Show, StyleStateChange -> StyleStateChange -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StyleStateChange -> StyleStateChange -> Bool
$c/= :: StyleStateChange -> StyleStateChange -> Bool
== :: StyleStateChange -> StyleStateChange -> Bool
$c== :: StyleStateChange -> StyleStateChange -> Bool
Eq)

-- Setting and unsetting hyperlinks
data URLDiff
    = LinkTo !ByteString
    | NoLinkChange
    | EndLink
    deriving (Int -> URLDiff -> ShowS
[URLDiff] -> ShowS
URLDiff -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [URLDiff] -> ShowS
$cshowList :: [URLDiff] -> ShowS
show :: URLDiff -> String
$cshow :: URLDiff -> String
showsPrec :: Int -> URLDiff -> ShowS
$cshowsPrec :: Int -> URLDiff -> ShowS
Show, URLDiff -> URLDiff -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URLDiff -> URLDiff -> Bool
$c/= :: URLDiff -> URLDiff -> Bool
== :: URLDiff -> URLDiff -> Bool
$c== :: URLDiff -> URLDiff -> Bool
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 :: FixedAttr -> FixedAttr -> DisplayAttrDiff
displayAttrDiffs FixedAttr
attr FixedAttr
attr' = DisplayAttrDiff
    { styleDiffs :: [StyleStateChange]
styleDiffs    = Style -> Style -> [StyleStateChange]
diffStyles (FixedAttr -> Style
fixedStyle FixedAttr
attr)      (FixedAttr -> Style
fixedStyle FixedAttr
attr')
    , foreColorDiff :: DisplayColorDiff
foreColorDiff = Maybe Color -> Maybe Color -> DisplayColorDiff
diffColor  (FixedAttr -> Maybe Color
fixedForeColor FixedAttr
attr) (FixedAttr -> Maybe Color
fixedForeColor FixedAttr
attr')
    , backColorDiff :: DisplayColorDiff
backColorDiff = Maybe Color -> Maybe Color -> DisplayColorDiff
diffColor  (FixedAttr -> Maybe Color
fixedBackColor FixedAttr
attr) (FixedAttr -> Maybe Color
fixedBackColor FixedAttr
attr')
    , urlDiff :: URLDiff
urlDiff       = Maybe Text -> Maybe Text -> URLDiff
diffURL    (FixedAttr -> Maybe Text
fixedURL FixedAttr
attr)       (FixedAttr -> Maybe Text
fixedURL FixedAttr
attr')
    }

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

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

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