Palette.hs

{-# 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
  , palTagmsg

  -- * 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
  { _palNicks         :: Vector Attr -- ^ highlighting identifiers
  , _palIdOverride    :: HashMap Identifier Attr -- ^ overrides for specific identifiers
  , _palSelf          :: Attr -- ^ own nickname(s)
  , _palSelfHighlight :: Attr -- ^ own nickname(s) in mentions
  , _palTime          :: Attr -- ^ message timestamps
  , _palMeta          :: Attr -- ^ coalesced metadata
  , _palSigil         :: Attr -- ^ sigils (e.g. @+)
  , _palLabel         :: Attr -- ^ information labels
  , _palLatency       :: Attr -- ^ ping latency
  , _palWindowName    :: Attr -- ^ window name
  , _palError         :: Attr -- ^ error messages
  , _palTextBox       :: Attr -- ^ textbox markers
  , _palActivity      :: Attr -- ^ window name with activity
  , _palMention       :: Attr -- ^ window name with mention
  , _palCommand       :: Attr -- ^ known command
  , _palCommandReady  :: Attr -- ^ known command with complete arguments
  , _palCommandPrefix :: Attr -- ^ prefix of known command
  , _palCommandError  :: Attr -- ^ unknown command
  , _palCommandPlaceholder :: Attr -- ^ command argument placeholder
  , _palWindowDivider :: Attr -- ^ Divider between split windows
  , _palLineMarker    :: Attr -- ^ Divider between new and old messages
  , _palAway          :: Attr -- ^ color of nickname when away
  , _palMonospace     :: Attr -- ^ rendering of monospace formatting text
  , _palModes         :: Attr -- ^ mode lines
  , _palJoin          :: Attr
  , _palPart          :: Attr
  , _palUsrChg        :: Attr
  , _palIgnore        :: Attr
  , _palTagmsg        :: Attr -- ^ color of TAGMSG sigil
  }
  deriving Show

data NetworkPalette = NetworkPalette
  { _palCModes        :: HashMap Char Attr -- ^ channel mode attributes
  , _palUModes        :: HashMap Char Attr -- ^ user mode attributes
  , _palSnomask       :: HashMap Char Attr -- ^ snotice mask attributes
  }
  deriving Show

makeLenses ''Palette
makeLenses ''NetworkPalette

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

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

-- | Combine one NetworkPalette with another.
unifyNetworkPalette :: NetworkPalette -> NetworkPalette -> NetworkPalette
unifyNetworkPalette defaults net = NetworkPalette
  { _palCModes     = HashMap.union (_palCModes net)     (_palCModes defaults)
  , _palUModes     = HashMap.union (_palUModes net)     (_palUModes defaults)
  , _palSnomask    = HashMap.union (_palSnomask net)    (_palSnomask 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 =
  [ ("self"             , Lens palSelf)
  , ("self-highlight"   , Lens palSelfHighlight)
  , ("time"             , Lens palTime)
  , ("meta"             , Lens palMeta)
  , ("modes"            , Lens palModes)
  , ("sigil"            , Lens palSigil)
  , ("label"            , Lens palLabel)
  , ("latency"          , Lens palLatency)
  , ("window-name"      , Lens palWindowName)
  , ("error"            , Lens palError)
  , ("textbox"          , Lens palTextBox)
  , ("activity"         , Lens palActivity)
  , ("mention"          , Lens palMention)
  , ("command"          , Lens palCommand)
  , ("command-ready"    , Lens palCommandReady)
  , ("command-placeholder", Lens palCommandPlaceholder)
  , ("command-prefix"   , Lens palCommandPrefix)
  , ("command-error"    , Lens palCommandError)
  , ("window-divider"   , Lens palWindowDivider)
  , ("line-marker"      , Lens palLineMarker)
  , ("away"             , Lens palAway)
  , ("monospace"        , Lens palMonospace)
  , ("join"             , Lens palJoin)
  , ("part"             , Lens palPart)
  , ("user-change"      , Lens palUsrChg)
  , ("ignore"           , Lens palIgnore)
  , ("tagmsg"           , Lens palTagmsg)
  ]