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

    module Graphics.Vty.DisplayAttributes 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 fattr :: FixedAttr
    fattr attr :: 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))
                    (Maybe Color -> MaybeDefault Color -> Maybe Color
    forall a. Maybe a -> MaybeDefault a -> Maybe a
    fixColor (FixedAttr -> Maybe Color
    fixedForeColor FixedAttr
    fattr) (Attr -> MaybeDefault Color
    attrForeColor Attr
    attr))
                    (Maybe Color -> MaybeDefault Color -> Maybe Color
    forall a. Maybe a -> MaybeDefault a -> Maybe a
    fixColor (FixedAttr -> Maybe Color
    fixedBackColor FixedAttr
    fattr) (Attr -> MaybeDefault Color
    attrBackColor Attr
    attr))
                    (Maybe Text -> MaybeDefault Text -> Maybe Text
    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 _s :: Style
    _s Default           = Style
    defaultStyleMask
            fixStyle s :: Style
    s KeepCurrent        = Style
    s
            fixStyle _s :: Style
    _s (SetTo newStyle :: Style
    newStyle)  = Style
    newStyle
            fixColor :: Maybe a -> MaybeDefault a -> Maybe a
    fixColor _c :: Maybe a
    _c Default           = Maybe a
    forall a. Maybe a
    Nothing
            fixColor c :: Maybe a
    c KeepCurrent        = Maybe a
    c
            fixColor _c :: Maybe a
    _c (SetTo c :: a
    c)         = a -> Maybe a
    forall a. a -> Maybe a
    Just a
    c
            fixURL :: Maybe a -> MaybeDefault a -> Maybe a
    fixURL c :: Maybe a
    c KeepCurrent          = Maybe a
    c
            fixURL _c :: Maybe a
    _c (SetTo n :: a
    n)           = a -> Maybe a
    forall a. a -> Maybe a
    Just a
    n
            fixURL _c :: Maybe a
    _c Default             = Maybe a
    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
    (Int -> DisplayAttrDiff -> ShowS)
    -> (DisplayAttrDiff -> String)
    -> ([DisplayAttrDiff] -> ShowS)
    -> Show DisplayAttrDiff
    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
        d0 :: DisplayAttrDiff
    d0 <> :: DisplayAttrDiff -> DisplayAttrDiff -> DisplayAttrDiff
    <> d1 :: 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 cs0 :: [StyleStateChange]
    cs0 cs1 :: [StyleStateChange]
    cs1 = [StyleStateChange]
    cs0 [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]
    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 _cd :: DisplayColorDiff
    _cd             ColorToDefault = DisplayColorDiff
    ColorToDefault
    simplifyColorDiffs cd :: DisplayColorDiff
    cd              NoColorChange  = DisplayColorDiff
    cd
    simplifyColorDiffs _cd :: 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 ud :: URLDiff
    ud NoLinkChange = URLDiff
    ud
    simplifyUrlDiffs _ ud :: 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
    (Int -> DisplayColorDiff -> ShowS)
    -> (DisplayColorDiff -> String)
    -> ([DisplayColorDiff] -> ShowS)
    -> Show DisplayColorDiff
    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
    (DisplayColorDiff -> DisplayColorDiff -> Bool)
    -> (DisplayColorDiff -> DisplayColorDiff -> Bool)
    -> Eq DisplayColorDiff
    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
        | ApplyUnderline
        | RemoveUnderline
        | ApplyReverseVideo
        | RemoveReverseVideo
        | ApplyBlink
        | RemoveBlink
        | ApplyDim
        | RemoveDim
        | ApplyBold
        | RemoveBold
        deriving (Int -> StyleStateChange -> ShowS
    [StyleStateChange] -> ShowS
    StyleStateChange -> String
    (Int -> StyleStateChange -> ShowS)
    -> (StyleStateChange -> String)
    -> ([StyleStateChange] -> ShowS)
    -> Show StyleStateChange
    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
    (StyleStateChange -> StyleStateChange -> Bool)
    -> (StyleStateChange -> StyleStateChange -> Bool)
    -> Eq StyleStateChange
    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
    (Int -> URLDiff -> ShowS)
    -> (URLDiff -> String) -> ([URLDiff] -> ShowS) -> Show URLDiff
    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
    (URLDiff -> URLDiff -> Bool)
    -> (URLDiff -> URLDiff -> Bool) -> Eq URLDiff
    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 attr :: FixedAttr
    attr attr' :: FixedAttr
    attr' = DisplayAttrDiff :: [StyleStateChange]
    -> DisplayColorDiff
    -> DisplayColorDiff
    -> URLDiff
    -> DisplayAttrDiff
    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 Nothing Nothing = URLDiff
    NoLinkChange
    diffURL (Just _) Nothing = URLDiff
    EndLink
    diffURL _ (Just url :: Text
    url) = ByteString -> URLDiff
    LinkTo (Text -> ByteString
    encodeUtf8 Text
    url)

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

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