diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for glirc2 +## 2.14 + +* Add `/help` +* Add `/palette` +* Add F3 to toggle activity detail bar + ## 2.13 * Add disconnect expansion, support expansions in connect-cmds diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -164,6 +164,7 @@ * `extensions` - list of text - Filenames of extension to load * `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) Settings -------- @@ -207,9 +208,7 @@ * `mention` - attr - attr for mention notification * `command` - attr - attr for recognized command * `command-ready` - attr - attr for command with successful parse -* `command-required` - attr - attr for required command argument placeholder -* `command-optional` - attr - attr for optional command argument placeholder -* `command-remaining` - attr - attr for remaining command text placeholder +* `command-placeholder` - attr - attr for command argument placeholder Text Attributes --------------- @@ -240,6 +239,7 @@ Client commands +* `/help [command]` - Show in-client help * `/exit` - Terminate the client * `/quit` - Gracefully terminate connection to the current server * `/connect ` - Connect to the given server @@ -340,6 +340,7 @@ * `M-D` delete word forwards * `TAB` nickname completion * `F2` toggle detailed view +* `F3` toggle detailed activity bar * `Page Up` scroll up * `Page Down` scroll down * `^B` bold diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.13 +version: 2.14 synopsis: Console IRC client description: Console IRC client license: ISC @@ -69,10 +69,12 @@ Client.Image Client.Image.Arguments Client.Image.ChannelInfo + Client.Image.Help Client.Image.MaskList Client.Image.Message Client.Image.MircFormatting Client.Image.Palette + Client.Image.PaletteView Client.Image.StatusLine Client.Image.Textbox Client.Image.UserList @@ -122,7 +124,7 @@ unix >=2.7 && <2.8, unordered-containers >=0.2.7 && <0.3, vector >=0.11 && <0.12, - vty >=5.10 && <5.11, + vty >=5.10 && <5.12, x509 >=1.6.3 && <1.7, x509-store >=1.6.1 && <1.7, x509-system >=1.6.3 && <1.7 diff --git a/src/Client/CApi.hs b/src/Client/CApi.hs --- a/src/Client/CApi.hs +++ b/src/Client/CApi.hs @@ -12,7 +12,10 @@ -} module Client.CApi - ( ActiveExtension(..) + ( -- * Extension type + ActiveExtension(..) + + -- * Extension callbacks , extensionSymbol , activateExtension , deactivateExtension @@ -122,6 +125,7 @@ then go rest msgPtr else return False +-- | Notify an extension of a client command with the given parameters. commandExtension :: Ptr () {- ^ client state stableptr -} -> [Text] {- ^ parameters -} -> diff --git a/src/Client/CommandArguments.hs b/src/Client/CommandArguments.hs --- a/src/Client/CommandArguments.hs +++ b/src/Client/CommandArguments.hs @@ -14,6 +14,8 @@ ( -- * Command-line argument type CommandArguments(..) + + -- * Lenses , cmdArgConfigFile , cmdArgInitialNetworks diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -19,7 +19,9 @@ , tabCompletion -- * Commands , Command(..) + , CommandImpl(..) , commands + , commandsList ) where import Client.CApi @@ -44,6 +46,7 @@ import Data.Foldable import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) +import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.Split import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) @@ -94,8 +97,8 @@ -- | requires an active channel window | ChannelCommand (ChannelCommand a) (Bool -> ChannelCommand String) --- | Pair of a command and it's argument specification -data Command = forall a. Command (ArgumentSpec a) (CommandImpl a) +-- | A command is an argument specification, implementation, and documentation +data Command = forall a. Command (ArgumentSpec a) Text (CommandImpl a) -- | Consider the text entry successful and resume the client commandSuccess :: Monad m => ClientState -> m CommandResult @@ -150,7 +153,12 @@ CommandFailure st1 -> process cs st1 -- ? CommandQuit st1 -> return (CommandQuit st1) -commandExpansion :: Maybe Text -> ClientState -> Text -> Maybe Text +-- | Compute the replacement value for the given expansion variable. +commandExpansion :: + Maybe Text {- ^ disconnect time -} -> + ClientState {- ^ client state -} -> + Text {- ^ expansion variable -} -> + Maybe Text {- ^ expansion value -} commandExpansion discoTime st v = case v of "network" -> views clientFocus focusNetwork st @@ -219,7 +227,7 @@ Nothing -> commandFailureMsg "Unknown command" st Just isReversed -> nickTabCompletion isReversed st - Just (Command argSpec impl) -> + Just (Command argSpec _docs impl) -> case impl of ClientCommand exec tab -> finish argSpec exec tab @@ -243,219 +251,397 @@ finish argSpec (exec channelId cs) (\x -> tab x channelId cs) | otherwise -> commandFailureMsg "This command requires an active chat window" st --- Expands each alias to have its own copy of the command callbacks -expandAliases :: [([a],b)] -> [(a,b)] -expandAliases xs = [ (a,b) | (as,b) <- xs, a <- as ] +-- | 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 ] + +-- | Map of built-in client commands to their implementations, tab completion +-- logic, and argument structures. commands :: HashMap Text Command -commands = HashMap.fromList - $ expandAliases +commands = HashMap.fromList (expandAliases commandsList) +commandsList :: [(NonEmpty Text,Command)] +commandsList = -- -- Client commands -- - [ ( ["connect"] + [ ( pure "connect" , Command (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 ) - , ( ["exit"] + , ( pure "exit" , Command NoArg + "Exit the client immediately.\n" $ ClientCommand cmdExit noClientTab ) - , ( ["focus"] + , ( pure "focus" , Command (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\ + \When \^Bnetwork\^B and \^Bchannel\^B are specified this switches to that chat window.\n\ + \\n\ + \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 ) - , ( ["clear"] + , ( pure "clear" , Command (OptTokenArg "network" (OptTokenArg "channel" NoArg)) + "Clear a window.\n\ + \\n\ + \If no arguments are provided the current window is cleared.\n\ + \If \^Bnetwork\^B is provided the that network window is cleared.\n\ + \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 ) - , ( ["reconnect"] + , ( pure "reconnect" , Command NoArg + "Reconnect to the current network.\n" $ ClientCommand cmdReconnect noClientTab ) - , ( ["ignore"] + , ( pure "ignore" , Command (RemainingArg "nicks") + "Toggle the soft-ignore on each of the space-delimited given nicknames.\n" $ ClientCommand cmdIgnore simpleClientTab ) - , ( ["reload"] + , ( pure "reload" , Command (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 ) - , ( ["extension"] + , ( pure "extension" , Command (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 ) - , ( ["windows"] + , ( pure "windows" , Command NoArg + "Show a list of all client message windows.\n" $ ClientCommand cmdWindows noClientTab ) - , ( ["exec"] + , ( pure "palette" + , Command NoArg + "Show the current palette settings and a color chart to help pick new colors.\n" + $ ClientCommand cmdPalette noClientTab + ) + , ( pure "exec" , Command (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\ + \\n\ + \When \^Binput\^B is specified it is sent to the stdin.\n\ + \\n\ + \When neither \^Bnetwork\^B nor \^Bchannel\^B are specified output goes to client window (*)\n\ + \When \^Bnetwork\^B is specified output is sent as raw IRC traffic to the network.\n\ + \When \^Bchannel\^B is specified output is sent as chat to the given channel on the current network.\n\ + \When \^Bnetwork\^B and \^Bchannel\^B are specified output is sent as chat to the given channel on the given network.\n\ + \\n" $ ClientCommand cmdExec simpleClientTab ) - , ( ["url"] + , ( pure "url" , Command (OptTokenArg "number" NoArg) + "Open a URL seen in chat.\n\ + \\n\ + \The URL is opened using the executable configured under \^Burl-opener\^B.\n\ + \\n\ + \When this command is active in the textbox, chat messages are filtered to only show ones with URLs.\n\ + \\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) + "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 + ) -- -- Network commands -- - , ( ["quote"] + , ( pure "quote" , Command (RemainingArg "raw IRC command") + "Send a raw IRC command.\n" $ NetworkCommand cmdQuote simpleNetworkTab ) - , ( ["j","join"] + , ( "join" :| ["j"] , Command (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 ) - , ( ["c","channel"] + , ( "channel" :| ["c"] , Command (ReqTokenArg "channel" NoArg) + "Change the focused window.\n\ + \\n\ + \Changes the focus to the \^Bchannel\^B chat window on the current network.\n\ + \\n\ + \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 ) - , ( ["mode"] + , ( pure "mode" , Command (RemainingArg "modes and parameters") + "Sets IRC modes.\n\ + \\n\ + \Examples:\n\ + \Setting a ban: /mode +b *!*@hostname\n\ + \Removing a quiet: /mode -q *!*@hostname\n\ + \Voicing two users: /mode +vv user1 user2\n\ + \Demoting an op to voice: /mode +v-o user1 user1\n\ + \\n\ + \When executed in a network window, mode changes are applied to your user.\n\ + \When executed in a channel window, mode changes are applied to the channel.\n\ + \\n\ + \This command has parameter sensitive tab-completion.\n" $ NetworkCommand cmdMode tabMode ) - , ( ["msg"] + , ( pure "msg" , Command (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 ) - , ( ["notice"] + , ( pure "notice" , Command (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 ) - , ( ["ctcp"] + , ( pure "ctcp" , Command (ReqTokenArg "target" (ReqTokenArg "command" (RemainingArg "arguments"))) + "Send a CTCP command to a user or a channel.\n\ + \\n\ + \Examples:\n\ + \Version query: /ctcp user1 version\n\ + \Local-time query: /ctcp user1 time\n\ + \\n\ + \\^Btarget\^B can be a channel or nickname.\n\ + \\^Bcommand\^B can be any CTCP command.\n\ + \\^Barguments\^B are specific to a particular command.\n" $ NetworkCommand cmdCtcp simpleNetworkTab ) - , ( ["nick"] + , ( pure "nick" , Command (ReqTokenArg "nick" NoArg) + "Change your nickname.\n" $ NetworkCommand cmdNick simpleNetworkTab ) - , ( ["quit"] - , Command (RemainingArg "quit message") + , ( pure "quit" + , Command (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 ) - , ( ["disconnect"] + , ( pure "disconnect" , Command NoArg + "Immediately terminate the current network connection.\n\ + \\n\ + \See also: /quit /exit\n" $ NetworkCommand cmdDisconnect noNetworkTab ) - , ( ["who"] + , ( pure "who" , Command (RemainingArg "arguments") + "Send WHO query to server with given arguments.\n" $ NetworkCommand cmdWho simpleNetworkTab ) - , ( ["whois"] + , ( pure "whois" , Command (RemainingArg "arguments") + "Send WHOIS query to server with given arguments.\n" $ NetworkCommand cmdWhois simpleNetworkTab ) - , ( ["whowas"] + , ( pure "whowas" , Command (RemainingArg "arguments") + "Send WHOWAS query to server with given arguments.\n" $ NetworkCommand cmdWhowas simpleNetworkTab ) - , ( ["ison"] + , ( pure "ison" , Command (RemainingArg "arguments") + "Send ISON query to server with given arguments.\n" $ NetworkCommand cmdIson simpleNetworkTab ) - , ( ["userhost"] + , ( pure "userhost" , Command (RemainingArg "arguments") + "Send USERHOST query to server with given arguments.\n" $ NetworkCommand cmdUserhost simpleNetworkTab ) - , ( ["away"] - , Command (RemainingArg "arguments") + , ( pure "away" + , Command (RemainingArg "message") + "Set away status.\n\ + \\n\ + \When \^Bmessage\^B is omitted away status is cleared.\n" $ NetworkCommand cmdAway simpleNetworkTab ) - , ( ["links"] + , ( pure "links" , Command (RemainingArg "arguments") + "Send LINKS query to server with given arguments.\n" $ NetworkCommand cmdLinks simpleNetworkTab ) - , ( ["time"] + , ( pure "time" , Command (RemainingArg "arguments") + "Send TIME query to server with given arguments.\n" $ NetworkCommand cmdTime simpleNetworkTab ) - , ( ["stats"] + , ( pure "stats" , Command (RemainingArg "arguments") + "Send STATS query to server with given arguments.\n" $ NetworkCommand cmdStats simpleNetworkTab ) - , ( ["znc"] + , ( pure "znc" , Command (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 ) - , ( ["znc-playback"] - , Command (RemainingArg "arguments") + , ( pure "znc-playback" + , Command (OptTokenArg "time" (OptTokenArg "date" NoArg)) + "Request playback from the ZNC 'playback' module.\n\ + \\n\ + \\^Btime\^B determines the time to playback since.\n\ + \\^Bdate\^B determines the date to playback since.\n\ + \\n\ + \When both \^Btime\^B and \^Bdate\^B are omitted, all playback is requested.\n\ + \When both \^Bdate\^B is omitted it is defaulted the most recent date in the past that makes sense.\n\ + \\n\ + \Time format: HOURS:MINUTES (example: 7:00)\n\ + \Date format: YEAR-MONTH-DAY (example: 2016-06-16)\n\ + \\n\ + \Note that the playback module is not installed in ZNC by default!\n" $ NetworkCommand cmdZncPlayback noNetworkTab ) - , ( ["invite"] + , ( pure "invite" , Command (ReqTokenArg "nick" NoArg) + "Invite a user to the current channel.\n" $ ChannelCommand cmdInvite simpleChannelTab ) - , ( ["topic"] + , ( pure "topic" , Command (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 ) - , ( ["kick"] + , ( pure "kick" , Command (ReqTokenArg "nick" (RemainingArg "reason")) + "Kick a user from the current channel.\n\ + \\n\ + \See also: /kickban /remove\n" $ ChannelCommand cmdKick simpleChannelTab ) - , ( ["kickban"] + , ( pure "kickban" , Command (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 ) - , ( ["remove"] + , ( pure "remove" , Command (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 ) - , ( ["part"] + , ( pure "part" , Command (RemainingArg "reason") + "Part from the current channel.\n" $ ChannelCommand cmdPart simpleChannelTab ) - , ( ["users"] + , ( pure "users" , Command 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 ) - , ( ["channelinfo"] + , ( pure "channelinfo" , Command NoArg + "Show information about the current channel.\n" $ ChannelCommand cmdChannelInfo noChannelTab ) - , ( ["masks"] + , ( pure "masks" , Command (ReqTokenArg "mode" NoArg) + "Show mask lists for current channel.\n\ + \\n\ + \Common \^Bmode\^B values:\n\ + \\^Bb\^B: bans\n\ + \\^Bq\^B: quiets\n\ + \\^BI\^B: invite exemptions (op view only)\n\ + \\^Be\^B: ban exemption (op view only)s\n\ + \\n\ + \To populate the mask lists for the first time use: /mode \^Bmode\^B\n" $ ChannelCommand cmdMasks noChannelTab ) - , ( ["me"] + , ( pure "me" , Command (RemainingArg "message") + "Send an 'action' to the current chat window.\n" $ ChatCommand cmdMe simpleChannelTab ) - , ( ["say"] + , ( pure "say" , Command (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 noClientTab :: Bool -> ClientCommand String noClientTab _ st _ = commandFailure st +-- | Provides no tab completion for network commands noNetworkTab :: Bool -> NetworkCommand String noNetworkTab _ _ st _ = commandFailure st +-- | Provides no tab completion for channel commands noChannelTab :: Bool -> ChannelCommand String noChannelTab _ _ _ st _ = commandFailure st +-- | Provides nickname based tab completion for client commands simpleClientTab :: Bool -> ClientCommand String simpleClientTab isReversed st _ = nickTabCompletion isReversed st +-- | Provides nickname based tab completion for network commands simpleNetworkTab :: Bool -> NetworkCommand String simpleNetworkTab isReversed _ st _ = nickTabCompletion isReversed st +-- | Provides nickname based tab completion for channel commands simpleChannelTab :: Bool -> ChannelCommand String simpleChannelTab isReversed _ _ st _ = nickTabCompletion isReversed st +-- | Implementation of @/exit@ command. cmdExit :: ClientCommand () cmdExit st _ = return (CommandQuit st) @@ -490,7 +676,8 @@ ChannelFocus network channel -> has (clientConnection network .csChannels . ix channel) st - +-- | Implementation of @/quote@. Parses arguments as a raw IRC command and +-- sends to the current network. cmdQuote :: NetworkCommand String cmdQuote cs st rest = case parseRawIrcMsg (Text.pack rest) of @@ -615,6 +802,21 @@ cmdWindows :: ClientCommand () cmdWindows st _ = commandSuccess (changeSubfocus FocusWindows st) +-- | Implementation of @/palette@ command. Set subfocus to Windows. +cmdPalette :: ClientCommand () +cmdPalette st _ = commandSuccess (changeSubfocus FocusPalette st) + +-- | Implementation of @/help@ command. Set subfocus to Windows. +cmdHelp :: ClientCommand (Maybe (String, ())) +cmdHelp st mb = commandSuccess (changeSubfocus focus st) + where + focus = FocusHelp (fmap (Text.pack . fst) mb) + +tabHelp :: Bool -> ClientCommand String +tabHelp isReversed st _ = simpleTabCompletion id [] commandNames isReversed st + where + commandNames = [ cmd | (cmd :| _, _) <- commandsList ] + simpleTabCompletion :: Prefix a => (String -> String) {- ^ leading transform -} -> @@ -701,16 +903,15 @@ do sendMsg cs (ircZnc (Text.words (Text.pack rest))) commandSuccess st --- TODO: support time ranges -cmdZncPlayback :: NetworkCommand String -cmdZncPlayback cs st rest = - case words rest of +cmdZncPlayback :: NetworkCommand (Maybe (String, Maybe (String, ()))) +cmdZncPlayback cs st args = + case args of -- request everything - [] -> success "0" + Nothing -> success "0" -- current date explicit time - [timeStr] + Just (timeStr, Nothing) | Just tod <- parse timeFormats timeStr -> do now <- getZonedTime let (nowTod,t) = (zonedTimeLocalTime . localTimeTimeOfDay <<.~ tod) now @@ -721,7 +922,7 @@ successZoned (fixDay t) -- explicit date and time - [dateStr,timeStr] + Just (dateStr, Just (timeStr, _)) | Just day <- parse dateFormats dateStr , Just tod <- parse timeFormats timeStr -> do tz <- getCurrentTimeZone diff --git a/src/Client/Commands/Exec.hs b/src/Client/Commands/Exec.hs --- a/src/Client/Commands/Exec.hs +++ b/src/Client/Commands/Exec.hs @@ -11,24 +11,49 @@ can show channel bans, quiets, invites, and exceptions. -} -module Client.Commands.Exec where +module Client.Commands.Exec + ( -- * Exec command configuration + ExecCmd(..) + -- * Lenses + , execOutputNetwork + , execOutputChannel + + -- * Operations + , parseExecCmd + , runExecCmd + ) where + import Control.Exception import Control.Lens import System.Console.GetOpt import System.Process +-- | Settings for @/exec@ command. +-- +-- When no network or channel are specified the output is sent to the client +-- window. +-- +-- When only a network is specified the output is sent as raw IRC commands to +-- that network. +-- +-- When only a channel is specified the output is sent as messages on the +-- current network to the given channel. +-- +-- When the network and channel are specified the output is sent as messages +-- to the given channel on the given network. data ExecCmd = ExecCmd - { _execOutputNetwork :: Maybe String - , _execOutputChannel :: Maybe String - , _execCommand :: String - , _execStdIn :: String - , _execArguments :: [String] + { _execOutputNetwork :: Maybe String -- ^ output network + , _execOutputChannel :: Maybe String -- ^ output channel + , _execCommand :: String -- ^ command filename + , _execStdIn :: String -- ^ stdin source + , _execArguments :: [String] -- ^ command arguments } deriving (Read,Show) makeLenses ''ExecCmd +-- | Default values for @/exec@ to be overridden by flags. emptyExecCmd :: ExecCmd emptyExecCmd = ExecCmd { _execOutputNetwork = Nothing @@ -51,8 +76,13 @@ "Use string as stdin" ] +-- | Parse the arguments to @/exec@ looking for various flags +-- and the command and its arguments. +-- -- TODO: support quoted strings -parseExecCmd :: String -> Either [String] ExecCmd +parseExecCmd :: + String {- ^ exec arguments -} -> + Either [String] ExecCmd {- ^ error or parsed command -} parseExecCmd str = case getOpt RequireOrder options (words str) of (_, [] , errs) -> Left ("No command specified":errs) @@ -63,7 +93,11 @@ $ emptyExecCmd (_,_, errs) -> Left errs -runExecCmd :: ExecCmd -> IO (Either [String] [String]) +-- | Execute the requested command synchronously and return +-- the output. +runExecCmd :: + ExecCmd {- ^ exec configuration -} -> + IO (Either [String] [String]) {- ^ error lines or output lines -} runExecCmd e = do res <- try (readProcess (view execCommand e) (view execArguments e) diff --git a/src/Client/Commands/Interpolation.hs b/src/Client/Commands/Interpolation.hs --- a/src/Client/Commands/Interpolation.hs +++ b/src/Client/Commands/Interpolation.hs @@ -35,6 +35,8 @@ | DefaultChunk ExpansionChunk Text deriving Show +-- | Parse a 'Text' searching for the expansions as specified in +-- 'ExpansionChunk'. @$$@ is used to escape a single @$@. parseExpansion :: Text -> Maybe [ExpansionChunk] parseExpansion txt = case parseOnly (many parseChunk <* endOfInput) txt of @@ -63,11 +65,14 @@ parseVariable = IntegerChunk <$> P.decimal <|> VariableChunk <$> P.takeWhile1 isAlpha +-- | Attempt to expand all of the elements in the given list using +-- the two expansion functions. If the expansion of any chunk +-- fails the whole expansion fails. resolveMacroExpansions :: (Text -> Maybe Text) {- ^ variable resolution -} -> (Integer -> Maybe Text) {- ^ argument index resolution -} -> - [ExpansionChunk] -> - Maybe Text + [ExpansionChunk] {- ^ chunks -} -> + Maybe Text {- ^ concatenated, expanded chunks -} resolveMacroExpansions var arg xs = Text.concat <$> traverse resolve1 xs where resolve1 (LiteralChunk lit) = Just lit diff --git a/src/Client/Commands/WordCompletion.hs b/src/Client/Commands/WordCompletion.hs --- a/src/Client/Commands/WordCompletion.hs +++ b/src/Client/Commands/WordCompletion.hs @@ -9,7 +9,7 @@ -} module Client.Commands.WordCompletion - ( Prefix + ( Prefix(..) , wordComplete ) where @@ -77,8 +77,19 @@ $ take n txt where 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 +-- predicate. +-- +-- @ +-- 'Prefix.toString' ('fromString' x) == x +-- 'fromString' ('Prefix.toString' x) == x +-- 'Prefix.isPrefix' x y ==> x '<=' y +-- @ class (IsString a, Ord a) => Prefix a where + -- | Check if the first argument is a lexicographic prefix of the second. isPrefix :: a -> a -> Bool + -- | Convert to a 'String'. toString :: a -> String instance Prefix Identifier where @@ -88,6 +99,7 @@ instance Prefix Text where isPrefix = Text.isPrefixOf toString = Text.unpack + tabSearch :: Prefix a => Bool -> a -> a -> [a] -> Maybe a tabSearch isReversed pat cur vals diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -18,6 +18,8 @@ -- * Configuration type Configuration(..) , ConfigurationFailure(..) + + -- * Lenses , configDefaults , configServers , configPalette @@ -29,6 +31,7 @@ , configExtraHighlights , configUrlOpener , configIgnores + , configActivityBar -- * Loading configuration , loadConfiguration @@ -79,17 +82,26 @@ , _configExtensions :: [FilePath] -- ^ paths to shared library , _configUrlOpener :: Maybe FilePath -- ^ paths to url opening executable , _configIgnores :: HashSet Identifier -- ^ initial ignore list + , _configActivityBar :: Bool -- ^ initially visibility of the activity bar } deriving Show makeLenses ''Configuration +-- | Failure cases when loading a configuration file. data ConfigurationFailure - = ConfigurationParseFailed String + + -- | Error message from reading configuration file + = ConfigurationReadFailed String + + -- | Error message from parser or lexer + | ConfigurationParseFailed String + + -- | Error message from loading parsed configuration | ConfigurationMalformed String - | ConfigurationReadFailed String deriving Show +-- | default instance instance Exception ConfigurationFailure defaultWindowNames :: Text @@ -201,6 +213,8 @@ _configIgnores <- maybe HashSet.empty HashSet.fromList <$> sectionOptWith (parseList parseIdentifier) "ignores" + _configActivityBar <- fromMaybe False <$> sectionOpt "activity-bar" + for_ _configNickPadding (\padding -> when (padding < 0) (liftConfigParser $ @@ -232,9 +246,7 @@ "mention" -> setAttr palMention "command" -> setAttr palCommand "command-ready" -> setAttr palCommandReady - "command-required" -> setAttr palCommandRequired - "command-optional" -> setAttr palCommandOptional - "command-remaining" -> setAttr palCommandRemaining + "command-placeholder" -> setAttr palCommandPlaceholder _ -> failure "Unknown palette entry" where setAttr l = diff --git a/src/Client/Configuration/Colors.hs b/src/Client/Configuration/Colors.hs --- a/src/Client/Configuration/Colors.hs +++ b/src/Client/Configuration/Colors.hs @@ -72,14 +72,18 @@ parseColor v = case v of _ | Just i <- parseInteger v -> parseColorNumber i + Atom a | Just c <- HashMap.lookup (atomName a) namedColors -> return c + List [r,g,b] | Just r' <- parseInteger r , Just g' <- parseInteger g , Just b' <- parseInteger b -> parseRgb r' g' b' + _ -> failure "Expected a color number, name, or RBG list" +-- | Match integers between 0 and 255 as Terminal colors. parseColorNumber :: Integer -> ConfigParser Color parseColorNumber i | i < 0 = failure "Negative color not supported" @@ -87,6 +91,8 @@ | i < 256 = return (Color240 (fromInteger (i - 16))) | otherwise = failure "Color value too high" +-- | Accepts any integer literal or floating literal which can +-- be losslessly converted to an integer. parseInteger :: Value -> Maybe Integer parseInteger v = case v of diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs --- a/src/Client/Configuration/ServerSettings.hs +++ b/src/Client/Configuration/ServerSettings.hs @@ -16,6 +16,8 @@ ( -- * Server settings type ServerSettings(..) + + -- * Lenses , ssNicks , ssUser , ssReal diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -399,7 +399,8 @@ KChar '\t' -> doCommandResult False =<< tabCompletion False st KChar c -> changeEditor (Edit.insert c) - KFun 2 -> eventLoop (over clientDetailView not st) + KFun 2 -> eventLoop (over clientDetailView not st) + KFun 3 -> eventLoop (over clientActivityBar not st) _ -> eventLoop st _ -> eventLoop st -- unsupported modifier diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -13,9 +13,11 @@ import Client.Configuration import Client.Image.ChannelInfo +import Client.Image.Help import Client.Image.MaskList import Client.Image.Message import Client.Image.Palette +import Client.Image.PaletteView import Client.Image.StatusLine import Client.Image.Textbox import Client.Image.UserList @@ -49,11 +51,7 @@ where (mp, st') = messagePane st (pos, tbImg) = textboxImage st' - img = vertCat - [ mp - , statusLineImage st' - , tbImg - ] + img = mp <-> statusLineImage st' <-> tbImg messagePaneImages :: ClientState -> [Image] messagePaneImages !st = @@ -66,8 +64,12 @@ (ChannelFocus network channel, FocusMasks mode) -> maskListImages mode network channel st (_, FocusWindows) -> windowsImages st + (_, FocusPalette) -> paletteViewLines pal + (_, FocusHelp mb) -> helpImageLines mb pal _ -> chatMessageImages st + where + pal = view (clientConfig . configPalette) st chatMessageImages :: ClientState -> [Image] chatMessageImages st = windowLineProcessor focusedMessages @@ -105,7 +107,12 @@ scroll = view clientScroll st vh = h + scroll - h = view clientHeight st - 2 + + reservedLines + | view clientActivityBar st = 3 + | otherwise = 2 + + h = view clientHeight st - reservedLines w = view clientWidth st windowLinesToImages :: ClientState -> [WindowLine] -> [Image] diff --git a/src/Client/Image/Arguments.hs b/src/Client/Image/Arguments.hs --- a/src/Client/Image/Arguments.hs +++ b/src/Client/Image/Arguments.hs @@ -53,12 +53,12 @@ case arg of NoArg -> emptyImage ReqTokenArg n a -> leader - <|> string (view palCommandRequired pal) n + <|> string (view palCommandPlaceholder pal) n <|> mkPlaceholders pal a OptTokenArg n a -> leader - <|> string (view palCommandOptional pal) n + <|> string (view palCommandPlaceholder pal) (n ++ "?") <|> mkPlaceholders pal a RemainingArg n -> leader - <|> string (view palCommandRemaining pal) n + <|> string (view palCommandPlaceholder pal) (n ++ "…") where leader = char defAttr ' ' diff --git a/src/Client/Image/Help.hs b/src/Client/Image/Help.hs new file mode 100644 --- /dev/null +++ b/src/Client/Image/Help.hs @@ -0,0 +1,75 @@ +{-| +Module : Client.Image.Help +Description : Renderer for help lines +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides the rendering used for the @/help@ command. + +-} +module Client.Image.Help + ( helpImageLines + ) where + +import Client.Image.Arguments +import Client.Image.Palette +import Client.Image.MircFormatting +import Client.Commands +import Client.Commands.Arguments +import Control.Lens +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Text (Text) +import qualified Data.Text as Text +import Graphics.Vty.Image + +-- | Generate either the list of all commands and their arguments, +-- or when given a command name generate the detailed help text +-- for that command. +helpImageLines :: + Maybe Text {- ^ optional command name -} -> + Palette {- ^ palette -} -> + [Image] {- ^ lines -} +helpImageLines mbCmd pal = + case mbCmd of + Nothing -> listAllCommands pal + Just cmd -> commandHelpLines cmd pal + +commandHelpLines :: Text -> Palette -> [Image] +commandHelpLines cmdName pal = + case view (at cmdName) commands of + Nothing -> [string (view palError pal) "Unknown command, try /help"] + Just (Command args doc impl) -> + reverse $ commandSummary pal (pure cmdName) args + : emptyImage + : explainContext impl + : emptyImage + : map parseIrcText docs + where + docs = Text.lines doc + +explainContext :: CommandImpl a -> Image +explainContext impl = + case impl of + ClientCommand {} -> go "client command" "works everywhere" + NetworkCommand{} -> go "network command" "works when focused on active network" + ChannelCommand{} -> go "channel command" "works when focused on active channel" + ChatCommand {} -> go "chat command" "works when focused on an active channel or private message" + where + go x y = string (withStyle defAttr bold) x <|> + string defAttr (": " ++ y) + +listAllCommands :: Palette -> [Image] +listAllCommands pal = + reverse + [ commandSummary pal name args + | (name, Command args _ _) <- commandsList ] + +commandSummary :: Palette -> NonEmpty Text -> ArgumentSpec a -> Image +commandSummary pal (cmd :| _) args = + char defAttr '/' <|> + text' (view palCommand pal) cmd <|> + argumentsImage pal' args "" + + where + pal' = set palCommandPlaceholder defAttr pal diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -302,7 +302,7 @@ string (view palSigil pal) sigils <|> coloredUserInfo pal rm myNicks nick <|> string defAttr " set mode: " <|> - separatedParams params + ircWords params Authenticate{} -> string defAttr "AUTHENTICATE ***" BatchStart{} -> string defAttr "BATCH +" @@ -322,8 +322,15 @@ separatorImage :: Image separatorImage = char (withForeColor defAttr blue) '·' +-- | Process list of 'Text' as individual IRC formatted words +-- separated by a special separator to distinguish parameters +-- from words within parameters. separatedParams :: [Text] -> Image separatedParams = horizCat . intersperse separatorImage . map parseIrcText + +-- | Process list of 'Text' as individual IRC formatted words +ircWords :: [Text] -> Image +ircWords = horizCat . intersperse (char defAttr ' ') . map parseIrcText renderReplyCode :: RenderMode -> MessageRendererParams -> ReplyCode -> Image renderReplyCode rm rp code@(ReplyCode w) = diff --git a/src/Client/Image/Palette.hs b/src/Client/Image/Palette.hs --- a/src/Client/Image/Palette.hs +++ b/src/Client/Image/Palette.hs @@ -1,4 +1,4 @@ -{-# Language TemplateHaskell, OverloadedLists #-} +{-# Language TemplateHaskell, OverloadedLists, OverloadedStrings #-} {-| Module : Client.Image.Palette Description : Palette of colors used to render the UI @@ -12,6 +12,8 @@ ( -- * Palette type Palette(..) + + -- * Lenses , palNicks , palSelf , palSelfHighlight @@ -27,15 +29,16 @@ , palMention , palCommand , palCommandReady - , palCommandRequired - , palCommandOptional - , palCommandRemaining + , palCommandPlaceholder + , paletteMap + -- * Defaults , defaultPalette ) where import Control.Lens +import Data.Text (Text) import Data.Vector (Vector) import Graphics.Vty.Attributes @@ -56,9 +59,7 @@ , _palMention :: Attr -- ^ window name with mention , _palCommand :: Attr -- ^ known command , _palCommandReady :: Attr -- ^ known command with complete arguments - , _palCommandRequired :: Attr -- ^ required argument placeholder - , _palCommandOptional :: Attr -- ^ optional argument placeholder - , _palCommandRemaining :: Attr -- ^ remaining command text placeholder + , _palCommandPlaceholder :: Attr -- ^ command argument placeholder } deriving Show @@ -82,9 +83,7 @@ , _palMention = withForeColor defAttr red , _palCommand = withForeColor defAttr yellow , _palCommandReady = withForeColor defAttr green - , _palCommandRequired = withStyle defAttr reverseVideo - , _palCommandOptional = withStyle defAttr reverseVideo - , _palCommandRemaining = withStyle defAttr reverseVideo + , _palCommandPlaceholder = withStyle defAttr reverseVideo } -- | Default nick highlighting colors that look nice in my dark solarized @@ -94,3 +93,21 @@ withForeColor defAttr <$> [cyan, magenta, green, yellow, blue, brightCyan, brightMagenta, brightGreen, brightBlue] + +paletteMap :: [(Text, ReifiedLens' Palette Attr)] +paletteMap = + [ ("self" , Lens palSelf) + , ("time" , Lens palTime) + , ("meta" , Lens palMeta) + , ("sigil" , Lens palSigil) + , ("label" , Lens palLabel) + , ("latency" , Lens palLatency) + , ("window-name" , Lens palWindowName) + , ("error" , Lens palError) + , ("textbox" , Lens palTextBox) + , ("activity" , Lens palActivity) + , ("mention" , Lens palMention) + , ("command" , Lens palCommand) + , ("command-ready" , Lens palCommandReady) + , ("command-placeholder", Lens palCommandPlaceholder) + ] diff --git a/src/Client/Image/PaletteView.hs b/src/Client/Image/PaletteView.hs new file mode 100644 --- /dev/null +++ b/src/Client/Image/PaletteView.hs @@ -0,0 +1,61 @@ +{-| +Module : Client.Image.PaletteView +Description : View current palette and to see all terminal colors +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +Lines for the @/palette@ command. This view shows all the colors of +the current palette as well as the colors available in the terminal. + +-} + +module Client.Image.PaletteView + ( paletteViewLines + ) where + +import Client.Image.Palette +import Control.Lens +import Data.List +import Graphics.Vty.Image + +digits :: String +digits = "0123456789ABCDEF" + +digitImage :: Char -> Image +digitImage d = string defAttr [' ',d,' '] + +columns :: [Image] -> Image +columns = horizCat . intersperse (char defAttr ' ') + +-- | Generate lines used for @/palette@. These lines show +-- all the colors used in the current palette as well as +-- the colors available for use in palettes. +paletteViewLines :: Palette -> [Image] +paletteViewLines pal = + [ columns + $ digitImage digit + : [ string (withBackColor defAttr c) " " + | col <- [0 .. 15] + , let c = Color240 (row * 16 + col) + ] + | (digit,row) <- reverse $ take 15 $ zip (drop 1 digits) [0 ..] + ] ++ + [ columns + $ digitImage '0' + : [ string (withBackColor defAttr (ISOColor c)) " " + | c <- [0..15] + ] + + , columns (map digitImage (' ':digits)) + , emptyImage + , columns + [ text' (view l pal) name + | (name, Lens l) <- paletteMap + ] + , emptyImage + , columns + [ string attr "nicks" + | attr <- toListOf (palNicks . folded) pal + ] + ] diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs --- a/src/Client/Image/StatusLine.hs +++ b/src/Client/Image/StatusLine.hs @@ -32,13 +32,15 @@ -- | Renders the status line between messages and the textbox. statusLineImage :: ClientState -> Image statusLineImage st - = content <|> charFill defAttr '─' fillSize 1 + = activityBar <-> + content <|> charFill defAttr '─' fillSize 1 where fillSize = max 0 (view clientWidth st - imageWidth content) + (activitySummary, activityBar) = activityImages st content = horizCat [ myNickImage st , focusImage st - , activityImage st + , activitySummary , detailImage st , scrollImage st , latencyImage st @@ -86,21 +88,56 @@ where attr = view (clientConfig . configPalette . palLabel) st -activityImage :: ClientState -> Image -activityImage st - | null indicators = emptyImage - | otherwise = string defAttr "─[" <|> - horizCat indicators <|> - string defAttr "]" +activityImages :: ClientState -> (Image, Image) +activityImages st = (summary, activityBar) where - windows = views clientWindows Map.elems st + activityBar + | view clientActivityBar st = activityBar' <|> activityFill + | otherwise = emptyImage + + summary + | null indicators = emptyImage + | otherwise = string defAttr "─[" <|> + horizCat indicators <|> + string defAttr "]" + + activityFill = charFill defAttr '─' + (max 0 (view clientWidth st - imageWidth activityBar')) + 1 + + activityBar' = foldr baraux emptyImage + $ zip winNames + $ Map.toList + $ view clientWindows st + + baraux (i,(focus,w)) rest + | n == 0 = rest + | otherwise = string defAttr "─[" <|> + char (view palWindowName pal) i <|> + char defAttr ':' <|> + text' (view palLabel pal) focusText <|> + char defAttr ':' <|> + string attr (show n) <|> + string defAttr "]" <|> rest + where + n = view winUnread w + pal = view (clientConfig . configPalette) st + attr | view winMention w = view palMention pal + | otherwise = view palActivity pal + focusText = + case focus of + Unfocused -> Text.pack "*" + NetworkFocus net -> net + ChannelFocus _ chan -> idText chan + + windows = views clientWindows Map.elems st windowNames = view (clientConfig . configWindowNames) st - winNames = Text.unpack windowNames ++ repeat '?' - indicators = aux (zip winNames windows) - aux [] = [] - aux ((i,w):ws) - | view winUnread w == 0 = aux ws - | otherwise = char attr i : aux ws + winNames = Text.unpack windowNames ++ repeat '?' + + indicators = foldr aux [] (zip winNames windows) + aux (i,w) rest + | view winUnread w == 0 = rest + | otherwise = char attr i : rest where pal = view (clientConfig . configPalette) st attr | view winMention w = view palMention pal @@ -154,6 +191,10 @@ FocusWindows -> Just $ string (view palLabel pal) "windows" FocusInfo -> Just $ string (view palLabel pal) "info" FocusUsers -> Just $ string (view palLabel pal) "users" + 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 FocusMasks m -> Just $ horizCat [ string (view palLabel pal) "masks" , char defAttr ':' diff --git a/src/Client/Image/Textbox.hs b/src/Client/Image/Textbox.hs --- a/src/Client/Image/Textbox.hs +++ b/src/Client/Image/Textbox.hs @@ -104,8 +104,8 @@ renderLine :: Palette -> String -> Image renderLine pal ('/':xs) - | (cmd,rest) <- break isSpace xs - , Just (Command spec _) <- view (at (Text.pack cmd)) commands + | (cmd,rest) <- break isSpace xs + , Just (Command spec _ _) <- view (at (Text.pack cmd)) commands , let attr = case parseArguments spec rest of Nothing -> view palCommand pal diff --git a/src/Client/Image/UserList.hs b/src/Client/Image/UserList.hs --- a/src/Client/Image/UserList.hs +++ b/src/Client/Image/UserList.hs @@ -8,7 +8,10 @@ This module renders the lines used in the channel user list. -} -module Client.Image.UserList where +module Client.Image.UserList + ( userListImages + , userInfoImages + ) where import Client.Configuration import Client.Image.Message @@ -27,7 +30,9 @@ import Irc.Identifier import Irc.UserInfo --- | Render the lines used in a simple user list window. +-- | Render the lines used by the @/users@ command in normal mode. +-- These lines show the count of users having each channel mode +-- in addition to the nicknames of the users. userListImages :: Text {- ^ network -} -> Identifier {- ^ channel -} -> @@ -77,7 +82,9 @@ usersHashMap = view (csChannels . ix channel . chanUsers) cs --- | Render lines for detailed channel user list which shows full user info. +-- | Render lines for the @/users@ command in detailed view. +-- Each user will be rendered on a separate line with username +-- and host visible when known. userInfoImages :: Text {- ^ network -} -> Identifier {- ^ channel -} -> diff --git a/src/Client/Image/Windows.hs b/src/Client/Image/Windows.hs --- a/src/Client/Image/Windows.hs +++ b/src/Client/Image/Windows.hs @@ -8,7 +8,9 @@ This module implements the rendering of the client window list. -} -module Client.Image.Windows (windowsImages) where +module Client.Image.Windows + ( windowsImages + ) where import Client.Configuration import Client.Image.Palette @@ -22,6 +24,7 @@ import Graphics.Vty.Image import Irc.Identifier +-- | Draw the image lines associated with the @/windows@ command. windowsImages :: ClientState -> [Image] windowsImages st = reverse diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -14,6 +14,8 @@ ( -- * Client state type ClientState(..) + + -- * Lenses , clientWindows , clientTextBox , clientConnections @@ -26,6 +28,7 @@ , clientConfig , clientScroll , clientDetailView + , clientActivityBar , clientSubfocus , clientNextConnectionId , clientNetworkMap @@ -33,12 +36,12 @@ , clientConnection , clientBell , clientExtensions + + -- * Client operations , withClientState - , clientShutdown , clientStartExtensions + , clientShutdown , clientPark - - -- * Client operations , clientMatcher , urlPattern @@ -143,6 +146,7 @@ , _clientConfig :: !Configuration -- ^ client configuration , _clientScroll :: !Int -- ^ buffer scroll lines , _clientDetailView :: !Bool -- ^ use detailed rendering mode + , _clientActivityBar :: !Bool -- ^ visible activity bar , _clientBell :: !Bool -- ^ sound a bell next draw , _clientIgnores :: !(HashSet Identifier) -- ^ ignored nicknames @@ -214,6 +218,7 @@ , _clientConfig = cfg , _clientScroll = 0 , _clientDetailView = False + , _clientActivityBar = view configActivityBar cfg , _clientNextConnectionId = 0 , _clientBell = False , _clientExtensions = exts @@ -669,7 +674,13 @@ windows = view clientWindows st (focus,_) = Map.elemAt i windows -changeFocus :: Focus -> ClientState -> ClientState +-- | Change the window focus to the given value, reset the subfocus +-- to message view, reset the scroll, remember the previous focus +-- if it changed. +changeFocus :: + Focus {- ^ new focus -} -> + ClientState {- ^ client state -} -> + ClientState changeFocus focus st = set clientScroll 0 . updatePrevious @@ -682,7 +693,12 @@ | focus == oldFocus = id | otherwise = set clientPrevFocus oldFocus -changeSubfocus :: Subfocus -> ClientState -> ClientState +-- | Change the subfocus to the given value, preserve the focus, reset +-- the scroll. +changeSubfocus :: + Subfocus {- ^ new subfocus -} -> + ClientState {- ^ client state -} -> + ClientState changeSubfocus focus = set clientScroll 0 . set clientSubfocus focus @@ -718,13 +734,23 @@ isForward = not isReversed (l,r) = Map.split (view clientFocus st) (view clientWindows st) -clientHighlights :: NetworkState -> ClientState -> HashSet Identifier +-- | Compute the set of extra identifiers that should be highlighted given +-- a particular network state. +clientHighlights :: + NetworkState {- ^ network state -} -> + ClientState {- ^ client state -} -> + HashSet Identifier {- ^ extra highlight identifiers -} clientHighlights cs st = HashSet.insert (view csNick cs) (view (clientConfig . configExtraHighlights) st) -clientHighlightsNetwork :: Text -> ClientState -> HashSet Identifier +-- | Compute the set of extra identifiers that should be highlighted given +-- a particular network. +clientHighlightsNetwork :: + Text {- ^ network -} -> + ClientState {- ^ client state -} -> + HashSet Identifier {- ^ extra highlight identifiers -} clientHighlightsNetwork network st = case preview (clientConnection network) st of Just cs -> clientHighlights cs st diff --git a/src/Client/State/EditBox/Content.hs b/src/Client/State/EditBox/Content.hs --- a/src/Client/State/EditBox/Content.hs +++ b/src/Client/State/EditBox/Content.hs @@ -66,7 +66,7 @@ endLine s = Line (length s) s -- | Zipper-ish view of the multi-line content of an 'EditBox'. --- Lines '_above' the '_currentLine' are stored in reverse order. +-- Lines 'above' the 'currentLine' are stored in reverse order. data Content = Content { _above :: ![String] , _currentLine :: !Line diff --git a/src/Client/State/Focus.hs b/src/Client/State/Focus.hs --- a/src/Client/State/Focus.hs +++ b/src/Client/State/Focus.hs @@ -54,6 +54,8 @@ | FocusUsers -- ^ Show channel user list | FocusMasks !Char -- ^ Show channel mask list for given mode | FocusWindows -- ^ Show client windows + | FocusPalette -- ^ Show current palette + | FocusHelp (Maybe Text) -- ^ Show help window with optional command deriving (Eq,Show) makePrisms ''Subfocus diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs --- a/src/Client/State/Network.hs +++ b/src/Client/State/Network.hs @@ -22,6 +22,7 @@ NetworkState(..) , newNetworkState + -- * Lenses , csNick , csChannels , csSocket @@ -143,6 +144,9 @@ csNick :: Lens' NetworkState Identifier csNick = csUserInfo . uiNick +-- | Transmit a 'RawIrcMsg' on the connection associated +-- with the given network. For @PRIVMSG@ and @NOTICE@ overlong +-- commands are detected and transmitted as multiple messages. sendMsg :: NetworkState -> RawIrcMsg -> IO () sendMsg cs msg = case (view msgCommand msg, view msgParams msg) of @@ -185,13 +189,15 @@ case Text.splitAt (charIx - startChar) currentTxt of (a,b) -> a : search byteIx charIx b xs' +-- | Construct a new network state using the given settings and +-- default values as specified by the IRC specification. newNetworkState :: - NetworkId -> - Text -> - ServerSettings -> - NetworkConnection -> - PingStatus -> - NetworkState + NetworkId {- ^ unique network ID -} -> + Text {- ^ network name -} -> + ServerSettings {- ^ server settings -} -> + NetworkConnection {- ^ active network connection -} -> + PingStatus {- ^ initial ping status -} -> + NetworkState {- ^ new network state -} newNetworkState networkId network settings sock ping = NetworkState { _csNetworkId = networkId , _csUserInfo = UserInfo "*" "" "" @@ -213,7 +219,9 @@ } - +-- | Used for updates to a 'NetworkState' that require no reply. +-- +-- @noReply x = ([], x)@ noReply :: NetworkState -> ([RawIrcMsg], NetworkState) noReply x = ([], x) diff --git a/src/Config/FromConfig.hs b/src/Config/FromConfig.hs --- a/src/Config/FromConfig.hs +++ b/src/Config/FromConfig.hs @@ -85,6 +85,12 @@ parseConfig (Text x) = return x parseConfig _ = failure "expected text" +-- | Matches @yes@ as 'True' and @no@ as 'False. +instance FromConfig Bool where + parseConfig (Atom "yes") = return True + parseConfig (Atom "no") = return False + parseConfig _ = failure "expected yes or no" + -- | Matches 'Number' values ignoring the base instance FromConfig Integer where parseConfig (Number _ n) = return n