{-# Language TemplateHaskell, OverloadedLists, OverloadedStrings #-}
module Client.Image.Palette
(
Palette(..)
, NetworkPalette(..)
, 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
, palCModes
, palUModes
, palSnomask
, palIdOverride
, paletteMap
, unifyNetworkPalette
, 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
data Palette = Palette
{ Palette -> Vector Attr
_palNicks :: Vector Attr
, Palette -> HashMap Identifier Attr
_palIdOverride :: HashMap Identifier Attr
, Palette -> Attr
_palSelf :: Attr
, Palette -> Attr
_palSelfHighlight :: Attr
, Palette -> Attr
_palTime :: Attr
, Palette -> Attr
_palMeta :: Attr
, Palette -> Attr
_palSigil :: Attr
, Palette -> Attr
_palLabel :: Attr
, Palette -> Attr
_palLatency :: Attr
, Palette -> Attr
_palWindowName :: Attr
, Palette -> Attr
_palError :: Attr
, Palette -> Attr
_palTextBox :: Attr
, Palette -> Attr
_palActivity :: Attr
, Palette -> Attr
_palMention :: Attr
, Palette -> Attr
_palCommand :: Attr
, Palette -> Attr
_palCommandReady :: Attr
, Palette -> Attr
_palCommandPrefix :: Attr
, Palette -> Attr
_palCommandError :: Attr
, Palette -> Attr
_palCommandPlaceholder :: Attr
, Palette -> Attr
_palWindowDivider :: Attr
, Palette -> Attr
_palLineMarker :: Attr
, Palette -> Attr
_palAway :: Attr
, Palette -> Attr
_palMonospace :: Attr
, Palette -> Attr
_palModes :: Attr
, 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
, NetworkPalette -> HashMap Char Attr
_palUModes :: HashMap Char Attr
, NetworkPalette -> HashMap Char Attr
_palSnomask :: HashMap Char Attr
}
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
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
}
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
]
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)
}
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)
]