{-# LANGUAGE OverloadedStrings #-}
module Matterhorn.Themes
( InternalTheme(..)
, defaultTheme
, internalThemes
, lookupTheme
, themeDocs
, currentUserAttr
, timeAttr
, verbatimTruncateMessageAttr
, channelHeaderAttr
, channelListHeaderAttr
, currentChannelNameAttr
, unreadChannelAttr
, unreadGroupMarkerAttr
, mentionsChannelAttr
, currentTeamAttr
, urlAttr
, codeAttr
, emailAttr
, emojiAttr
, reactionAttr
, myReactionAttr
, channelNameAttr
, clientMessageAttr
, clientHeaderAttr
, strikeThroughAttr
, clientEmphAttr
, clientStrongAttr
, dateTransitionAttr
, pinnedMessageIndicatorAttr
, newMessageTransitionAttr
, gapMessageAttr
, errorMessageAttr
, helpAttr
, helpEmphAttr
, helpKeyEventAttr
, channelSelectPromptAttr
, channelSelectMatchAttr
, completionAlternativeListAttr
, completionAlternativeCurrentAttr
, permalinkAttr
, dialogAttr
, dialogEmphAttr
, recentMarkerAttr
, replyParentAttr
, loadMoreAttr
, urlListSelectedAttr
, messageSelectAttr
, messageSelectStatusAttr
, urlSelectStatusAttr
, misspellingAttr
, editedMarkingAttr
, editedRecentlyMarkingAttr
, tabSelectedAttr
, tabUnselectedAttr
, buttonAttr
, buttonFocusedAttr
, threadAttr
, focusedEditorPromptAttr
, colorUsername
, attrForUsername
, usernameColorHashBuckets
)
where
import Prelude ()
import Matterhorn.Prelude
import Brick
import Brick.Themes
import Brick.Widgets.List
import qualified Brick.Widgets.FileBrowser as FB
import Brick.Widgets.Skylighting ( attrNameForTokenType
, attrMappingsForStyle
, highlightedCodeBlockAttr
)
import Brick.Forms ( focusedFormInputAttr )
import Data.Hashable ( hash )
import qualified Data.Map as M
import qualified Data.Text as T
import Graphics.Vty
import qualified Skylighting.Styles as Sky
import Skylighting.Types ( TokenType(..) )
import Matterhorn.Types ( InternalTheme(..), specialUserMentions )
helpAttr :: AttrName
helpAttr :: AttrName
helpAttr = String -> AttrName
attrName String
"help"
helpEmphAttr :: AttrName
helpEmphAttr :: AttrName
helpEmphAttr = String -> AttrName
attrName String
"helpEmphasis"
helpKeyEventAttr :: AttrName
helpKeyEventAttr :: AttrName
helpKeyEventAttr = String -> AttrName
attrName String
"helpKeyEvent"
recentMarkerAttr :: AttrName
recentMarkerAttr :: AttrName
recentMarkerAttr = String -> AttrName
attrName String
"recentChannelMarker"
replyParentAttr :: AttrName
replyParentAttr :: AttrName
replyParentAttr = String -> AttrName
attrName String
"replyParentPreview"
pinnedMessageIndicatorAttr :: AttrName
pinnedMessageIndicatorAttr :: AttrName
pinnedMessageIndicatorAttr = String -> AttrName
attrName String
"pinnedMessageIndicator"
loadMoreAttr :: AttrName
loadMoreAttr :: AttrName
loadMoreAttr = String -> AttrName
attrName String
"loadMoreMessages"
urlListSelectedAttr :: AttrName
urlListSelectedAttr :: AttrName
urlListSelectedAttr = String -> AttrName
attrName String
"urlListCursor"
messageSelectAttr :: AttrName
messageSelectAttr :: AttrName
messageSelectAttr = String -> AttrName
attrName String
"messageSelectCursor"
editedMarkingAttr :: AttrName
editedMarkingAttr :: AttrName
editedMarkingAttr = String -> AttrName
attrName String
"editedMarking"
editedRecentlyMarkingAttr :: AttrName
editedRecentlyMarkingAttr :: AttrName
editedRecentlyMarkingAttr = String -> AttrName
attrName String
"editedRecentlyMarking"
permalinkAttr :: AttrName
permalinkAttr :: AttrName
permalinkAttr = String -> AttrName
attrName String
"permalink"
dialogAttr :: AttrName
dialogAttr :: AttrName
dialogAttr = String -> AttrName
attrName String
"dialog"
dialogEmphAttr :: AttrName
dialogEmphAttr :: AttrName
dialogEmphAttr = String -> AttrName
attrName String
"dialogEmphasis"
channelSelectMatchAttr :: AttrName
channelSelectMatchAttr :: AttrName
channelSelectMatchAttr = String -> AttrName
attrName String
"channelSelectMatch"
channelSelectPromptAttr :: AttrName
channelSelectPromptAttr :: AttrName
channelSelectPromptAttr = String -> AttrName
attrName String
"channelSelectPrompt"
completionAlternativeListAttr :: AttrName
completionAlternativeListAttr :: AttrName
completionAlternativeListAttr = String -> AttrName
attrName String
"tabCompletionAlternative"
completionAlternativeCurrentAttr :: AttrName
completionAlternativeCurrentAttr :: AttrName
completionAlternativeCurrentAttr = String -> AttrName
attrName String
"tabCompletionCursor"
timeAttr :: AttrName
timeAttr :: AttrName
timeAttr = String -> AttrName
attrName String
"time"
currentUserAttr :: AttrName
currentUserAttr :: AttrName
currentUserAttr = String -> AttrName
attrName String
"currentUser"
channelHeaderAttr :: AttrName
= String -> AttrName
attrName String
"channelHeader"
verbatimTruncateMessageAttr :: AttrName
verbatimTruncateMessageAttr :: AttrName
verbatimTruncateMessageAttr = String -> AttrName
attrName String
"verbatimTruncateMessage"
channelListHeaderAttr :: AttrName
= String -> AttrName
attrName String
"channelListSectionHeader"
currentChannelNameAttr :: AttrName
currentChannelNameAttr :: AttrName
currentChannelNameAttr = String -> AttrName
attrName String
"currentChannelName"
channelNameAttr :: AttrName
channelNameAttr :: AttrName
channelNameAttr = String -> AttrName
attrName String
"channelName"
unreadChannelAttr :: AttrName
unreadChannelAttr :: AttrName
unreadChannelAttr = String -> AttrName
attrName String
"unreadChannel"
unreadGroupMarkerAttr :: AttrName
unreadGroupMarkerAttr :: AttrName
unreadGroupMarkerAttr = String -> AttrName
attrName String
"unreadChannelGroupMarker"
mentionsChannelAttr :: AttrName
mentionsChannelAttr :: AttrName
mentionsChannelAttr = String -> AttrName
attrName String
"channelWithMentions"
currentTeamAttr :: AttrName
currentTeamAttr :: AttrName
currentTeamAttr = String -> AttrName
attrName String
"currentTeam"
tabSelectedAttr :: AttrName
tabSelectedAttr :: AttrName
tabSelectedAttr = String -> AttrName
attrName String
"tabSelected"
tabUnselectedAttr :: AttrName
tabUnselectedAttr :: AttrName
tabUnselectedAttr = String -> AttrName
attrName String
"tabUnselected"
dateTransitionAttr :: AttrName
dateTransitionAttr :: AttrName
dateTransitionAttr = String -> AttrName
attrName String
"dateTransition"
newMessageTransitionAttr :: AttrName
newMessageTransitionAttr :: AttrName
newMessageTransitionAttr = String -> AttrName
attrName String
"newMessageTransition"
urlAttr :: AttrName
urlAttr :: AttrName
urlAttr = String -> AttrName
attrName String
"url"
codeAttr :: AttrName
codeAttr :: AttrName
codeAttr = String -> AttrName
attrName String
"codeBlock"
emailAttr :: AttrName
emailAttr :: AttrName
emailAttr = String -> AttrName
attrName String
"email"
emojiAttr :: AttrName
emojiAttr :: AttrName
emojiAttr = String -> AttrName
attrName String
"emoji"
reactionAttr :: AttrName
reactionAttr :: AttrName
reactionAttr = String -> AttrName
attrName String
"reaction"
myReactionAttr :: AttrName
myReactionAttr :: AttrName
myReactionAttr = AttrName
reactionAttr forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"mine"
clientMessageAttr :: AttrName
clientMessageAttr :: AttrName
clientMessageAttr = String -> AttrName
attrName String
"clientMessage"
clientHeaderAttr :: AttrName
= String -> AttrName
attrName String
"markdownHeader"
strikeThroughAttr :: AttrName
strikeThroughAttr :: AttrName
strikeThroughAttr = String -> AttrName
attrName String
"markdownStrikethrough"
clientEmphAttr :: AttrName
clientEmphAttr :: AttrName
clientEmphAttr = String -> AttrName
attrName String
"markdownEmph"
clientStrongAttr :: AttrName
clientStrongAttr :: AttrName
clientStrongAttr = String -> AttrName
attrName String
"markdownStrong"
errorMessageAttr :: AttrName
errorMessageAttr :: AttrName
errorMessageAttr = String -> AttrName
attrName String
"errorMessage"
gapMessageAttr :: AttrName
gapMessageAttr :: AttrName
gapMessageAttr = String -> AttrName
attrName String
"gapMessage"
misspellingAttr :: AttrName
misspellingAttr :: AttrName
misspellingAttr = String -> AttrName
attrName String
"misspelling"
messageSelectStatusAttr :: AttrName
messageSelectStatusAttr :: AttrName
messageSelectStatusAttr = String -> AttrName
attrName String
"messageSelectStatus"
urlSelectStatusAttr :: AttrName
urlSelectStatusAttr :: AttrName
urlSelectStatusAttr = String -> AttrName
attrName String
"urlSelectStatus"
buttonAttr :: AttrName
buttonAttr :: AttrName
buttonAttr = String -> AttrName
attrName String
"button"
buttonFocusedAttr :: AttrName
buttonFocusedAttr :: AttrName
buttonFocusedAttr = AttrName
buttonAttr forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"focused"
threadAttr :: AttrName
threadAttr :: AttrName
threadAttr = String -> AttrName
attrName String
"thread"
focusedEditorPromptAttr :: AttrName
focusedEditorPromptAttr :: AttrName
focusedEditorPromptAttr = String -> AttrName
attrName String
"focusedEditorPrompt"
lookupTheme :: Text -> Maybe InternalTheme
lookupTheme :: Text -> Maybe InternalTheme
lookupTheme Text
n = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== Text
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalTheme -> Text
internalThemeName) [InternalTheme]
internalThemes
internalThemes :: [InternalTheme]
internalThemes :: [InternalTheme]
internalThemes = InternalTheme -> InternalTheme
validateInternalTheme forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
[ InternalTheme
darkColorTheme
, InternalTheme
darkColor256Theme
, InternalTheme
lightColorTheme
, InternalTheme
lightColor256Theme
]
validateInternalTheme :: InternalTheme -> InternalTheme
validateInternalTheme :: InternalTheme -> InternalTheme
validateInternalTheme InternalTheme
it =
let un :: [AttrName]
un = Theme -> [AttrName]
undocumentedAttrNames (InternalTheme -> Theme
internalTheme InternalTheme
it)
in if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AttrName]
un
then forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Internal theme " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Text -> String
T.unpack (InternalTheme -> Text
internalThemeName InternalTheme
it)) forall a. Semigroup a => a -> a -> a
<>
String
" references undocumented attribute names: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [AttrName]
un
else InternalTheme
it
undocumentedAttrNames :: Theme -> [AttrName]
undocumentedAttrNames :: Theme -> [AttrName]
undocumentedAttrNames Theme
t =
let noDocs :: AttrName -> Bool
noDocs AttrName
k = forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ ThemeDocumentation -> AttrName -> Maybe Text
attrNameDescription ThemeDocumentation
themeDocs AttrName
k
in forall a. (a -> Bool) -> [a] -> [a]
filter AttrName -> Bool
noDocs (forall k a. Map k a -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ Theme -> Map AttrName Attr
themeDefaultMapping Theme
t)
defaultTheme :: InternalTheme
defaultTheme :: InternalTheme
defaultTheme = InternalTheme
darkColorTheme
lightColorTheme :: InternalTheme
lightColorTheme :: InternalTheme
lightColorTheme = Text -> Theme -> Text -> InternalTheme
InternalTheme Text
name Theme
theme Text
desc
where
theme :: Theme
theme = Attr -> [(AttrName, Attr)] -> Theme
newTheme Attr
def forall a b. (a -> b) -> a -> b
$ [Attr] -> [(AttrName, Attr)]
lightAttrs [Attr]
usernameColors16
name :: Text
name = Text
"builtin:light"
def :: Attr
def = Color
black Color -> Color -> Attr
`on` Color
white
desc :: Text
desc = Text
"A 16-color theme for terminal windows with light background colors"
lightColor256Theme :: InternalTheme
lightColor256Theme :: InternalTheme
lightColor256Theme = Text -> Theme -> Text -> InternalTheme
InternalTheme Text
name Theme
theme Text
desc
where
theme :: Theme
theme = Attr -> [(AttrName, Attr)] -> Theme
newTheme Attr
def forall a b. (a -> b) -> a -> b
$ [Attr] -> [(AttrName, Attr)]
lightAttrs [Attr]
usernameColors256
name :: Text
name = Text
"builtin:light256"
def :: Attr
def = Color
black Color -> Color -> Attr
`on` Color
white
desc :: Text
desc = Text
"Like builtin:light, but with 256-color username colors"
lightAttrs :: [Attr] -> [(AttrName, Attr)]
lightAttrs :: [Attr] -> [(AttrName, Attr)]
lightAttrs [Attr]
usernameColors =
let sty :: Style
sty = Style
Sky.kate
in [ (AttrName
timeAttr, Color -> Attr
fg Color
black)
, (AttrName
buttonAttr, Color
black Color -> Color -> Attr
`on` Color
cyan)
, (AttrName
buttonFocusedAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
threadAttr, Attr
defAttr)
, (AttrName
focusedEditorPromptAttr, Color -> Attr
fg Color
yellow Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
currentUserAttr, Attr
defAttr Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
channelHeaderAttr, Color -> Attr
fg Color
black)
, (AttrName
verbatimTruncateMessageAttr, Color -> Attr
fg Color
blue)
, (AttrName
scrollbarAttr, Attr
defAttr)
, (AttrName
scrollbarHandleAttr, Attr
defAttr Attr -> Style -> Attr
`withStyle` Style
reverseVideo)
, (AttrName
scrollbarTroughAttr, Attr
defAttr)
, (AttrName
channelListHeaderAttr, Color -> Attr
fg Color
cyan)
, (AttrName
currentChannelNameAttr, Color
black Color -> Color -> Attr
`on` Color
yellow Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
unreadChannelAttr, Color
black Color -> Color -> Attr
`on` Color
cyan Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
unreadGroupMarkerAttr, Color -> Attr
fg Color
black Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
mentionsChannelAttr, Color
black Color -> Color -> Attr
`on` Color
red Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
urlAttr, Color -> Attr
fg Color
brightYellow)
, (AttrName
emailAttr, Color -> Attr
fg Color
yellow)
, (AttrName
codeAttr, Color -> Attr
fg Color
magenta)
, (AttrName
emojiAttr, Color -> Attr
fg Color
yellow)
, (AttrName
reactionAttr, Color -> Attr
fg Color
yellow)
, (AttrName
myReactionAttr, Color -> Attr
fg Color
yellow Attr -> Style -> Attr
`withStyle` Style
underline)
, (AttrName
channelNameAttr, Color -> Attr
fg Color
blue)
, (AttrName
clientMessageAttr, Color -> Attr
fg Color
black)
, (AttrName
clientEmphAttr, Color -> Attr
fg Color
black Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
clientStrongAttr, Color -> Attr
fg Color
black Attr -> Style -> Attr
`withStyle` Style
bold Attr -> Style -> Attr
`withStyle` Style
underline)
, (AttrName
clientHeaderAttr, Color -> Attr
fg Color
red Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
strikeThroughAttr, Attr
defAttr Attr -> Style -> Attr
`withStyle` Style
strikethrough)
, (AttrName
dateTransitionAttr, Color -> Attr
fg Color
green)
, (AttrName
newMessageTransitionAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
errorMessageAttr, Color -> Attr
fg Color
red)
, (AttrName
gapMessageAttr, Color -> Attr
fg Color
red)
, (AttrName
helpAttr, Color -> Attr
fg Color
black)
, (AttrName
pinnedMessageIndicatorAttr, Color
black Color -> Color -> Attr
`on` Color
cyan)
, (AttrName
helpEmphAttr, Color -> Attr
fg Color
blue Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
helpKeyEventAttr, Color -> Attr
fg Color
magenta)
, (AttrName
channelSelectMatchAttr, Color
black Color -> Color -> Attr
`on` Color
magenta Attr -> Style -> Attr
`withStyle` Style
underline)
, (AttrName
channelSelectPromptAttr, Color -> Attr
fg Color
black)
, (AttrName
completionAlternativeListAttr, Color
white Color -> Color -> Attr
`on` Color
blue)
, (AttrName
completionAlternativeCurrentAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
dialogAttr, Color
black Color -> Color -> Attr
`on` Color
cyan)
, (AttrName
dialogEmphAttr, Color -> Attr
fg Color
white)
, (AttrName
permalinkAttr, Color -> Attr
fg Color
green)
, (AttrName
listSelectedFocusedAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
recentMarkerAttr, Color -> Attr
fg Color
black Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
loadMoreAttr, Color
black Color -> Color -> Attr
`on` Color
cyan)
, (AttrName
urlListSelectedAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
messageSelectAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
messageSelectStatusAttr, Color -> Attr
fg Color
black)
, (AttrName
urlSelectStatusAttr, Color -> Attr
fg Color
black)
, (AttrName
misspellingAttr, Color -> Attr
fg Color
red Attr -> Style -> Attr
`withStyle` Style
underline)
, (AttrName
editedMarkingAttr, Color -> Attr
fg Color
yellow)
, (AttrName
editedRecentlyMarkingAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
tabSelectedAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
focusedFormInputAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
currentTeamAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
FB.fileBrowserCurrentDirectoryAttr, Color
white Color -> Color -> Attr
`on` Color
blue)
, (AttrName
FB.fileBrowserSelectionInfoAttr, Color
white Color -> Color -> Attr
`on` Color
blue)
, (AttrName
FB.fileBrowserDirectoryAttr, Color -> Attr
fg Color
blue)
, (AttrName
FB.fileBrowserBlockDeviceAttr, Color -> Attr
fg Color
magenta)
, (AttrName
FB.fileBrowserCharacterDeviceAttr, Color -> Attr
fg Color
green)
, (AttrName
FB.fileBrowserNamedPipeAttr, Color -> Attr
fg Color
yellow)
, (AttrName
FB.fileBrowserSymbolicLinkAttr, Color -> Attr
fg Color
cyan)
, (AttrName
FB.fileBrowserUnixSocketAttr, Color -> Attr
fg Color
red)
] forall a. Semigroup a => a -> a -> a
<>
((\(Int
i, Attr
a) -> (Int -> AttrName
usernameAttr Int
i, Attr
a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..Int
usernameColorHashBucketsforall a. Num a => a -> a -> a
-Int
1] (forall a. [a] -> [a]
cycle [Attr]
usernameColors)) forall a. Semigroup a => a -> a -> a
<>
(forall a. (a -> Bool) -> [a] -> [a]
filter (AttrName, Attr) -> Bool
skipBaseCodeblockAttr forall a b. (a -> b) -> a -> b
$ Style -> [(AttrName, Attr)]
attrMappingsForStyle Style
sty)
darkAttrs :: [Attr] -> [(AttrName, Attr)]
darkAttrs :: [Attr] -> [(AttrName, Attr)]
darkAttrs [Attr]
usernameColors =
let sty :: Style
sty = Style
Sky.espresso
in [ (AttrName
timeAttr, Color -> Attr
fg Color
white)
, (AttrName
buttonAttr, Color
black Color -> Color -> Attr
`on` Color
cyan)
, (AttrName
buttonFocusedAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
threadAttr, Attr
defAttr)
, (AttrName
focusedEditorPromptAttr, Color -> Attr
fg Color
yellow Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
currentUserAttr, Attr
defAttr Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
channelHeaderAttr, Color -> Attr
fg Color
white)
, (AttrName
verbatimTruncateMessageAttr, Color -> Attr
fg Color
cyan)
, (AttrName
channelListHeaderAttr, Color -> Attr
fg Color
cyan)
, (AttrName
currentChannelNameAttr, Color
black Color -> Color -> Attr
`on` Color
yellow Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
unreadChannelAttr, Color
black Color -> Color -> Attr
`on` Color
cyan Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
unreadGroupMarkerAttr, Color -> Attr
fg Color
white Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
mentionsChannelAttr, Color
black Color -> Color -> Attr
`on` Color
brightMagenta Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
scrollbarAttr, Attr
defAttr)
, (AttrName
scrollbarHandleAttr, Attr
defAttr Attr -> Style -> Attr
`withStyle` Style
reverseVideo)
, (AttrName
scrollbarTroughAttr, Attr
defAttr)
, (AttrName
urlAttr, Color -> Attr
fg Color
yellow)
, (AttrName
emailAttr, Color -> Attr
fg Color
yellow)
, (AttrName
codeAttr, Color -> Attr
fg Color
magenta)
, (AttrName
emojiAttr, Color -> Attr
fg Color
yellow)
, (AttrName
reactionAttr, Color -> Attr
fg Color
yellow)
, (AttrName
myReactionAttr, Color -> Attr
fg Color
yellow Attr -> Style -> Attr
`withStyle` Style
underline)
, (AttrName
channelNameAttr, Color -> Attr
fg Color
cyan)
, (AttrName
pinnedMessageIndicatorAttr, Color -> Attr
fg Color
cyan Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
clientMessageAttr, Color -> Attr
fg Color
white)
, (AttrName
clientEmphAttr, Color -> Attr
fg Color
white Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
clientStrongAttr, Color -> Attr
fg Color
white Attr -> Style -> Attr
`withStyle` Style
bold Attr -> Style -> Attr
`withStyle` Style
underline)
, (AttrName
clientHeaderAttr, Color -> Attr
fg Color
red Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
strikeThroughAttr, Attr
defAttr Attr -> Style -> Attr
`withStyle` Style
strikethrough)
, (AttrName
dateTransitionAttr, Color -> Attr
fg Color
green)
, (AttrName
newMessageTransitionAttr, Color -> Attr
fg Color
yellow Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
errorMessageAttr, Color -> Attr
fg Color
red)
, (AttrName
gapMessageAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
helpAttr, Color -> Attr
fg Color
white)
, (AttrName
helpEmphAttr, Color -> Attr
fg Color
cyan Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
helpKeyEventAttr, Color -> Attr
fg Color
yellow)
, (AttrName
channelSelectMatchAttr, Color
black Color -> Color -> Attr
`on` Color
magenta Attr -> Style -> Attr
`withStyle` Style
underline)
, (AttrName
channelSelectPromptAttr, Color -> Attr
fg Color
white)
, (AttrName
completionAlternativeListAttr, Color
white Color -> Color -> Attr
`on` Color
blue)
, (AttrName
completionAlternativeCurrentAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
dialogAttr, Color
black Color -> Color -> Attr
`on` Color
cyan)
, (AttrName
dialogEmphAttr, Color -> Attr
fg Color
white)
, (AttrName
permalinkAttr, Color -> Attr
fg Color
brightCyan)
, (AttrName
listSelectedFocusedAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
recentMarkerAttr, Color -> Attr
fg Color
yellow Attr -> Style -> Attr
`withStyle` Style
bold)
, (AttrName
loadMoreAttr, Color
black Color -> Color -> Attr
`on` Color
cyan)
, (AttrName
urlListSelectedAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
messageSelectAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
messageSelectStatusAttr, Color -> Attr
fg Color
white)
, (AttrName
urlSelectStatusAttr, Color -> Attr
fg Color
white)
, (AttrName
misspellingAttr, Color -> Attr
fg Color
red Attr -> Style -> Attr
`withStyle` Style
underline)
, (AttrName
editedMarkingAttr, Color -> Attr
fg Color
yellow)
, (AttrName
editedRecentlyMarkingAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
tabSelectedAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
focusedFormInputAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
currentTeamAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
, (AttrName
FB.fileBrowserCurrentDirectoryAttr, Color
white Color -> Color -> Attr
`on` Color
blue)
, (AttrName
FB.fileBrowserSelectionInfoAttr, Color
white Color -> Color -> Attr
`on` Color
blue)
, (AttrName
FB.fileBrowserDirectoryAttr, Color -> Attr
fg Color
blue)
, (AttrName
FB.fileBrowserBlockDeviceAttr, Color -> Attr
fg Color
magenta)
, (AttrName
FB.fileBrowserCharacterDeviceAttr, Color -> Attr
fg Color
green)
, (AttrName
FB.fileBrowserNamedPipeAttr, Color -> Attr
fg Color
yellow)
, (AttrName
FB.fileBrowserSymbolicLinkAttr, Color -> Attr
fg Color
cyan)
, (AttrName
FB.fileBrowserUnixSocketAttr, Color -> Attr
fg Color
red)
] forall a. Semigroup a => a -> a -> a
<>
((\(Int
i, Attr
a) -> (Int -> AttrName
usernameAttr Int
i, Attr
a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..Int
usernameColorHashBucketsforall a. Num a => a -> a -> a
-Int
1] (forall a. [a] -> [a]
cycle [Attr]
usernameColors)) forall a. Semigroup a => a -> a -> a
<>
(forall a. (a -> Bool) -> [a] -> [a]
filter (AttrName, Attr) -> Bool
skipBaseCodeblockAttr forall a b. (a -> b) -> a -> b
$ Style -> [(AttrName, Attr)]
attrMappingsForStyle Style
sty)
skipBaseCodeblockAttr :: (AttrName, Attr) -> Bool
skipBaseCodeblockAttr :: (AttrName, Attr) -> Bool
skipBaseCodeblockAttr = ((forall a. Eq a => a -> a -> Bool
/= AttrName
highlightedCodeBlockAttr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
darkColorTheme :: InternalTheme
darkColorTheme :: InternalTheme
darkColorTheme = Text -> Theme -> Text -> InternalTheme
InternalTheme Text
name Theme
theme Text
desc
where
theme :: Theme
theme = Attr -> [(AttrName, Attr)] -> Theme
newTheme Attr
def forall a b. (a -> b) -> a -> b
$ [Attr] -> [(AttrName, Attr)]
darkAttrs [Attr]
usernameColors16
name :: Text
name = Text
"builtin:dark"
def :: Attr
def = Attr
defAttr
desc :: Text
desc = Text
"A 16-color theme for terminal windows with dark background colors"
darkColor256Theme :: InternalTheme
darkColor256Theme :: InternalTheme
darkColor256Theme = Text -> Theme -> Text -> InternalTheme
InternalTheme Text
name Theme
theme Text
desc
where
theme :: Theme
theme = Attr -> [(AttrName, Attr)] -> Theme
newTheme Attr
def forall a b. (a -> b) -> a -> b
$ [Attr] -> [(AttrName, Attr)]
darkAttrs [Attr]
usernameColors256
name :: Text
name = Text
"builtin:dark256"
def :: Attr
def = Attr
defAttr
desc :: Text
desc = Text
"Like builtin:dark, but with 256-color username colors"
usernameAttr :: Int -> AttrName
usernameAttr :: Int -> AttrName
usernameAttr Int
i = String -> AttrName
attrName String
"username" forall a. Semigroup a => a -> a -> a
<> (String -> AttrName
attrName forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
i)
colorUsername :: Text
-> Text
-> Text
-> Widget a
colorUsername :: forall a. Text -> Text -> Text -> Widget a
colorUsername Text
current Text
username Text
display =
let aName :: AttrName
aName = Text -> AttrName
attrForUsername Text
username
maybeWithCurrentAttr :: Widget n -> Widget n
maybeWithCurrentAttr = if Text
current forall a. Eq a => a -> a -> Bool
== Text
username
then forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
currentUserAttr
else forall a. a -> a
id
in forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
aName forall a b. (a -> b) -> a -> b
$
forall {n}. Widget n -> Widget n
maybeWithCurrentAttr forall a b. (a -> b) -> a -> b
$
forall n. Text -> Widget n
txt (Text
display)
attrForUsername :: Text
-> AttrName
attrForUsername :: Text -> AttrName
attrForUsername Text
username =
let normalizedUsername :: Text
normalizedUsername = Text -> Text
T.toLower Text
username
aName :: AttrName
aName = if Text
normalizedUsername forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
specialUserMentions
then AttrName
clientEmphAttr
else Int -> AttrName
usernameAttr Int
h
h :: Int
h = forall a. Hashable a => a -> Int
hash Text
normalizedUsername forall a. Integral a => a -> a -> a
`mod` Int
usernameColorHashBuckets
in AttrName
aName
usernameColorHashBuckets :: Int
usernameColorHashBuckets :: Int
usernameColorHashBuckets = Int
50
usernameColors16 :: [Attr]
usernameColors16 :: [Attr]
usernameColors16 =
[ Color -> Attr
fg Color
red
, Color -> Attr
fg Color
green
, Color -> Attr
fg Color
yellow
, Color -> Attr
fg Color
blue
, Color -> Attr
fg Color
magenta
, Color -> Attr
fg Color
cyan
, Color -> Attr
fg Color
brightRed
, Color -> Attr
fg Color
brightGreen
, Color -> Attr
fg Color
brightYellow
, Color -> Attr
fg Color
brightBlue
, Color -> Attr
fg Color
brightMagenta
, Color -> Attr
fg Color
brightCyan
]
usernameColors256 :: [Attr]
usernameColors256 :: [Attr]
usernameColors256 = forall {i}. Integral i => (i, i, i) -> Attr
mkColor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Integer, Integer, Integer)]
username256ColorChoices
where
mkColor :: (i, i, i) -> Attr
mkColor (i
r, i
g, i
b) = Attr
defAttr Attr -> Color -> Attr
`withForeColor` forall i. Integral i => i -> i -> i -> Color
rgbColor i
r i
g i
b
username256ColorChoices :: [(Integer, Integer, Integer)]
username256ColorChoices :: [(Integer, Integer, Integer)]
username256ColorChoices =
[ (Integer
255, Integer
0, Integer
86)
, (Integer
158, Integer
0, Integer
142)
, (Integer
14, Integer
76, Integer
161)
, (Integer
255, Integer
229, Integer
2)
, (Integer
149, Integer
0, Integer
58)
, (Integer
255, Integer
147, Integer
126)
, (Integer
164, Integer
36, Integer
0)
, (Integer
98, Integer
14, Integer
0)
, (Integer
0, Integer
0, Integer
255)
, (Integer
106, Integer
130, Integer
108)
, (Integer
0, Integer
174, Integer
126)
, (Integer
194, Integer
140, Integer
159)
, (Integer
0, Integer
143, Integer
156)
, (Integer
95, Integer
173, Integer
78)
, (Integer
255, Integer
2, Integer
157)
, (Integer
255, Integer
116, Integer
163)
, (Integer
152, Integer
255, Integer
82)
, (Integer
167, Integer
87, Integer
64)
, (Integer
254, Integer
137, Integer
0)
, (Integer
1, Integer
208, Integer
255)
, (Integer
187, Integer
136, Integer
0)
, (Integer
117, Integer
68, Integer
177)
, (Integer
165, Integer
255, Integer
210)
, (Integer
122, Integer
71, Integer
130)
, (Integer
0, Integer
71, Integer
84)
, (Integer
181, Integer
0, Integer
255)
, (Integer
144, Integer
251, Integer
146)
, (Integer
189, Integer
211, Integer
147)
, (Integer
229, Integer
111, Integer
254)
, (Integer
222, Integer
255, Integer
116)
, (Integer
0, Integer
255, Integer
120)
, (Integer
0, Integer
155, Integer
255)
, (Integer
0, Integer
100, Integer
1)
, (Integer
0, Integer
118, Integer
255)
, (Integer
133, Integer
169, Integer
0)
, (Integer
0, Integer
185, Integer
23)
, (Integer
120, Integer
130, Integer
49)
, (Integer
0, Integer
255, Integer
198)
, (Integer
255, Integer
110, Integer
65)
]
attrNameDescription :: ThemeDocumentation -> AttrName -> Maybe Text
attrNameDescription :: ThemeDocumentation -> AttrName -> Maybe Text
attrNameDescription ThemeDocumentation
td AttrName
an = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AttrName
an (ThemeDocumentation -> Map AttrName Text
themeDescriptions ThemeDocumentation
td)
themeDocs :: ThemeDocumentation
themeDocs :: ThemeDocumentation
themeDocs = Map AttrName Text -> ThemeDocumentation
ThemeDocumentation forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
[ ( AttrName
timeAttr
, Text
"Timestamps on chat messages"
)
, ( AttrName
channelHeaderAttr
, Text
"Channel headers displayed above chat message lists"
)
, ( AttrName
channelListHeaderAttr
, Text
"The heading of the channel list sections"
)
, ( AttrName
currentChannelNameAttr
, Text
"The currently selected channel in the channel list"
)
, ( AttrName
unreadChannelAttr
, Text
"A channel in the channel list with unread messages"
)
, ( AttrName
unreadGroupMarkerAttr
, Text
"The channel group marker indicating unread messages"
)
, ( AttrName
mentionsChannelAttr
, Text
"A channel in the channel list with unread mentions"
)
, ( AttrName
urlAttr
, Text
"A URL in a chat message"
)
, ( AttrName
codeAttr
, Text
"A code block in a chat message with no language indication"
)
, ( AttrName
emailAttr
, Text
"An e-mail address in a chat message"
)
, ( AttrName
emojiAttr
, Text
"A text emoji indication in a chat message"
)
, ( AttrName
reactionAttr
, Text
"An emoji reaction on a chat message"
)
, ( AttrName
myReactionAttr
, Text
"An emoji reaction that the current user has posted on a chat message"
)
, ( AttrName
channelNameAttr
, Text
"A channel name in a chat message"
)
, ( AttrName
clientMessageAttr
, Text
"A Matterhorn diagnostic or informative message"
)
, ( AttrName
clientHeaderAttr
, Text
"Markdown heading"
)
, ( AttrName
strikeThroughAttr
, Text
"Markdown strikethrough text"
)
, ( AttrName
clientEmphAttr
, Text
"Markdown 'emphasized' text"
)
, ( AttrName
clientStrongAttr
, Text
"Markdown 'strong' text"
)
, ( AttrName
dateTransitionAttr
, Text
"Date transition lines between chat messages on different days"
)
, ( AttrName
pinnedMessageIndicatorAttr
, Text
"The indicator for messages that have been pinned"
)
, ( AttrName
newMessageTransitionAttr
, Text
"The 'New Messages' line that appears above unread messages"
)
, ( AttrName
tabSelectedAttr
, Text
"Selected tabs in tabbed windows"
)
, ( AttrName
tabUnselectedAttr
, Text
"Unselected tabs in tabbed windows"
)
, ( AttrName
errorMessageAttr
, Text
"Matterhorn error messages"
)
, ( AttrName
gapMessageAttr
, Text
"Matterhorn message gap information"
)
, ( AttrName
helpAttr
, Text
"The help screen text"
)
, ( AttrName
helpEmphAttr
, Text
"The help screen's emphasized text"
)
, ( AttrName
helpKeyEventAttr
, Text
"The help screen's mention of key event names"
)
, ( AttrName
channelSelectPromptAttr
, Text
"Channel selection: prompt"
)
, ( AttrName
channelSelectMatchAttr
, Text
"Channel selection: the portion of a channel name that matches"
)
, ( AttrName
completionAlternativeListAttr
, Text
"Tab completion alternatives"
)
, ( AttrName
completionAlternativeCurrentAttr
, Text
"The currently-selected tab completion alternative"
)
, ( AttrName
permalinkAttr
, Text
"A post permalink"
)
, ( AttrName
dialogAttr
, Text
"Dialog box text"
)
, ( AttrName
dialogEmphAttr
, Text
"Dialog box emphasized text"
)
, ( AttrName
recentMarkerAttr
, Text
"The marker indicating the channel last visited"
)
, ( AttrName
replyParentAttr
, Text
"The first line of parent messages appearing above reply messages"
)
, ( AttrName
loadMoreAttr
, Text
"The 'Load More' line that appears at the top of a chat message list"
)
, ( AttrName
urlListSelectedAttr
, Text
"URL list: the selected URL"
)
, ( AttrName
messageSelectAttr
, Text
"Message selection: the currently-selected message"
)
, ( AttrName
messageSelectStatusAttr
, Text
"Message selection: the message selection actions"
)
, ( AttrName
urlSelectStatusAttr
, Text
"Link selection: the message selection actions"
)
, ( AttrName
misspellingAttr
, Text
"A misspelled word in the chat message editor"
)
, ( AttrName
editedMarkingAttr
, Text
"The 'edited' marking that appears on edited messages"
)
, ( AttrName
editedRecentlyMarkingAttr
, Text
"The 'edited' marking that appears on newly-edited messages"
)
, ( AttrName
highlightedCodeBlockAttr
, Text
"The base attribute for syntax-highlighted code blocks"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
KeywordTok
, Text
"Syntax highlighting: Keyword"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
DataTypeTok
, Text
"Syntax highlighting: DataType"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
DecValTok
, Text
"Syntax highlighting: Declaration"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
BaseNTok
, Text
"Syntax highlighting: BaseN"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
FloatTok
, Text
"Syntax highlighting: Float"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
ConstantTok
, Text
"Syntax highlighting: Constant"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
CharTok
, Text
"Syntax highlighting: Char"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
SpecialCharTok
, Text
"Syntax highlighting: Special Char"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
StringTok
, Text
"Syntax highlighting: String"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
VerbatimStringTok
, Text
"Syntax highlighting: Verbatim String"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
SpecialStringTok
, Text
"Syntax highlighting: Special String"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
ImportTok
, Text
"Syntax highlighting: Import"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
CommentTok
, Text
"Syntax highlighting: Comment"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
DocumentationTok
, Text
"Syntax highlighting: Documentation"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
AnnotationTok
, Text
"Syntax highlighting: Annotation"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
CommentVarTok
, Text
"Syntax highlighting: Comment"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
OtherTok
, Text
"Syntax highlighting: Other"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
FunctionTok
, Text
"Syntax highlighting: Function"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
VariableTok
, Text
"Syntax highlighting: Variable"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
ControlFlowTok
, Text
"Syntax highlighting: Control Flow"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
OperatorTok
, Text
"Syntax highlighting: Operator"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
BuiltInTok
, Text
"Syntax highlighting: Built-In"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
ExtensionTok
, Text
"Syntax highlighting: Extension"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
PreprocessorTok
, Text
"Syntax highlighting: Preprocessor"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
AttributeTok
, Text
"Syntax highlighting: Attribute"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
RegionMarkerTok
, Text
"Syntax highlighting: Region Marker"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
InformationTok
, Text
"Syntax highlighting: Information"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
WarningTok
, Text
"Syntax highlighting: Warning"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
AlertTok
, Text
"Syntax highlighting: Alert"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
ErrorTok
, Text
"Syntax highlighting: Error"
)
, ( TokenType -> AttrName
attrNameForTokenType TokenType
NormalTok
, Text
"Syntax highlighting: Normal text"
)
, ( AttrName
listSelectedFocusedAttr
, Text
"The selected channel"
)
, ( AttrName
focusedFormInputAttr
, Text
"A form input that has focus"
)
, ( AttrName
FB.fileBrowserAttr
, Text
"The base file browser attribute"
)
, ( AttrName
FB.fileBrowserCurrentDirectoryAttr
, Text
"The file browser current directory attribute"
)
, ( AttrName
FB.fileBrowserSelectionInfoAttr
, Text
"The file browser selection information attribute"
)
, ( AttrName
FB.fileBrowserDirectoryAttr
, Text
"Attribute for directories in the file browser"
)
, ( AttrName
FB.fileBrowserBlockDeviceAttr
, Text
"Attribute for block devices in the file browser"
)
, ( AttrName
FB.fileBrowserRegularFileAttr
, Text
"Attribute for regular files in the file browser"
)
, ( AttrName
FB.fileBrowserCharacterDeviceAttr
, Text
"Attribute for character devices in the file browser"
)
, ( AttrName
FB.fileBrowserNamedPipeAttr
, Text
"Attribute for named pipes in the file browser"
)
, ( AttrName
FB.fileBrowserSymbolicLinkAttr
, Text
"Attribute for symbolic links in the file browser"
)
, ( AttrName
FB.fileBrowserUnixSocketAttr
, Text
"Attribute for Unix sockets in the file browser"
)
, ( AttrName
buttonAttr
, Text
"Attribute for input form buttons"
)
, ( AttrName
buttonFocusedAttr
, Text
"Attribute for focused input form buttons"
)
, ( AttrName
currentUserAttr
, Text
"Attribute for the username of the user running Matterhorn"
)
, ( AttrName
currentTeamAttr
, Text
"The currently-selected team"
)
, ( AttrName
verbatimTruncateMessageAttr
, Text
"Attribute for a message indicating that a verbatim or code block has been only partially displayed"
)
, ( AttrName
scrollbarAttr
, Text
"Base aAttribute for scroll bars"
)
, ( AttrName
scrollbarTroughAttr
, Text
"Attribute for scroll bar troughs"
)
, ( AttrName
scrollbarHandleAttr
, Text
"Attribute for scroll bar handles"
)
, ( AttrName
threadAttr
, Text
"Base attribute for the thread window"
)
, ( AttrName
focusedEditorPromptAttr
, Text
"The attribute for the prompt of the focused message editor"
)
] forall a. Semigroup a => a -> a -> a
<> [ (Int -> AttrName
usernameAttr Int
i, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Username color " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
i)
| Int
i <- [Int
0..Int
usernameColorHashBucketsforall a. Num a => a -> a -> a
-Int
1]
]