glirc 2.21.1 → 2.22

raw patch · 29 files changed

+1228/−465 lines, 29 filesdep ~config-schemadep ~irc-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: config-schema, irc-core

API changes (from Hackage documentation)

Files

• ChangeLog.md +18/−0
• glirc.cabal +6/−4
• src/Client/Commands.hs +343/−49
• src/Client/Configuration.hs +41/−6
• src/Client/Image/Layout.hs +10/−5
• src/Client/Image/LineWrap.hs +44/−30
• src/Client/Image/Message.hs +228/−112
• src/Client/Image/PackedImage.hs +10/−1
• src/Client/Image/StatusLine.hs +80/−75
• src/Client/Log.hs +1/−8
• src/Client/State.hs +26/−13
• src/Client/State/Channel.hs +1/−1
• src/Client/State/Focus.hs +2/−1
• src/Client/State/Network.hs +17/−10
• src/Client/State/Window.hs +74/−6
• src/Client/View.hs +5/−3
• src/Client/View/ChannelInfo.hs +11/−13
• src/Client/View/Digraphs.hs +6/−5
• src/Client/View/Help.hs +15/−13
• src/Client/View/KeyMap.hs +5/−4
• src/Client/View/MaskList.hs +12/−11
• src/Client/View/Mentions.hs +11/−7
• src/Client/View/Messages.hs +32/−30
• src/Client/View/Palette.hs +7/−7
• src/Client/View/RtsStats.hs +36/−0
• src/Client/View/UrlSelection.hs +22/−14
• src/Client/View/UserList.hs +32/−25
• src/Client/View/Windows.hs +13/−12
• src/RtsStats.hs +120/−0

@@ -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

@@ -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,

@@ -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

@@ -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

@@ -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 ::

@@ -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 

@@ -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)) <>

@@ -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) ' ')

@@ -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

@@ -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"       }

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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 ] 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -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 =

@@ -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