diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,23 @@ # Revision history for glirc2 +## 2.22 + +* Added dynanic indentation of wrapped lines. Lines now + wrap to where the message portion of the line started. + This removes `indent-wrapped-lines` configuration setting +* Added pervasive word-boundary oriented line wrapping + (beyond what was previously restricted to chat messages) +* Made nick prefix padding configurable to be on left or right. + See `nick-padding` setting in `glirc2 --config-format`. + In addition this setting is now reconfigurable at runtime + via `/reload` +* Added `/oper` command for network operator authentication. +* Memory savings by packing message timestamp information, and + using the "detailed" image for regular expression matching. +* Added `/rtsstats` command for inspecting the GHC RTS statistics +* Added many minor IRC query commands: admin, info, map, rules + motd, version, lusers, kill, knock, list. + ## 2.21.1 * Support for latest config-schema diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.21.1 +version: 2.22 synopsis: Console IRC client description: Console IRC client . @@ -54,7 +54,7 @@ build-depends: base, glirc, lens, text, vty library - ghc-options: -Wall + ghc-options: -Wall -O2 hs-source-dirs: src include-dirs: include includes: include/glirc-api.h @@ -113,6 +113,7 @@ Client.View.Mentions Client.View.Messages Client.View.Palette + Client.View.RtsStats Client.View.UrlSelection Client.View.UserList Client.View.Windows @@ -120,6 +121,7 @@ other-modules: LensUtils StrictUnit Digraphs + RtsStats Paths_glirc Build_glirc @@ -129,14 +131,14 @@ bytestring >=0.10.8 && <0.11, base64-bytestring >=1.0.0.1 && <1.1, config-value >=0.6 && <0.7, - config-schema >=0.4 && <0.5, + config-schema >=0.4 && <0.6, containers >=0.5.7 && <0.6, directory >=1.2.6 && <1.4, filepath >=1.4.1 && <1.5, gitrev >=1.2 && <1.4, hashable >=1.2.4 && <1.3, HsOpenSSL >=0.11 && <0.12, - irc-core >=2.2 && <2.3, + irc-core >=2.3 && <2.4, lens >=4.14 && <4.16, kan-extensions >=5.0 && <5.1, network >=2.6.2 && <2.7, diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -61,6 +61,7 @@ import Irc.UserInfo import Irc.Modes import LensUtils +import RtsStats (getStats) import System.Process import Text.Read import Text.Regex.TDFA @@ -338,6 +339,12 @@ $ ClientCommand cmdKeyMap noClientTab , Command + (pure "rtsstats") + NoArg + "Show the GHC RTS statistics.\n" + $ ClientCommand cmdRtsStats noClientTab + + , Command (pure "exec") (RemainingArg "arguments") "Execute a command synchnonously sending the to a configuration destination.\n\ @@ -346,7 +353,7 @@ \\n\ \When \^Binput\^B is specified it is sent to the stdin.\n\ \\n\ - \When neither \^Bnetwork\^B nor \^Bchannel\^B are specified output goes to client window (*)\n\ + \When neither \^Bnetwork\^B nor \^Bchannel\^B are specified output goes to client window (*).\n\ \When \^Bnetwork\^B is specified output is sent as raw IRC traffic to the network.\n\ \When \^Bchannel\^B is specified output is sent as chat to the given channel on the current network.\n\ \When \^Bnetwork\^B and \^Bchannel\^B are specified output is sent as chat to the given channel on the given network.\n\ @@ -494,18 +501,32 @@ , Command (pure "splits") (RemainingArg "focuses") - "Set the extra message view splits.\n\ + "\^BParameters:\^B\n\ \\n\ - \\^Bfocuses\^B: space delimited list of focus names.\n\ + \ focuses: List of focus names\n\ \\n\ - \Client: *\n\ - \Network: \^BNETWORK\^B:\n\ - \Channel: \^BNETWORK\^B:\^B#CHANNEL\^B\n\ - \User: \^BNETWORK\^B:\^BNICK\^B\n\ + \\^BDescription:\^B\n\ \\n\ - \If the network part is omitted, the current network will be used\n\ + \ This command sents the set of focuses that will always\n\ + \ be visible, even when unfocused. When the client is focused\n\ + \ to an active network, the network can be omitted when\n\ + \ specifying a focus. If no focuses are listed, they will\n\ + \ all be cleared.\n\ \\n\ - \Not providing an argument unsplits the current windows.\n" + \ Client: *\n\ + \ Network: \^_network\^_:\n\ + \ Channel: \^_#channel\^_\n\ + \ Channel: \^_network\^_:\^_#channel\^_\n\ + \ User: \^_nick\^_\n\ + \ User: \^_network\^_:\^_nick\^_\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /splits * fn:#haskell fn:chanserv\n\ + \ /splits #haskell #haskell-lens nickserv\n\ + \ /splits\n\ + \\n\ + \\^BSee also:\^B splits+, splits-\n" $ ClientCommand cmdSplits tabSplits , Command @@ -521,7 +542,7 @@ \Channel: \^BNETWORK\^B:\^B#CHANNEL\^B\n\ \User: \^BNETWORK\^B:\^BNICK\^B\n\ \\n\ - \If the network part is omitted, the current network will be used\n" + \If the network part is omitted, the current network will be used.\n" $ ClientCommand cmdSplitsAdd tabSplits , Command @@ -537,7 +558,7 @@ \Channel: \^BNETWORK\^B:\^B#CHANNEL\^B\n\ \User: \^BNETWORK\^B:\^BNICK\^B\n\ \\n\ - \If the network part is omitted, the current network will be used\n" + \If the network part is omitted, the current network will be used.\n" $ ClientCommand cmdSplitsDel tabActiveSplits , Command @@ -581,89 +602,219 @@ [ Command ("join" :| ["j"]) (ReqTokenArg "channels" (OptTokenArg "keys" NoArg)) - "Join a chat channel.\n\ + "\^BParameters:\^B\n\ \\n\ - \\^Bchannels\^B: comma-separated list of channels\n\ - \\^Bkeys\^B: comma-separated list of keys\n" - $ NetworkCommand cmdJoin simpleNetworkTab + \ channels: Comma-separated list of channels\n\ + \ keys: Comma-separated list of keys\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Join the given channels. When keys are provided, they should\n\ + \ occur in the same order as the channels.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /join #friends\n\ + \ /join #secret thekey\n\ + \ /join #secret1,#secret2 key1,key2\n\ + \\n\ + \\^BSee also:\^B channel, clear, part\n" + $ NetworkCommand cmdJoin simpleNetworkTab , Command (pure "part") (RemainingArg "reason") - "Part from the current channel.\n" + "\^BParameters:\^B\n\ + \\n\ + \ reason: Optional message sent to channel as part reason\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Part from the current channel.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /part\n\ + \ /part It's not me, it's you\n\ + \\n\ + \\^BSee also:\^B clear, join, quit\n" $ ChannelCommand cmdPart simpleChannelTab , Command (pure "msg") (ReqTokenArg "target" (RemainingArg "message")) - "Send a chat message to a user or a channel.\n\ + "\^BParameters:\^B\n\ \\n\ - \\^Btarget\^B can be a channel or nickname.\n" - $ NetworkCommand cmdMsg simpleNetworkTab + \ target: Comma-separated list of nicknames and channels\n\ + \ message: Formatted message body\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Send a chat message to a user or a channel. On servers\n\ + \ with STATUSMSG support, the channel name can be prefixed\n\ + \ with a sigil to restrict the recipients to those with the\n\ + \ given mode.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /msg buddy I'm sending you a message.\n\ + \ /msg #friends This message is for the whole channel.\n\ + \ /msg him,her I'm chatting with two people.\n\ + \ /msg @#users This message is only for ops!\n\ + \\n\ + \\^BSee also:\^B notice, me, say\n" + $ NetworkCommand cmdMsg simpleNetworkTab , Command (pure "me") (RemainingArg "message") - "Send an 'action' to the current chat window.\n" + "\^BParameters:\^B\n\ + \\n\ + \ message: Body of action message\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Sends an action message to the currently focused channel.\n\ + \ Most clients will render these messages prefixed with\n\ + \ only your nickname as though describing an action.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /me shrugs\n\ + \\n\ + \\^BSee also:\^B notice, msg, say\n" $ ChatCommand cmdMe simpleChannelTab , Command (pure "say") (RemainingArg "message") - "Send a message to the current chat window.\n\ + "\^BParameters:\^B\n\ \\n\ - \This can be useful for sending a chat message with a leading '/'.\n" + \ message: Body of message\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Send a message to the current chat window. This can be useful\n\ + \ for sending a chat message with a leading '/' to the current\n\ + \ chat window.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /say /help is the right place to start!\n\ + \\n\ + \\^BSee also:\^B notice, me, msg\n" $ ChatCommand cmdSay simpleChannelTab , Command (pure "notice") (ReqTokenArg "target" (RemainingArg "message")) - "Send a notice message to a user or a channel. Notices are typically used by bots.\n\ + "\^BParameters:\^B\n\ \\n\ - \\^Btarget\^B can be a channel or nickname.\n" + \ target: Comma-separated list of nicknames and channels\n\ + \ message: Formatted message body\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Send a chat notice to a user or a channel. On servers\n\ + \ with STATUSMSG support, the channel name can be prefixed\n\ + \ with a sigil to restrict the recipients to those with the\n\ + \ given mode. Notice messages were originally intended to be\n\ + \ used by bots. Different clients will render these in different\n\ + \ ways.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /notice buddy I'm sending you a message.\n\ + \ /notice #friends This message is for the whole channel.\n\ + \ /notice him,her I'm chatting with two people.\n\ + \ /notice @#users This message is only for ops!\n\ + \\n\ + \\^BSee also:\^B me, msg, say\n" $ NetworkCommand cmdNotice simpleNetworkTab , Command (pure "ctcp") (ReqTokenArg "target" (ReqTokenArg "command" (RemainingArg "arguments"))) - "Send a CTCP command to a user or a channel.\n\ + "\^BParameters:\^B\n\ \\n\ - \Examples:\n\ - \Version query: /ctcp user1 version\n\ - \Local-time query: /ctcp user1 time\n\ + \ target: Comma-separated list of nicknames and channels\n\ + \ command: CTCP command name\n\ + \ arguments: CTCP command arguments\n\ \\n\ - \\^Btarget\^B can be a channel or nickname.\n\ - \\^Bcommand\^B can be any CTCP command.\n\ - \\^Barguments\^B are specific to a particular command.\n" + \\^BDescription:\^B\n\ + \\n\ + \ Client-to-client protocol (CTCP) commands can be used\n\ + \ to query information from another user's client application\n\ + \ directly. Common CTCP commands include: ACTION, PING, VERSION,\n\ + \ USERINFO, CLIENTINFO, and TIME. glirc does not automatically\n\ + \ respond to CTCP commands.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /ctcp myfriend VERSION\n\ + \ /ctcp myfriend CLIENTINFO\n" $ NetworkCommand cmdCtcp simpleNetworkTab , Command (pure "nick") (ReqTokenArg "nick" NoArg) - "Change your nickname.\n" - $ NetworkCommand cmdNick simpleNetworkTab + "\^BParameters:\^B\n\ + \\n\ + \ nick: New nickname\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Change your nickname on the currently focused server.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /nick guest123\n\ + \ /nick better_nick\n" + $ NetworkCommand cmdNick simpleNetworkTab , Command (pure "away") (RemainingArg "message") - "Set away status.\n\ + "\^BParameters:\^B\n\ \\n\ - \When \^Bmessage\^B is omitted away status is cleared.\n" + \ message: Optional away message\n\ + \\n\ + \\^BDescription:\^B\n\ + \\n\ + \ Change your nickname on the currently focused server.\n\ + \ Omit the message parameter to clear your away status.\n\ + \ The away message is only used by the server to update\n\ + \ status in /whois and to provide automated responses.\n\ + \ It is not used by this client directly.\n\ + \\n\ + \\^BExamples:\^B\n\ + \\n\ + \ /away\n\ + \ /away Out getting some sun\n" $ NetworkCommand cmdAway simpleNetworkTab , Command ("users" :| ["names"]) NoArg - "Show the user list for the current channel.\n\ + "\^BDescription:\^B\n\ \\n\ - \Detailed view (F2) shows full hostmask.\n\ - \Hostmasks can be populated with /who #channel.\n" + \ Show the user list for the current channel.\n\ + \ Detailed view (default key F2) shows full hostmask.\n\ + \ Hostmasks can be populated with /who #channel.\n\ + \ Press ESC to exit the userlist.\n\ + \\n\ + \\^BSee also:\^B channelinfo, masks\n" $ ChannelCommand cmdUsers noChannelTab , Command (pure "channelinfo") NoArg - "Show information about the current channel.\n" + "\^BDescription:\^B\n\ + \\n\ + \ Show information about the current channel.\n\ + \ Press ESC to exit the channel info window.\n\ + \\n\ + \\^BSee also:\^B masks, users\n" $ ChannelCommand cmdChannelInfo noChannelTab , Command @@ -707,14 +858,8 @@ $ NetworkCommand cmdUserhost simpleNetworkTab , Command - (pure "links") - (RemainingArg "arguments") - "Send LINKS query to server with given arguments.\n" - $ NetworkCommand cmdLinks simpleNetworkTab - - , Command (pure "time") - (RemainingArg "arguments") + (OptTokenArg "servername" NoArg) "Send TIME query to server with given arguments.\n" $ NetworkCommand cmdTime simpleNetworkTab @@ -724,6 +869,42 @@ "Send STATS query to server with given arguments.\n" $ NetworkCommand cmdStats simpleNetworkTab + , Command + (pure "lusers") + (OptTokenArg "mask" (OptTokenArg "servername" NoArg)) + "Send LUSERS query to server with given arguments.\n" + $ NetworkCommand cmdLusers simpleNetworkTab + + , Command + (pure "motd") (OptTokenArg "servername" NoArg) + "Send MOTD query to server.\n" + $ NetworkCommand cmdMotd simpleNetworkTab + + , Command + (pure "admin") (OptTokenArg "servername" NoArg) + "Send ADMIN query to server.\n" + $ NetworkCommand cmdAdmin simpleNetworkTab + + , Command + (pure "rules") (OptTokenArg "servername" NoArg) + "Send RULES query to server.\n" + $ NetworkCommand cmdRules simpleNetworkTab + + , Command + (pure "info") NoArg + "Send INFO query to server.\n" + $ NetworkCommand cmdInfo noNetworkTab + + , Command + (pure "list") (RemainingArg "arguments") + "Send LIST query to server.\n" + $ NetworkCommand cmdList simpleNetworkTab + + , Command + (pure "version") (OptTokenArg "servername" NoArg) + "Send VERSION query to server.\n" + $ NetworkCommand cmdVersion simpleNetworkTab + ------------------------------------------------------------------------ ] , CommandSection "IRC channel management" ------------------------------------------------------------------------ @@ -799,6 +980,12 @@ \See also: /kick /kickban\n" $ ChannelCommand cmdRemove simpleChannelTab + , Command + (pure "knock") + (ReqTokenArg "channel" (RemainingArg "message")) + "Request entry to an invite-only channel.\n" + $ NetworkCommand cmdKnock simpleNetworkTab + ------------------------------------------------------------------------ ] , CommandSection "ZNC Support" ------------------------------------------------------------------------ @@ -828,6 +1015,32 @@ \Note that the playback module is not installed in ZNC by default!\n" $ NetworkCommand cmdZncPlayback noNetworkTab + ] , CommandSection "Network operator commands" + + [ Command + (pure "oper") + (ReqTokenArg "user" (ReqTokenArg "password" NoArg)) + "Authenticate as a server operator.\n" + $ NetworkCommand cmdOper noNetworkTab + + , Command + (pure "kill") + (ReqTokenArg "client" (RemainingArg "reason")) + "Kill a client connection to the server.\n" + $ NetworkCommand cmdKill simpleNetworkTab + + , Command + (pure "map") + NoArg + "Display network map.\n" + $ NetworkCommand cmdMap simpleNetworkTab + + , Command + (pure "links") + (RemainingArg "arguments") + "Send LINKS query to server with given arguments.\n" + $ NetworkCommand cmdLinks simpleNetworkTab + ]] -- | Provides no tab completion for client commands @@ -1083,6 +1296,16 @@ cmdKeyMap :: ClientCommand () cmdKeyMap st _ = commandSuccess (changeSubfocus FocusKeyMap st) +-- | Implementation of @/rtsstats@ command. Set subfocus to RtsStats. +-- Update cached rts stats in client state. +cmdRtsStats :: ClientCommand () +cmdRtsStats st _ = + do mb <- getStats + case mb of + Nothing -> commandFailureMsg "RTS statistics not available. (Use +RTS -T)" st + Just{} -> commandSuccess $ set clientRtsStats mb + $ changeSubfocus FocusRtsStats st + -- | Implementation of @/help@ command. Set subfocus to Help. cmdHelp :: ClientCommand (Maybe (String, ())) cmdHelp st mb = commandSuccess (changeSubfocus focus st) @@ -1269,6 +1492,64 @@ do sendMsg cs (ircStats (Text.pack <$> words rest)) commandSuccess st +cmdLusers :: NetworkCommand (Maybe (String, Maybe (String, ()))) +cmdLusers cs st arg = + do sendMsg cs $ ircLusers $ fmap Text.pack $ + case arg of + Nothing -> [] + Just (x, Nothing) -> [x] + Just (x, (Just (y,_))) -> [x,y] + commandSuccess st + +cmdMotd :: NetworkCommand (Maybe (String, ())) +cmdMotd cs st mbservername = + do sendMsg cs $ ircMotd $ case mbservername of + Just (s,_) -> Text.pack s + Nothing -> "" + commandSuccess st + +cmdAdmin :: NetworkCommand (Maybe (String, ())) +cmdAdmin cs st mbservername = + do sendMsg cs $ ircAdmin $ case mbservername of + Just (s,_) -> Text.pack s + Nothing -> "" + commandSuccess st + +cmdRules :: NetworkCommand (Maybe (String, ())) +cmdRules cs st mbservername = + do sendMsg cs $ ircRules $ + case mbservername of + Just (s,_) -> Text.pack s + Nothing -> "" + commandSuccess st + +cmdMap :: NetworkCommand () +cmdMap cs st _ = + do sendMsg cs ircMap + commandSuccess st + +cmdInfo :: NetworkCommand () +cmdInfo cs st _ = + do sendMsg cs ircInfo + commandSuccess st + +cmdVersion :: NetworkCommand (Maybe (String, ())) +cmdVersion cs st mbservername = + do sendMsg cs $ ircVersion $ case mbservername of + Just (s,_) -> Text.pack s + Nothing -> "" + commandSuccess st + +cmdList :: NetworkCommand String +cmdList cs st rest = + do sendMsg cs (ircList (Text.pack <$> words rest)) + commandSuccess st + +cmdKill :: NetworkCommand (String, String) +cmdKill cs st (client,rest) = + do sendMsg cs (ircKill (Text.pack client) (Text.pack rest)) + commandSuccess st + cmdAway :: NetworkCommand String cmdAway cs st rest = do sendMsg cs (ircAway (Text.pack rest)) @@ -1279,9 +1560,12 @@ do sendMsg cs (ircLinks (Text.pack <$> words rest)) commandSuccess st -cmdTime :: NetworkCommand String -cmdTime cs st rest = - do sendMsg cs (ircTime (Text.pack <$> words rest)) +cmdTime :: NetworkCommand (Maybe (String, ())) +cmdTime cs st arg = + do sendMsg cs $ ircTime $ + case arg of + Nothing -> "" + Just (x,_) -> Text.pack x commandSuccess st cmdZnc :: NetworkCommand String @@ -1439,6 +1723,11 @@ cs' <- sendModeration channelId [cmd] cs commandSuccessUpdateCS cs' st +cmdKnock :: NetworkCommand (String, String) +cmdKnock cs st (chan,message) = + do sendMsg cs (ircKnock (Text.pack chan) (Text.pack message)) + commandSuccess st + cmdJoin :: NetworkCommand (String, Maybe (String, ())) cmdJoin cs st (channels, mbKeys) = do let network = view csNetwork cs @@ -1812,3 +2101,8 @@ case compile defaultCompOpt{caseSensitive=sensitive} defaultExecOpt str of Left e -> commandFailureMsg (Text.pack e) st Right r -> commandSuccess (set clientRegex (Just r) st) + +cmdOper :: NetworkCommand (String, (String, ())) +cmdOper cs st (user, (pass, ())) = + do sendMsg cs (ircOper (Text.pack user) (Text.pack pass)) + commandSuccess st diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -20,6 +20,7 @@ Configuration(..) , ConfigurationFailure(..) , LayoutMode(..) + , PaddingMode(..) -- * Lenses , configDefaults @@ -27,7 +28,6 @@ , configPalette , configWindowNames , configNickPadding - , configIndentWrapped , configConfigPath , configMacros , configExtensions @@ -91,8 +91,7 @@ , _configPalette :: Palette , _configWindowNames :: Text -- ^ Names of windows, used when alt-jumping) , _configExtraHighlights :: HashSet Identifier -- ^ Extra highlight nicks/terms - , _configNickPadding :: Maybe Integer -- ^ Padding of nicks - , _configIndentWrapped :: Maybe Int -- ^ How far to indent wrapped lines + , _configNickPadding :: PaddingMode -- ^ Padding of nicks in messages , _configConfigPath :: Maybe FilePath -- ^ manually specified configuration path, used for reloading , _configMacros :: Recognizer Macro -- ^ command macros @@ -108,6 +107,13 @@ } deriving Show +-- | Setting for how to pad the message prefix. +data PaddingMode + = LeftPadding !Int -- ^ Whitespace add to the left side of chat prefix + | RightPadding !Int -- ^ Whitespace add to the right side of chat prefix + | NoPadding -- ^ No whitespace added + deriving (Show) + data LayoutMode -- | Vertically stack all windows in a single column = OneColumn @@ -255,10 +261,8 @@ "External command used by /url command" _configExtraHighlights <- sec' mempty "extra-highlights" identifierSetSpec "Extra words to highlight in chat messages" - _configNickPadding <- optSection' "nick-padding" nonnegativeSpec + _configNickPadding <- sec' NoPadding "nick-padding" nickPaddingSpec "Amount of space to reserve for nicknames in chat messages" - _configIndentWrapped <- optSection' "indent-wrapped-lines" nonnegativeSpec - "Amount of indentation for wrapped message lines" _configIgnores <- sec' mempty "ignores" identifierSetSpec "Set of nicknames to ignore on startup" _configActivityBar <- sec' False "activity-bar" yesOrNoSpec @@ -277,6 +281,37 @@ _configServers = buildServerMap _configDefaults ssUpdates _configKeyMap = foldl (\acc f -> f acc) initialKeyMap bindings in Configuration{..}) + +-- | The default nick padding side if padding is going to be used +defaultPaddingSide :: Int -> PaddingMode +defaultPaddingSide = RightPadding + +-- | Either full or abbreviated nick-padding configuration +-- +-- > nick-padding: 10 +-- +-- > nick-padding: +-- > side: right +-- > width: 16 +nickPaddingSpec :: ValueSpecs PaddingMode +nickPaddingSpec = defaultPaddingSide <$> nonnegativeSpec fullNickPaddingSpec + +-- | Full nick padding specification: +-- +-- > nick-padding: +-- > side: left +-- > width: 15 +fullNickPaddingSpec :: ValueSpecs PaddingMode +fullNickPaddingSpec = sectionsSpec "nick-padding" (sideSec <*> amtSec) + where + sideSpec = LeftPadding <$ atomSpec "left" + RightPadding <$ atomSpec "right" + + sideSec = fromMaybe defaultPaddingSide + <$> optSection' "side" sideSpec "Side to pad (default `right`)" + + amtSec = reqSection' "width" nonnegativeSpec "Field width" + modifierSpec :: ValueSpecs [Modifier] modifierSpec = toList <$> oneOrNonemptySpec modifier1Spec diff --git a/src/Client/Image/Layout.hs b/src/Client/Image/Layout.hs --- a/src/Client/Image/Layout.hs +++ b/src/Client/Image/Layout.hs @@ -12,9 +12,10 @@ import Client.State import Client.State.Focus import Client.Configuration (LayoutMode(..)) +import Client.Image.PackedImage (Image', unpackImage) import Client.Image.StatusLine (statusLineImage, minorStatusLineImage) import Client.Image.Textbox -import Client.Image.LineWrap (lineWrap) +import Client.Image.LineWrap (lineWrap, terminate) import Client.Image.Palette import Client.View import Graphics.Vty.Image @@ -114,10 +115,10 @@ Int {- ^ draw width -} -> Int {- ^ draw height -} -> Focus {- ^ focus -} -> - [Image] {- ^ image lines -} -> + [Image'] {- ^ image lines -} -> Image {- ^ rendered window -} drawExtra st w h focus lineImages = - msgImg <-> minorStatusLineImage focus w True st + msgImg <-> unpackImage (minorStatusLineImage focus w True st) where (_, msgImg) = messagePane w h 0 lineImages @@ -129,7 +130,7 @@ Int {- ^ client width -} -> Int {- ^ available rows -} -> Int {- ^ current scroll -} -> - [Image] {- ^ focused window -} -> + [Image'] {- ^ focused window -} -> (Int, Image) {- ^ overscroll, rendered messages -} messagePane w h scroll images = (overscroll, img) where @@ -143,7 +144,11 @@ assemble acc _ | imageHeight acc >= vh = cropTop vh acc assemble acc [] = acc - assemble acc (x:xs) = assemble (lineWrap w x <-> acc) xs + assemble acc (x:xs) = assemble (this <-> acc) xs + where + this = vertCat + $ map (terminate w . unpackImage) + $ lineWrap w x splitHeights :: diff --git a/src/Client/Image/LineWrap.hs b/src/Client/Image/LineWrap.hs --- a/src/Client/Image/LineWrap.hs +++ b/src/Client/Image/LineWrap.hs @@ -8,7 +8,12 @@ Provides utilities for line wrapping images. -} -module Client.Image.LineWrap (lineWrap, lineWrapChat) where +module Client.Image.LineWrap + ( lineWrap + , lineWrapPrefix + , fullLineWrap + , terminate + ) where import Client.Image.PackedImage import Data.Semigroup @@ -16,18 +21,6 @@ import Graphics.Vty.Attributes import qualified Data.Text.Lazy as L --- | Given an image, break the image up into chunks of at most the --- given width and stack the resulting chunks vertically top-to-bottom. -lineWrap :: - Int {- ^ terminal width -} -> - Vty.Image {- ^ unwrapped image -} -> - Vty.Image {- ^ wrapped image -} -lineWrap w img - | Vty.imageWidth img == 0 = Vty.emptyImage - | Vty.imageWidth img <= w = terminate w img - | otherwise = - terminate w (Vty.cropRight w img) Vty.<-> - lineWrap w (Vty.cropLeft (Vty.imageWidth img - w) img) -- | Trailing space with default attributes deals with bug in VTY -- where the formatting will continue past the end of chat messages. @@ -41,31 +34,52 @@ | otherwise = img Vty.<|> Vty.char defAttr ' ' -lineWrapChat :: - Int {- ^ terminal width -} -> - Maybe Int {- ^ optional indentation -} -> - Image' {- ^ unwrapped image -} -> - [Image'] {- ^ wrapped image -} -lineWrapChat w (Just i) - | 2*i <= w = reverse . addPadding i . wordLineWrap w (w-i) -lineWrapChat w _ = reverse . wordLineWrap w w +-- | This version of line wrap wraps without regard for word boundaries. +fullLineWrap :: + Int {- ^ terminal width -} -> + Image' {- ^ unwrapped image -} -> + [Image'] {- ^ wrapped image -} +fullLineWrap w img + | iw <= w = [img] + | otherwise = l : fullLineWrap w r + where + iw = imageWidth img + (l,r) = splitImage w img +lineWrapPrefix :: + Int {- ^ terminal width -} -> + Image' {- ^ prefix image -} -> + Image' {- ^ unwrapped image -} -> + [Image'] {- ^ wrapped image -} +lineWrapPrefix w pfx img + | 3*pfxW <= w = pfx <> char defAttr ' ' <> x : + map (pad<>) xs + where + pfxW = imageWidth pfx + x:xs = lineWrap (w - pfxW - 1) img + pad = string defAttr (replicate (pfxW + 1) ' ') -addPadding :: Int -> [Image'] -> [Image'] -addPadding _ [] = [] -addPadding i (x:xs) = x : map indent xs - where indent = (string defAttr (replicate i ' ') <>) +-- Don't index when the window is tiny +lineWrapPrefix w pfx img = lineWrap w (pfx <> char defAttr ' ' <> img) -wordLineWrap :: +lineWrap :: Int {- ^ first line length -} -> - Int {- ^ secondary line length -} -> Image' {- ^ image -} -> [Image'] {- ^ splits -} -wordLineWrap w wNext img +lineWrap w img + | imageWidth img <= w = [img] -- could be empty + | otherwise = lineWrap' w img + + +lineWrap' :: + Int {- ^ first line length -} -> + Image' {- ^ image -} -> + [Image'] {- ^ splits -} +lineWrap' w img | imgW == 0 = [] | imgW <= w = [img] - | otherwise = l : wordLineWrap wNext wNext (dropSpaces r) + | otherwise = l : lineWrap' w (dropSpaces r) where imgW = imageWidth img x:xs = splitOptions img @@ -78,7 +92,7 @@ go y [] = min y w go y (z:zs) - | z-y > wNext = w + | z-y > w = w | z > w = y | otherwise = go z zs diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -22,9 +22,11 @@ , coloredIdentifier , cleanText , cleanChar - , rightPad + , nickPad + , timeImage ) where +import Client.Configuration (PaddingMode(..)) import Client.Image.MircFormatting import Client.Image.PackedImage import Client.Image.Palette @@ -55,7 +57,6 @@ , rendNicks :: HashSet Identifier -- ^ nicknames to highlight , rendMyNicks :: HashSet Identifier -- ^ nicknames to highlight in red , rendPalette :: Palette -- ^ nick color palette - , rendNickPadding :: Maybe Integer -- ^ nick padding } -- | Default 'MessageRendererParams' with no sigils or nicknames specified @@ -66,132 +67,255 @@ , rendNicks = HashSet.empty , rendMyNicks = HashSet.empty , rendPalette = defaultPalette - , rendNickPadding = Nothing } + -- | Construct a message given the time the message was received and its -- render parameters. msgImage :: - RenderMode -> - ZonedTime {- ^ time of message -} -> - MessageRendererParams -> MessageBody -> Image' -msgImage rm when params body = mconcat - [ renderTime rm (rendPalette params) when - , statusMsgImage (rendStatusMsg params) - , bodyImage rm params body - ] + ZonedTime {- ^ time of message -} -> + MessageRendererParams {- render parameters -} -> + MessageBody {- ^ message body -} -> + (Image', Image', Image') {- ^ prefix, image, full -} +msgImage when params body = (prefix, image, full) + where + si = statusMsgImage (rendStatusMsg params) + prefix = si <> prefixImage params body + + image = bodyImage NormalRender params body + + full = + mconcat + [ datetimeImage (rendPalette params) when + , statusMsgImage (rendStatusMsg params) + , bodyImage DetailedRender params body + ] + cleanChar :: Char -> Char cleanChar x - | x < '\x20' = chr (0x2400 + ord x) - | x == '\DEL' = '␡' - | isControl x = '�' + | x < '\x20' = chr (0x2400 + ord x) -- ␀ .. ␙ + | x == '\DEL' = '\x2421' -- ␡ + | isControl x = '\xfffd' -- � | otherwise = x cleanText :: Text -> Text cleanText = Text.map cleanChar -errorImage :: +errorPrefix :: MessageRendererParams -> - Text {- ^ error message -} -> Image' -errorImage params txt = mconcat - [ text' (view palError (rendPalette params)) "error " - , text' defAttr (cleanText txt) - ] +errorPrefix params = + text' (view palError (rendPalette params)) "error" <> + char defAttr ':' -normalImage :: - MessageRendererParams -> - Text {- ^ message -} -> - Image' -normalImage params txt = mconcat - [ text' (view palLabel (rendPalette params)) "client " - , text' defAttr (cleanText txt) - ] --- | Render the given time according to the current mode and palette. -renderTime :: RenderMode -> Palette -> ZonedTime -> Image' -renderTime DetailedRender = datetimeImage -renderTime NormalRender = timeImage +normalPrefix :: MessageRendererParams -> Image' +normalPrefix params = + text' (view palLabel (rendPalette params)) "client" <> + char defAttr ':' + -- | Render the sigils for a restricted message. statusMsgImage :: [Char] {- ^ sigils -} -> Image' statusMsgImage modes | null modes = mempty - | otherwise = string defAttr "(" <> - string statusMsgColor modes <> - string defAttr ") " + | otherwise = "(" <> string statusMsgColor modes <> ") " where statusMsgColor = withForeColor defAttr red + -- | Render a 'MessageBody' given the sender's sigils and the nicknames to -- highlight. +prefixImage :: + MessageRendererParams -> + MessageBody -> Image' +prefixImage params body = + case body of + IrcBody irc -> ircLinePrefix params irc + ErrorBody{} -> errorPrefix params + NormalBody{} -> normalPrefix params + +-- | Render a 'MessageBody' given the sender's sigils and the nicknames to +-- highlight. 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 + IrcBody irc | NormalRender <- rm -> ircLineImage params irc + | DetailedRender <- rm -> fullIrcLineImage params irc + ErrorBody txt -> text' defAttr (cleanText txt) + NormalBody txt -> text' defAttr (cleanText txt) -- | Render a 'ZonedTime' as time using quiet attributes -- -- @ -- 23:15 -- @ -timeImage :: Palette -> ZonedTime -> Image' +timeImage :: Palette -> TimeOfDay -> Image' timeImage palette = string (view palTime palette) . formatTime defaultTimeLocale "%R " --- | Render a 'ZonedTime' as full date and time user quiet attributes +-- | Render a 'ZonedTime' as full date and time user quiet attributes. +-- Excludes the year. -- -- @ --- 2016-07-24 23:15:10 +-- 07-24 23:15:10 -- @ datetimeImage :: Palette -> ZonedTime -> Image' datetimeImage palette = string (view palTime palette) - . formatTime defaultTimeLocale "%F %T " + . formatTime defaultTimeLocale "%m-%d %T " -- | Level of detail to use when rendering data RenderMode = NormalRender -- ^ only render nicknames | DetailedRender -- ^ render full user info --- | Optionally insert padding on the right of an 'Image' until it has --- the minimum width. -rightPad :: RenderMode -> Maybe Integer -> Image' -> Image' -rightPad NormalRender (Just minWidth) i = - let w = max 0 (fromIntegral minWidth - imageWidth i) - in i <> string defAttr (replicate w ' ') -rightPad _ _ i = i +-- | Optionally add padding to an input image according to the +-- specified mode. If the input image is already wider than +-- the specified padding mode, the image is returned unmodified. +nickPad :: + PaddingMode {- ^ padding mode -} -> + Image' {- ^ input image -} -> + Image' {- ^ padded image -} +nickPad mode img = + case mode of + LeftPadding w | w > iw -> mkpad (w-iw) <> img + RightPadding w | w > iw -> img <> mkpad (w-iw) + _ -> img + where + iw = imageWidth img + mkpad n = string defAttr (replicate n ' ') + +-- | Render the sender of a message in normal mode. +-- This is typically something like @\@nickname:@ +ircLinePrefix :: + MessageRendererParams -> + IrcMsg -> Image' +ircLinePrefix !rp body = + let pal = rendPalette rp + sigils = rendUserSigils rp + myNicks = rendMyNicks rp + rm = NormalRender + + who n = string (view palSigil pal) sigils <> + coloredUserInfo pal rm myNicks n + in + case body of + Join {} -> mempty + Part {} -> mempty + Quit {} -> mempty + Ping {} -> mempty + Pong {} -> mempty + Nick {} -> mempty + + Topic src _ _ -> + who src <> " changed the topic:" + + Kick kicker _channel kickee _reason -> + who kicker <> + " kicked " <> + coloredIdentifier pal NormalIdentifier myNicks kickee <> + ":" + + Notice src _ _ -> + who src <> + string (withForeColor defAttr red) ":" + + Privmsg src _ _ -> who src <> ":" + + Ctcp src _dst "ACTION" _txt -> + string (withForeColor defAttr blue) "* " <> who src + Ctcp {} -> mempty + + CtcpNotice src _dst "ACTION" _txt -> + string (withForeColor defAttr red) "* " <> who src + CtcpNotice {} -> mempty + + Error {} -> string (view palError pal) "ERROR" <> ":" + + Reply code _ -> replyCodePrefix code + + UnknownMsg irc -> + case view msgPrefix irc of + Just ui -> who ui + Nothing -> string (view palError pal) "?" + + Cap cmd _ -> + text' (withForeColor defAttr magenta) (renderCapCmd cmd) <> ":" + + Mode nick _ _ -> who nick <> " set mode:" + + Authenticate{} -> "AUTHENTICATE" + BatchStart{} -> mempty + BatchEnd{} -> mempty + + -- | Render a chat message given a rendering mode, the sigils of the user -- who sent the message, and a list of nicknames to highlight. ircLineImage :: - RenderMode -> MessageRendererParams -> IrcMsg -> Image' -ircLineImage rm !rp body = +ircLineImage !rp body = + let pal = rendPalette rp + myNicks = rendMyNicks rp + nicks = rendNicks rp + in + case body of + Join {} -> mempty + Part {} -> mempty + Quit {} -> mempty + Ping {} -> mempty + Pong {} -> mempty + BatchStart {} -> mempty + BatchEnd {} -> mempty + Nick {} -> mempty + Authenticate{} -> "***" + + Error txt -> parseIrcText txt + Topic _ _ txt -> parseIrcTextWithNicks pal myNicks nicks txt + Kick _ _ _ txt -> parseIrcTextWithNicks pal myNicks nicks txt + Notice _ _ txt -> parseIrcTextWithNicks pal myNicks nicks txt + Privmsg _ _ txt -> parseIrcTextWithNicks pal myNicks nicks txt + Ctcp _ _ "ACTION" txt -> parseIrcTextWithNicks pal myNicks nicks txt + Ctcp {} -> mempty + CtcpNotice _ _ "ACTION" txt -> parseIrcTextWithNicks pal myNicks nicks txt + CtcpNotice {} -> mempty + + Reply code params -> renderReplyCode NormalRender code params + UnknownMsg irc -> + text' defAttr (view msgCommand irc) <> + char defAttr ' ' <> + separatedParams (view msgParams irc) + Cap _ args -> separatedParams args + Mode _ _ params -> ircWords params + +-- | Render a chat message given a rendering mode, the sigils of the user +-- who sent the message, and a list of nicknames to highlight. +fullIrcLineImage :: + MessageRendererParams -> + IrcMsg -> Image' +fullIrcLineImage !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 -> mempty - DetailedRender -> img + rm = DetailedRender + + who n = string (view palSigil pal) sigils <> + coloredUserInfo pal rm myNicks n 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 " <> + string quietAttr "nick " <> + who old <> + " is now known as " <> coloredIdentifier pal NormalIdentifier myNicks new Join nick _chan -> @@ -213,84 +337,70 @@ 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 " <> + string quietAttr "kick " <> + who kicker <> + " kicked " <> coloredIdentifier pal NormalIdentifier myNicks kickee <> - string defAttr ": " <> + ": " <> parseIrcText reason Topic src _dst txt -> - detail (string quietAttr "tpic ") <> + string quietAttr "tpic " <> coloredUserInfo pal rm myNicks src <> - string defAttr " changed the topic to: " <> + " changed the topic: " <> 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 quietAttr "note " <> + who 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 ": " <> + string quietAttr "chat " <> + who src <> ": " <> parseIrcTextWithNicks pal myNicks nicks txt Ctcp src _dst "ACTION" txt -> - detail (string quietAttr "actp ") <> + string quietAttr "actp " <> string (withForeColor defAttr blue) "* " <> - string (view palSigil pal) sigils <> - coloredUserInfo pal rm myNicks src <> - string defAttr " " <> + who src <> " " <> parseIrcTextWithNicks pal myNicks nicks txt CtcpNotice src _dst "ACTION" txt -> - detail (string quietAttr "actn ") <> + string quietAttr "actn " <> string (withForeColor defAttr red) "* " <> - string (view palSigil pal) sigils <> - coloredUserInfo pal rm myNicks src <> - string defAttr " " <> + who src <> " " <> parseIrcTextWithNicks pal myNicks nicks txt Ctcp src _dst cmd txt -> - detail (string quietAttr "ctcp ") <> + string quietAttr "ctcp " <> string (withForeColor defAttr blue) "! " <> - string (view palSigil pal) sigils <> - coloredUserInfo pal rm myNicks src <> - string defAttr " " <> + who src <> " " <> parseIrcText cmd <> separatorImage <> parseIrcText txt CtcpNotice src _dst cmd txt -> - detail (string quietAttr "ctcp ") <> + string quietAttr "ctcp " <> string (withForeColor defAttr red) "! " <> - string (view palSigil pal) sigils <> - coloredUserInfo pal rm myNicks src <> - string defAttr " " <> + who src <> " " <> parseIrcText cmd <> separatorImage <> parseIrcText txt Ping params -> - string defAttr "PING " <> separatedParams params + "PING " <> separatedParams params Pong params -> - string defAttr "PONG " <> separatedParams params + "PONG " <> separatedParams params Error reason -> string (view palError pal) "ERROR " <> parseIrcText reason Reply code params -> - renderReplyCode rm rp code params + renderReplyCode DetailedRender code params UnknownMsg irc -> foldMap (\ui -> coloredUserInfo pal rm myNicks ui <> char defAttr ' ') @@ -305,15 +415,13 @@ separatedParams args Mode nick _chan params -> - detail (string quietAttr "mode ") <> - string (view palSigil pal) sigils <> - coloredUserInfo pal rm myNicks nick <> - string defAttr " set mode: " <> + string quietAttr "mode " <> + who nick <> " set mode: " <> ircWords params - Authenticate{} -> string defAttr "AUTHENTICATE ***" - BatchStart{} -> string defAttr "BATCH +" - BatchEnd{} -> string defAttr "BATCH -" + Authenticate{} -> "AUTHENTICATE ***" + BatchStart{} -> "BATCH +" + BatchEnd{} -> "BATCH -" renderCapCmd :: CapCmd -> Text @@ -339,22 +447,31 @@ ircWords :: [Text] -> Image' ircWords = mconcat . intersperse (char defAttr ' ') . map parseIrcText -renderReplyCode :: RenderMode -> MessageRendererParams -> ReplyCode -> [Text] -> Image' -renderReplyCode rm rp code@(ReplyCode w) params = +replyCodePrefix :: ReplyCode -> Image' +replyCodePrefix code = + text' attr (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 + +renderReplyCode :: RenderMode -> ReplyCode -> [Text] -> Image' +renderReplyCode rm code@(ReplyCode w) params = case rm of - DetailedRender -> string attr (show w) <> rawParamsImage + DetailedRender -> string attr (shows w " ") <> rawParamsImage NormalRender -> - rightPad rm (rendNickPadding rp) - (text' attr (replyCodeText info)) <> - char defAttr ':' <> - case code of RPL_WHOISIDLE -> whoisIdleParamsImage _ -> rawParamsImage where - rawParamsImage = - char defAttr ' ' <> - separatedParams params' + rawParamsImage = separatedParams params' params' = case rm of DetailedRender -> params @@ -373,7 +490,6 @@ whoisIdleParamsImage = case params' of [name, idle, signon, _txt] -> - char defAttr ' ' <> text' defAttr name <> text' defAttr " idle: " <> string defAttr (prettySeconds (Text.unpack idle)) <> diff --git a/src/Client/Image/PackedImage.hs b/src/Client/Image/PackedImage.hs --- a/src/Client/Image/PackedImage.hs +++ b/src/Client/Image/PackedImage.hs @@ -20,6 +20,7 @@ , imageWidth , splitImage , imageText + , resizeImage ) where import Data.List (findIndex) @@ -42,7 +43,7 @@ -- | Packed, strict version of 'Image' used for long-term storage of images. data Image' = HorizText' - Attr -- don't unpack, these get reused from the palette + !Attr -- don't unpack, these get reused from the palette {-# UNPACK #-} !S.Text {-# UNPACK #-} !Int {-# UNPACK #-} !Int @@ -101,3 +102,11 @@ where go EmptyImage' = [] go (HorizText' _ t _ _ xs) = t : go xs + +resizeImage :: Int -> Image' -> Image' +resizeImage w img = + let iw = imageWidth img in + case compare w iw of + LT -> fst (splitImage w img) + EQ -> img + GT -> img <> string defAttr (replicate (w-iw) ' ') diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs --- a/src/Client/Image/StatusLine.hs +++ b/src/Client/Image/StatusLine.hs @@ -17,6 +17,7 @@ ) where import Client.Image.Message (cleanText) +import Client.Image.PackedImage import Client.Image.Palette import Client.State import Client.State.Channel @@ -26,10 +27,11 @@ import Control.Lens import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Semigroup import Data.Text (Text) import qualified Data.Text as Text import Graphics.Vty.Attributes -import Graphics.Vty.Image +import qualified Graphics.Vty.Image as Vty import Irc.Identifier (Identifier, idText) import Numeric @@ -40,13 +42,14 @@ statusLineImage :: Int {- ^ draw width -} -> ClientState {- ^ client state -} -> - Image {- ^ status bar -} + Vty.Image {- ^ status bar -} statusLineImage w st = makeLines w (common : activity ++ errorImgs) where - common = horizCat - [ myNickImage st - , focusImage (view clientFocus st) st + common = Vty.horizCat $ + myNickImage st : + map unpackImage + [ focusImage (view clientFocus st) st , subfocusImage st , detailImage st , nometaImage (view clientFocus st) st @@ -66,12 +69,12 @@ -- Generates an error message notification image. transientErrorImage :: Text {- ^ @error-message@ -} -> - Image {- ^ @─[error: error-message]@ -} + Vty.Image {- ^ @─[error: error-message]@ -} transientErrorImage txt = - text' defAttr "─[" <|> - text' (withForeColor defAttr red) "error: " <|> - text' defAttr (cleanText txt) <|> - text' defAttr "]" + Vty.text' defAttr "─[" Vty.<|> + Vty.text' (withForeColor defAttr red) "error: " Vty.<|> + Vty.text' defAttr (cleanText txt) Vty.<|> + Vty.text' defAttr "]" -- | The minor status line is used when rendering the @/splits@ and @@ -80,20 +83,21 @@ Focus {- ^ window name -} -> Int {- ^ draw width -} -> Bool {- ^ show hidemeta status -} -> - ClientState -> Image + ClientState {- ^ client state -} -> + Image' minorStatusLineImage focus w showHideMeta st = - content <|> charFill defAttr bar fillSize 1 + content <> string defAttr (replicate fillSize bar) where - content = focusImage focus st <|> + content = focusImage focus st <> if showHideMeta then nometaImage focus st else mempty fillSize = max 0 (w - imageWidth content) -- | Indicate when the client is scrolling and old messages are being shown. -scrollImage :: ClientState -> Image +scrollImage :: ClientState -> Image' scrollImage st - | 0 == view clientScroll st = emptyImage + | 0 == view clientScroll st = mempty | otherwise = infoBubble (string attr "scroll") where pal = clientPalette st @@ -102,10 +106,10 @@ -- | Indicate when the client is potentially showing a subset of the -- available chat messages. -filterImage :: ClientState -> Image +filterImage :: ClientState -> Image' filterImage st = case clientActiveRegex st of - Nothing -> emptyImage + Nothing -> mempty Just {} -> infoBubble (string attr "filtered") where pal = clientPalette st @@ -115,42 +119,42 @@ -- | Indicate the current connection health. This will either indicate -- that the connection is being established or that a ping has been -- sent or long the previous ping round-trip was. -latencyImage :: ClientState -> Image +latencyImage :: ClientState -> Image' latencyImage st = case views clientFocus focusNetwork st of - Nothing -> emptyImage + Nothing -> mempty Just network -> case preview (clientConnection network) st of Nothing -> infoBubble (string (view palError pal) "offline") Just cs -> case view csPingStatus cs of - PingNever -> emptyImage + PingNever -> mempty PingSent {} -> latency "ping sent" PingLatency delta -> latency (showFFloat (Just 2) delta "s") PingConnecting n _ -> - infoBubble (string (view palLatency pal) "connecting" <|> + infoBubble (string (view palLatency pal) "connecting" <> retryImage n) where pal = clientPalette st latency = infoBubble . string (view palLatency pal) retryImage n - | n > 0 = string defAttr ": " <|> - string (view palLabel pal) ("retry " ++ show n) - | otherwise = emptyImage + | n > 0 = ": " <> string (view palLabel pal) ("retry " ++ show n) + | otherwise = mempty -- | Wrap some text in parentheses to make it suitable for inclusion in the -- status line. -infoBubble :: Image -> Image -infoBubble img = string defAttr (bar:"(") <|> img <|> string defAttr ")" +infoBubble :: Image' -> Image' +infoBubble img = + string defAttr (bar:"(") <> img <> ")" -- | Indicate that the client is in the /detailed/ view. -detailImage :: ClientState -> Image +detailImage :: ClientState -> Image' detailImage st | view clientDetailView st = infoBubble (string attr "detail") - | otherwise = emptyImage + | otherwise = mempty where pal = clientPalette st attr = view palLabel pal @@ -158,10 +162,10 @@ -- | Indicate that the client isn't showing the metadata lines in /normal/ -- view. -nometaImage :: Focus -> ClientState -> Image +nometaImage :: Focus -> ClientState -> Image' nometaImage focus st | metaHidden = infoBubble (string attr "nometa") - | otherwise = emptyImage + | otherwise = mempty where pal = clientPalette st attr = view palLabel pal @@ -170,12 +174,12 @@ -- | Image for little box with active window names: -- -- @-[15p]@ -activitySummary :: ClientState -> Image +activitySummary :: ClientState -> Vty.Image activitySummary st - | null indicators = emptyImage - | otherwise = string defAttr (bar:"[") <|> - horizCat indicators <|> - string defAttr "]" + | null indicators = Vty.emptyImage + | otherwise = Vty.string defAttr (bar:"[") Vty.<|> + Vty.horizCat indicators Vty.<|> + Vty.string defAttr "]" where winNames = clientWindowNames st ++ repeat '?' @@ -184,14 +188,14 @@ aux (i,w) rest = case view winMention w of - WLImportant -> char (view palMention pal) i : rest - WLNormal -> char (view palActivity pal) i : rest + WLImportant -> Vty.char (view palMention pal) i : rest + WLNormal -> Vty.char (view palActivity pal) i : rest WLBoring -> rest where pal = clientPalette st -- | Multi-line activity information enabled by F3 -activityBarImages :: ClientState -> [Image] +activityBarImages :: ClientState -> [Vty.Image] activityBarImages st = catMaybes $ zipWith baraux winNames @@ -205,13 +209,13 @@ baraux i (focus,w) | n == 0 = Nothing -- todo: make configurable | otherwise = Just - $ string defAttr (bar:"[") <|> - char (view palWindowName pal) i <|> - char defAttr ':' <|> - text' (view palLabel pal) focusText <|> - char defAttr ':' <|> - string attr (show n) <|> - string defAttr "]" + $ Vty.string defAttr (bar:"[") Vty.<|> + Vty.char (view palWindowName pal) i Vty.<|> + Vty.char defAttr ':' Vty.<|> + Vty.text' (view palLabel pal) focusText Vty.<|> + Vty.char defAttr ':' Vty.<|> + Vty.string attr (show n) Vty.<|> + Vty.string defAttr "]" where n = view winUnread w pal = clientPalette st @@ -232,35 +236,35 @@ -- cases. makeLines :: Int {- ^ window width -} -> - [Image] {- ^ components to pack -} -> - Image -makeLines _ [] = emptyImage + [Vty.Image] {- ^ components to pack -} -> + Vty.Image +makeLines _ [] = Vty.emptyImage makeLines w (x:xs) = go x xs where go acc (y:ys) - | let acc' = acc <|> y - , imageWidth acc' <= w + | let acc' = acc Vty.<|> y + , Vty.imageWidth acc' <= w = go acc' ys go acc ys = makeLines w ys - <-> acc <|> charFill defAttr bar (max 0 (w - imageWidth acc)) 1 + Vty.<-> acc Vty.<|> Vty.charFill defAttr bar (max 0 (w - Vty.imageWidth acc)) 1 -myNickImage :: ClientState -> Image +myNickImage :: ClientState -> Vty.Image myNickImage st = case view clientFocus st of NetworkFocus network -> nickPart network Nothing ChannelFocus network chan -> nickPart network (Just chan) - Unfocused -> emptyImage + Unfocused -> Vty.emptyImage where pal = clientPalette st nickPart network mbChan = case preview (clientConnection network) st of - Nothing -> emptyImage - Just cs -> string (view palSigil pal) myChanModes - <|> text' defAttr (idText nick) - <|> parens defAttr (string defAttr ('+' : view csModes cs)) + Nothing -> Vty.emptyImage + Just cs -> Vty.string (view palSigil pal) myChanModes + Vty.<|> Vty.text' defAttr (idText nick) + Vty.<|> parens defAttr (Vty.string defAttr ('+' : view csModes cs)) where nick = view csNick cs myChanModes = @@ -269,14 +273,14 @@ Just chan -> view (csChannels . ix chan . chanUsers . ix nick) cs -subfocusImage :: ClientState -> Image +subfocusImage :: ClientState -> Image' subfocusImage st = foldMap infoBubble (viewSubfocusLabel pal subfocus) where pal = clientPalette st subfocus = view clientSubfocus st -focusImage :: Focus -> ClientState -> Image -focusImage focus st = infoBubble $ horizCat +focusImage :: Focus -> ClientState -> Image' +focusImage focus st = infoBubble $ mconcat [ char (view palWindowName pal) windowName , char defAttr ':' , viewFocusLabel st focus @@ -290,10 +294,10 @@ preview (ix i) windowNames -parens :: Attr -> Image -> Image -parens attr i = char attr '(' <|> i <|> char attr ')' +parens :: Attr -> Vty.Image -> Vty.Image +parens attr i = Vty.char attr '(' Vty.<|> i Vty.<|> Vty.char attr ')' -viewFocusLabel :: ClientState -> Focus -> Image +viewFocusLabel :: ClientState -> Focus -> Image' viewFocusLabel st focus = let !pal = clientPalette st in case focus of @@ -302,25 +306,25 @@ NetworkFocus network -> text' (view palLabel pal) network ChannelFocus network channel -> - text' (view palLabel pal) network <|> - char defAttr ':' <|> - text' (view palLabel pal) (idText channel) <|> + text' (view palLabel pal) network <> + char defAttr ':' <> + text' (view palLabel pal) (idText channel) <> channelModesImage network channel st -channelModesImage :: Text -> Identifier -> ClientState -> Image +channelModesImage :: Text -> Identifier -> ClientState -> Image' channelModesImage network channel st = case preview (clientConnection network . csChannels . ix channel . chanModes) st of Just modeMap | not (null modeMap) -> - string defAttr (" +" ++ modes) <|> - horizCat [ char defAttr ' ' <|> text' defAttr arg | arg <- args, not (Text.null arg) ] + string defAttr (" +" ++ modes) <> + mconcat [ char defAttr ' ' <> text' defAttr arg | arg <- args, not (Text.null arg) ] where (modes,args) = unzip (Map.toList modeMap) - _ -> emptyImage + _ -> mempty -viewSubfocusLabel :: Palette -> Subfocus -> Maybe Image +viewSubfocusLabel :: Palette -> Subfocus -> Maybe Image' viewSubfocusLabel pal subfocus = case subfocus of FocusMessages -> Nothing - FocusWindows filt -> Just $ string (view palLabel pal) "windows" <|> + FocusWindows filt -> Just $ string (view palLabel pal) "windows" <> opt (windowFilterName filt) FocusInfo -> Just $ string (view palLabel pal) "info" FocusUsers -> Just $ string (view palLabel pal) "users" @@ -328,15 +332,16 @@ FocusPalette -> Just $ string (view palLabel pal) "palette" FocusDigraphs -> Just $ string (view palLabel pal) "digraphs" FocusKeyMap -> Just $ string (view palLabel pal) "keymap" - FocusHelp mb -> Just $ string (view palLabel pal) "help" <|> + FocusHelp mb -> Just $ string (view palLabel pal) "help" <> opt mb - FocusMasks m -> Just $ horizCat + FocusRtsStats -> Just $ string (view palLabel pal) "rtsstats" + FocusMasks m -> Just $ mconcat [ string (view palLabel pal) "masks" , char defAttr ':' , char (view palLabel pal) m ] where - opt = foldMap (\cmd -> char defAttr ':' <|> + opt = foldMap (\cmd -> char defAttr ':' <> text' (view palLabel pal) cmd) windowFilterName :: WindowsFilter -> Maybe Text diff --git a/src/Client/Log.hs b/src/Client/Log.hs --- a/src/Client/Log.hs +++ b/src/Client/Log.hs @@ -16,15 +16,12 @@ import Client.Message import Control.Exception import Control.Lens hiding ((<.>)) -import qualified Data.ByteString as B import Data.Monoid import Data.Time import Data.Text (Text) import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.IO as L -import qualified Data.Vector.Primitive as PV import Irc.Identifier import Irc.Message import Irc.UserInfo @@ -90,10 +87,6 @@ success txt = Just LogLine { logBaseDir = dir , logDay = day - , logTarget = Text.toLower - $ Text.decodeUtf8 - $ B.pack - $ PV.toList - $ idDenote target + , logTarget = Text.toLower (idTextNorm target) , logLine = L.fromChunks ["[", Text.pack todStr, "] "] <> txt <> "\n" } diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -42,6 +42,7 @@ , clientActivityReturn , clientErrorMsg , clientLayout + , clientRtsStats -- * Client operations , withClientState @@ -49,6 +50,7 @@ , clientShutdown , clientPark , clientMatcher + , clientMatcher' , clientActiveRegex , clientToggleHideMeta @@ -133,6 +135,7 @@ import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText import Data.Time import Foreign.Ptr import Foreign.StablePtr @@ -142,6 +145,7 @@ import Irc.RawIrcMsg import Irc.UserInfo import LensUtils +import RtsStats (Stats) import Text.Regex.TDFA import Text.Regex.TDFA.String (compile) @@ -179,6 +183,7 @@ , _clientExtensions :: !ExtensionState -- ^ state of loaded extensions , _clientLogQueue :: ![LogLine] -- ^ log lines ready to write , _clientErrorMsg :: Maybe Text -- ^ transient error box text + , _clientRtsStats :: Maybe Stats -- ^ most recent GHC RTS stats } @@ -259,6 +264,7 @@ , _clientExtensions = exts , _clientLogQueue = [] , _clientErrorMsg = Nothing + , _clientRtsStats = Nothing } withExtensionState :: (ExtensionState -> IO a) -> IO a @@ -302,7 +308,6 @@ , rendNicks = HashSet.fromList (channelUserList network channel' st) , rendMyNicks = highlights , rendPalette = clientPalette st - , rendNickPadding = view (clientConfig . configNickPadding) st } -- on failure returns mempty/"" @@ -514,22 +519,20 @@ toWindowLine :: MessageRendererParams -> WindowLineImportance -> ClientMessage -> WindowLine toWindowLine params importance msg = WindowLine { _wlSummary = msgSummary (view msgBody msg) - , _wlText = msgText (view msgBody msg) - , _wlImage = mkImage NormalRender - , _wlFullImage = mkImage DetailedRender + , _wlPrefix = prefix + , _wlImage = image + , _wlFullImage = full , _wlImportance = importance - , _wlTimestamp = zonedTimeToUTC (view msgTime msg) + , _wlTimestamp = views msgTime packZonedTime msg } where - mkImage mode = - msgImage mode (view msgTime msg) params (view msgBody msg) + (prefix, image, full) = msgImage (view msgTime msg) params (view msgBody msg) -- | 'toWindowLine' but with mostly defaulted parameters. toWindowLine' :: Configuration -> WindowLineImportance -> ClientMessage -> WindowLine toWindowLine' config = toWindowLine defaultRenderParams { rendPalette = view configPalette config - , rendNickPadding = view configNickPadding config , rendMyNicks = view configExtraHighlights config } @@ -594,12 +597,20 @@ -- | Returns the current filtering predicate if one is active. clientMatcher :: ClientState {- ^ client state -} -> - Maybe (Text -> Bool) {- ^ optional predicate -} + Maybe (LText.Text -> Bool) {- ^ optional predicate -} clientMatcher st = do r <- clientActiveRegex st - return (matchTest r . Text.unpack) + return (matchTest r . LText.unpack) +-- | Strict version of 'clientMatcher' +clientMatcher' :: + ClientState {- ^ client state -} -> + Maybe (Text -> Bool) {- ^ optional predicate -} +clientMatcher' st = + do p <- clientMatcher st + return (p . LText.fromStrict) + -- | Construct a text matching predicate used to filter the message window. clientActiveRegex :: ClientState -> Maybe Regex clientActiveRegex st = @@ -640,11 +651,13 @@ -- | Find all the URL matches using 'urlPattern' in a given 'Text' suitable -- for being opened. Surrounding @<@ and @>@ are removed. -urlMatches :: Text -> [Text] +urlMatches :: LText.Text -> [Text] urlMatches txt = removeBrackets . extractText . (^?! ix 0) - <$> matchAll urlPattern (Text.unpack txt) + <$> matchAll urlPattern (LText.unpack txt) where - extractText (off,len) = Text.take len (Text.drop off txt) + extractText (off,len) = LText.toStrict + $ LText.take (fromIntegral len) + $ LText.drop (fromIntegral off) txt removeBrackets t = case Text.uncons t of diff --git a/src/Client/State/Channel.hs b/src/Client/State/Channel.hs --- a/src/Client/State/Channel.hs +++ b/src/Client/State/Channel.hs @@ -111,7 +111,7 @@ -- | Remove a user from the user list partChannel :: Identifier -> ChannelState -> ChannelState -partChannel nick = set (chanUsers . at nick) Nothing +partChannel = over chanUsers . sans -- | Rename a user in the user list nickChange :: Identifier -> Identifier -> ChannelState -> ChannelState diff --git a/src/Client/State/Focus.hs b/src/Client/State/Focus.hs --- a/src/Client/State/Focus.hs +++ b/src/Client/State/Focus.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} {-| Module : Client.State.Focus @@ -53,6 +53,7 @@ | FocusDigraphs -- ^ Show all digraphs | FocusKeyMap -- ^ Show key bindings | FocusHelp (Maybe Text) -- ^ Show help window with optional command + | FocusRtsStats -- ^ Show GHC RTS statistics deriving (Eq,Show) -- | Unfocused first, followed by focuses sorted by network. diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs --- a/src/Client/State/Network.hs +++ b/src/Client/State/Network.hs @@ -273,23 +273,16 @@ $ forgetUser (userNick user) $ overChannels (partChannel (userNick user)) cs - Part user chan _mbreason -> - noReply - $ forgetUser' (userNick user) -- possibly forget - $ if userNick user == view csNick cs - then over csChannels (sans chan) cs - else overChannel chan (partChannel (userNick user)) cs + Part user chan _mbreason -> exitChannel chan (userNick user) + Kick _kicker chan nick _reason -> exitChannel chan nick + Nick oldNick newNick -> noReply $ renameUser (userNick oldNick) newNick $ updateMyNick (userNick oldNick) newNick $ overChannels (nickChange (userNick oldNick) newNick) cs - Kick _kicker chan nick _reason -> - noReply - $ forgetUser' nick - $ overChannel chan (partChannel nick) cs Reply RPL_WELCOME (me:_) -> doWelcome msgWhen (mkId me) cs Reply RPL_SASLSUCCESS _ -> ([ircCapEnd], cs) Reply RPL_SASLFAIL _ -> ([ircCapEnd], cs) @@ -301,6 +294,20 @@ Mode who target (modes:params) -> doMode msgWhen who target modes params cs Topic user chan topic -> noReply (doTopic msgWhen user chan topic cs) _ -> noReply cs + where + exitChannel chan nick + | nick == view csNick cs = noReply $ pruneUsers + $ over csChannels (sans chan) cs + + | otherwise = noReply $ forgetUser' nick + $ overChannel chan (partChannel nick) cs + +-- | Restrict 'csUsers' to only users are in a channel that the client +-- is connected to. +pruneUsers :: NetworkState -> NetworkState +pruneUsers cs = over csUsers (`HashMap.intersection` u) cs + where + u = foldOf (csChannels . folded . chanUsers) cs -- | 001 'RPL_WELCOME' is the first message received when transitioning -- from the initial handshake to a connected state. At this point we know diff --git a/src/Client/State/Window.hs b/src/Client/State/Window.hs --- a/src/Client/State/Window.hs +++ b/src/Client/State/Window.hs @@ -26,6 +26,7 @@ , WindowLine(..) , wlSummary , wlText + , wlPrefix , wlImage , wlFullImage , wlImportance @@ -40,24 +41,39 @@ , windowSeen , windowActivate , windowDeactivate + + -- * Packed time + , PackedTime + , packZonedTime + , unpackUTCTime + , unpackTimeOfDay ) where import Client.Image.PackedImage import Client.Message import Control.Lens -import Data.Text (Text) -import Data.Time (UTCTime) +import Control.Monad ((<$!>)) +import Data.Text.Lazy (Text) +import Data.Time +import Data.Word +import Data.Bits --- | A single message to be displayed in a window +-- | A single message to be displayed in a window. +-- The normal message line consists of the image prefix +-- and the image. This allows line wrapping to be applied +-- separately to the image and prefix so that wrapped +-- messages can fall to the right side of the prefix. data WindowLine = WindowLine { _wlSummary :: !IrcSummary -- ^ Summary value - , _wlText :: {-# UNPACK #-} !Text -- ^ Searchable text form + , _wlPrefix :: !Image' -- ^ Normal rendered image prefix , _wlImage :: !Image' -- ^ Normal rendered image , _wlFullImage :: !Image' -- ^ Detailed rendered image , _wlImportance :: !WindowLineImportance -- ^ Importance of message - , _wlTimestamp :: {-# UNPACK #-} !UTCTime + , _wlTimestamp :: {-# UNPACK #-} !PackedTime } +newtype PackedTime = PackedTime Word64 + data WindowLines = {-# UNPACK #-} !WindowLine :- WindowLines | Nil @@ -87,6 +103,9 @@ makeLenses ''WindowLine +wlText :: Getter WindowLine Text +wlText = wlFullImage . to imageText + -- | A window with no messages emptyWindow :: Window emptyWindow = Window @@ -104,7 +123,7 @@ addToWindow !msg !win = Window { _winMessages = msg :- view winMessages win , _winTotal = view winTotal win + 1 - , _winMarker = do i <- view winMarker win; return $! i+1 + , _winMarker = (+1) <$!> view winMarker win , _winUnread = if view wlImportance msg == WLBoring then view winUnread win else view winUnread win + 1 @@ -135,3 +154,52 @@ instance Each WindowLines WindowLines WindowLine WindowLine where each _ Nil = pure Nil each f (x :- xs) = (:-) <$> f x <*> each f xs + +------------------------------------------------------------------------ + +-- Field Range Bits Start +-- year: 0.. 33 31 +-- month: 1..12 4 27 +-- day: 1..31 5 22 +-- hour: 0..23 5 17 +-- minute: 0..60 6 11 +-- second: 0..61 6 5 +-- offset: -12..14 5 0 + +field :: Num a => PackedTime -> Int -> Int -> a +field (PackedTime x) off sz = fromIntegral ((x `shiftR` off) .&. (2^sz-1)) +{-# INLINE field #-} + +packField :: Int -> Int -> Word64 +packField off val = fromIntegral val `shiftL` off + +packZonedTime :: ZonedTime -> PackedTime +packZonedTime (ZonedTime (LocalTime (ModifiedJulianDay d) (TimeOfDay h m s)) z) + = PackedTime + $ packField 17 h .|. + packField 11 m .|. + packField 5 (floor s) .|. + packField 22 (fromInteger d) .|. + packField 0 (timeZoneMinutes z `div` 60 + 12) + +unpackTimeOfDay :: PackedTime -> TimeOfDay +unpackTimeOfDay !x = TimeOfDay h m s + where + h = field x 17 5 + m = field x 11 6 + s = field x 5 6 + +unpackLocalTime :: PackedTime -> LocalTime +unpackLocalTime !x = LocalTime d t + where + d = ModifiedJulianDay (field x 22 42) + t = unpackTimeOfDay x + +unpackUTCTime :: PackedTime -> UTCTime +unpackUTCTime = zonedTimeToUTC . unpackZonedTime + +unpackZonedTime :: PackedTime -> ZonedTime +unpackZonedTime !x = ZonedTime t z + where + z = minutesToTimeZone ((field x 0 5 - 12) * 60) + t = unpackLocalTime x diff --git a/src/Client/View.hs b/src/Client/View.hs --- a/src/Client/View.hs +++ b/src/Client/View.hs @@ -13,6 +13,7 @@ ( viewLines ) where +import Client.Image.PackedImage import Client.State import Client.State.Focus import Client.View.ChannelInfo @@ -23,17 +24,17 @@ import Client.View.Mentions import Client.View.Messages import Client.View.Palette +import Client.View.RtsStats import Client.View.UrlSelection import Client.View.UserList import Client.View.Windows import Control.Lens -import Graphics.Vty.Image -viewLines :: Focus -> Subfocus -> Int -> ClientState -> [Image] +viewLines :: Focus -> Subfocus -> Int -> ClientState -> [Image'] viewLines focus subfocus w !st = case (focus, subfocus) of _ | Just ("url",arg) <- clientActiveCommand st -> - urlSelectionView focus arg st + urlSelectionView w focus arg st (ChannelFocus network channel, FocusInfo) -> channelInfoImages network channel st (ChannelFocus network channel, FocusUsers) @@ -47,6 +48,7 @@ (_, FocusDigraphs) -> digraphLines w st (_, FocusKeyMap) -> keyMapLines st (_, FocusHelp mb) -> helpImageLines mb pal + (_, FocusRtsStats) -> rtsStatsLines (view clientRtsStats st) pal _ -> chatMessageImages focus w st where pal = clientPalette st diff --git a/src/Client/View/ChannelInfo.hs b/src/Client/View/ChannelInfo.hs --- a/src/Client/View/ChannelInfo.hs +++ b/src/Client/View/ChannelInfo.hs @@ -18,24 +18,24 @@ import Client.Image.Message import Client.Image.MircFormatting -import Client.Image.PackedImage (unpackImage) +import Client.Image.PackedImage import Client.Image.Palette import Client.State import Client.State.Channel import Client.State.Network import Control.Lens import Data.HashSet (HashSet) +import Data.Semigroup import Data.Text (Text) import Data.Time import Graphics.Vty.Attributes -import Graphics.Vty.Image import Irc.Identifier -- | Render the lines used in a channel mask list channelInfoImages :: Text {- ^ network -} -> Identifier {- ^ channel -} -> - ClientState -> [Image] + ClientState -> [Image'] channelInfoImages network channelId st | Just cs <- preview (clientConnection network) st @@ -46,7 +46,7 @@ where pal = clientPalette st -channelInfoImages' :: Palette -> HashSet Identifier -> ChannelState -> [Image] +channelInfoImages' :: Palette -> HashSet Identifier -> ChannelState -> [Image'] channelInfoImages' pal myNicks !channel = topicLine : provenanceLines @@ -56,8 +56,8 @@ where label = text' (view palLabel pal) - topicLine = label "Topic: " <|> - unpackImage (parseIrcText (view chanTopic channel)) + topicLine = label "Topic: " <> + parseIrcText (view chanTopic channel) utcTimeImage = string defAttr . formatTime defaultTimeLocale "%F %T" @@ -66,20 +66,18 @@ case view chanTopicProvenance channel of Nothing -> [] Just !prov -> - [ label "Topic set by: " <|> - unpackImage - (coloredUserInfo - pal DetailedRender myNicks (view topicAuthor prov)) - , label "Topic set on: " <|> utcTimeImage (view topicTime prov) + [ label "Topic set by: " <> + coloredUserInfo pal DetailedRender myNicks (view topicAuthor prov) + , label "Topic set on: " <> utcTimeImage (view topicTime prov) ] creationLines = case view chanCreation channel of Nothing -> [] - Just time -> [label "Created on: " <|> utcTimeImage time] + Just time -> [label "Created on: " <> utcTimeImage time] urlLines = case view chanUrl channel of Nothing -> [] - Just url -> [ label "Channel URL: " <|> unpackImage (parseIrcText url) ] + Just url -> [ label "Channel URL: " <> parseIrcText url ] diff --git a/src/Client/View/Digraphs.hs b/src/Client/View/Digraphs.hs --- a/src/Client/View/Digraphs.hs +++ b/src/Client/View/Digraphs.hs @@ -12,28 +12,29 @@ module Client.View.Digraphs (digraphLines) where import Client.Image.Message (cleanChar) +import Client.Image.PackedImage import Client.State import Data.List import Data.List.Split import qualified Data.Text as Text import Digraphs import Graphics.Vty.Attributes -import Graphics.Vty.Image +import Graphics.Vty.Image (wcwidth, wcswidth) -- | Render the lines of a table showing all of the available digraph entries digraphLines :: Int {- ^ draw width -} -> ClientState {- ^ client state -} -> - [Image] {- ^ output lines -} + [Image'] {- ^ output lines -} digraphLines w st - = map (horizCat . intersperse sep) + = map (mconcat . intersperse sep) $ chunksOf entriesPerLine $ map (text' defAttr) $ matcher $ map (Text.pack . drawEntry) $ digraphListToList digraphs where - matcher = maybe id filter (clientMatcher st) + matcher = maybe id filter (clientMatcher' st) entriesPerLine = max 1 -- just in case? $ (w + sepWidth) `quot` (entryWidth + sepWidth) @@ -43,7 +44,7 @@ sepWidth :: Int sepWidth = imageWidth sep -sep :: Image +sep :: Image' sep = text' defAttr " " drawEntry :: (Char,Char,Char) -> String diff --git a/src/Client/View/Help.hs b/src/Client/View/Help.hs --- a/src/Client/View/Help.hs +++ b/src/Client/View/Help.hs @@ -29,7 +29,6 @@ import Data.Text (Text) import qualified Data.Text as Text import Graphics.Vty.Attributes -import Graphics.Vty.Image (Image) -- | Generate either the list of all commands and their arguments, -- or when given a command name generate the detailed help text @@ -37,8 +36,8 @@ helpImageLines :: Maybe Text {- ^ optional command name -} -> Palette {- ^ palette -} -> - [Image] {- ^ help lines -} -helpImageLines mbCmd pal = map unpackImage $ + [Image'] {- ^ help lines -} +helpImageLines mbCmd pal = case mbCmd of Nothing -> listAllCommands pal Just cmd -> commandHelpLines cmd pal @@ -57,7 +56,7 @@ suggestions = Text.unpack $ Text.intercalate " " ((cmdName <>) <$> sfxs) Exact Command{cmdNames = names, cmdImplementation = impl, cmdArgumentSpec = spec, cmdDocumentation = doc} -> - reverse $ commandSummary pal (pure cmdName) spec + reverse $ heading "Syntax: " <> commandSummary pal (pure cmdName) spec : emptyLine : aliasLines ++ explainContext impl @@ -67,24 +66,27 @@ aliasLines = case delete cmdName (toList names) of [] -> [] - ns -> [ text' defAttr (Text.unwords ("Aliases:":ns)) + ns -> [ heading "Aliases: " <> + text' defAttr (Text.intercalate ", " ns) , emptyLine ] +heading :: Text -> Image' +heading = text' (withStyle defAttr bold) + -- | Generate an explanation of the context where the given command -- implementation will be valid. explainContext :: CommandImpl a {- ^ command implementation -} -> Image' {- ^ help line -} explainContext impl = + heading "Context: " <> case impl of - ClientCommand {} -> go "client command" "works everywhere" - NetworkCommand{} -> go "network command" "works when focused on active network" - ChannelCommand{} -> go "channel command" "works when focused on active channel" - ChatCommand {} -> go "chat command" "works when focused on an active channel or private message" - where - go x y = string (withStyle defAttr bold) x <> - string defAttr (": " ++ y) + ClientCommand {} -> "client (works everywhere)" + NetworkCommand{} -> "network (works when focused on active network)" + ChannelCommand{} -> "channel (works when focused on active channel)" + ChatCommand {} -> "chat (works when focused on an active channel or private message)" + -- | Generate the lines for the help window showing all commands. listAllCommands :: Palette {- ^ palette -} -> @@ -116,7 +118,7 @@ Image' {- ^ summary help line -} commandSummary pal (cmd :| _) args = char defAttr '/' <> - text' (view palCommand pal) cmd <> + text' (view palCommandReady pal) cmd <> argumentsImage pal' args "" where diff --git a/src/Client/View/KeyMap.hs b/src/Client/View/KeyMap.hs --- a/src/Client/View/KeyMap.hs +++ b/src/Client/View/KeyMap.hs @@ -13,26 +13,27 @@ import Client.Configuration import Client.EventLoop.Actions +import Client.Image.PackedImage import Client.State import Control.Lens import Data.List +import Data.Semigroup import Data.Ord import Graphics.Vty.Attributes -import Graphics.Vty.Image import Graphics.Vty.Input -- | Render the lines of a table showing all of the available digraph entries keyMapLines :: ClientState {- ^ client state -} -> - [Image] {- ^ output lines -} + [Image'] {- ^ output lines -} keyMapLines = renderEntries . keyMapEntries . view (clientConfig . configKeyMap) -renderEntries :: [([Modifier], Key, Action)] -> [Image] +renderEntries :: [([Modifier], Key, Action)] -> [Image'] renderEntries entries = - [ resizeWidth keyColWidth key <|> act | (key,act) <- images ] + [ resizeImage keyColWidth key <> act | (key,act) <- images ] where third (_,_,x) = x diff --git a/src/Client/View/MaskList.hs b/src/Client/View/MaskList.hs --- a/src/Client/View/MaskList.hs +++ b/src/Client/View/MaskList.hs @@ -13,6 +13,7 @@ ( maskListImages ) where +import Client.Image.PackedImage import Client.Image.Palette import Client.State import Client.State.Channel @@ -23,10 +24,10 @@ import Data.List import Data.Ord import Data.Maybe +import Data.Semigroup import Data.Text (Text) import Data.Time import Graphics.Vty.Attributes -import Graphics.Vty.Image import Irc.Identifier -- | Render the lines used in a channel mask list @@ -35,7 +36,7 @@ Text {- ^ network -} -> Identifier {- ^ channel -} -> Int {- ^ draw width -} -> - ClientState -> [Image] + ClientState -> [Image'] maskListImages mode network channel w st = case mbEntries of Nothing -> [text' (view palError pal) "Mask list not loaded"] @@ -49,17 +50,17 @@ . chanLists . ix mode ) st -maskListImages' :: HashMap Text MaskListEntry -> Int -> ClientState -> [Image] +maskListImages' :: HashMap Text MaskListEntry -> Int -> ClientState -> [Image'] maskListImages' entries w st = countImage : images where pal = clientPalette st - countImage = text' (view palLabel pal) "Masks (visible/total): " <|> - string defAttr (show (length entryList)) <|> - char (view palLabel pal) '/' <|> + countImage = text' (view palLabel pal) "Masks (visible/total): " <> + string defAttr (show (length entryList)) <> + char (view palLabel pal) '/' <> string defAttr (show (HashMap.size entries)) - matcher = fromMaybe (const True) (clientMatcher st) + matcher = fromMaybe (const True) (clientMatcher' st) matcher' (mask,entry) = matcher mask || matcher (view maskListSetter entry) @@ -72,14 +73,14 @@ (masks, whoWhens) = unzip entryList maskImages = text' defAttr <$> masks maskColumnWidth = maximum (imageWidth <$> maskImages) + 1 - paddedMaskImages = resizeWidth maskColumnWidth <$> maskImages + paddedMaskImages = resizeImage maskColumnWidth <$> maskImages width = max 1 w - images = [ cropLine $ mask <|> - text' defAttr who <|> + images = [ cropLine $ mask <> + text' defAttr who <> string defAttr (renderWhen when) | (mask, MaskListEntry who when) <- zip paddedMaskImages whoWhens ] cropLine img - | imageWidth img > width = cropRight width img + | imageWidth img > width = resizeImage width img | otherwise = img diff --git a/src/Client/View/Mentions.hs b/src/Client/View/Mentions.hs --- a/src/Client/View/Mentions.hs +++ b/src/Client/View/Mentions.hs @@ -14,20 +14,20 @@ ( mentionsViewLines ) where -import Client.Image.PackedImage (Image', unpackImage) +import Client.Image.PackedImage import Client.Image.StatusLine import Client.State import Client.State.Focus import Client.State.Window import qualified Data.Map as Map import Control.Lens +import Data.Semigroup import Data.Time (UTCTime) -import Graphics.Vty.Image -- | Generate the list of message lines marked important ordered by -- time. Each run of lines from the same channel will be grouped -- together. Messages are headed by their window, network, and channel. -mentionsViewLines :: Int -> ClientState -> [Image] +mentionsViewLines :: Int -> ClientState -> [Image'] mentionsViewLines w st = addMarkers w st entries where @@ -51,10 +51,10 @@ Int {- ^ draw width -} -> ClientState {- ^ client state -} -> [MentionLine] {- ^ list of mentions in time order -} -> - [Image] {- ^ mention images and channel labels -} + [Image'] {- ^ mention images and channel labels -} addMarkers _ _ [] = [] addMarkers w !st (!ml : xs) - = map (unpackImage . mlImage) (ml:same) + = map mlImage (ml:same) ++ minorStatusLineImage (mlFocus ml) w False st : addMarkers w st rest where @@ -70,10 +70,14 @@ [MentionLine] windowEntries !detailed name focus w = [ MentionLine - { mlTimestamp = view wlTimestamp l + { mlTimestamp = views wlTimestamp unpackUTCTime l , mlWindowName = name , mlFocus = focus - , mlImage = if detailed then view wlFullImage l else view wlImage l + , mlImage = if detailed + then view wlFullImage l + else view wlPrefix l <> + char mempty ' ' <> + view wlImage l } | let p x = WLImportant == view wlImportance x , l <- toListOf (winMessages . each . filtered p) w diff --git a/src/Client/View/Messages.hs b/src/Client/View/Messages.hs --- a/src/Client/View/Messages.hs +++ b/src/Client/View/Messages.hs @@ -1,3 +1,4 @@ +{-# Language OverloadedStrings #-} {-| Module : Client.View.Messages Description : Chat message view @@ -26,14 +27,13 @@ import Client.State.Window import Control.Lens import Control.Monad +import Data.List import Data.Semigroup -import Graphics.Vty.Attributes -import qualified Graphics.Vty.Image as Vty import Irc.Identifier import Irc.Message -chatMessageImages :: Focus -> Int -> ClientState -> [Vty.Image] +chatMessageImages :: Focus -> Int -> ClientState -> [Image'] chatMessageImages focus w st = case preview (clientWindows . ix focus) st of Nothing -> [] @@ -54,12 +54,13 @@ where palette = clientPalette st - marker = Vty.string (view palLineMarker palette) (replicate w '-') + marker = string (view palLineMarker palette) (replicate w '-') windowLineProcessor hideMeta | view clientDetailView st = + concatMap (reverse . fullLineWrap w) . if hideMeta then detailedImagesWithoutMetadata st - else map (views wlFullImage unpackImage) + else map (view wlFullImage) | otherwise = windowLinesToImages st w hideMeta . filter (not . isNoisy) @@ -68,11 +69,11 @@ ReplySummary code -> squelchIrcMsg (Reply code []) _ -> False -detailedImagesWithoutMetadata :: ClientState -> [WindowLine] -> [Vty.Image] +detailedImagesWithoutMetadata :: ClientState -> [WindowLine] -> [Image'] detailedImagesWithoutMetadata st wwls = case gatherMetadataLines st wwls of ([], []) -> [] - ([], w:ws) -> views wlFullImage unpackImage w + ([], w:ws) -> view wlFullImage w : detailedImagesWithoutMetadata st ws (_:_, wls) -> detailedImagesWithoutMetadata st wls @@ -82,70 +83,71 @@ Int {- ^ draw width -} -> Bool {- ^ hide metadata -} -> [WindowLine] {- ^ window lines -} -> - [Vty.Image] {- ^ image lines -} + [Image'] {- ^ image lines -} windowLinesToImages st w hideMeta wwls = case gatherMetadataLines st wwls of ([], []) -> [] - ([], wl:wls) -> - map unpackImage - (lineWrapChat w - (view (clientConfig . configIndentWrapped) st) - (view wlImage wl)) + ([], wl:wls) -> drawLine wl ++ windowLinesToImages st w hideMeta wls ((img,who,mbnext):mds, wls) | hideMeta -> windowLinesToImages st w hideMeta wls | otherwise -> - mkLines w (startMetadata img mbnext who mds palette) + wrap + metaPad + (mconcat + (intersperse " " + (startMetadata img mbnext who mds palette))) ++ windowLinesToImages st w hideMeta wls where palette = clientPalette st + config = view clientConfig st + padAmt = view configNickPadding config -mkLines :: Int -> [Vty.Image] -> [Vty.Image] -mkLines _ [] = [] -mkLines w (x:xs) = reverse (mkLines1 w x xs) + drawTime = timeImage palette . unpackTimeOfDay + padNick = nickPad padAmt + metaPad = " " <> padNick "" -mkLines1 :: Int -> Vty.Image -> [Vty.Image] -> [Vty.Image] -mkLines1 _ x [] = [x] -mkLines1 w x (y:ys) - | Vty.imageWidth x' <= w = mkLines1 w x' ys - | otherwise = x : mkLines1 w y ys - where - x' = x Vty.<|> Vty.char defAttr ' ' Vty.<|> y + drawPrefix = views wlTimestamp drawTime <> + views wlPrefix padNick + wrap pfx body = reverse (lineWrapPrefix w pfx body) + + drawLine wl = wrap (drawPrefix wl) (view wlImage wl) + ------------------------------------------------------------------------ type MetadataState = Identifier {- ^ current nick -} -> [(Image',Identifier,Maybe Identifier)] {- ^ metadata -} -> Palette {- ^ palette -} -> - [Vty.Image] + [Image'] startMetadata :: Image' {- ^ metadata image -} -> Maybe Identifier {- ^ possible nick transition -} -> MetadataState startMetadata img mbnext who mds palette = - let acc = unpackImage (quietIdentifier palette who <> img) + let acc = quietIdentifier palette who <> img in transitionMetadata acc mbnext who mds palette transitionMetadata :: - Vty.Image -> + Image' {- ^ image accumulator -} -> Maybe Identifier {- ^ possible nick transition -} -> MetadataState transitionMetadata acc mbwho who mds palette = case mbwho of Nothing -> continueMetadata acc who mds palette Just who' -> - let acc' = acc Vty.<|> unpackImage (quietIdentifier palette who') + let acc' = acc <> quietIdentifier palette who' in continueMetadata acc' who' mds palette -continueMetadata :: Vty.Image -> MetadataState +continueMetadata :: Image' -> MetadataState continueMetadata acc _ [] _ = [acc] continueMetadata acc who1 ((img, who2, mbwho3):mds) palette - | who1 == who2 = let acc' = acc Vty.<|> unpackImage img + | who1 == who2 = let acc' = acc <> img in transitionMetadata acc' mbwho3 who2 mds palette | otherwise = acc : startMetadata img mbwho3 who2 mds palette diff --git a/src/Client/View/Palette.hs b/src/Client/View/Palette.hs --- a/src/Client/View/Palette.hs +++ b/src/Client/View/Palette.hs @@ -15,24 +15,24 @@ ) where import Client.Image.Palette +import Client.Image.PackedImage import Control.Lens import Data.List import Graphics.Vty.Attributes -import Graphics.Vty.Image digits :: String digits = "0123456789ABCDEF" -digitImage :: Char -> Image +digitImage :: Char -> Image' digitImage d = string defAttr [' ',d,' '] -columns :: [Image] -> Image -columns = horizCat . intersperse (char defAttr ' ') +columns :: [Image'] -> Image' +columns = mconcat . intersperse (char defAttr ' ') -- | Generate lines used for @/palette@. These lines show -- all the colors used in the current palette as well as -- the colors available for use in palettes. -paletteViewLines :: Palette -> [Image] +paletteViewLines :: Palette -> [Image'] paletteViewLines pal = [ columns $ digitImage digit @@ -49,12 +49,12 @@ ] , columns (map digitImage (' ':digits)) - , emptyImage + , mempty , columns [ text' (view l pal) name | (name, Lens l) <- paletteMap ] - , emptyImage + , mempty , columns [ string attr "nicks" | attr <- toListOf (palNicks . folded) pal diff --git a/src/Client/View/RtsStats.hs b/src/Client/View/RtsStats.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/RtsStats.hs @@ -0,0 +1,36 @@ +{-# Language CPP, OverloadedStrings #-} +{-| +Module : Client.View.RtsStats +Description : View current GHC RTS statistics +Copyright : (c) Eric Mertens, 2017 +License : ISC +Maintainer : emertens@gmail.com + +Lines for the @/rtsstats@ command. This module depends +on GHC 8.2.1 API. + +-} + +module Client.View.RtsStats + ( rtsStatsLines + ) where + +import Client.Image.PackedImage +import Client.Image.Palette +import Control.Lens +import Data.Semigroup +import Graphics.Vty.Attributes +import RtsStats + +-- | Generate lines used for @/rtsstats@. +rtsStatsLines :: Maybe Stats -> Palette -> [Image'] +rtsStatsLines Nothing pal = [text' (view palError pal) "Statistics not available"] +rtsStatsLines (Just stats) pal + | null entries = [text' (view palError pal) "Statistics empty"] + | otherwise = zipWith (\v l -> padV wv v <> " " <> l) valueImages labelImages + where + entries = statsToEntries stats + labelImages = map (text' (view palLabel pal) . fst) entries + valueImages = map (text' defAttr . snd) entries + wv = maximum (0 : map imageWidth valueImages) + padV n img = string defAttr (replicate (n - imageWidth img) ' ') <> img diff --git a/src/Client/View/UrlSelection.hs b/src/Client/View/UrlSelection.hs --- a/src/Client/View/UrlSelection.hs +++ b/src/Client/View/UrlSelection.hs @@ -1,3 +1,4 @@ +{-# Language OverloadedStrings #-} {-| Module : Client.View.UrlSelection Description : URL selection module @@ -15,8 +16,9 @@ import Client.Configuration import Client.Image.Message -import Client.Image.PackedImage (unpackImage) +import Client.Image.PackedImage import Client.Image.Palette +import Client.Image.LineWrap import Client.Message import Client.State import Client.State.Focus @@ -25,27 +27,32 @@ import Control.Lens import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet +import Data.Semigroup import Data.Text (Text) import Graphics.Vty.Attributes -import Graphics.Vty.Image import Irc.Identifier import Text.Read (readMaybe) -- | Generate the lines used for the view when typing @/url@ urlSelectionView :: + Int {- ^ render width -} -> Focus {- ^ window to search -} -> String {- ^ argument to command -} -> ClientState {- ^ client state -} -> - [Image] {- ^ image lines -} -urlSelectionView focus arg st = - zipWith (draw me pal padding selected) [1..] (toListOf urled st) + [Image'] {- ^ image lines -} +urlSelectionView w focus arg st + = concat + $ zipWith (draw w me pal padding selected) [1..] (toListOf urled st) where urled = clientWindows . ix focus . winMessages . each . folding matches + focused = focus == view clientFocus st + selected + | not focused = 0 | all (==' ') arg = 1 | Just i <- readMaybe arg = i | otherwise = 0 -- won't match @@ -77,20 +84,21 @@ -- | Render one line of the url list draw :: + Int {- ^ rendered width -} -> HashSet Identifier {- ^ my nick -} -> Palette {- ^ palette -} -> - Maybe Integer {- ^ nick render padding -} -> + PaddingMode {- ^ nick render padding -} -> Int {- ^ selected index -} -> Int {- ^ url index -} -> (Maybe Identifier, Text) {- ^ sender and url text -} -> - Image {- ^ rendered line -} -draw me pal padding selected i (who,url) = - unpackImage - (rightPad NormalRender padding - (foldMap (coloredIdentifier pal NormalIdentifier me) who)) <|> - string defAttr ": " <|> - string attr (shows i ". ") <|> - text' attr (cleanText url) + [Image'] {- ^ rendered lines -} +draw w me pal padding selected i (who,url) + = reverse + $ lineWrapPrefix w + (string defAttr (shows i ". ") <> + nickPad padding + (foldMap (coloredIdentifier pal NormalIdentifier me) who) <> ": ") + (text' attr (cleanText url)) where attr | selected == i = withStyle defAttr reverseVideo | otherwise = defAttr diff --git a/src/Client/View/UserList.hs b/src/Client/View/UserList.hs --- a/src/Client/View/UserList.hs +++ b/src/Client/View/UserList.hs @@ -14,7 +14,7 @@ ) where import Client.Image.Message -import Client.Image.PackedImage (unpackImage) +import Client.Image.PackedImage import Client.Image.Palette import Client.State import Client.State.Channel @@ -25,10 +25,11 @@ import Data.List import Data.Maybe import Data.Ord +import Data.Semigroup import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText import Graphics.Vty.Attributes -import Graphics.Vty.Image import Irc.Identifier import Irc.UserInfo @@ -39,7 +40,7 @@ Text {- ^ network -} -> Identifier {- ^ channel -} -> ClientState -> - [Image] + [Image'] userListImages network channel st = case preview (clientConnection network) st of Just cs -> userListImages' cs channel st @@ -47,43 +48,47 @@ where pal = clientPalette st -userListImages' :: NetworkState -> Identifier -> ClientState -> [Image] +userListImages' :: NetworkState -> Identifier -> ClientState -> [Image'] userListImages' cs channel st = - [countImage, horizCat (intersperse gap (map renderUser usersList))] + [countImage, mconcat (intersperse gap (map renderUser usersList))] where - countImage = text' (view palLabel pal) "Users:" <|> - sigilCountImage + countImage = drawSigilCount pal (map snd usersList) matcher = fromMaybe (const True) (clientMatcher st) myNicks = clientHighlights cs st renderUser (ident, sigils) = - string (view palSigil pal) sigils <|> - unpackImage (coloredIdentifier pal NormalIdentifier myNicks ident) + string (view palSigil pal) sigils <> + coloredIdentifier pal NormalIdentifier myNicks ident gap = char defAttr ' ' - matcher' (ident,sigils) = matcher (Text.pack sigils `Text.append` idText ident) + matcher' (ident,sigils) = matcher (LText.fromChunks [Text.pack sigils, idText ident]) usersList = sortBy (comparing fst) $ filter matcher' $ HashMap.toList usersHashMap - sigilCounts = Map.fromListWith (+) - [ (take 1 sigil, 1::Int) | (_,sigil) <- usersList ] - - sigilCountImage = horizCat - [ string (view palSigil pal) (' ':sigil) <|> - string defAttr (show n) - | (sigil,n) <- Map.toList sigilCounts - ] - pal = clientPalette st usersHashMap = view (csChannels . ix channel . chanUsers) cs +drawSigilCount :: Palette -> [String] -> Image' +drawSigilCount pal sigils = + text' (view palLabel pal) "Users:" <> mconcat entries + where + sigilCounts = Map.fromListWith (+) [ (take 1 sigil, 1::Int) | sigil <- sigils ] + + entries + | Map.null sigilCounts = [" 0"] + | otherwise = [ string (view palSigil pal) (' ':sigil) <> + string defAttr (show n) + | (sigil,n) <- Map.toList sigilCounts + ] + + -- | Render lines for the @/users@ command in detailed view. -- Each user will be rendered on a separate line with username -- and host visible when known. @@ -91,7 +96,7 @@ Text {- ^ network -} -> Identifier {- ^ channel -} -> ClientState -> - [Image] + [Image'] userInfoImages network channel st = case preview (clientConnection network) st of Just cs -> userInfoImages' cs channel st @@ -99,21 +104,23 @@ where pal = clientPalette st -userInfoImages' :: NetworkState -> Identifier -> ClientState -> [Image] -userInfoImages' cs channel st = renderEntry <$> usersList +userInfoImages' :: NetworkState -> Identifier -> ClientState -> [Image'] +userInfoImages' cs channel st = countImage : map renderEntry usersList where matcher = fromMaybe (const True) (clientMatcher st) + countImage = drawSigilCount pal (map snd usersList) + myNicks = clientHighlights cs st pal = clientPalette st renderEntry (info, sigils) = - string (view palSigil pal) sigils <|> - unpackImage (coloredUserInfo pal DetailedRender myNicks info) + string (view palSigil pal) sigils <> + coloredUserInfo pal DetailedRender myNicks info matcher' (info,sigils) = - matcher (Text.pack sigils `Text.append` renderUserInfo info) + matcher (LText.fromChunks [Text.pack sigils, renderUserInfo info]) userInfos = view csUsers cs diff --git a/src/Client/View/Windows.hs b/src/Client/View/Windows.hs --- a/src/Client/View/Windows.hs +++ b/src/Client/View/Windows.hs @@ -12,6 +12,7 @@ ( windowsImages ) where +import Client.Image.PackedImage import Client.Image.Palette import Client.State import Client.State.Focus @@ -20,12 +21,12 @@ import Control.Lens import Data.List import qualified Data.Map as Map +import Data.Semigroup import Graphics.Vty.Attributes -import Graphics.Vty.Image import Irc.Identifier -- | Draw the image lines associated with the @/windows@ command. -windowsImages :: WindowsFilter -> ClientState -> [Image] +windowsImages :: WindowsFilter -> ClientState -> [Image'] windowsImages filt st = reverse (createColumns windows) where windows = [ renderWindowColumns pal n k v @@ -61,7 +62,7 @@ ------------------------------------------------------------------------ -renderWindowColumns :: Palette -> Char -> Focus -> Window -> [Image] +renderWindowColumns :: Palette -> Char -> Focus -> Window -> [Image'] renderWindowColumns pal name focus win = [ char (view palWindowName pal) name , renderedFocus pal focus @@ -69,15 +70,15 @@ ] -createColumns :: [[Image]] -> [Image] +createColumns :: [[Image']] -> [Image'] createColumns xs = map makeRow xs where columnWidths = maximum . map imageWidth <$> transpose xs - makeRow = horizCat + makeRow = mconcat . intersperse (char defAttr ' ') - . zipWith resizeWidth columnWidths + . zipWith resizeImage columnWidths -renderedFocus :: Palette -> Focus -> Image +renderedFocus :: Palette -> Focus -> Image' renderedFocus pal focus = case focus of Unfocused -> @@ -85,14 +86,14 @@ NetworkFocus network -> text' (view palLabel pal) network ChannelFocus network channel -> - text' (view palLabel pal) network <|> - char defAttr ':' <|> + text' (view palLabel pal) network <> + char defAttr ':' <> text' (view palLabel pal) (idText channel) -renderedWindowInfo :: Palette -> Window -> Image +renderedWindowInfo :: Palette -> Window -> Image' renderedWindowInfo pal win = - string (view newMsgAttrLens pal) (views winUnread show win) <|> - char defAttr '/' <|> + string (view newMsgAttrLens pal) (views winUnread show win) <> + char defAttr '/' <> string (view palActivity pal) (views winTotal show win) where newMsgAttrLens = diff --git a/src/RtsStats.hs b/src/RtsStats.hs new file mode 100644 --- /dev/null +++ b/src/RtsStats.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, DeriveGeneric, TypeOperators, StandaloneDeriving, CPP, EmptyCase #-} +{-# OPTIONS_GHC -Wno-orphans -funfolding-use-threshold=2000 -funfolding-creation-threshold=1000 #-} + +{-| +Module : RtsStats +Description : Compatibility layer for GHC RTS statistics across versions +Copyright : (c) Eric Mertens, 2017 +License : ISC +Maintainer : emertens@gmail.com + +-} + +module RtsStats + ( Stats + , getStats + , statsToEntries + ) where + +import Data.Int +import Data.List (intercalate) +import Data.List.Split (chunksOf) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Word +import GHC.Generics +import GHC.Stats + +type KVs = [(Text,Text)] -> [(Text,Text)] + +cons :: (Text, Text) -> KVs +cons = (:) + +class Fields a where fields :: a -> Text -> KVs +instance Fields Int64 where fields = commaFields +instance Fields Word32 where fields = commaFields +instance Fields Word64 where fields = commaFields +instance Fields Double where fields = showFields + +showFields :: Show a => a -> Text -> KVs +showFields x n = cons (n, Text.pack (show x)) +{-# NOINLINE showFields #-} + +commaFields :: Show a => a -> Text -> KVs +commaFields x n = cons (n, Text.pack (addCommas (show x))) +{-# NOINLINE commaFields #-} + +addCommas :: String -> String +addCommas = reverse . intercalate "," . chunksOf 3 . reverse + +genericFields :: (Generic a, GFields (Rep a)) => a -> Text -> KVs +genericFields = gfields . from + +class GFields f where + gfields :: f p -> Text -> KVs + +instance GFields f => GFields (D1 c f) where + gfields (M1 x) = gfields x + {-# INLINE gfields #-} + +instance GFields f => GFields (C1 c f) where + gfields (M1 x) = gfields x + {-# INLINE gfields #-} + +instance (Selector s, GFields f) => GFields (S1 s f) where + gfields s@(M1 x) _ = gfields x (Text.pack (selName s)) + {-# INLINE gfields #-} + +instance (GFields f, GFields g) => GFields (f :*: g) where + gfields (x :*: y) n = gfields x n . gfields y n + {-# INLINE gfields #-} + +instance (GFields f, GFields g) => GFields (f :+: g) where + gfields (L1 x) = gfields x + gfields (R1 x) = gfields x + {-# INLINE gfields #-} + +instance GFields U1 where + gfields _ _ = id + {-# INLINE gfields #-} + +instance GFields V1 where + gfields v _ = case v of {} + {-# INLINE gfields #-} + +instance Fields a => GFields (K1 i a) where + gfields (K1 x) = fields x + {-# INLINE gfields #-} + +statsToEntries :: Stats -> [(Text, Text)] +statsToEntries (Stats rts) = fields rts "stats" [] + +#if MIN_VERSION_base(4,10,0) + +newtype Stats = Stats RTSStats + +deriving instance Generic RTSStats +deriving instance Generic GCDetails +instance Fields RTSStats where fields = genericFields +instance Fields GCDetails where fields = genericFields + +getStats :: IO (Maybe Stats) +getStats = + do enabled <- getRTSStatsEnabled + if enabled then Just . Stats <$> getRTSStats + else pure Nothing + +#else + +newtype Stats = Stats GCStats + +deriving instance Generic GCStats +instance Fields GCStats where fields = genericFields + +getStats :: IO (Maybe Stats) +getStats = + do enabled <- getGCStatsEnabled + if enabled then Just . Stats <$> getGCStats + else pure Nothing + +#endif