    -- 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.
    fix_display_attr :: FixedAttr -> Attr -> FixedAttr
    fix_display_attr fattr attr
        = FixedAttr ( fix_style (fixed_style fattr) (attr_style attr) )
                    ( fix_color (fixed_fore_color fattr) (attr_fore_color attr) )
                    ( fix_color (fixed_back_color fattr) (attr_back_color attr) )
        where
            fix_style _s Default = default_style_mask
            fix_style s KeepCurrent = s
            fix_style _s (SetTo new_style) = new_style
            fix_color _c Default = Nothing
            fix_color c KeepCurrent = c
            fix_color _c (SetTo c) = Just c

    data DisplayAttrDiff = DisplayAttrDiff
        { style_diffs :: [ StyleStateChange ]
        , fore_color_diff :: DisplayColorDiff
        , back_color_diff :: DisplayColorDiff
        }
        deriving ( Show )

    instance Monoid DisplayAttrDiff where
        mempty = DisplayAttrDiff [] NoColorChange NoColorChange
        mappend d_0 d_1 =
            let ds = simplify_style_diffs ( style_diffs d_0 ) ( style_diffs d_1 )
                fcd = simplify_color_diffs ( fore_color_diff d_0 ) ( fore_color_diff d_1 )
                bcd = simplify_color_diffs ( back_color_diff d_0 ) ( back_color_diff d_1 )
            in DisplayAttrDiff ds fcd bcd

    simplify_style_diffs :: [ StyleStateChange ] -> [ StyleStateChange ] -> [ StyleStateChange ]
    simplify_style_diffs cs_0 cs_1 = cs_0 `mappend` cs_1

    simplify_color_diffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff
    simplify_color_diffs _cd             ColorToDefault  = ColorToDefault
    simplify_color_diffs cd              NoColorChange   = cd
    simplify_color_diffs _cd             ( SetColor !c ) = SetColor c

    data DisplayColorDiff
        = ColorToDefault
        | NoColorChange
        | SetColor !Color
        deriving ( Show, Eq )

    data StyleStateChange
        = ApplyStandout
        | RemoveStandout
        | ApplyUnderline
        | RemoveUnderline
        | ApplyReverseVideo
        | RemoveReverseVideo
        | ApplyBlink
        | RemoveBlink
        | ApplyDim
        | RemoveDim
        | ApplyBold
        | RemoveBold
        deriving ( Show, Eq )

    display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff
    display_attr_diffs attr attr' = DisplayAttrDiff
        { style_diffs = diff_styles ( fixed_style attr ) ( fixed_style attr' )
        , fore_color_diff = diff_color ( fixed_fore_color attr ) ( fixed_fore_color attr' )
        , back_color_diff = diff_color ( fixed_back_color attr ) ( fixed_back_color attr' )
        }

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

    diff_styles :: Style -> Style -> [StyleStateChange]
    diff_styles prev cur
        = mconcat
        [ style_diff standout ApplyStandout RemoveStandout
        , style_diff underline ApplyUnderline RemoveUnderline
        , style_diff reverse_video ApplyReverseVideo RemoveReverseVideo
        , style_diff blink ApplyBlink RemoveBlink
        , style_diff dim ApplyDim RemoveDim
        , style_diff bold ApplyBold RemoveBold
        ]
        where
            style_diff 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 ]