{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}

-- | Display attributes
--
-- Attributes have three components: a foreground color, a background
-- color, and a style mask. The simplest attribute is the default
-- attribute, or 'defAttr'. Attributes can be modified with
-- 'withForeColor', 'withBackColor', and 'withStyle', e.g.,
--
-- @
--     defAttr \`withForeColor\` red
-- @
--
-- 'Image' constructors often require an 'Attr' to indicate the
-- attributes used in the image, e.g.,
--
-- @
--     string (defAttr \`withForeColor\` red) "this text will be red"
-- @
--
-- The appearance of 'Image's using 'defAttr' is determined by the The
-- terminal, so this is not something VTY can control. The user is free
-- to The define the color scheme of the terminal as they see fit.
--
-- The value 'currentAttr' will keep the attributes of whatever was
-- output previously.
module Graphics.Vty.Attributes
  ( module Graphics.Vty.Attributes.Color

  , Attr(..)
  , FixedAttr(..)
  , MaybeDefault(..)
  , defAttr
  , currentAttr

  -- * Styles
  , Style
  , withStyle
  , standout
  , italic
  , strikethrough
  , underline
  , reverseVideo
  , blink
  , dim
  , bold
  , defaultStyleMask
  , styleMask
  , hasStyle

  -- * Setting attribute colors
  , withForeColor
  , withBackColor

  -- * Setting hyperlinks
  , withURL
  )
where

import Control.DeepSeq
import Data.Bits
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup
#endif
import Data.Text (Text)
import Data.Word
import GHC.Generics

import Graphics.Vty.Attributes.Color

-- | A display attribute defines the Color and Style of all the
-- characters rendered after the attribute is applied.
--
-- At most 256 colors, picked from a 240 and 16 color palette, are
-- possible for the background and foreground. The 240 colors and
-- 16 colors are points in different palettes. See Color for more
-- information.
data Attr = Attr
    { Attr -> MaybeDefault Style
attrStyle :: !(MaybeDefault Style)
    , Attr -> MaybeDefault Color
attrForeColor :: !(MaybeDefault Color)
    , Attr -> MaybeDefault Color
attrBackColor :: !(MaybeDefault Color)
    , Attr -> MaybeDefault Text
attrURL :: !(MaybeDefault Text)
    } deriving ( Attr -> Attr -> Bool
(Attr -> Attr -> Bool) -> (Attr -> Attr -> Bool) -> Eq Attr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attr -> Attr -> Bool
$c/= :: Attr -> Attr -> Bool
== :: Attr -> Attr -> Bool
$c== :: Attr -> Attr -> Bool
Eq, Int -> Attr -> ShowS
[Attr] -> ShowS
Attr -> String
(Int -> Attr -> ShowS)
-> (Attr -> String) -> ([Attr] -> ShowS) -> Show Attr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attr] -> ShowS
$cshowList :: [Attr] -> ShowS
show :: Attr -> String
$cshow :: Attr -> String
showsPrec :: Int -> Attr -> ShowS
$cshowsPrec :: Int -> Attr -> ShowS
Show, ReadPrec [Attr]
ReadPrec Attr
Int -> ReadS Attr
ReadS [Attr]
(Int -> ReadS Attr)
-> ReadS [Attr] -> ReadPrec Attr -> ReadPrec [Attr] -> Read Attr
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Attr]
$creadListPrec :: ReadPrec [Attr]
readPrec :: ReadPrec Attr
$creadPrec :: ReadPrec Attr
readList :: ReadS [Attr]
$creadList :: ReadS [Attr]
readsPrec :: Int -> ReadS Attr
$creadsPrec :: Int -> ReadS Attr
Read, (forall x. Attr -> Rep Attr x)
-> (forall x. Rep Attr x -> Attr) -> Generic Attr
forall x. Rep Attr x -> Attr
forall x. Attr -> Rep Attr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Attr x -> Attr
$cfrom :: forall x. Attr -> Rep Attr x
Generic, Attr -> ()
(Attr -> ()) -> NFData Attr
forall a. (a -> ()) -> NFData a
rnf :: Attr -> ()
$crnf :: Attr -> ()
NFData )

-- This could be encoded into a single 32 bit word. The 32 bit word is
-- first divided into 4 groups of 8 bits where: The first group codes
-- what action should be taken with regards to the other groups.
--      XXYYZZ__
--      XX - style action
--          00 => reset to default
--          01 => unchanged
--          10 => set
--      YY - foreground color action
--          00 => reset to default
--          01 => unchanged
--          10 => set
--      ZZ - background color action
--          00 => reset to default
--          01 => unchanged
--          10 => set
--      __ - unused
--
--  Next is the style flags
--      SURBDOI_
--      S - standout
--      U - underline
--      R - reverse video
--      B - blink
--      D - dim
--      O - bold
--      I - italic
--      _ - unused
--
--  Then the foreground color encoded into 8 bits.
--  Then the background color encoded into 8 bits.

instance Semigroup Attr where
    Attr
attr0 <> :: Attr -> Attr -> Attr
<> Attr
attr1 =
        MaybeDefault Style
-> MaybeDefault Color
-> MaybeDefault Color
-> MaybeDefault Text
-> Attr
Attr ( Attr -> MaybeDefault Style
attrStyle Attr
attr0     MaybeDefault Style -> MaybeDefault Style -> MaybeDefault Style
forall a. Semigroup a => a -> a -> a
<> Attr -> MaybeDefault Style
attrStyle Attr
attr1 )
             ( Attr -> MaybeDefault Color
attrForeColor Attr
attr0 MaybeDefault Color -> MaybeDefault Color -> MaybeDefault Color
forall a. Semigroup a => a -> a -> a
<> Attr -> MaybeDefault Color
attrForeColor Attr
attr1 )
             ( Attr -> MaybeDefault Color
attrBackColor Attr
attr0 MaybeDefault Color -> MaybeDefault Color -> MaybeDefault Color
forall a. Semigroup a => a -> a -> a
<> Attr -> MaybeDefault Color
attrBackColor Attr
attr1 )
             ( Attr -> MaybeDefault Text
attrURL Attr
attr0       MaybeDefault Text -> MaybeDefault Text -> MaybeDefault Text
forall a. Semigroup a => a -> a -> a
<> Attr -> MaybeDefault Text
attrURL Attr
attr1 )

instance Monoid Attr where
    mempty :: Attr
mempty = MaybeDefault Style
-> MaybeDefault Color
-> MaybeDefault Color
-> MaybeDefault Text
-> Attr
Attr MaybeDefault Style
forall a. Monoid a => a
mempty MaybeDefault Color
forall a. Monoid a => a
mempty MaybeDefault Color
forall a. Monoid a => a
mempty MaybeDefault Text
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
    mappend = (<>)
#endif

-- | Specifies the display attributes such that the final style and
-- color values do not depend on the previously applied display
-- attribute. The display attributes can still depend on the terminal's
-- default colors (unfortunately).
data FixedAttr = FixedAttr
    { FixedAttr -> Style
fixedStyle :: !Style
    , FixedAttr -> Maybe Color
fixedForeColor :: !(Maybe Color)
    , FixedAttr -> Maybe Color
fixedBackColor :: !(Maybe Color)
    , FixedAttr -> Maybe Text
fixedURL       :: !(Maybe Text)
    } deriving ( FixedAttr -> FixedAttr -> Bool
(FixedAttr -> FixedAttr -> Bool)
-> (FixedAttr -> FixedAttr -> Bool) -> Eq FixedAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FixedAttr -> FixedAttr -> Bool
$c/= :: FixedAttr -> FixedAttr -> Bool
== :: FixedAttr -> FixedAttr -> Bool
$c== :: FixedAttr -> FixedAttr -> Bool
Eq, Int -> FixedAttr -> ShowS
[FixedAttr] -> ShowS
FixedAttr -> String
(Int -> FixedAttr -> ShowS)
-> (FixedAttr -> String)
-> ([FixedAttr] -> ShowS)
-> Show FixedAttr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FixedAttr] -> ShowS
$cshowList :: [FixedAttr] -> ShowS
show :: FixedAttr -> String
$cshow :: FixedAttr -> String
showsPrec :: Int -> FixedAttr -> ShowS
$cshowsPrec :: Int -> FixedAttr -> ShowS
Show )

-- | The style and color attributes can either be the terminal defaults.
-- Or be equivalent to the previously applied style. Or be a specific
-- value.
data MaybeDefault v where
    Default :: MaybeDefault v
    KeepCurrent :: MaybeDefault v
    SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v

instance (NFData v) => NFData (MaybeDefault v) where
    rnf :: MaybeDefault v -> ()
rnf MaybeDefault v
Default = ()
    rnf MaybeDefault v
KeepCurrent = ()
    rnf (SetTo v
v) = v -> ()
forall a. NFData a => a -> ()
rnf v
v

deriving instance Eq v => Eq (MaybeDefault v)
deriving instance Eq v => Show (MaybeDefault v)
deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)

instance Eq v => Semigroup (MaybeDefault v) where
    MaybeDefault v
Default     <> :: MaybeDefault v -> MaybeDefault v -> MaybeDefault v
<> MaybeDefault v
Default     = MaybeDefault v
forall v. MaybeDefault v
Default
    MaybeDefault v
Default     <> MaybeDefault v
KeepCurrent = MaybeDefault v
forall v. MaybeDefault v
Default
    MaybeDefault v
Default     <> SetTo v
v     = v -> MaybeDefault v
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo v
v
    MaybeDefault v
KeepCurrent <> MaybeDefault v
Default     = MaybeDefault v
forall v. MaybeDefault v
Default
    MaybeDefault v
KeepCurrent <> MaybeDefault v
KeepCurrent = MaybeDefault v
forall v. MaybeDefault v
KeepCurrent
    MaybeDefault v
KeepCurrent <> SetTo v
v     = v -> MaybeDefault v
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo v
v
    SetTo v
_v    <> MaybeDefault v
Default     = MaybeDefault v
forall v. MaybeDefault v
Default
    SetTo v
v     <> MaybeDefault v
KeepCurrent = v -> MaybeDefault v
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo v
v
    SetTo v
_     <> SetTo v
v     = v -> MaybeDefault v
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo v
v

instance Eq v => Monoid ( MaybeDefault v ) where
    mempty :: MaybeDefault v
mempty = MaybeDefault v
forall v. MaybeDefault v
KeepCurrent
#if !(MIN_VERSION_base(4,11,0))
    mappend = (<>)
#endif

-- | Styles are represented as an 8 bit word. Each bit in the word is 1
-- if the style attribute assigned to that bit should be applied and 0
-- if the style attribute should not be applied.
type Style = Word8

-- | Valid style attributes include:
--
--      * standout
--
--      * underline
--
--      * reverseVideo
--
--      * blink
--
--      * dim
--
--      * bold/bright
--
--      * italic
--
--      * strikethrough (via the smxx/rmxx terminfo capabilities)
--
--  (The invisible, protect, and altcharset display attributes some
--  terminals support are not supported via VTY.)
standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style
standout :: Style
standout        = Style
0x01
underline :: Style
underline       = Style
0x02
reverseVideo :: Style
reverseVideo    = Style
0x04
blink :: Style
blink           = Style
0x08
dim :: Style
dim             = Style
0x10
bold :: Style
bold            = Style
0x20
italic :: Style
italic          = Style
0x40
strikethrough :: Style
strikethrough   = Style
0x80

defaultStyleMask :: Style
defaultStyleMask :: Style
defaultStyleMask = Style
0x00

styleMask :: Attr -> Word8
styleMask :: Attr -> Style
styleMask Attr
attr
    = case Attr -> MaybeDefault Style
attrStyle Attr
attr of
        MaybeDefault Style
Default  -> Style
0
        MaybeDefault Style
KeepCurrent -> Style
0
        SetTo Style
v  -> Style
v

-- | true if the given Style value has the specified Style set.
hasStyle :: Style -> Style -> Bool
hasStyle :: Style -> Style -> Bool
hasStyle Style
s Style
bitMask = ( Style
s Style -> Style -> Style
forall a. Bits a => a -> a -> a
.&. Style
bitMask ) Style -> Style -> Bool
forall a. Eq a => a -> a -> Bool
/= Style
0

-- | Set the foreground color of an `Attr'.
withForeColor :: Attr -> Color -> Attr
withForeColor :: Attr -> Color -> Attr
withForeColor Attr
attr Color
c = Attr
attr { attrForeColor :: MaybeDefault Color
attrForeColor = Color -> MaybeDefault Color
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo Color
c }

-- | Set the background color of an `Attr'.
withBackColor :: Attr -> Color -> Attr
withBackColor :: Attr -> Color -> Attr
withBackColor Attr
attr Color
c = Attr
attr { attrBackColor :: MaybeDefault Color
attrBackColor = Color -> MaybeDefault Color
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo Color
c }

-- | Add the given style attribute
withStyle :: Attr -> Style -> Attr
withStyle :: Attr -> Style -> Attr
withStyle Attr
attr Style
0 = Attr
attr
withStyle Attr
attr Style
styleFlag = Attr
attr { attrStyle :: MaybeDefault Style
attrStyle = Style -> MaybeDefault Style
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo (Style -> MaybeDefault Style) -> Style -> MaybeDefault Style
forall a b. (a -> b) -> a -> b
$ Attr -> Style
styleMask Attr
attr Style -> Style -> Style
forall a. Bits a => a -> a -> a
.|. Style
styleFlag }

-- | Add a hyperlinked URL using the proposed [escape sequences for
-- hyperlinked
-- URLs](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda).
-- These escape sequences are comparatively new and aren't widely
-- supported in terminal emulators yet, but most terminal emulators
-- that don't know about these sequences will ignore these sequences,
-- and therefore this should fall back sensibly. In some cases they
-- won't and this will result in garbage, so this is why hyperlinking is
-- disabled by default, in which case this combinator has no observable
-- effect. To enable it, enable 'Hyperlink' mode on your Vty output
-- interface.
withURL :: Attr -> Text -> Attr
withURL :: Attr -> Text -> Attr
withURL Attr
attr Text
url = Attr
attr { attrURL :: MaybeDefault Text
attrURL = Text -> MaybeDefault Text
forall v. (Eq v, Show v, Read v) => v -> MaybeDefault v
SetTo Text
url }

-- | Sets the style, background color and foreground color to the
-- default values for the terminal. There is no easy way to determine
-- what the default background and foreground colors are.
defAttr :: Attr
defAttr :: Attr
defAttr = MaybeDefault Style
-> MaybeDefault Color
-> MaybeDefault Color
-> MaybeDefault Text
-> Attr
Attr MaybeDefault Style
forall v. MaybeDefault v
Default MaybeDefault Color
forall v. MaybeDefault v
Default MaybeDefault Color
forall v. MaybeDefault v
Default MaybeDefault Text
forall v. MaybeDefault v
Default

-- | Keeps the style, background color and foreground color that was
-- previously set. Used to override some part of the previous style.
--
-- EG: current_style `withForeColor` brightMagenta
--
-- Would be the currently applied style (be it underline, bold, etc) but
-- with the foreground color set to brightMagenta.
currentAttr :: Attr
currentAttr :: Attr
currentAttr = MaybeDefault Style
-> MaybeDefault Color
-> MaybeDefault Color
-> MaybeDefault Text
-> Attr
Attr MaybeDefault Style
forall v. MaybeDefault v
KeepCurrent MaybeDefault Color
forall v. MaybeDefault v
KeepCurrent MaybeDefault Color
forall v. MaybeDefault v
KeepCurrent MaybeDefault Text
forall v. MaybeDefault v
KeepCurrent