{-# Language TemplateHaskell, OverloadedLists, OverloadedStrings #-}
{-|
Module      : Client.Image.Palette
Description : Palette of colors used to render the UI
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module provides names for all of the colors used in the UI.
-}
module Client.Image.Palette
  (
  -- * Palette type
    Palette(..)
  , NetworkPalette(..)

  -- * Lenses
  , palNicks
  , palSelf
  , palSelfHighlight
  , palTime
  , palMeta
  , palSigil
  , palLabel
  , palLatency
  , palWindowName
  , palError
  , palTextBox
  , palActivity
  , palMention
  , palCommand
  , palCommandReady
  , palCommandPlaceholder
  , palCommandPrefix
  , palCommandError
  , palWindowDivider
  , palLineMarker
  , palAway
  , palMonospace
  , palJoin
  , palPart
  , palModes
  , palUsrChg
  , palIgnore

  -- * Lenses (Network)
  , palCModes
  , palUModes
  , palSnomask
  , palIdOverride

  , paletteMap
  , unifyNetworkPalette

  -- * Defaults
  , defaultPalette
  , defaultNetworkPalette
  ) where

import Control.Lens (makeLenses, ReifiedLens(Lens), ReifiedLens')
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Text (Text)
import Data.Vector (Vector)
import Graphics.Vty.Attributes
import Irc.Identifier

-- | Color palette used for rendering the client UI
data Palette = Palette
  { Palette -> Vector Attr
_palNicks         :: Vector Attr -- ^ highlighting identifiers
  , Palette -> HashMap Identifier Attr
_palIdOverride    :: HashMap Identifier Attr -- ^ overrides for specific identifiers
  , Palette -> Attr
_palSelf          :: Attr -- ^ own nickname(s)
  , Palette -> Attr
_palSelfHighlight :: Attr -- ^ own nickname(s) in mentions
  , Palette -> Attr
_palTime          :: Attr -- ^ message timestamps
  , Palette -> Attr
_palMeta          :: Attr -- ^ coalesced metadata
  , Palette -> Attr
_palSigil         :: Attr -- ^ sigils (e.g. @+)
  , Palette -> Attr
_palLabel         :: Attr -- ^ information labels
  , Palette -> Attr
_palLatency       :: Attr -- ^ ping latency
  , Palette -> Attr
_palWindowName    :: Attr -- ^ window name
  , Palette -> Attr
_palError         :: Attr -- ^ error messages
  , Palette -> Attr
_palTextBox       :: Attr -- ^ textbox markers
  , Palette -> Attr
_palActivity      :: Attr -- ^ window name with activity
  , Palette -> Attr
_palMention       :: Attr -- ^ window name with mention
  , Palette -> Attr
_palCommand       :: Attr -- ^ known command
  , Palette -> Attr
_palCommandReady  :: Attr -- ^ known command with complete arguments
  , Palette -> Attr
_palCommandPrefix :: Attr -- ^ prefix of known command
  , Palette -> Attr
_palCommandError  :: Attr -- ^ unknown command
  , Palette -> Attr
_palCommandPlaceholder :: Attr -- ^ command argument placeholder
  , Palette -> Attr
_palWindowDivider :: Attr -- ^ Divider between split windows
  , Palette -> Attr
_palLineMarker    :: Attr -- ^ Divider between new and old messages
  , Palette -> Attr
_palAway          :: Attr -- ^ color of nickname when away
  , Palette -> Attr
_palMonospace     :: Attr -- ^ rendering of monospace formatting text
  , Palette -> Attr
_palModes         :: Attr -- ^ mode lines
  , Palette -> Attr
_palJoin          :: Attr
  , Palette -> Attr
_palPart          :: Attr
  , Palette -> Attr
_palUsrChg        :: Attr
  , Palette -> Attr
_palIgnore        :: Attr
  }
  deriving Int -> Palette -> ShowS
[Palette] -> ShowS
Palette -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Palette] -> ShowS
$cshowList :: [Palette] -> ShowS
show :: Palette -> String
$cshow :: Palette -> String
showsPrec :: Int -> Palette -> ShowS
$cshowsPrec :: Int -> Palette -> ShowS
Show

data NetworkPalette = NetworkPalette
  { NetworkPalette -> HashMap Char Attr
_palCModes        :: HashMap Char Attr -- ^ channel mode attributes
  , NetworkPalette -> HashMap Char Attr
_palUModes        :: HashMap Char Attr -- ^ user mode attributes
  , NetworkPalette -> HashMap Char Attr
_palSnomask       :: HashMap Char Attr -- ^ snotice mask attributes
  }
  deriving Int -> NetworkPalette -> ShowS
[NetworkPalette] -> ShowS
NetworkPalette -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NetworkPalette] -> ShowS
$cshowList :: [NetworkPalette] -> ShowS
show :: NetworkPalette -> String
$cshow :: NetworkPalette -> String
showsPrec :: Int -> NetworkPalette -> ShowS
$cshowsPrec :: Int -> NetworkPalette -> ShowS
Show

makeLenses ''Palette
makeLenses ''NetworkPalette

-- | Default UI colors
defaultPalette :: Palette
defaultPalette :: Palette
defaultPalette = Palette
  { _palNicks :: Vector Attr
_palNicks              = Vector Attr
defaultNickColorPalette
  , _palIdOverride :: HashMap Identifier Attr
_palIdOverride         = forall k v. HashMap k v
HashMap.empty
  , _palSelf :: Attr
_palSelf               = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
brightWhite
  , _palSelfHighlight :: Attr
_palSelfHighlight      = Attr
defAttr Attr -> Color -> Attr
`withBackColor` Color
brightYellow Attr -> Color -> Attr
`withForeColor` Color
black
  , _palTime :: Attr
_palTime               = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
brightBlack
  , _palMeta :: Attr
_palMeta               = Attr
metaNo
  , _palSigil :: Attr
_palSigil              = Attr
defAttr Attr -> Word8 -> Attr
`withStyle` Word8
bold Attr -> Color -> Attr
`withForeColor` Color
brightYellow
  , _palLabel :: Attr
_palLabel              = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
cyan
  , _palLatency :: Attr
_palLatency            = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
green
  , _palWindowName :: Attr
_palWindowName         = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
brightCyan
  , _palError :: Attr
_palError              = Attr
defAttr Attr -> Word8 -> Attr
`withStyle` Word8
bold Attr -> Color -> Attr
`withForeColor` Color
red
  , _palTextBox :: Attr
_palTextBox            = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
brightBlack
  , _palActivity :: Attr
_palActivity           = Attr
metaLo
  , _palMention :: Attr
_palMention            = Attr
metaHi
  , _palCommand :: Attr
_palCommand            = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
yellow
  , _palCommandReady :: Attr
_palCommandReady       = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
brightGreen
  , _palCommandPrefix :: Attr
_palCommandPrefix      = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
yellow
  , _palCommandError :: Attr
_palCommandError       = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
red
  , _palCommandPlaceholder :: Attr
_palCommandPlaceholder = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
brightBlack
  , _palWindowDivider :: Attr
_palWindowDivider      = Attr -> Word8 -> Attr
withStyle Attr
defAttr Word8
reverseVideo
  , _palLineMarker :: Attr
_palLineMarker         = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
cyan
  , _palAway :: Attr
_palAway               = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
blue
  , _palMonospace :: Attr
_palMonospace          = Attr
defAttr
  , _palJoin :: Attr
_palJoin               = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
brightGreen
  , _palPart :: Attr
_palPart               = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
brightRed
  , _palModes :: Attr
_palModes              = Attr
metaLo
  , _palUsrChg :: Attr
_palUsrChg             = Attr
metaLo
  , _palIgnore :: Attr
_palIgnore             = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
white
  }
  where
    metaNo :: Attr
metaNo = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
brightBlack
    metaLo :: Attr
metaLo = Attr -> Color -> Attr
withForeColor Attr
defAttr Color
brightBlue
    metaHi :: Attr
metaHi = Attr
defAttr Attr -> Word8 -> Attr
`withStyle` Word8
bold Attr -> Color -> Attr
`withBackColor` Color
brightMagenta Attr -> Color -> Attr
`withForeColor` Color
black

defaultNetworkPalette :: NetworkPalette
defaultNetworkPalette :: NetworkPalette
defaultNetworkPalette = NetworkPalette
  { _palCModes :: HashMap Char Attr
_palCModes = forall k v. HashMap k v
HashMap.empty
  , _palUModes :: HashMap Char Attr
_palUModes = forall k v. HashMap k v
HashMap.empty
  , _palSnomask :: HashMap Char Attr
_palSnomask= forall k v. HashMap k v
HashMap.empty
  }
-- | Default nick highlighting colors that look nice in my dark solarized
-- color scheme.
defaultNickColorPalette :: Vector Attr
defaultNickColorPalette :: Vector Attr
defaultNickColorPalette =
  Attr -> Color -> Attr
withForeColor Attr
defAttr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [ Word8 -> Color
Color240  Word8
18, Word8 -> Color
Color240  Word8
19, Word8 -> Color
Color240  Word8
20, Word8 -> Color
Color240  Word8
21, Word8 -> Color
Color240  Word8
22, Word8 -> Color
Color240  Word8
23
    , Word8 -> Color
Color240  Word8
24, Word8 -> Color
Color240  Word8
25, Word8 -> Color
Color240  Word8
26, Word8 -> Color
Color240  Word8
27, Word8 -> Color
Color240  Word8
28, Word8 -> Color
Color240  Word8
29
    , Word8 -> Color
Color240 Word8
192, Word8 -> Color
Color240 Word8
193, Word8 -> Color
Color240 Word8
194, Word8 -> Color
Color240 Word8
195, Word8 -> Color
Color240 Word8
196, Word8 -> Color
Color240 Word8
197
    , Word8 -> Color
Color240 Word8
198, Word8 -> Color
Color240 Word8
199, Word8 -> Color
Color240 Word8
200, Word8 -> Color
Color240 Word8
201, Word8 -> Color
Color240 Word8
202, Word8 -> Color
Color240 Word8
203
    ]

-- | Combine one NetworkPalette with another.
unifyNetworkPalette :: NetworkPalette -> NetworkPalette -> NetworkPalette
unifyNetworkPalette :: NetworkPalette -> NetworkPalette -> NetworkPalette
unifyNetworkPalette NetworkPalette
defaults NetworkPalette
net = NetworkPalette
  { _palCModes :: HashMap Char Attr
_palCModes     = forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HashMap.union (NetworkPalette -> HashMap Char Attr
_palCModes NetworkPalette
net)     (NetworkPalette -> HashMap Char Attr
_palCModes NetworkPalette
defaults)
  , _palUModes :: HashMap Char Attr
_palUModes     = forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HashMap.union (NetworkPalette -> HashMap Char Attr
_palUModes NetworkPalette
net)     (NetworkPalette -> HashMap Char Attr
_palUModes NetworkPalette
defaults)
  , _palSnomask :: HashMap Char Attr
_palSnomask    = forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HashMap.union (NetworkPalette -> HashMap Char Attr
_palSnomask NetworkPalette
net)    (NetworkPalette -> HashMap Char Attr
_palSnomask NetworkPalette
defaults)
  } -- TODO: Replace the above with a nicer lens pattern later.

-- | List of palette entry names and lenses for accessing that component
-- of the palette.
paletteMap :: [(Text, ReifiedLens' Palette Attr)]
paletteMap :: [(Text, ReifiedLens' Palette Attr)]
paletteMap =
  [ (Text
"self"             , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palSelf)
  , (Text
"self-highlight"   , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palSelfHighlight)
  , (Text
"time"             , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palTime)
  , (Text
"meta"             , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palMeta)
  , (Text
"modes"            , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palModes)
  , (Text
"sigil"            , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palSigil)
  , (Text
"label"            , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palLabel)
  , (Text
"latency"          , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palLatency)
  , (Text
"window-name"      , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palWindowName)
  , (Text
"error"            , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palError)
  , (Text
"textbox"          , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palTextBox)
  , (Text
"activity"         , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palActivity)
  , (Text
"mention"          , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palMention)
  , (Text
"command"          , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palCommand)
  , (Text
"command-ready"    , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palCommandReady)
  , (Text
"command-placeholder", forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palCommandPlaceholder)
  , (Text
"command-prefix"   , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palCommandPrefix)
  , (Text
"command-error"    , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palCommandError)
  , (Text
"window-divider"   , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palWindowDivider)
  , (Text
"line-marker"      , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palLineMarker)
  , (Text
"away"             , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palAway)
  , (Text
"monospace"        , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palMonospace)
  , (Text
"join"             , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palJoin)
  , (Text
"part"             , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palPart)
  , (Text
"user-change"      , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palUsrChg)
  , (Text
"ignore"           , forall s t a b. Lens s t a b -> ReifiedLens s t a b
Lens Lens' Palette Attr
palIgnore)
  ]