{-# Language OverloadedStrings, BangPatterns #-}
module Client.Image.Message
( MessageRendererParams(..)
, RenderMode(..)
, IdentifierColorMode(..)
, defaultRenderParams
, msgImage
, metadataImg
, ignoreImage
, quietIdentifier
, coloredUserInfo
, coloredIdentifier
) where
import Client.Image.MircFormatting
import Client.Image.Palette
import Client.Message
import Control.Lens
import Data.Char
import Data.Hashable (hash)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time
import qualified Data.Vector as Vector
import Graphics.Vty.Image
import Irc.Codes
import Irc.Identifier
import Irc.Message
import Irc.RawIrcMsg
import Irc.UserInfo
data MessageRendererParams = MessageRendererParams
{ rendStatusMsg :: [Char]
, rendUserSigils :: [Char]
, rendNicks :: HashSet Identifier
, rendMyNicks :: HashSet Identifier
, rendPalette :: Palette
, rendNickPadding :: Maybe Integer
}
defaultRenderParams :: MessageRendererParams
defaultRenderParams = MessageRendererParams
{ rendStatusMsg = ""
, rendUserSigils = ""
, rendNicks = HashSet.empty
, rendMyNicks = HashSet.empty
, rendPalette = defaultPalette
, rendNickPadding = Nothing
}
msgImage ::
RenderMode ->
ZonedTime ->
MessageRendererParams -> MessageBody -> Image
msgImage rm when params body = horizCat
[ renderTime rm (rendPalette params) when
, char defAttr ' '
, statusMsgImage (rendStatusMsg params)
, bodyImage rm params body
]
errorImage ::
MessageRendererParams ->
Text ->
Image
errorImage params txt = horizCat
[ text' (view palError (rendPalette params)) "error "
, text' defAttr txt
]
normalImage ::
MessageRendererParams ->
Text ->
Image
normalImage params txt = horizCat
[ text' (view palLabel (rendPalette params)) "client "
, text' defAttr txt
]
renderTime :: RenderMode -> Palette -> ZonedTime -> Image
renderTime DetailedRender = datetimeImage
renderTime NormalRender = timeImage
statusMsgImage :: [Char] -> Image
statusMsgImage modes
| null modes = emptyImage
| otherwise = string defAttr "(" <|>
string statusMsgColor modes <|>
string defAttr ") "
where
statusMsgColor = withForeColor defAttr red
bodyImage ::
RenderMode ->
MessageRendererParams ->
MessageBody -> Image
bodyImage rm params body =
case body of
IrcBody irc -> ircLineImage rm params irc
ErrorBody txt -> errorImage params txt
NormalBody txt -> normalImage params txt
timeImage :: Palette -> ZonedTime -> Image
timeImage palette
= string (view palTime palette)
. formatTime defaultTimeLocale "%R"
datetimeImage :: Palette -> ZonedTime -> Image
datetimeImage palette
= string (view palTime palette)
. formatTime defaultTimeLocale "%F %T"
data RenderMode
= NormalRender
| DetailedRender
rightPad :: RenderMode -> Maybe Integer -> Image -> Image
rightPad NormalRender (Just minWidth) i =
let h = 1
w = max 0 (fromIntegral minWidth - imageWidth i)
in i <|> backgroundFill w h
rightPad _ _ i = i
ircLineImage ::
RenderMode ->
MessageRendererParams ->
IrcMsg -> Image
ircLineImage rm !rp body =
let quietAttr = view palMeta pal
pal = rendPalette rp
sigils = rendUserSigils rp
myNicks = rendMyNicks rp
nicks = rendNicks rp
detail img =
case rm of
NormalRender -> emptyImage
DetailedRender -> img
in
case body of
Nick old new ->
detail (string quietAttr "nick ") <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks old <|>
string defAttr " is now known as " <|>
coloredIdentifier pal NormalIdentifier myNicks new
Join nick _chan ->
string quietAttr "join " <|>
coloredUserInfo pal rm myNicks nick
Part nick _chan mbreason ->
string quietAttr "part " <|>
coloredUserInfo pal rm myNicks nick <|>
foldMap (\reason -> string quietAttr " (" <|>
parseIrcText reason <|>
string quietAttr ")") mbreason
Quit nick mbreason ->
string quietAttr "quit " <|>
coloredUserInfo pal rm myNicks nick <|>
foldMap (\reason -> string quietAttr " (" <|>
parseIrcText reason <|>
string quietAttr ")") mbreason
Kick kicker _channel kickee reason ->
detail (string quietAttr "kick ") <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks kicker <|>
string defAttr " kicked " <|>
coloredIdentifier pal NormalIdentifier myNicks kickee <|>
string defAttr ": " <|>
parseIrcText reason
Topic src _dst txt ->
detail (string quietAttr "tpic ") <|>
coloredUserInfo pal rm myNicks src <|>
string defAttr " changed the topic to: " <|>
parseIrcText txt
Notice src _dst txt ->
detail (string quietAttr "note ") <|>
rightPad rm (rendNickPadding rp)
(string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src) <|>
string (withForeColor defAttr red) ": " <|>
parseIrcTextWithNicks pal myNicks nicks txt
Privmsg src _dst txt ->
detail (string quietAttr "chat ") <|>
rightPad rm (rendNickPadding rp)
(string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src) <|>
string defAttr ": " <|>
parseIrcTextWithNicks pal myNicks nicks txt
Ctcp src _dst "ACTION" txt ->
detail (string quietAttr "actp ") <|>
string (withForeColor defAttr blue) "* " <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src <|>
string defAttr " " <|>
parseIrcTextWithNicks pal myNicks nicks txt
CtcpNotice src _dst "ACTION" txt ->
detail (string quietAttr "actn ") <|>
string (withForeColor defAttr red) "* " <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src <|>
string defAttr " " <|>
parseIrcTextWithNicks pal myNicks nicks txt
Ctcp src _dst cmd txt ->
detail (string quietAttr "ctcp ") <|>
string (withForeColor defAttr blue) "! " <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src <|>
string defAttr " " <|>
parseIrcText cmd <|>
separatorImage <|>
parseIrcText txt
CtcpNotice src _dst cmd txt ->
detail (string quietAttr "ctcp ") <|>
string (withForeColor defAttr red) "! " <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks src <|>
string defAttr " " <|>
parseIrcText cmd <|>
separatorImage <|>
parseIrcText txt
Ping params ->
string defAttr "PING " <|> separatedParams params
Pong params ->
string defAttr "PONG " <|> separatedParams params
Error reason ->
string (view palError pal) "ERROR " <|>
parseIrcText reason
Reply code params ->
renderReplyCode rm rp code <|>
char defAttr ' ' <|>
separatedParams (dropFst params)
where
dropFst = case rm of
DetailedRender -> id
NormalRender -> drop 1
UnknownMsg irc ->
maybe emptyImage (\ui -> coloredUserInfo pal rm myNicks ui <|> char defAttr ' ')
(view msgPrefix irc) <|>
text' defAttr (view msgCommand irc) <|>
char defAttr ' ' <|>
separatedParams (view msgParams irc)
Cap cmd args ->
text' (withForeColor defAttr magenta) (renderCapCmd cmd) <|>
text' defAttr ": " <|>
separatedParams args
Mode nick _chan params ->
detail (string quietAttr "mode ") <|>
string (view palSigil pal) sigils <|>
coloredUserInfo pal rm myNicks nick <|>
string defAttr " set mode: " <|>
separatedParams params
Authenticate{} -> string defAttr "AUTHENTICATE ***"
BatchStart{} -> string defAttr "BATCH +"
BatchEnd{} -> string defAttr "BATCH -"
renderCapCmd :: CapCmd -> Text
renderCapCmd cmd =
case cmd of
CapLs -> "caps available"
CapList -> "caps active"
CapAck -> "caps acknowledged"
CapNak -> "caps rejected"
CapEnd -> "caps finished"
CapReq -> "caps requested"
separatorImage :: Image
separatorImage = char (withForeColor defAttr blue) '·'
separatedParams :: [Text] -> Image
separatedParams = horizCat . intersperse separatorImage . map parseIrcText
renderReplyCode :: RenderMode -> MessageRendererParams -> ReplyCode -> Image
renderReplyCode rm rp code@(ReplyCode w) =
case rm of
DetailedRender -> string attr (show w)
NormalRender ->
rightPad rm (rendNickPadding rp)
(text' attr (Text.toLower (replyCodeText info))) <|>
char defAttr ':'
where
info = replyCodeInfo code
color = case replyCodeType info of
ClientServerReply -> magenta
CommandReply -> green
ErrorReply -> red
UnknownReply -> yellow
attr = withForeColor defAttr color
data IdentifierColorMode
= PrivmsgIdentifier
| NormalIdentifier
coloredIdentifier ::
Palette ->
IdentifierColorMode ->
HashSet Identifier ->
Identifier ->
Image
coloredIdentifier palette icm myNicks ident =
text' color (idText ident)
where
color
| ident `HashSet.member` myNicks =
case icm of
PrivmsgIdentifier -> fromMaybe
(view palSelf palette)
(view palSelfHighlight palette)
NormalIdentifier -> view palSelf palette
| otherwise = v Vector.! i
v = view palNicks palette
i = hash ident `mod` Vector.length v
coloredUserInfo ::
Palette ->
RenderMode ->
HashSet Identifier ->
UserInfo ->
Image
coloredUserInfo palette NormalRender myNicks ui =
coloredIdentifier palette NormalIdentifier myNicks (userNick ui)
coloredUserInfo palette DetailedRender myNicks !ui =
horizCat
[ coloredIdentifier palette NormalIdentifier myNicks (userNick ui)
, aux '!' (userName ui)
, aux '@' (userHost ui)
]
where
quietAttr = view palMeta palette
aux x xs
| Text.null xs = emptyImage
| otherwise = char defAttr x <|> text' quietAttr xs
quietIdentifier :: Palette -> Identifier -> Image
quietIdentifier palette ident =
text' (view palMeta palette) (idText ident)
parseIrcTextWithNicks ::
Palette ->
HashSet Identifier ->
HashSet Identifier ->
Text -> Image
parseIrcTextWithNicks palette myNicks nicks txt
| Text.any isControl txt = parseIrcText txt
| otherwise = highlightNicks palette myNicks nicks txt
highlightNicks ::
Palette ->
HashSet Identifier ->
HashSet Identifier ->
Text -> Image
highlightNicks palette myNicks nicks txt = horizCat (highlight1 <$> txtParts)
where
txtParts = nickSplit txt
allNicks = HashSet.union myNicks nicks
highlight1 part
| HashSet.member partId allNicks = coloredIdentifier palette PrivmsgIdentifier myNicks partId
| otherwise = text' defAttr part
where
partId = mkId part
metadataImg :: IrcMsg -> Maybe (Image, Identifier, Maybe Identifier)
metadataImg msg =
case msg of
Quit who _ -> Just (char (withForeColor defAttr red ) 'x', userNick who, Nothing)
Part who _ _ -> Just (char (withForeColor defAttr red ) '-', userNick who, Nothing)
Join who _ -> Just (char (withForeColor defAttr green) '+', userNick who, Nothing)
Ctcp who _ cmd _ | cmd /= "ACTION" ->
Just (char (withForeColor defAttr white) 'C', userNick who, Nothing)
Nick old new -> Just (char (withForeColor defAttr yellow) '>', userNick old, Just new)
_ -> Nothing
ignoreImage :: Image
ignoreImage = char (withForeColor defAttr yellow) 'I'