glirc 2.16 → 2.17

raw patch · 25 files changed

+1023/−550 lines, 25 filesdep ~vtyPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: vty

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−0
• README.md +11/−2
• exec/Main.hs +14/−8
• glirc.cabal +7/−1
• src/Client/CApi/Types.hsc +20/−6
• src/Client/Commands.hs +327/−217
• src/Client/Commands/WordCompletion.hs +39/−16
• src/Client/Configuration.hs +12/−1
• src/Client/Configuration/ServerSettings.hs +10/−0
• src/Client/EventLoop.hs +152/−141
• src/Client/EventLoop/Errors.hs +0/−11
• src/Client/Image.hs +80/−28
• src/Client/Image/Message.hs +13/−2
• src/Client/Image/MircFormatting.hs +0/−1
• src/Client/Image/StatusLine.hs +83/−41
• src/Client/Image/Textbox.hs +1/−1
• src/Client/Options.hs +5/−0
• src/Client/State.hs +64/−52
• src/Client/State/Focus.hs +10/−1
• src/Client/State/Network.hs +50/−0
• src/Client/View.hs +3/−2
• src/Client/View/Help.hs +16/−8
• src/Client/View/UrlSelection.hs +37/−0
• src/Client/View/Windows.hs +35/−8
• src/Config/FromConfig.hs +25/−3

@@ -1,5 +1,14 @@ # Revision history for glirc2 +## 2.17++* Add `reconnect-attempts` setting+* Add peristence for `/grep` and `/grepi`+* Add filter argument to `/windows`+* Better tab completion for `/channel` and `/focus`+* Isolate and number urls in view with `/url`+* Map `M-Left` and `M-Right` to backward word and forward word+ ## 2.16  * Add `/splits` to show multiple chat windows simultaneously

@@ -3,6 +3,8 @@  [![Build Status](https://secure.travis-ci.org/glguy/irc-core.svg)](http://travis-ci.org/glguy/irc-core) +[Wiki Documentation](https://github.com/glguy/irc-core/wiki)+ ![](https://raw.githubusercontent.com/wiki/glguy/irc-core/images/screenshot.png)  Building@@ -31,7 +33,7 @@ $ cabal build ``` -Building with stack using ghc-8 resolver (nightly resolvers can work using --solver)+Building with stack using ghc-8 resolver (lts-7 resolvers can work using --solver)  ``` $ stack init --resolver=ghc-8@@ -73,6 +75,7 @@ ``` glirc [FLAGS] INITIAL_NETWORKS...   -c PATH  --config=PATH  Configuration file path+  -!       --noconnect    Disable autoconnecting   -h       --help         Show help   -v       --version      Show version ```@@ -176,6 +179,7 @@ | `url-opener`       | text                | Command to execute with URL parameter for `/url` e.g. gnome-open on GNOME or open on macOS | | `ignores`          | list of text        | Initial list of nicknames to ignore                                                        | | `activity-bar`     | yes or no           | Initial setting for visibility of activity bar (default no)                                |+| `macros`           | list of macros      | User-configurable client commands                                                          |  Server Settings ---------------@@ -202,6 +206,9 @@ | `flood-penalty`       | number               | cost in seconds per message                                    | | `flood-threshold`     | number               | threshold in seconds for burst                                 | | `message-hooks`       | list of text         | names of hooks to enable                                       |+| `reconnect-attempts`  | int                  | number of reconnections to attempt on error                    |+| `autoconnect`         | yes or no            | automatically connect at client startup                        |+| `nick-completion`     | default or slack     | set this to slack to use `@` sigils when completing nicks      |  Palette -------@@ -263,7 +270,7 @@ * `/disconnect` - Forcefully terminate connection to the current server * `/reconnect` - Reconnect to the current server * `/reload [path]` - Load a new configuration file (optional path)-* `/windows` - List all open windows+* `/windows [filter]` - List all open windows (filters: networks, channels, users) * `/palette` - Show the client palette * `/mentions` - Show all the highlighted lines across all windows * `/extension <extension name> <params...>` - Send the given params to the named extension@@ -367,6 +374,8 @@ * `C-t` swap characters at cursor * `M-f` forward word * `M-b` backward word+* `M-Right` forward word+* `M-Left` backward word * `M-Backspace` delete word backwards * `M-d` delete word forwards * `M-Enter` insert newline

@@ -13,6 +13,7 @@ import Control.Concurrent import Control.Lens import Control.Monad+import Data.List (nub) import Data.Text (Text) import System.Exit import System.IO@@ -31,9 +32,16 @@      runInUnboundThread $        withClientState cfg $        clientStartExtensions >=>-       addInitialNetworks (view optInitialNetworks opts) >=>+       initialNetworkLogic opts >=>        eventLoop +initialNetworkLogic :: Options -> ClientState -> IO ClientState+initialNetworkLogic opts st+  | view optNoConnect opts = return st+  | otherwise              = addInitialNetworks networks st+  where+    networks = nub (clientAutoconnects st ++ view optInitialNetworks opts)+ -- | Load configuration and handle errors along the way. loadConfiguration' :: Maybe FilePath -> IO Configuration loadConfiguration' path =@@ -52,15 +60,13 @@          hPutStrLn stderr msg          exitFailure --- | Create connections for all the networks on the command line.+-- | Create connections for the given networks. -- Set the client focus to the first network listed. addInitialNetworks ::   [Text] {- networks -} ->   ClientState           ->   IO ClientState-addInitialNetworks networks st =-  case networks of-    []        -> return st-    network:_ ->-      do st' <- foldM (flip (addConnection 0 Nothing)) st networks-         return (set clientFocus (NetworkFocus network) st')+addInitialNetworks [] st = return st+addInitialNetworks (n:ns) st =+  do st' <- foldM (flip (addConnection 0 Nothing)) st (n:ns)+     return $! set clientFocus (NetworkFocus n) st'

@@ -1,7 +1,12 @@ name:                glirc-version:             2.16+version:             2.17 synopsis:            Console IRC client description:         Console IRC client+                     .+                     glirc is a console IRC client with an emphasis on providing+                     dynamic views into the model of your IRC connections.+                     .+                     <https://github.com/glguy/irc-core/wiki Documentation Wiki> license:             ISC license-file:        LICENSE author:              Eric Mertens@@ -91,6 +96,7 @@                        Client.View.Mentions                        Client.View.Messages                        Client.View.Palette+                       Client.View.UrlSelection                        Client.View.UserList                        Client.View.Windows                        Config.FromConfig

@@ -48,28 +48,42 @@ import Foreign.Ptr import Foreign.Storable +-- | Tag for describing the kind of message to display in the client+-- as used in `glirc_print`.+--+-- @enum message_code;@ newtype MessageCode = MessageCode CInt deriving Eq #enum MessageCode, MessageCode, NORMAL_MESSAGE, ERROR_MESSAGE +-- | Result used to determine what to do after processing a message with+-- the 'ProcessMessage' callback.+--+-- @enum process_result;@ newtype MessageResult = MessageResult CInt deriving Eq #enum MessageResult, MessageResult, PASS_MESSAGE, DROP_MESSAGE +--++-- | @typedef void *start(void *glirc, const char *path);@ type StartExtension =   Ptr ()      {- ^ api token                   -} ->   CString     {- ^ path to extension           -} ->   IO (Ptr ()) {- ^ initialized extension state -} +-- | @typedef void stop(void *glirc, void *S);@ type StopExtension =   Ptr () {- ^ api token       -} ->   Ptr () {- ^ extension state -} ->   IO () +-- | Type of @typedef enum process_result process_message(void *glirc, void *S, const struct glirc_message *);@ type ProcessMessage =   Ptr ()     {- ^ api token       -} ->   Ptr ()     {- ^ extention state -} ->   Ptr FgnMsg {- ^ message to send -} ->   IO MessageResult +-- | @typedef void process_command(void *glirc, void *S, const struct glirc_command *);@ type ProcessCommand =   Ptr ()     {- ^ api token       -} ->   Ptr ()     {- ^ extension state -} ->@@ -86,14 +100,14 @@  ------------------------------------------------------------------------ --- | @struct glirc_extension@+-- | @struct glirc_extension;@ data FgnExtension = FgnExtension-  { fgnStart   :: FunPtr StartExtension -- ^ Optional callback-  , fgnStop    :: FunPtr StopExtension  -- ^ Optional callback-  , fgnMessage :: FunPtr ProcessMessage -- ^ Optional callback-  , fgnCommand :: FunPtr ProcessCommand -- ^ Optional callback+  { fgnStart   :: FunPtr StartExtension -- ^ Optional startup callback+  , fgnStop    :: FunPtr StopExtension  -- ^ Optional shutdown callback+  , fgnMessage :: FunPtr ProcessMessage -- ^ Optional message received callback+  , fgnCommand :: FunPtr ProcessCommand -- ^ Optional client command callback   , fgnName    :: CString               -- ^ Null-terminated name-  , fgnMajorVersion, fgnMinorVersion :: CInt+  , fgnMajorVersion, fgnMinorVersion :: CInt -- ^ extension version   }  instance Storable FgnExtension where

@@ -31,7 +31,6 @@ import           Client.Commands.Recognizer import           Client.Commands.WordCompletion import           Client.Configuration-import           Client.Configuration.ServerSettings import           Client.Message import           Client.State import           Client.State.Channel@@ -64,6 +63,7 @@ import           System.Process import           Text.Read import           Text.Regex.TDFA+import           Text.Regex.TDFA.String (compile)  -- | Possible results of running a command data CommandResult@@ -98,9 +98,21 @@   -- | requires an active channel window   | ChannelCommand (ChannelCommand a) (Bool -> ChannelCommand String) --- | A command is an argument specification, implementation, and documentation-data Command = forall a. Command (ArgumentSpec a) Text (CommandImpl a) +-- | A command is a list of aliases, an argument specification, implementation,+-- and documentation. The arguments and implementation must match so that+-- the parsed arguments will match what the implementation expects.+data Command = forall a. Command+  -- | Names of this command, first in the list is the "primary" name+  { cmdNames          :: NonEmpty Text+  -- | Specification of the arguments of the command+  , cmdArgumentSpec   :: ArgumentSpec a+  -- | Multi-line IRC-formatted documentation text used for @/help@+  , cmdDocumentation  :: Text+  -- | Implementation of the command for both execution and tab completion+  , cmdImplementation :: CommandImpl a+  }+ -- | Consider the text entry successful and resume the client commandSuccess :: Monad m => ClientState -> m CommandResult commandSuccess = return . CommandSuccess@@ -224,7 +236,7 @@   in   case recognize cmdTxt commands of -    Exact (Command argSpec _docs impl) ->+    Exact Command{cmdImplementation=impl, cmdArgumentSpec=argSpec} ->       case impl of         ClientCommand exec tab ->           finish argSpec exec tab@@ -254,8 +266,9 @@   -- | Expands each alias to have its own copy of the command callbacks-expandAliases :: [(NonEmpty a,b)] -> [(a,b)]-expandAliases xs = [ (a,b) | (as,b) <- xs, a <- toList as ]+expandAliases :: [Command] -> [(Text,Command)]+expandAliases xs =+  [ (name, cmd) | cmd <- xs, name <- toList (cmdNames cmd) ]   -- | Map of built-in client commands to their implementations, tab completion@@ -263,25 +276,28 @@ commands :: Recognizer Command commands = fromCommands (expandAliases commandsList) -commandsList :: [(NonEmpty Text,Command)]+commandsList :: [Command] commandsList =   --   -- Client commands   ---  [ ( pure "connect"-    , Command (ReqTokenArg "network" NoArg)+  [ Command+      (pure "connect")+      (ReqTokenArg "network" NoArg)       "Connect to \^Bnetwork\^B by name.\n\       \\n\       \If no name is configured the hostname is the 'name'.\n"     $ ClientCommand cmdConnect tabConnect-    )-  , ( pure "exit"-    , Command NoArg++  , Command+      (pure "exit")+      NoArg       "Exit the client immediately.\n"     $ ClientCommand cmdExit noClientTab-    )-  , ( pure "focus"-    , Command (ReqTokenArg "network" (OptTokenArg "channel" NoArg))++  , Command+      (pure "focus")+      (ReqTokenArg "network" (OptTokenArg "channel" NoArg))       "Change the focused window.\n\       \\n\       \When only \^Bnetwork\^B is specified this switches to the network status window.\n\@@ -290,9 +306,10 @@       \Nicknames can be specified in the \^Bchannel\^B parameter to switch to private chat.\n\       \See also: /channel (aliased /c) to switch to a channel on the current network.\n"     $ ClientCommand cmdFocus tabFocus-    )-  , ( pure "clear"-    , Command (OptTokenArg "network" (OptTokenArg "channel" NoArg))++  , Command+      (pure "clear")+      (OptTokenArg "network" (OptTokenArg "channel" NoArg))       "Clear a window.\n\       \\n\       \If no arguments are provided the current window is cleared.\n\@@ -300,50 +317,61 @@       \If \^Bnetwork\^B and \^Bchannel\^B are provided that chat window is cleared.\n\       \\n\       \If a window is cleared and no longer active that window will be removed from the client.\n"-    $ ClientCommand cmdClear noClientTab-    )-  , ( pure "reconnect"-    , Command NoArg+    $ ClientCommand cmdClear tabFocus++  , Command+      (pure "reconnect")+      NoArg       "Reconnect to the current network.\n"     $ ClientCommand cmdReconnect noClientTab-    )-  , ( pure "ignore"-    , Command (RemainingArg "nicks")++  , Command+      (pure "ignore")+      (RemainingArg "nicks")       "Toggle the soft-ignore on each of the space-delimited given nicknames.\n"     $ ClientCommand cmdIgnore simpleClientTab-    )-  , ( pure "reload"-    , Command (OptTokenArg "filename" NoArg)++  , Command+      (pure "reload")+      (OptTokenArg "filename" NoArg)       "Reload the client configuration file.\n\       \\n\       \If \^Bfilename\^B is provided it will be used to reload.\n\       \Otherwise the previously loaded configuration file will be reloaded.\n"     $ ClientCommand cmdReload tabReload-    )-  , ( pure "extension"-    , Command (ReqTokenArg "extension" (RemainingArg "arguments"))++  , Command+      (pure "extension")+      (ReqTokenArg "extension" (RemainingArg "arguments"))       "Calls the process_command callback of the given extension.\n\       \\n\       \\^Bextension\^B should be the name of the loaded extension.\n"     $ ClientCommand cmdExtension simpleClientTab-    )-  , ( pure "windows"-    , Command NoArg-      "Show a list of all client message windows.\n"-    $ ClientCommand cmdWindows noClientTab-    )-  , ( pure "mentions"-    , Command NoArg++  , Command+      (pure "windows")+      (OptTokenArg "kind" NoArg)+      "Show a list of all windows with an optional argument to limit the kinds of windows listed.\n\+      \\n\+      \\^Bkind\^O: one of \^Bnetworks\^O, \^Bchannels\^O, \^Busers\^O\n\+      \\n"+    $ ClientCommand cmdWindows tabWindows++  , Command+      (pure "mentions")+      NoArg       "Show a list of all message that were highlighted as important.\n"     $ ClientCommand cmdMentions noClientTab-    )-  , ( pure "palette"-    , Command NoArg++  , Command+      (pure "palette")+      NoArg       "Show the current palette settings and a color chart to help pick new colors.\n"     $ ClientCommand cmdPalette noClientTab-    )-  , ( pure "exec"-    , Command (RemainingArg "arguments")++  , Command+      (pure "exec")+      (RemainingArg "arguments")       "Execute a command synchnonously sending the to a configuration destination.\n\       \\n\       \\^Barguments\^B: [-n network] [-c channel] [-i input] command [command arguments...]\n\@@ -360,9 +388,10 @@       \ escaped characters and spaces inside.\n\       \\n"     $ ClientCommand cmdExec simpleClientTab-    )-  , ( pure "url"-    , Command (OptTokenArg "number" NoArg)++  , Command+      (pure "url")+      (OptTokenArg "number" NoArg)       "Open a URL seen in chat.\n\       \\n\       \The URL is opened using the executable configured under \^Burl-opener\^B.\n\@@ -371,48 +400,75 @@       \\n\       \When \^Bnumber\^B is omitted it defaults to \^B1\^B. The number selects the URL to open counting back from the most recent.\n"     $ ClientCommand cmdUrl noClientTab-    ) -  , ( pure "help"-    , Command (OptTokenArg "command" NoArg)+  , Command+      (pure "help")+      (OptTokenArg "command" NoArg)       "Show command documentation.\n\       \\n\       \When \^Bcommand\^B is omitted a list of all commands is displayed.\n\       \When \^Bcommand\^B is specified detailed help for that command is shown.\n"     $ ClientCommand cmdHelp tabHelp-    ) -  , ( pure "splits"-    , Command (RemainingArg "focuses")+  , Command+      (pure "splits")+      (RemainingArg "focuses")       "Set the extra message view splits.\n\       \\n\-      \\^Bfocues\^B: space delimited list of focus names.\n\+      \\^Bfocuses\^B: space delimited 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"+      \User:    \^BNETWORK\^B:\^BNICK\^B\n\+      \\n\+      \Not providing an argument unsplits the current windows.\n"     $ ClientCommand cmdSplits tabSplits-    ) +  , Command+      (pure "grep")+      (RemainingArg "regular-expression")+      "Set the persistent regular expression.\n\+      \\n\+      \Clear the regular expression by calling this without an argument.\n\+      \\n\+      \\^B/grep\^O is case-sensitive.\n\+      \\^B/grepi\^O is case-insensitive.\n"+    $ ClientCommand (cmdGrep True) simpleClientTab++  , Command+      (pure "grepi")+      (RemainingArg "regular-expression")+      "Set the persistent regular expression.\n\+      \\n\+      \Clear the regular expression by calling this without an argument.\n\+      \\n\+      \\^B/grep\^O is case-sensitive.\n\+      \\^B/grepi\^O is case-insensitive.\n"+    $ ClientCommand (cmdGrep False) simpleClientTab++   --   -- Network commands   ---  , ( pure "quote"-    , Command (RemainingArg "raw IRC command")+  , Command+      (pure "quote")+      (RemainingArg "raw IRC command")       "Send a raw IRC command.\n"     $ NetworkCommand cmdQuote  simpleNetworkTab-    )-  , ( "join" :| ["j"]-    , Command (ReqTokenArg "channels" (OptTokenArg "keys" NoArg))++  , Command+      ("join" :| ["j"])+      (ReqTokenArg "channels" (OptTokenArg "keys" NoArg))       "Join a chat channel.\n\       \\n\       \\^Bchannels\^B: comma-separated list of channels\n\       \\^Bkeys\^B: comma-separated list of keys\n"     $ NetworkCommand cmdJoin   simpleNetworkTab-    )-  , ( "channel" :| ["c"]-    , Command (ReqTokenArg "channel" NoArg)++  , Command+      ("channel" :| ["c"])+      (ReqTokenArg "channel" NoArg)       "Change the focused window.\n\       \\n\       \Changes the focus to the \^Bchannel\^B chat window on the current network.\n\@@ -420,10 +476,11 @@       \Nicknames can be specified in the \^Bchannel\^B parameter to switch to private chat.\n\       \See also: /focus to switch to a channel on a different network.\n\       \See also: /focus to switch to a channel on a different network.\n"-    $ NetworkCommand cmdChannel simpleNetworkTab-    )-  , ( pure "mode"-    , Command (RemainingArg "modes and parameters")+    $ NetworkCommand cmdChannel tabChannel++  , Command+      (pure "mode")+      (RemainingArg "modes and parameters")       "Sets IRC modes.\n\       \\n\       \Examples:\n\@@ -437,23 +494,26 @@       \\n\       \This command has parameter sensitive tab-completion.\n"     $ NetworkCommand cmdMode   tabMode-    )-  , ( pure "msg"-    , Command (ReqTokenArg "target" (RemainingArg "message"))++  , Command+      (pure "msg")+      (ReqTokenArg "target" (RemainingArg "message"))       "Send a chat message to a user or a channel.\n\       \\n\       \\^Btarget\^B can be a channel or nickname.\n"     $ NetworkCommand cmdMsg    simpleNetworkTab-    )-  , ( pure "notice"-    , Command (ReqTokenArg "target" (RemainingArg "message"))++  , Command+      (pure "notice")+      (ReqTokenArg "target" (RemainingArg "message"))       "Send a notice message to a user or a channel. Notices are typically used by bots.\n\       \\n\       \\^Btarget\^B can be a channel or nickname.\n"     $ NetworkCommand cmdNotice simpleNetworkTab-    )-  , ( pure "ctcp"-    , Command (ReqTokenArg "target" (ReqTokenArg "command" (RemainingArg "arguments")))++  , Command+      (pure "ctcp")+      (ReqTokenArg "target" (ReqTokenArg "command" (RemainingArg "arguments")))       "Send a CTCP command to a user or a channel.\n\       \\n\       \Examples:\n\@@ -464,84 +524,98 @@       \\^Bcommand\^B can be any CTCP command.\n\       \\^Barguments\^B are specific to a particular command.\n"     $ NetworkCommand cmdCtcp simpleNetworkTab-    )-  , ( pure "nick"-    , Command (ReqTokenArg "nick" NoArg)++  , Command+      (pure "nick")+      (ReqTokenArg "nick" NoArg)       "Change your nickname.\n"     $ NetworkCommand cmdNick   simpleNetworkTab-    )-  , ( pure "quit"-    , Command (RemainingArg "reason")++  , Command+      (pure "quit")+      (RemainingArg "reason")       "Gracefully disconnect the current network connection.\n\       \\n\       \\^Breason\^B: optional quit reason\n\       \\n\       \See also: /disconnect /exit\n"     $ NetworkCommand cmdQuit   simpleNetworkTab-    )-  , ( pure "disconnect"-    , Command NoArg++  , Command+      (pure "disconnect")+      NoArg       "Immediately terminate the current network connection.\n\       \\n\       \See also: /quit /exit\n"     $ NetworkCommand cmdDisconnect noNetworkTab-    )-  , ( pure "who"-    , Command (RemainingArg "arguments")++  , Command+      (pure "who")+      (RemainingArg "arguments")       "Send WHO query to server with given arguments.\n"     $ NetworkCommand cmdWho simpleNetworkTab-    )-  , ( pure "whois"-    , Command (RemainingArg "arguments")++  , Command+      (pure "whois")+      (RemainingArg "arguments")       "Send WHOIS query to server with given arguments.\n"     $ NetworkCommand cmdWhois simpleNetworkTab-    )-  , ( pure "whowas"-    , Command (RemainingArg "arguments")++  , Command+      (pure "whowas")+      (RemainingArg "arguments")       "Send WHOWAS query to server with given arguments.\n"     $ NetworkCommand cmdWhowas simpleNetworkTab-    )-  , ( pure "ison"-    , Command (RemainingArg "arguments")++  , Command+      (pure "ison")+      (RemainingArg "arguments")       "Send ISON query to server with given arguments.\n"     $ NetworkCommand cmdIson   simpleNetworkTab-    )-  , ( pure "userhost"-    , Command (RemainingArg "arguments")++  , Command+      (pure "userhost")+      (RemainingArg "arguments")       "Send USERHOST query to server with given arguments.\n"     $ NetworkCommand cmdUserhost simpleNetworkTab-    )-  , ( pure "away"-    , Command (RemainingArg "message")++  , Command+      (pure "away")+      (RemainingArg "message")       "Set away status.\n\       \\n\       \When \^Bmessage\^B is omitted away status is cleared.\n"-    $ NetworkCommand cmdAway   simpleNetworkTab-    )-  , ( pure "links"-    , Command (RemainingArg "arguments")+    $ NetworkCommand cmdAway simpleNetworkTab++  , Command+      (pure "links")+      (RemainingArg "arguments")       "Send LINKS query to server with given arguments.\n"-    $ NetworkCommand cmdLinks  simpleNetworkTab-    )-  , ( pure "time"-    , Command (RemainingArg "arguments")+    $ NetworkCommand cmdLinks simpleNetworkTab++  , Command+      (pure "time")+      (RemainingArg "arguments")       "Send TIME query to server with given arguments.\n"-    $ NetworkCommand cmdTime   simpleNetworkTab-    )-  , ( pure "stats"-    , Command (RemainingArg "arguments")+    $ NetworkCommand cmdTime simpleNetworkTab++  , Command+      (pure "stats")+      (RemainingArg "arguments")       "Send STATS query to server with given arguments.\n"-    $ NetworkCommand cmdStats  simpleNetworkTab-    )-  , ( pure "znc"-    , Command (RemainingArg "arguments")+    $ NetworkCommand cmdStats simpleNetworkTab++  , Command+      (pure "znc")+      (RemainingArg "arguments")       "Send command directly to ZNC.\n\       \\n\       \The advantage of this over /msg is that responses are not broadcast to call clients.\n"-    $ NetworkCommand cmdZnc    simpleNetworkTab-    )-  , ( pure "znc-playback"-    , Command (OptTokenArg "time" (OptTokenArg "date" NoArg))+    $ NetworkCommand cmdZnc simpleNetworkTab++  , Command+      (pure "znc-playback")+      (OptTokenArg "time" (OptTokenArg "date" NoArg))       "Request playback from the ZNC 'playback' module.\n\       \\n\       \\^Btime\^B determines the time to playback since.\n\@@ -555,64 +629,71 @@       \\n\       \Note that the playback module is not installed in ZNC by default!\n"     $ NetworkCommand cmdZncPlayback noNetworkTab-    ) -  , ( pure "invite"-    , Command (ReqTokenArg "nick" NoArg)+  , Command+      (pure "invite")+      (ReqTokenArg "nick" NoArg)       "Invite a user to the current channel.\n"     $ ChannelCommand cmdInvite simpleChannelTab-    )-  , ( pure "topic"-    , Command (RemainingArg "message")++  , Command+      (pure "topic")+      (RemainingArg "message")       "Set the topic on the current channel.\n\       \\n\       \Tab-completion with no \^Bmessage\^B specified will load the current topic for editing.\n"     $ ChannelCommand cmdTopic tabTopic-    )-  , ( pure "kick"-    , Command (ReqTokenArg "nick" (RemainingArg "reason"))++  , Command+      (pure "kick")+      (ReqTokenArg "nick" (RemainingArg "reason"))       "Kick a user from the current channel.\n\       \\n\       \See also: /kickban /remove\n"     $ ChannelCommand cmdKick   simpleChannelTab-    )-  , ( pure "kickban"-    , Command (ReqTokenArg "nick" (RemainingArg "reason"))++  , Command+      (pure "kickban")+      (ReqTokenArg "nick" (RemainingArg "reason"))       "Ban and kick a user from the current channel.\n\       \\n\       \Users are banned by hostname match.\n\       \See also: /kick /remove\n"     $ ChannelCommand cmdKickBan simpleChannelTab-    )-  , ( pure "remove"-    , Command (ReqTokenArg "nick" (RemainingArg "reason"))++  , Command+      (pure "remove")+      (ReqTokenArg "nick" (RemainingArg "reason"))       "Remove a user from the current channel.\n\       \\n\       \Remove works like /kick except it results in a PART.\n\       \See also: /kick /kickban\n"     $ ChannelCommand cmdRemove simpleChannelTab-    )-  , ( pure "part"-    , Command (RemainingArg "reason")++  , Command+      (pure "part")+      (RemainingArg "reason")       "Part from the current channel.\n"     $ ChannelCommand cmdPart simpleChannelTab-    ) -  , ( pure "users"-    , Command NoArg+  , Command+      (pure "users")+      NoArg       "Show the user list for the current channel.\n\       \\n\       \Detailed view (F2) shows full hostmask.\n\       \Hostmasks can be populated with /who #channel.\n"     $ ChannelCommand cmdUsers  noChannelTab-    )-  , ( pure "channelinfo"-    , Command NoArg++  , Command+      (pure "channelinfo")+      NoArg       "Show information about the current channel.\n"     $ ChannelCommand cmdChannelInfo noChannelTab-    )-  , ( pure "masks"-    , Command (ReqTokenArg "mode" NoArg)++  , Command+      (pure "masks")+      (ReqTokenArg "mode" NoArg)       "Show mask lists for current channel.\n\       \\n\       \Common \^Bmode\^B values:\n\@@ -623,20 +704,20 @@       \\n\       \To populate the mask lists for the first time use: /mode \^Bmode\^B\n"     $ ChannelCommand cmdMasks noChannelTab-    ) -  , ( pure "me"-    , Command (RemainingArg "message")+  , Command+      (pure "me")+      (RemainingArg "message")       "Send an 'action' to the current chat window.\n"     $ ChatCommand cmdMe simpleChannelTab-    )-  , ( pure "say"-    , Command (RemainingArg "message")++  , Command+      (pure "say")+      (RemainingArg "message")       "Send a message to the current chat window.\n\       \\n\       \This can be useful for sending a chat message with a leading '/'.\n"     $ ChatCommand cmdSay simpleChannelTab-    )   ]  -- | Provides no tab completion for client commands@@ -683,16 +764,17 @@     Just (network, Just (channel, _)) ->         clearFocus (ChannelFocus (Text.pack network) (mkId (Text.pack channel)))   where-    clearFocus focus = commandSuccess (windowEffect st)+    clearFocus focus = commandSuccess (focusEffect (windowEffect st))       where         windowEffect-          | isActive  = clearWindow-          | otherwise = deleteWindow+          | isActive  = setWindow (Just emptyWindow)+          | otherwise = setWindow Nothing -        deleteWindow = advanceFocus . setWindow Nothing-        clearWindow  =                setWindow (Just emptyWindow)+        focusEffect+          | not isActive && view clientFocus st == focus = advanceFocus+          | otherwise                                    = id -        setWindow = set (clientWindows . at (view clientFocus st))+        setWindow = set (clientWindows . at focus)          isActive =           case focus of@@ -823,9 +905,27 @@          commandSuccess            $ changeFocus focus st ++tabWindows :: Bool -> ClientCommand String+tabWindows isReversed st _ =+  simpleTabCompletion plainWordCompleteMode [] completions isReversed st+  where+    completions = ["networks","channels","users"] :: [Text]++ -- | Implementation of @/windows@ command. Set subfocus to Windows.-cmdWindows :: ClientCommand ()-cmdWindows st _ = commandSuccess (changeSubfocus FocusWindows st)+cmdWindows :: ClientCommand (Maybe (String, ()))+cmdWindows st arg =+  case arg of+    Nothing             -> success AllWindows+    Just ("networks",_) -> success NetworkWindows+    Just ("channels",_) -> success ChannelWindows+    Just ("users"   ,_) -> success UserWindows+    _                   -> commandFailureMsg errmsg st+  where+    errmsg = "/windows expected networks, channels, or users"+    success x =+      commandSuccess (changeSubfocus (FocusWindows x) st)  -- | Implementation of @/mentions@ command. Set subfocus to Windows. cmdMentions :: ClientCommand ()@@ -849,7 +949,8 @@             newline = Edit.endLine cmd         commandSuccess (set (clientTextBox . Edit.line) newline st) -  | otherwise = simpleTabCompletion id [] completions isReversed st+  | otherwise =+        simpleTabCompletion plainWordCompleteMode [] completions isReversed st   where     currentExtras = view clientExtraFocus st @@ -874,28 +975,30 @@         (net,_:chan) -> ChannelFocus (Text.pack net) (mkId (Text.pack chan))  tabHelp :: Bool -> ClientCommand String-tabHelp isReversed st _ = simpleTabCompletion id [] commandNames isReversed st+tabHelp isReversed st _ =+  simpleTabCompletion plainWordCompleteMode [] commandNames isReversed st   where-    commandNames = [ cmd | (cmd :| _, _) <- commandsList ]+    commandNames = fst <$> expandAliases commandsList  simpleTabCompletion ::   Prefix a =>-  (String -> String) {- ^ leading transform -} ->-  [a] {- ^ hints           -} ->-  [a] {- ^ all completions -} ->-  Bool {- ^ reversed order -} ->-  ClientState -> IO CommandResult-simpleTabCompletion lead hints completions isReversed st =+  WordCompletionMode {- ^ word completion mode -} ->+  [a]                {- ^ hints                -} ->+  [a]                {- ^ all completions      -} ->+  Bool               {- ^ reversed order       -} ->+  ClientState        {- ^ client state         -} ->+  IO CommandResult+simpleTabCompletion mode hints completions isReversed st =   case traverseOf clientTextBox tryCompletion st of     Nothing  -> commandFailure st     Just st' -> commandSuccess st'   where-    tryCompletion = wordComplete lead isReversed hints completions+    tryCompletion = wordComplete mode isReversed hints completions  -- | @/connect@ tab completes known server names tabConnect :: Bool -> ClientCommand String tabConnect isReversed st _ =-  simpleTabCompletion id [] networks isReversed st+  simpleTabCompletion plainWordCompleteMode [] networks isReversed st   where     networks = views clientNetworkMap               HashMap.keys st             ++ views (clientConfig . configServers) HashMap.keys st@@ -905,14 +1008,16 @@ -- the current networks are used. tabFocus :: Bool -> ClientCommand String tabFocus isReversed st _ =-  simpleTabCompletion id [] completions isReversed st+  simpleTabCompletion plainWordCompleteMode [] completions isReversed st   where     networks   = map mkId $ HashMap.keys $ view clientNetworkMap st     params     = words $ uncurry take $ clientLine st -    completions-      | length params == 2 = networks-      | otherwise          = currentCompletionList st+    completions =+      case params of+        [_cmd,_net]      -> networks+        [_cmd,net,_chan] -> channelWindowsOnNetwork (Text.pack net) st+        _                -> []  cmdWhois :: NetworkCommand String cmdWhois cs st rest =@@ -931,7 +1036,7 @@  cmdIson :: NetworkCommand String cmdIson cs st rest =-  do sendMsg cs (ircIson (Text.pack <$> words rest))+  do sendMsg cs (ircIson [Text.pack (unwords (words rest))])      commandSuccess st  cmdUserhost :: NetworkCommand String@@ -1038,20 +1143,13 @@  commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult commandSuccessUpdateCS cs st =-  let networkId = view csNetworkId cs in-  commandSuccess-    $ setStrict (clientConnections . ix networkId) cs st+  do let networkId = view csNetworkId cs+     commandSuccess+       $ setStrict (clientConnections . ix networkId) cs st  cmdTopic :: ChannelCommand String cmdTopic channelId cs st rest =-  do let cmd =-           case rest of-             ""    -> ircTopic channelId ""-             topic | useChanServ channelId cs ->-                        ircPrivmsg "ChanServ"-                          ("TOPIC " <> idText channelId <> Text.pack (' ' : topic))-                   | otherwise -> ircTopic channelId (Text.pack topic)-     sendMsg cs cmd+  do sendTopic channelId (Text.pack rest) cs      commandSuccess st  tabTopic ::@@ -1130,7 +1228,26 @@   commandSuccess     $ changeFocus (ChannelFocus (view csNetwork cs) (mkId (Text.pack channel))) st +-- | Tab completion for @/channel@+tabChannel ::+  Bool {- ^ reversed order -} ->+  NetworkCommand String+tabChannel isReversed cs st _ =+  simpleTabCompletion plainWordCompleteMode [] completions isReversed st+  where+    completions = channelWindowsOnNetwork (view csNetwork cs) st +-- | Return the list of identifiers for open channel windows on+-- the given network name.+channelWindowsOnNetwork ::+  Text         {- ^ network              -} ->+  ClientState  {- ^ client state         -} ->+  [Identifier] {- ^ open channel windows -}+channelWindowsOnNetwork network st =+  [ chan | ChannelFocus net chan <- Map.keys (view clientWindows st)+         , net == network ]++ cmdQuit :: NetworkCommand String cmdQuit cs st rest =   do let msg = Text.pack rest@@ -1246,7 +1363,7 @@               [ (pol,mode) | (pol,mode,arg) <- parsedModes, not (Text.null arg) ]       , (pol,mode):_      <- drop (paramIndex-3) parsedModesWithParams       , let (hint, completions) = computeModeCompletion pol mode channel cs st-      -> simpleTabCompletion id hint completions isReversed st+      -> simpleTabCompletion plainWordCompleteMode hint completions isReversed st      _ -> commandFailure st @@ -1315,7 +1432,7 @@ commandNameCompletion :: Bool -> ClientState -> Maybe ClientState commandNameCompletion isReversed st =   do guard (cursorPos == n)-     clientTextBox (wordComplete id isReversed [] possibilities) st+     clientTextBox (wordComplete plainWordCompleteMode isReversed [] possibilities) st   where     n = length leadingPart     (cursorPos, line) = clientLine st@@ -1328,30 +1445,11 @@ -- userlist for the currently focused channel (if any) nickTabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO CommandResult nickTabCompletion isReversed st =-  simpleTabCompletion (++": ") hint completions isReversed st+  simpleTabCompletion mode hint completions isReversed st   where     hint          = activeNicks st     completions   = currentCompletionList st---- | Used to send commands that require ops to perform.--- If this channel is one that the user has chanserv access and ops are needed--- then ops are requested and the commands are queued, otherwise send them--- directly.-sendModeration ::-  Identifier      {- ^ channel       -} ->-  [RawIrcMsg]     {- ^ commands      -} ->-  NetworkState    {- ^ network state -} ->-  IO NetworkState-sendModeration channel cmds cs-  | useChanServ channel cs =-      do sendMsg cs (ircPrivmsg "ChanServ" ("OP " <> idText channel))-         return $ csChannels . ix channel . chanQueuedModeration <>~ cmds $ cs-  | otherwise = cs <$ traverse_ (sendMsg cs) cmds--useChanServ :: Identifier -> NetworkState    -> Bool-useChanServ channel cs =-  channel `elem` view (csSettings . ssChanservChannels) cs &&-  not (iHaveOp channel cs)+    mode          = currentNickCompletionMode st  cmdExtension :: ClientCommand (String, String) cmdExtension st (name,params) =@@ -1440,6 +1538,7 @@     , _msgNetwork = ""     } ste + cmdUrl :: ClientCommand (Maybe (String, ())) cmdUrl st mbArg =   case view (clientConfig . configUrlOpener) st of@@ -1471,3 +1570,14 @@      case res of        Left e  -> commandFailureMsg (Text.pack (displayException (e :: IOError))) st        Right{} -> commandSuccess st++-- | Implementation of @/grep@ and @/grepi@+cmdGrep ::+  Bool {- ^ case sensitive -} ->+  ClientCommand String+cmdGrep sensitive st str+  | null str  = commandSuccess (set clientRegex Nothing st)+  | otherwise =+      case compile defaultCompOpt{caseSensitive=sensitive} defaultExecOpt str of+        Left e -> commandFailureMsg (Text.pack e) st+        Right r -> commandSuccess (set clientRegex (Just r) st)

@@ -11,13 +11,18 @@ module Client.Commands.WordCompletion   ( Prefix(..)   , wordComplete++  -- * Word completion modes+  , WordCompletionMode(..)+  , plainWordCompleteMode+  , defaultNickWordCompleteMode+  , slackNickWordCompleteMode   ) where  import qualified Client.State.EditBox as Edit import           Control.Applicative import           Control.Lens import           Control.Monad-import           Data.Char import           Data.List import qualified Data.Set as Set import           Data.String (IsString(..))@@ -25,6 +30,20 @@ import           Data.Text (Text) import           Irc.Identifier +-- | Word completion prefix and suffix+data WordCompletionMode = WordCompletionMode+  { wcmStartPrefix, wcmStartSuffix, wcmMiddlePrefix, wcmMiddleSuffix :: String }+  deriving Show++plainWordCompleteMode :: WordCompletionMode+plainWordCompleteMode = WordCompletionMode "" "" "" ""++defaultNickWordCompleteMode :: WordCompletionMode+defaultNickWordCompleteMode = WordCompletionMode "" ": " "" ""++slackNickWordCompleteMode :: WordCompletionMode+slackNickWordCompleteMode = WordCompletionMode "@" " " "@" ""+ -- | Perform word completion on a text box. -- -- The leading update operation is applied to the result of tab-completion@@ -37,13 +56,13 @@ -- completions. wordComplete ::   Prefix a =>-  (String -> String) {- ^ leading update operation -} ->+  WordCompletionMode {- ^ leading update operation -} ->   Bool               {- ^ reversed -} ->   [a]       {- ^ priority completions -} ->   [a]       {- ^ possible completions -} ->   Edit.EditBox -> Maybe Edit.EditBox-wordComplete leadingCase isReversed hint vals box =-  do let current = currentWord box+wordComplete mode isReversed hint vals box =+  do let current = currentWord mode box      guard (not (null current))      let cur = fromString current      case view Edit.lastOperation box of@@ -51,7 +70,7 @@          | isPrefix pat cur ->           do next <- tabSearch isReversed pat cur vals-            Just $ replaceWith leadingCase (toString next) box+            Just $ replaceWith mode (toString next) box          where            pat = fromString patternStr @@ -59,23 +78,27 @@          do next <- find (isPrefix cur) hint <|>                     tabSearch isReversed cur cur vals             Just $ set Edit.lastOperation (Edit.TabOperation current)-                 $ replaceWith leadingCase (toString next) box+                 $ replaceWith mode (toString next) box -replaceWith :: (String -> String) -> String -> Edit.EditBox -> Edit.EditBox-replaceWith leadingCase str box =+replaceWith :: WordCompletionMode -> String -> Edit.EditBox -> Edit.EditBox+replaceWith (WordCompletionMode spfx ssfx mpfx msfx) str box =     let box1 = Edit.killWordBackward False box-        str1 | view Edit.pos box1 == 0 = leadingCase str-             | otherwise               = str+        str1 | view Edit.pos box1 == 0 = spfx ++ str ++ ssfx+             | otherwise               = mpfx ++ str ++ msfx     in over Edit.content (Edit.insertString str1) box1 -currentWord :: Edit.EditBox -> String-currentWord box-  = reverse-  $ takeWhile (not . isSpace)-  $ dropWhile (\x -> x==' ' || x==':')+currentWord :: WordCompletionMode -> Edit.EditBox -> String+currentWord (WordCompletionMode spfx ssfx mpfx msfx) box+  = dropWhile (`elem`pfx)   $ reverse+  $ takeWhile (/= ' ')+  $ dropWhile (`elem`sfx)+  $ reverse   $ take n txt- where Edit.Line n txt = view Edit.line box+  where+    pfx = spfx++mpfx+    sfx = ssfx++msfx+    Edit.Line n txt = view Edit.line box  -- | Class for types that are isomorphic to 'String' -- and which can support a total order and a prefix

@@ -45,6 +45,7 @@ import           Client.Configuration.ServerSettings import           Client.Commands.Interpolation import           Client.Commands.Recognizer+import           Client.Commands.WordCompletion import           Control.Exception import           Control.Monad import           Config@@ -273,7 +274,10 @@     "flood-threshold"     -> setField       ssFloodThreshold     "message-hooks"       -> setField       ssMessageHooks     "name"                -> setFieldMb     ssName-    _                     -> failure "Unknown section"+    "reconnect-attempts"  -> setField       ssReconnectAttempts+    "autoconnect"         -> setField       ssAutoconnect+    "nick-completion"     -> setFieldWith   ssNickCompletion parseNickCompletion+    _                     -> failure "Unknown setting"   where     setField   l = setFieldWith   l parseConfig     setFieldMb l = setFieldWithMb l parseConfig@@ -342,3 +346,10 @@      case parseExpansion txt of        Nothing -> failure "bad macro line"        Just ex -> return ex++parseNickCompletion :: Value -> ConfigParser WordCompletionMode+parseNickCompletion v =+  case v of+    Atom "default" -> return defaultNickWordCompleteMode+    Atom "slack"   -> return slackNickWordCompleteMode+    _              -> failure "expected default or slack"

@@ -39,6 +39,9 @@   , ssFloodThreshold   , ssMessageHooks   , ssName+  , ssReconnectAttempts+  , ssAutoconnect+  , ssNickCompletion    -- * Load function   , loadDefaultServerSettings@@ -49,6 +52,7 @@   ) where  import           Client.Commands.Interpolation+import           Client.Commands.WordCompletion import           Control.Lens import           Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty@@ -82,6 +86,9 @@   , _ssFloodThreshold   :: !Rational -- ^ Flood limited threshold (seconds)   , _ssMessageHooks     :: ![Text] -- ^ Initial message hooks   , _ssName             :: !(Maybe Text) -- ^ The name referencing the server in commands+  , _ssReconnectAttempts:: !Int -- ^ The number of reconnect attempts to make on error+  , _ssAutoconnect      :: Bool -- ^ Connect to this network on server startup+  , _ssNickCompletion   :: WordCompletionMode -- ^ Nick completion mode for this server   }   deriving Show @@ -123,4 +130,7 @@        , _ssFloodThreshold   = 10        , _ssMessageHooks     = []        , _ssName             = Nothing+       , _ssReconnectAttempts= 6 -- six feels great+       , _ssAutoconnect      = False+       , _ssNickCompletion   = defaultNickWordCompleteMode        }

@@ -1,4 +1,4 @@-{-# Language OverloadedStrings, NondecreasingIndentation #-}+{-# Language BangPatterns, OverloadedStrings, NondecreasingIndentation #-}  {-| Module      : Client.EventLoop@@ -35,7 +35,6 @@ import           Control.Monad import           Data.ByteString (ByteString) import           Data.Foldable-import qualified Data.IntMap as IntMap import           Data.List import           Data.Maybe import           Data.Monoid@@ -53,8 +52,6 @@ import           LensUtils import           Network.Connection -reconnectAttempts :: Int-reconnectAttempts = 6  -- | Sum of the three possible event types the event loop handles data ClientEvent@@ -76,20 +73,10 @@   where     vtyEventChannel = _eventChannel (inputIface (view clientVty st)) -    possibleTimedEvents =-      [ (networkId, runAt, action)-           | (networkId, cs) <- views clientConnections IntMap.toList st-           , Just (runAt, action) <- [nextTimedAction cs]-           ]--    earliestEvent-      | null possibleTimedEvents = Nothing-      | otherwise = Just (minimumBy (comparing (\(_,runAt,_) -> runAt)) possibleTimedEvents)-     prepareTimer =-      case earliestEvent of+      case earliestEvent st of         Nothing -> return retry-        Just (networkId,runAt,action) ->+        Just (networkId,(runAt,action)) ->           do now <- getCurrentTime              let microsecs = truncate (1000000 * diffUTCTime runAt now)              var <- registerDelay (max 0 microsecs)@@ -97,27 +84,33 @@                          unless ready retry                          return (TimerEvent networkId action) +-- | Compute the earliest scheduled timed action for the client+earliestEvent :: ClientState -> Maybe (NetworkId, (UTCTime, TimedAction))+earliestEvent =+  minimumByOf+    (clientConnections . (ifolded <. folding nextTimedAction) . withIndex)+    (comparing (fst . snd))+ -- | Apply this function to an initial 'ClientState' to launch the client. eventLoop :: ClientState -> IO ()-eventLoop st0 =-  do let st1 = clientTick st0-         vty = view clientVty st-         (pic, st) = clientPicture st1+eventLoop st =+  do let vty = view clientVty st+     when (view clientBell st) (beep vty) -     -- check st0 for bell, it will be always be cleared in st1-     when (view clientBell st0) (beep vty)+     let (pic, st') = clientPicture (clientTick st)      update vty pic -     event <- getEvent st+     event <- getEvent st'      case event of-       TimerEvent networkId action  -> doTimerEvent networkId action st-       VtyEvent vtyEvent         -> doVtyEvent vtyEvent st+       TimerEvent networkId action  -> eventLoop =<< doTimerEvent networkId action st'+       VtyEvent vtyEvent -> traverse_ eventLoop =<< doVtyEvent vtyEvent st'        NetworkEvent networkEvent ->+         eventLoop =<<          case networkEvent of-           NetworkLine  network time line -> doNetworkLine network time line st-           NetworkError network time ex   -> doNetworkError network time ex st-           NetworkOpen  network time      -> doNetworkOpen  network time st-           NetworkClose network time      -> doNetworkClose network time st+           NetworkLine  net time line -> doNetworkLine  net time line st'+           NetworkError net time ex   -> doNetworkError net time ex st'+           NetworkOpen  net time      -> doNetworkOpen  net time st'+           NetworkClose net time      -> doNetworkClose net time st'  -- | Sound the terminal bell assuming that the @BEL@ control code -- is supported.@@ -129,89 +122,92 @@   NetworkId   {- ^ network id   -} ->   ZonedTime   {- ^ event time   -} ->   ClientState {- ^ client state -} ->-  IO ()+  IO ClientState doNetworkOpen networkId time st =   case view (clientConnections . at networkId) st of     Nothing -> error "doNetworkOpen: Network missing"     Just cs ->-      let msg = ClientMessage-                  { _msgTime    = time-                  , _msgNetwork = view csNetwork cs-                  , _msgBody    = NormalBody "connection opened"-                  }-      in eventLoop $ recordNetworkMessage msg-                   $ overStrict (clientConnections . ix networkId . csLastReceived)-                                (\old -> old `seq` Just $! zonedTimeToUTC time) st+      do let msg = ClientMessage+                     { _msgTime    = time+                     , _msgNetwork = view csNetwork cs+                     , _msgBody    = NormalBody "connection opened"+                     }+         return $! recordNetworkMessage msg+                 $ overStrict (clientConnections . ix networkId . csLastReceived)+                              (\old -> old `seq` Just $! zonedTimeToUTC time)+                              st  -- | Respond to a network connection closing normally. doNetworkClose ::-  NetworkId {- ^ network id -} ->-  ZonedTime {- ^ event time -} ->-  ClientState -> IO ()+  NetworkId   {- ^ network id   -} ->+  ZonedTime   {- ^ event time   -} ->+  ClientState {- ^ client state -} ->+  IO ClientState doNetworkClose networkId time st =-  let (cs,st') = removeNetwork networkId st-      msg = ClientMessage-              { _msgTime    = time-              , _msgNetwork = view csNetwork cs-              , _msgBody    = NormalBody "connection closed"-              }-  in eventLoop $ recordNetworkMessage msg st'+  do let (cs,st') = removeNetwork networkId st+         msg = ClientMessage+                 { _msgTime    = time+                 , _msgNetwork = view csNetwork cs+                 , _msgBody    = NormalBody "connection closed"+                 }+     return (recordNetworkMessage msg st')   -- | Respond to a network connection closing abnormally. doNetworkError ::-  NetworkId {- ^ failed network -} ->-  ZonedTime {- ^ current time   -} ->+  NetworkId     {- ^ failed network     -} ->+  ZonedTime     {- ^ current time       -} ->   SomeException {- ^ termination reason -} ->-  ClientState -> IO ()+  ClientState   {- ^ client state       -} ->+  IO ClientState doNetworkError networkId time ex st =   do let (cs,st1) = removeNetwork networkId st-         st2 = foldl' (flip recordNetworkMessage) st1 msgs--         msgs = exceptionToLines ex <&> \e ->-                ClientMessage-                 { _msgTime    = time-                 , _msgNetwork = view csNetwork cs-                 , _msgBody    = ErrorBody (Text.pack e)-                 }--         shouldReconnect =-           case view csPingStatus cs of-             PingConnecting n _-               | n == 0 || n > reconnectAttempts -> False+         st2 = foldl' (\acc msg -> recordError time cs (Text.pack msg) acc) st1+             $ exceptionToLines ex+     reconnectLogic ex cs st2 -             _ | Just HostNotResolved{}   <-              fromException ex -> True-               | Just HostCannotConnect{} <-              fromException ex -> True-               | Just PingTimeout         <-              fromException ex -> True-               | Just ResourceVanished    <- ioe_type <$> fromException ex -> True-               | Just NoSuchThing         <- ioe_type <$> fromException ex -> True+reconnectLogic ::+  SomeException {- ^ thread failure reason -} ->+  NetworkState  {- ^ failed network        -} ->+  ClientState   {- ^ client state          -} ->+  IO ClientState+reconnectLogic ex cs st -               | otherwise -> False+  | shouldReconnect =+      do (attempts, mbDisconnectTime) <- computeRetryInfo+         addConnection attempts mbDisconnectTime (view csNetwork cs) st +  | otherwise = return st -         reconnect = do-           (attempts, mbDisconnectTime)-              <- case view csPingStatus cs of-                   PingConnecting n tm                   -> pure (n+1, tm)-                   _ | Just tm <- view csLastReceived cs -> pure (1, Just tm)-                     | otherwise -> do now <- getCurrentTime-                                       pure (1, Just now)-           addConnection attempts mbDisconnectTime (view csNetwork cs) st2+  where+    computeRetryInfo =+      case view csPingStatus cs of+        PingConnecting n tm                   -> pure (n+1, tm)+        _ | Just tm <- view csLastReceived cs -> pure (1, Just tm)+          | otherwise                         -> do now <- getCurrentTime+                                                    pure (1, Just now) -         nextAction-           | shouldReconnect = reconnect-           | otherwise       = return st2+    reconnectAttempts = view (csSettings . ssReconnectAttempts) cs -     eventLoop =<< nextAction+    shouldReconnect =+      case view csPingStatus cs of+        PingConnecting n _ | n == 0 || n > reconnectAttempts          -> False+        _ | Just HostNotResolved{}   <-              fromException ex -> True+          | Just HostCannotConnect{} <-              fromException ex -> True+          | Just PingTimeout         <-              fromException ex -> True+          | Just ResourceVanished    <- ioe_type <$> fromException ex -> True+          | Just NoSuchThing         <- ioe_type <$> fromException ex -> True+          | otherwise                                                 -> False   -- | Respond to an IRC protocol line. This will parse the message, updated the -- relevant connection state and update the UI buffers. doNetworkLine ::-  NetworkId {- ^ Network ID of message -} ->-  ZonedTime {- ^ current time          -} ->-  ByteString {- ^ Raw IRC message without newlines -} ->-  ClientState -> IO ()+  NetworkId   {- ^ Network ID of message            -} ->+  ZonedTime   {- ^ current time                     -} ->+  ByteString  {- ^ Raw IRC message without newlines -} ->+  ClientState {- ^ client state                     -} ->+  IO ClientState doNetworkLine networkId time line st =   case view (clientConnections . at networkId) st of     Nothing -> error "doNetworkLine: Network missing"@@ -219,13 +215,8 @@       let network = view csNetwork cs in       case parseRawIrcMsg (asUtf8 line) of         Nothing ->-          do let txt = Text.pack ("Malformed message: " ++ show line)-                 msg = ClientMessage-                        { _msgTime    = time-                        , _msgNetwork = network-                        , _msgBody    = ErrorBody txt-                        }-             eventLoop (recordNetworkMessage msg st)+          do let msg = Text.pack ("Malformed message: " ++ show line)+             return $! recordError time cs msg st          Just raw ->           do (st1,passed) <- clientPark st $ \ptr ->@@ -233,7 +224,7 @@                                  (view (clientExtensions . esActive) st)  -             if not passed then eventLoop st1 else do+             if not passed then return st1 else do               let time' = computeEffectiveTime time (view msgTags raw) @@ -245,10 +236,9 @@                           messageHooks               case stateHook (cookIrcMsg raw) of-               Nothing  -> eventLoop st1 -- Message ignored+               Nothing  -> return st1 -- Message ignored                Just irc -> do traverse_ (sendMsg cs) replies-                              st3 <- clientResponse time' irc cs st2-                              eventLoop st3+                              clientResponse time' irc cs st2                  where                    -- state with message recorded                    recSt = case viewHook irc of@@ -285,14 +275,14 @@ processConnectCmd ::   ZonedTime       {- ^ now             -} ->   NetworkState    {- ^ current network -} ->-  ClientState                             ->+  ClientState     {- ^ client state    -} ->   [ExpansionChunk]{- ^ command         -} ->   IO ClientState processConnectCmd now cs st0 cmdTxt =   do dc <- forM disco $ \t ->              Text.pack . formatTime defaultTimeLocale "%H:%M:%S"                <$> utcToLocalZonedTime t-     let failureCase = reportConnectCmdError now cs+     let failureCase e = recordError now cs ("Bad connect-cmd: " <> e)      case resolveMacroExpansions (commandExpansion dc st0) (const Nothing) cmdTxt of        Nothing -> return $! failureCase "Unable to expand connect command" st0        Just cmdTxt' ->@@ -307,17 +297,17 @@    _ -> Nothing  -reportConnectCmdError ::+recordError ::   ZonedTime       {- ^ now             -} ->   NetworkState    {- ^ current network -} ->-  Text            {- ^ bad command     -} ->-  ClientState ->+  Text            {- ^ error message   -} ->+  ClientState     {- ^ client state    -} ->   ClientState-reportConnectCmdError now cs cmdTxt =+recordError now cs msg =   recordNetworkMessage ClientMessage     { _msgTime    = now     , _msgNetwork = view csNetwork cs-    , _msgBody    = ErrorBody ("Bad connect-cmd: " <> cmdTxt)+    , _msgBody    = ErrorBody msg     }  -- | Find the ZNC provided server time@@ -342,7 +332,10 @@   -- | Respond to a VTY event.-doVtyEvent :: Event -> ClientState -> IO ()+doVtyEvent ::+  Event                  {- ^ vty event             -} ->+  ClientState            {- ^ client state          -} ->+  IO (Maybe ClientState) {- ^ nothing when finished -} doVtyEvent vtyEvent st =   case vtyEvent of     EvKey k modifier -> doKey k modifier st@@ -350,19 +343,23 @@       do let vty = view clientVty st          refresh vty          (w,h) <- displayBounds (outputIface vty)-         eventLoop $ set clientWidth w-                   $ set clientHeight h st+         return $! Just $! set clientWidth  w+                         $ set clientHeight h st     EvPaste utf8 ->-       let str = Text.unpack (Text.decodeUtf8With Text.lenientDecode utf8)-           st' = over clientTextBox (Edit.insertPaste str) st-       in eventLoop st'-    _ -> eventLoop st+       do let str = Text.unpack (Text.decodeUtf8With Text.lenientDecode utf8)+          return $! Just $! over clientTextBox (Edit.insertPaste str) st+    _ -> return (Just st)   -- | Map keyboard inputs to actions in the client-doKey :: Key -> [Modifier] -> ClientState -> IO ()+doKey ::+  Key         {- ^ key pressed    -} ->+  [Modifier]  {- ^ modifiers held -} ->+  ClientState {- ^ client state   -} ->+  IO (Maybe ClientState) doKey key modifier st =-  let changeEditor  f = eventLoop (over clientTextBox f st)+  let continue !out   = return (Just out)+      changeEditor  f = continue (over clientTextBox f st)       changeContent f = changeEditor                       $ over Edit.content f                       . set  Edit.lastOperation Edit.OtherOperation@@ -384,10 +381,11 @@         KChar '_' -> changeEditor (Edit.insert '\^_')         KChar 'o' -> changeEditor (Edit.insert '\^O')         KChar 'v' -> changeEditor (Edit.insert '\^V')-        KChar 'p' -> eventLoop (retreatFocus st)-        KChar 'n' -> eventLoop (advanceFocus st)-        KChar 'l' -> refresh (view clientVty st) >> eventLoop st-        _         -> eventLoop st+        KChar 'p' -> continue (retreatFocus st)+        KChar 'n' -> continue (advanceFocus st)+        KChar 'l' -> do refresh (view clientVty st)+                        continue st+        _         -> continue st      [MMeta] ->       case key of@@ -396,16 +394,18 @@         KChar 'd' -> changeEditor (Edit.killWordForward True)         KChar 'b' -> changeContent Edit.leftWord         KChar 'f' -> changeContent Edit.rightWord-        KChar 'a' -> eventLoop (jumpToActivity st)-        KChar 's' -> eventLoop (returnFocus st)+        KLeft     -> changeContent Edit.leftWord+        KRight    -> changeContent Edit.rightWord+        KChar 'a' -> continue (jumpToActivity st)+        KChar 's' -> continue (returnFocus st)         KChar c   | let names = clientWindowNames st                   , Just i <- elemIndex c names ->-                            eventLoop (jumpFocus i st)-        _ -> eventLoop st+                            continue (jumpFocus i st)+        _ -> continue st      [] -> -- no modifier       case key of-        KEsc       -> eventLoop (changeSubfocus FocusMessages st)+        KEsc       -> continue (changeSubfocus FocusMessages st)         KBS        -> changeContent Edit.backspace         KDel       -> changeContent Edit.delete         KLeft      -> changeContent Edit.left@@ -414,8 +414,8 @@         KEnd       -> changeEditor Edit.end         KUp        -> changeEditor $ \ed -> fromMaybe ed $ Edit.earlier ed         KDown      -> changeEditor $ \ed -> fromMaybe ed $ Edit.later ed-        KPageUp    -> eventLoop (pageUp st)-        KPageDown  -> eventLoop (pageDown st)+        KPageUp    -> continue (scrollClient ( scrollAmount st) st)+        KPageDown  -> continue (scrollClient (-scrollAmount st) st)          KEnter     -> doCommandResult True  =<< executeInput st         KBackTab   -> doCommandResult False =<< tabCompletion True  st@@ -424,32 +424,43 @@         KChar c    -> changeEditor (Edit.insert c)          -- toggles-        KFun 2     -> eventLoop (over clientDetailView  not st)-        KFun 3     -> eventLoop (over clientActivityBar not st)-        KFun 4     -> eventLoop (over clientShowMetadata not st)+        KFun 2     -> continue (over clientDetailView  not st)+        KFun 3     -> continue (over clientActivityBar not st)+        KFun 4     -> continue (over clientShowMetadata not st) -        _          -> eventLoop st+        _          -> continue st -    _ -> eventLoop st -- unsupported modifier+    _ -> continue st -- unsupported modifier --- | Process 'CommandResult' by either running the 'eventLoop' with the--- new 'ClientState' or returning.-doCommandResult :: Bool -> CommandResult -> IO ()++-- | Process 'CommandResult' and update the 'ClientState' textbox+-- and error state. When quitting return 'Nothing'.+doCommandResult ::+  Bool          {- ^ clear on success -} ->+  CommandResult {- ^ command result   -} ->+  IO (Maybe ClientState) doCommandResult clearOnSuccess res =+  let continue !st = return (Just st) in   case res of-    CommandQuit    st -> clientShutdown st-    CommandSuccess st -> eventLoop (if clearOnSuccess then consumeInput st else st)-    CommandFailure st -> eventLoop (set clientBell True st)+    CommandQuit    st -> Nothing <$ clientShutdown st+    CommandSuccess st -> continue (if clearOnSuccess then consumeInput st else st)+    CommandFailure st -> continue (set clientBell True st) -executeInput :: ClientState -> IO CommandResult++-- | Execute the the command on the first line of the text box+executeInput ::+  ClientState {- ^ client state -} ->+  IO CommandResult executeInput st = execute (clientFirstLine st) st   -- | Respond to a timer event. doTimerEvent ::-  NetworkId {- ^ Network related to event -} ->-  TimedAction {- ^ Action to perform -} ->-  ClientState -> IO ()+  NetworkId   {- ^ Network related to event -} ->+  TimedAction {- ^ Action to perform        -} ->+  ClientState {- ^ client state             -} ->+  IO ClientState doTimerEvent networkId action =-  eventLoop <=< traverseOf (clientConnections . ix networkId)-                           (applyTimedAction action)+  traverseOf+    (clientConnections . ix networkId)+    (applyTimedAction action)

@@ -15,7 +15,6 @@   ) where  import           Control.Exception-import           Data.Char import           Data.List.NonEmpty (NonEmpty(..)) import           Network.Connection import           Network.TLS@@ -27,20 +26,10 @@   NonEmpty String {- ^ client lines  -} exceptionToLines   = indentMessages-  . fmap cleanLine   . exceptionToLines'  indentMessages :: NonEmpty String -> NonEmpty String indentMessages (x :| xs) = x :| map ("⋯ "++) xs--cleanLine :: String -> String-cleanLine = map clean1-  where-    clean1 x-      | x < '\x20'  = chr (0x2400 + ord x)-      | x == '\DEL' = '␡'-      | isControl x = '�'-      | otherwise   = x  exceptionToLines' ::   SomeException   {- ^ network error -} ->

@@ -9,7 +9,10 @@ This module provides the renderer for the client's UI.  -}-module Client.Image (clientPicture) where+module Client.Image+  ( clientPicture+  , scrollAmount+  ) where  import           Client.Image.Palette import           Client.Image.StatusLine@@ -18,7 +21,6 @@ import           Client.State.Focus import           Client.View import           Control.Lens-import           Data.List import           Graphics.Vty (Background(..), Picture(..), Cursor(..)) import           Graphics.Vty.Image @@ -34,35 +36,52 @@               , picLayers     = [img]               } +-- | Primary UI render logic clientImage ::-  ClientState ->-  (Int, Image, ClientState) -- ^ text box cursor position, image, updated state-clientImage st = (pos, img, st'')+  ClientState               {- ^ client state -} ->+  (Int, Image, ClientState) {- ^ text box cursor position, image, updated state -}+clientImage st = (pos, img, st')   where-    (st', mp) = messagePane mainHeight focus (view clientSubfocus st) st-    (st'', extras) = mapAccumL renderExtra st' splits+    (mainHeight, splitHeight) = clientWindowHeights (imageHeight activityBar) st+    splitFocuses              = clientExtraFocuses st+    focus                     = view clientFocus st+    (pos , tbImg )            = textboxImage st -    (pos, tbImg) = textboxImage st''-    img = vertCat extras <->-          mp <->-          statusLineImage st'' <->-          tbImg+    -- update client state for scroll clamp+    st' = over clientScroll (max 0 . subtract overscroll) st -    focus = view clientFocus st+    (overscroll, msgs) = messagePane mainHeight focus (view clientSubfocus st) st+    splits = renderExtra st' <$> splitFocuses+    -- outgoing state is ignored here, splits don't get to truncate scrollback -    (mainHeight, splitHeight) = clientWindowHeights st-    splits                    = clientExtraFocuses st+    img = vertCat splits      <->+          msgs                <->+          activityBar         <->+          statusLineImage st' <->+          tbImg -    renderExtra stIn focus1 = (stOut, outImg)+    activityBar = activityBarImage st+        -- must be st, not st', needed to compute window heights+        -- before rendering the message panes++    renderExtra stIn focus1 = outImg       where-        (stOut,msgImg) = messagePane splitHeight focus1 FocusMessages stIn-        pal = clientPalette st+        (_,msgImg) = messagePane splitHeight focus1 FocusMessages stIn+        pal = clientPalette stIn         divider = view palWindowDivider pal-        outImg = msgImg <-> minorStatusLineImage focus1 st-                        <-> charFill divider ' ' (view clientWidth st) 1+        outImg = msgImg <-> minorStatusLineImage focus1 stIn+                        <-> charFill divider ' ' (view clientWidth stIn) 1 -messagePane :: Int -> Focus -> Subfocus -> ClientState -> (ClientState, Image)-messagePane h focus subfocus st = (st', img)+-- | Generate an image corresponding to the image lines of the given+-- focus and subfocus. Returns the number of lines overscrolled to+-- assist in clamping scroll to the lines available in the window.+messagePane ::+  Int          {- ^ available rows                -} ->+  Focus        {- ^ focused window                -} ->+  Subfocus     {- ^ subfocus to render            -} ->+  ClientState  {- ^ client state                  -} ->+  (Int, Image) {- ^ overscroll, rendered messages -}+messagePane h focus subfocus st = (overscroll, img)   where     images = viewLines focus subfocus st     vimg   = assemble emptyImage images@@ -71,8 +90,6 @@      overscroll = vh - imageHeight vimg -    st' = over clientScroll (max 0 . subtract overscroll) st-     assemble acc _ | imageHeight acc >= vh = cropTop vh acc     assemble acc [] = acc     assemble acc (x:xs) = assemble (lineWrap w x <-> acc) xs@@ -82,9 +99,44 @@      w      = view clientWidth st -lineWrap :: Int -> Image -> Image+-- | 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   {- ^ maximum image width -} ->+  Image {- ^ unwrapped image     -} ->+  Image {- ^ wrapped image       -} lineWrap w img-  | imageWidth img > w = cropRight w img <-> lineWrap w (cropLeft (imageWidth img - w) img)+  | imageWidth img > w = cropRight w img <->+                         lineWrap w (cropLeft (imageWidth img - w) img)   | otherwise = img <|> char defAttr ' '-                        -- trailing space with default attributes deals with bug in VTY-                        -- where the formatting will continue past the end of chat messages+      -- trailing space with default attributes deals with bug in VTY+      -- where the formatting will continue past the end of chat messages+++-- | Compute the number of lines in a page at the current window size+scrollAmount ::+  ClientState {- ^ client state              -} ->+  Int         {- ^ scroll amount             -}+scrollAmount st = max 1 (snd (clientWindowHeights actSize st))+               -- extra will be equal to main or 1 smaller+  where+    actSize = imageHeight (activityBarImage st)+++-- | Number of lines to allocate for the focused window and the+-- main window. This doesn't include the textbox, activity bar,+-- or status line.+clientWindowHeights ::+  Int         {- ^ activity bar height       -} ->+  ClientState {- ^ client state              -} ->+  (Int,Int)   {- ^ main height, extra height -}+clientWindowHeights activityBar st =+  (max 0 (h - overhead - extras*d), max 0 (d-overhead))+  where+    d        = h `quot` (1 + extras)++    h        = max 0 (view clientHeight st - activityBar) -- lines available++    extras   = length (clientExtraFocuses st)++    overhead = 2 -- status line and textbox/divider

@@ -20,6 +20,7 @@   , quietIdentifier   , coloredUserInfo   , coloredIdentifier+  , cleanText   ) where  import           Client.Image.MircFormatting@@ -76,13 +77,23 @@   , bodyImage rm params body   ] +cleanChar :: Char -> Char+cleanChar x+  | x < '\x20'  = chr (0x2400 + ord x)+  | x == '\DEL' = '␡'+  | isControl x = '�'+  | otherwise   = x++cleanText :: Text -> Text+cleanText = Text.map cleanChar+ errorImage ::   MessageRendererParams ->   Text {- ^ error message -} ->   Image errorImage params txt = horizCat   [ text' (view palError (rendPalette params)) "error "-  , text' defAttr txt+  , text' defAttr (cleanText txt)   ]  normalImage ::@@ -91,7 +102,7 @@   Image normalImage params txt = horizCat   [ text' (view palLabel (rendPalette params)) "client "-  , text' defAttr txt+  , text' defAttr (cleanText txt)   ]  -- | Render the given time according to the current mode and palette.

@@ -170,4 +170,3 @@     (first, cntl:rest) -> Vty.string defAttr first Vty.<|>                           controlImage cntl Vty.<|>                           plainText rest-

@@ -1,4 +1,4 @@-{-# Language BangPatterns #-}+{-# Language OverloadedStrings, BangPatterns #-} {-| Module      : Client.Image.StatusLine Description : Renderer for status line@@ -14,6 +14,7 @@ module Client.Image.StatusLine   ( statusLineImage   , minorStatusLineImage+  , activityBarImage   ) where  import           Client.Image.Palette@@ -32,20 +33,20 @@ import           Numeric  -- | Renders the status line between messages and the textbox.-statusLineImage :: ClientState -> Image-statusLineImage st-  = activityBar <->-    content <|> charFill defAttr '─' fillSize 1+statusLineImage ::+  ClientState {- ^ client state             -} ->+  Image       {- ^ activity bar, status bar -}+statusLineImage st = content <|> charFill defAttr '─' fillSize 1   where     fillSize = max 0 (view clientWidth st - imageWidth content)-    (activitySummary, activityBar) = activityImages st     content = horizCat       [ myNickImage st       , focusImage st-      , activitySummary+      , activitySummary st       , detailImage st       , nometaImage st       , scrollImage st+      , filterImage st       , latencyImage st       ] @@ -60,12 +61,20 @@ scrollImage :: ClientState -> Image scrollImage st   | 0 == view clientScroll st = emptyImage-  | otherwise = infoBubble-              $ string attr "scroll"+  | otherwise = infoBubble (string attr "scroll")   where     pal  = clientPalette st     attr = view palLabel pal +filterImage :: ClientState -> Image+filterImage st =+  case clientActiveRegex st of+    Nothing -> emptyImage+    Just {} -> infoBubble (string attr "filtered")+  where+    pal  = clientPalette st+    attr = view palLabel pal+ latencyImage :: ClientState -> Image latencyImage st   | Just network <- views clientFocus focusNetwork st@@ -105,37 +114,53 @@     pal  = clientPalette st     attr = view palLabel pal -activityImages :: ClientState -> (Image, Image)-activityImages st = (summary, activityBar)+-- | Image for little box with active window names:+--+-- @-[15p]@+activitySummary :: ClientState -> Image+activitySummary st+  | null indicators = emptyImage+  | otherwise       = string defAttr "─[" <|>+                      horizCat indicators <|>+                      string defAttr "]"   where-    activityBar-      | view clientActivityBar st = activityBar' <|> activityFill-      | otherwise                 = emptyImage+    winNames = clientWindowNames st ++ repeat '?' -    summary-      | null indicators = emptyImage-      | otherwise       = string defAttr "─[" <|>-                          horizCat indicators <|>-                          string defAttr "]"+    indicators = foldr aux [] (zip winNames windows)+    windows    = views clientWindows Map.elems st -    activityFill = charFill defAttr '─'-                        (max 0 (view clientWidth st - imageWidth activityBar'))-                        1+    aux (i,w) rest+      | view winUnread w == 0 = rest+      | otherwise = char attr i : rest+      where+        pal = clientPalette st+        attr | view winMention w = view palMention pal+             | otherwise         = view palActivity pal -    activityBar' = foldr baraux emptyImage-                 $ zip winNames+-- | Multi-line activity information enabled by F3+activityBarImage :: ClientState -> Image+activityBarImage st+  | view clientActivityBar st = activityBar'+  | otherwise                 = emptyImage+  where+    activityBar' = makeLines (view clientWidth st)+                 $ catMaybes+                 $ zipWith baraux winNames                  $ Map.toList                  $ view clientWindows st -    baraux (i,(focus,w)) rest-      | n == 0 = rest-      | otherwise = string defAttr "─[" <|>+    winNames = clientWindowNames st ++ repeat '?'++    baraux i (focus,w)+      | n == 0 = Nothing -- todo: make configurable+      | otherwise = Just+                  $ string defAttr "─[" <|>                     char (view palWindowName pal) i <|>                     char defAttr              ':' <|>                     text' (view palLabel pal) focusText <|>                     char defAttr              ':' <|>                     string attr               (show n) <|>-                    string defAttr "]" <|> rest+                    string defAttr "]"       where         n   = view winUnread w         pal = clientPalette st@@ -147,19 +172,25 @@             NetworkFocus net    -> net             ChannelFocus _ chan -> idText chan -    windows  = views clientWindows Map.elems st-    winNames = clientWindowNames st ++ repeat '?' -    indicators  = foldr aux [] (zip winNames windows)-    aux (i,w) rest-      | view winUnread w == 0 = rest-      | otherwise = char attr i : rest-      where-        pal = clientPalette st-        attr | view winMention w = view palMention pal-             | otherwise         = view palActivity pal +makeLines ::+  Int     {- ^ window width       -} ->+  [Image] {- ^ components to pack -} ->+  Image+makeLines _ [] = emptyImage+makeLines w (x:xs) = go x xs+  where +    go acc (y:ys)+      | let acc' = acc <|> y+      , imageWidth acc' <= w+      = go acc' ys++    go acc ys = makeLines w ys+            <-> acc <|> charFill defAttr '─' (max 0 (w - imageWidth acc)) 1++ myNickImage :: ClientState -> Image myNickImage st =   case view clientFocus st of@@ -238,16 +269,27 @@ viewSubfocusLabel pal subfocus =   case subfocus of     FocusMessages -> Nothing-    FocusWindows  -> 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"     FocusMentions -> Just $ string (view palLabel pal) "mentions"     FocusPalette  -> Just $ string (view palLabel pal) "palette"     FocusHelp mb  -> Just $ string (view palLabel pal) "help" <|>-                            foldMap (\cmd -> char defAttr ':' <|>-                                        text' (view palLabel pal) cmd) mb+                            opt mb     FocusMasks m  -> Just $ horizCat       [ string (view palLabel pal) "masks"       , char defAttr ':'       , char (view palLabel pal) m       ]+  where+    opt = foldMap (\cmd -> char defAttr ':' <|>+                           text' (view palLabel pal) cmd)++windowFilterName :: WindowsFilter -> Maybe Text+windowFilterName x =+  case x of+    AllWindows     -> Nothing+    NetworkWindows -> Just "networks"+    ChannelWindows -> Just "channels"+    UserWindows    -> Just "users"

@@ -118,7 +118,7 @@  allCommands = (Left <$> macros) <> (Right <$> commands)  (attr, continue)    = case recognize (Text.pack cmd) allCommands of-       Exact (Right (Command spec _ _)) ->+       Exact (Right Command{cmdArgumentSpec = spec}) ->          ( specAttr spec          , argumentsImage pal spec          )

@@ -17,6 +17,7 @@   -- * Lenses   , optConfigFile   , optInitialNetworks+  , optNoConnect    -- * Options loader   , getOptions@@ -38,6 +39,7 @@ data Options = Options   { _optConfigFile      :: Maybe FilePath -- ^ configuration file path   , _optInitialNetworks :: [Text]         -- ^ initial networks+  , _optNoConnect       :: Bool           -- ^ disable autoconnect   , _optShowHelp        :: Bool           -- ^ show help message   , _optShowVersion     :: Bool           -- ^ show version message   }@@ -51,6 +53,7 @@   , _optInitialNetworks = []   , _optShowHelp        = False   , _optShowVersion     = False+  , _optNoConnect       = False   }  -- | Option descriptions@@ -58,6 +61,8 @@ options =   [ Option "c" ["config"]  (ReqArg (set optConfigFile . Just) "PATH")     "Configuration file path"+  , Option "!" ["noconnect"] (NoArg (set optNoConnect True))+    "Disable autoconnecting"   , Option "h" ["help"]    (NoArg (set optShowHelp True))     "Show help"   , Option "v" ["version"] (NoArg (set optShowVersion True))

@@ -38,6 +38,7 @@   , clientConnection   , clientBell   , clientExtensions+  , clientRegex    -- * Client operations   , withClientState@@ -45,7 +46,7 @@   , clientShutdown   , clientPark   , clientMatcher-  , urlPattern+  , clientActiveRegex    , consumeInput   , currentCompletionList@@ -60,9 +61,11 @@   , clientHighlights   , clientWindowNames   , clientPalette+  , clientAutoconnects+  , clientActiveCommand    , clientExtraFocuses-  , clientWindowHeights+  , currentNickCompletionMode    -- * Add messages to buffers   , recordChannelMessage@@ -79,16 +82,19 @@   , jumpFocus    -- * Scrolling-  , pageUp-  , pageDown+  , scrollClient    -- * Extensions   , ExtensionState   , esActive +  -- * URL view+  , urlPattern+   ) where  import           Client.CApi+import           Client.Commands.WordCompletion import           Client.Configuration import           Client.Configuration.ServerSettings import           Client.Image.Message@@ -160,6 +166,7 @@   , _clientDetailView        :: !Bool                     -- ^ use detailed rendering mode   , _clientActivityBar       :: !Bool                     -- ^ visible activity bar   , _clientShowMetadata      :: !Bool                     -- ^ visible activity bar+  , _clientRegex             :: (Maybe Regex)             -- ^ optional persistent filter    , _clientBell              :: !Bool                     -- ^ sound a bell next draw @@ -234,6 +241,7 @@         , _clientScroll            = 0         , _clientDetailView        = False         , _clientShowMetadata      = True+        , _clientRegex             = Nothing         , _clientActivityBar       = view configActivityBar cfg         , _clientNextConnectionId  = 0         , _clientBell              = False@@ -491,6 +499,13 @@       ++ channelUserList network chan st     _                         -> [] +-- | Returns the 'WordCompletionMode' associated with the current network.+currentNickCompletionMode :: ClientState -> WordCompletionMode+currentNickCompletionMode st =+  fromMaybe defaultNickWordCompleteMode $+  do network <- views clientFocus focusNetwork st+     preview (clientConnection network . csSettings . ssNickCompletion) st+ networkChannelList ::   Text         {- ^ network -} ->   ClientState                  ->@@ -506,23 +521,46 @@ channelUserList network channel =   views (clientConnection network . csChannels . ix channel . chanUsers) HashMap.keys --- | Construct a text matching predicate used to filter the message window. clientMatcher :: ClientState -> Text -> Bool clientMatcher st =-  case break (==' ') (clientFirstLine st) of-    ("/grep" ,_:reStr) -> go True  reStr-    ("/grepi",_:reStr) -> go False reStr-    ("/url"  ,_      ) -> match urlPattern-    _                  -> const True+  case clientActiveRegex st of+    Nothing -> const True+    Just r  -> matchTest r++-- | Construct a text matching predicate used to filter the message window.+clientActiveRegex :: ClientState -> Maybe Regex+clientActiveRegex st =+  case clientActiveCommand st of+    Just ("grep" ,reStr) -> go True  reStr+    Just ("grepi",reStr) -> go False reStr+    _ -> case view clientRegex st of+           Nothing -> Nothing+           Just r  -> Just r   where     go sensitive reStr =-      case compile defaultCompOpt{caseSensitive=sensitive} defaultExecOpt reStr of-        Left{}  -> const True-        Right r -> match r :: Text -> Bool+      case compile defaultCompOpt{caseSensitive=sensitive}+                   defaultExecOpt{captureGroups=False}+                   reStr of+        Left{}  -> Nothing+        Right r -> Just r ++-- | Compute the command and arguments currently in the textbox.+clientActiveCommand ::+  ClientState           {- ^ client state                     -} ->+  Maybe (String,String) {- ^ command name and argument string -}+clientActiveCommand st =+  case break (==' ') (clientFirstLine st) of+    ('/':cmd,_:args) -> Just (cmd,args)+    _                -> Nothing++ urlPattern :: Regex-urlPattern = makeRegex-  ("https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[^[:space:]]*)"::String)+Right urlPattern =+  compile+    defaultCompOpt+    defaultExecOpt{captureGroups=False}+    "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[^[:cntrl:][:space:]]*)"  -- | Remove a network connection and unlink it from the network map. -- This operation assumes that the networkconnection exists and should@@ -577,7 +615,7 @@   IrcMsg                     {- ^ message recieved         -} ->   NetworkId                  {- ^ message network          -} ->   NetworkState               {- ^ network connection state -} ->-  ClientState                                                 ->+  ClientState                {- ^ client state             -} ->   ([RawIrcMsg], ClientState) {- ^ response , updated state -} applyMessageToClientState time irc networkId cs st =   cs' `seq` (reply, st')@@ -656,21 +694,9 @@ -- Scrolling ------------------------------------------------------------------------ --- | Scroll the current buffer to show older messages-pageUp :: ClientState -> ClientState-pageUp st = over clientScroll (+ scrollAmount st) st- -- | Scroll the current buffer to show newer messages-pageDown :: ClientState -> ClientState-pageDown st = over clientScroll (max 0 . subtract (scrollAmount st)) st---- | Compute the number of lines in a page at the current window size-scrollAmount :: ClientState -> Int-scrollAmount st = max 1 (min main extra)-  where-    (main,extra) = clientWindowHeights st--+scrollClient :: Int -> ClientState -> ClientState+scrollClient amt = over clientScroll $ \n -> max 0 (n + amt)   -- | List of extra focuses to display as split windows@@ -680,28 +706,7 @@     FocusMessages -> view clientFocus st `delete` view clientExtraFocus st     _             -> [] --- | Number of lines to allocate for the focused window and the--- main window. This doesn't include the textbox, activity bar,--- or status line.-clientWindowHeights ::-  ClientState {- ^ client state              -} ->-  (Int,Int)   {- ^ main height, extra height -}-clientWindowHeights st = (max 0 (h - overhead - extras*d), max 0 (d-overhead))-  where-    d        = h `quot` (1 + extras) -    h        = max 0 (view clientHeight st - reservedLines) -- lines available--    extras   = length (clientExtraFocuses st)--    overhead = 2 -- status line and textbox/divider--    reservedLines-      | view clientActivityBar st = 1 -- activity bar-      | otherwise                 = 0--- ------------------------------------------------------------------------ -- Focus Management ------------------------------------------------------------------------@@ -727,7 +732,7 @@   | 0 <= i, i < Map.size windows = changeFocus focus st   | otherwise                    = st   where-    windows = view clientWindows st+    windows   = view clientWindows st     (focus,_) = Map.elemAt i windows  -- | Change the window focus to the given value, reset the subfocus@@ -821,3 +826,10 @@ -- | Produce the list of window names configured for the client. clientPalette :: ClientState -> Palette clientPalette = view (clientConfig . configPalette)++-- | Returns the list of network names that requested autoconnection.+clientAutoconnects :: ClientState -> [Text]+clientAutoconnects st =+  [ network | (network, cfg) <- views (clientConfig . configServers) HashMap.toList st+            , view ssAutoconnect cfg+            ]

@@ -16,6 +16,7 @@   ( -- * Types     Focus(..)   , Subfocus(..)+  , WindowsFilter(..)    -- * Focus operations   , focusNetwork@@ -46,7 +47,7 @@   | FocusInfo        -- ^ Show channel metadata   | FocusUsers       -- ^ Show channel user list   | FocusMasks !Char -- ^ Show channel mask list for given mode-  | FocusWindows     -- ^ Show client windows+  | FocusWindows WindowsFilter -- ^ Show client windows   | FocusPalette     -- ^ Show current palette   | FocusMentions    -- ^ Show all mentions   | FocusHelp (Maybe Text) -- ^ Show help window with optional command@@ -71,3 +72,11 @@ focusNetwork Unfocused = Nothing focusNetwork (NetworkFocus network) = Just network focusNetwork (ChannelFocus network _) = Just network++-- | Filter argument for 'FocusWindows'+data WindowsFilter+  = AllWindows     -- ^ no filter+  | NetworkWindows -- ^ only network windows+  | ChannelWindows -- ^ only channel windows+  | UserWindows    -- ^ only user windows+  deriving (Eq, Show)

@@ -64,6 +64,11 @@   , TimedAction(..)   , nextTimedAction   , applyTimedAction++  -- * Moderation+  , useChanServ+  , sendModeration+  , sendTopic   ) where  import           Client.Configuration.ServerSettings@@ -820,3 +825,48 @@          sendMsg cs (ircPing ["ping"])          return $! set csNextPingTime (Just $! addUTCTime 60 now)                 $  set csPingStatus   (PingSent now) cs++------------------------------------------------------------------------+-- Moderation+------------------------------------------------------------------------++-- | Used to send commands that require ops to perform.+-- If this channel is one that the user has chanserv access and ops are needed+-- then ops are requested and the commands are queued, otherwise send them+-- directly.+sendModeration ::+  Identifier      {- ^ channel       -} ->+  [RawIrcMsg]     {- ^ commands      -} ->+  NetworkState    {- ^ network state -} ->+  IO NetworkState+sendModeration channel cmds cs+  | useChanServ channel cs =+      do let cmd = ircPrivmsg "ChanServ" (Text.unwords ["OP", idText channel])+         sendMsg cs cmd+         return $ csChannels . ix channel . chanQueuedModeration <>~ cmds $ cs+  | otherwise = cs <$ traverse_ (sendMsg cs) cmds++useChanServ ::+  Identifier   {- ^ channel            -} ->+  NetworkState {- ^ network state      -} ->+  Bool         {- ^ chanserv available -}+useChanServ channel cs =+  channel `elem` view (csSettings . ssChanservChannels) cs &&+  not (iHaveOp channel cs)++sendTopic ::+  Identifier   {- ^ channel       -} ->+  Text         {- ^ topic         -} ->+  NetworkState {- ^ network state -} ->+  IO ()+sendTopic channelId topic cs = sendMsg cs cmd+  where+    chanservTopicCmd =+      ircPrivmsg+        "ChanServ"+        (Text.unwords ["TOPIC", idText channelId, topic])++    cmd+      | Text.null topic          = ircTopic channelId ""+      | useChanServ channelId cs = chanservTopicCmd+      | otherwise                = ircTopic channelId topic

@@ -21,6 +21,7 @@ import           Client.View.Mentions import           Client.View.Messages import           Client.View.Palette+import           Client.View.UrlSelection import           Client.View.UserList import           Client.View.Windows import           Control.Lens@@ -29,6 +30,7 @@ viewLines :: Focus -> Subfocus -> ClientState -> [Image] viewLines focus subfocus !st =   case (focus, subfocus) of+    _ | Just ("url",_) <- clientActiveCommand st -> urlSelectionView focus st     (ChannelFocus network channel, FocusInfo) ->       channelInfoImages network channel st     (ChannelFocus network channel, FocusUsers)@@ -36,11 +38,10 @@       | otherwise                -> userListImages network channel st     (ChannelFocus network channel, FocusMasks mode) ->       maskListImages mode network channel st-    (_, FocusWindows) -> windowsImages st+    (_, FocusWindows filt) -> windowsImages filt st     (_, FocusMentions) -> mentionsViewLines st     (_, FocusPalette) -> paletteViewLines pal     (_, FocusHelp mb) -> helpImageLines mb pal-     _ -> chatMessageImages focus st   where     pal = clientPalette st

@@ -1,4 +1,4 @@-{-# Language OverloadedStrings #-}+{-# Language BangPatterns, OverloadedStrings #-}  {-| Module      : Client.View.Help@@ -21,6 +21,8 @@ import           Client.Image.Palette import           Client.Commands.Recognizer import           Control.Lens+import           Data.Foldable (toList)+import           Data.List (delete) import           Data.List.NonEmpty (NonEmpty((:|))) import           Data.Monoid ((<>)) import           Data.Text (Text)@@ -51,14 +53,20 @@       [string (view palError pal) $ "Unknown command, did you mean: " ++ suggestions]       where       suggestions = Text.unpack $ Text.intercalate " " ((cmdName <>) <$> sfxs)-    Exact (Command args doc impl) ->-      reverse $ commandSummary pal (pure cmdName) args+    Exact Command{cmdNames = names, cmdImplementation = impl,+                  cmdArgumentSpec = spec, cmdDocumentation = doc} ->+      reverse $ commandSummary pal (pure cmdName) spec               : emptyImage-              : explainContext impl+              : aliasLines+             ++ explainContext impl               : emptyImage-              : map parseIrcText docs+              : map parseIrcText (Text.lines doc)       where-        docs = Text.lines doc+        aliasLines =+          case delete cmdName (toList names) of+            [] -> []+            ns -> [ text' defAttr (Text.unwords ("Aliases:":ns))+                  , emptyImage ]  -- | Generate an explanation of the context where the given command -- implementation will be valid.@@ -81,8 +89,8 @@   [Image] {- ^ help lines -} listAllCommands pal =   reverse-    [ commandSummary pal name args-    | (name, Command args _ _) <- commandsList ]+    [ commandSummary pal names spec+    | Command{ cmdNames = names, cmdArgumentSpec = spec } <- commandsList ]  -- | Generate the help line for the given command and its -- specification for use in the list of commands.

@@ -0,0 +1,37 @@+{-# Language BangPatterns #-}+{-|+Module      : Client.View.UrlSelection+Description : URL selection module+Copyright   : (c) Eric Mertens, 2016+License     : ISC+Maintainer  : emertens@gmail.com++This module provides a list of the URLs found in the current message+window in order to assist in selecting one to open with @/url@++-}+module Client.View.UrlSelection+  ( urlSelectionView+  ) where++import           Client.State+import           Client.State.Window+import           Client.State.Focus+import           Client.Image.Message+import           Control.Lens+import           Graphics.Vty.Image+import           Text.Regex.TDFA+import           Data.Text (Text)+++urlSelectionView :: Focus -> ClientState -> [Image]+urlSelectionView focus st =+    zipWith draw [1..]+         $ toListOf (clientWindows . ix focus . winMessages . folded . wlText . folding textUrls) st++textUrls :: Text -> [Text]+textUrls = getAllTextMatches . match urlPattern++draw :: Int -> Text -> Image+draw i url = string defAttr (shows i ". ")+         <|> text' defAttr (cleanText url)

@@ -16,6 +16,7 @@ import           Client.State import           Client.State.Focus import           Client.State.Window+import           Client.State.Network import           Control.Lens import           Data.List import qualified Data.Map as Map@@ -23,23 +24,49 @@ import           Irc.Identifier  -- | Draw the image lines associated with the @/windows@ command.-windowsImages :: ClientState -> [Image]-windowsImages st-  = reverse-  $ createColumns-  $ zipWith (renderWindowColumns pal) names windows+windowsImages :: WindowsFilter -> ClientState -> [Image]+windowsImages filt st = reverse (createColumns windows)   where-    windows = views clientWindows Map.toAscList st+    windows = [ renderWindowColumns pal n k v+              | (n,(k,v)) <- zip names+                           $ views clientWindows Map.toAscList st+              , windowMatcher filt st k+              ]      pal     = clientPalette st     names   = clientWindowNames st ++ repeat '?' -renderWindowColumns :: Palette -> Char -> (Focus, Window) -> [Image]-renderWindowColumns pal name (focus, win) =++------------------------------------------------------------------------++windowMatcher :: WindowsFilter -> ClientState -> Focus -> Bool++windowMatcher AllWindows _ _ = True++windowMatcher NetworkWindows _ NetworkFocus{} = True++windowMatcher ChannelWindows st (ChannelFocus net chan) =+  case preview (clientConnection net) st of+    Just cs -> isChannelIdentifier cs chan+    Nothing -> True++windowMatcher UserWindows st (ChannelFocus net chan) =+  case preview (clientConnection net) st of+    Just cs -> not (isChannelIdentifier cs chan)+    Nothing -> True++windowMatcher _ _ _ = False++------------------------------------------------------------------------+++renderWindowColumns :: Palette -> Char -> Focus -> Window -> [Image]+renderWindowColumns pal name focus win =   [ char (view palWindowName pal) name   , renderedFocus pal focus   , renderedWindowInfo pal win   ]+  createColumns :: [[Image]] -> [Image] createColumns xs = map makeRow xs

@@ -43,6 +43,7 @@ import           Control.Monad.Trans.State import           Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet import           Data.Monoid import           Data.Ratio import           Data.Text (Text)@@ -100,6 +101,15 @@       n = floatingToRatio c e   parseConfig _                 = failure "expected integral number" +instance FromConfig Int where+  parseConfig v =+    do i <- parseConfig v+       let small = minBound :: Int+           large = maxBound :: Int+       when (i < toInteger small || toInteger large < i)+          (failure "int out of range")+       return (fromInteger i)+ -- | Matches 'Number' values ignoring the base instance Integral a => FromConfig (Ratio a) where   parseConfig (Number _ n)   = return $! fromIntegral n@@ -133,7 +143,8 @@ -- of the sections from that value. parseSections :: SectionParser a -> Value -> ConfigParser a parseSections (SectionParser p) (Sections xs) =-  do (res, xs') <- runStateT p (toHashMap xs)+  do hm <- toHashMap xs+     (res, xs') <- runStateT p hm      let unused = HashMap.keys xs'      unless (null unused)        (failure ("unknown keys: " <> Text.intercalate ", " unused))@@ -168,8 +179,19 @@                           Nothing -> failure ("section required: " <> key)                           Just x  -> return x -toHashMap :: [Section] -> HashMap Text Value-toHashMap xs = HashMap.fromList [ (k,v) | Section k v <- xs ] -- todo: handle duplicate sections+toHashMap :: [Section] -> ConfigParser (HashMap Text Value)+toHashMap xs =+  case duplicateCheck xs of+    Just key -> failure ("duplicate section: " <> key)+    Nothing  -> return $! HashMap.fromList [ (k,v) | Section k v <- xs ]++duplicateCheck :: [Section] -> Maybe Text+duplicateCheck = go HashSet.empty+  where+    go _ [] = Nothing+    go seen (Section x _:xs)+      | HashSet.member x seen = Just x+      | otherwise             = go (HashSet.insert x seen) xs  floatingToRatio :: Integral a => Integer -> Integer -> Ratio a floatingToRatio c e = fromIntegral c * 10 ^^ e