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