diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for glirc2 +## 2.8 + +* Support `vty-5.8` +* Implement inital support for macros +* Support `znc.in/self-message` + ## 2.7 * Switch to regex-tdfa (easier to install on macOS than text-icu) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -89,6 +89,12 @@ server-certificates: * "/path/to/extra/certificate.pem" +macros: + * name: "wipe" + commands: + * "clear" + * "znc *status clearbuffer $channel" + palette: time: fg: [10,10,10] -- RGB values for color for timestamps @@ -290,6 +296,37 @@ * `^]` italic * `^O` reset formatting * `M-Enter` insert newline + +Macros +====== + +The `macros` configuration section allows you to define +sequences of commands. These commands can contain expansions. + +Configuration +------------- + +* `name` - text - name of macro +* `commands` - list of text - commands to send after expansion + +Expansions +---------- + +Variable names and integer indexes can be used when defining commands. +Variables are specified with a leading `$`. For disambiguation a variable +name can be surrounded by `{}`. `$channel` and `${channel}` are +equivalent. + +* `channel` - current channel +* `network` - current network name +* `nick` - current nickname + +The arguments to a command will be mapped to integer indexes. The command +itself is at index zero. + +* `0` - command +* `1` - first argument +* `2` - second argument (etc.) Hooks ===== diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.7 +version: 2.8 synopsis: Console IRC client description: Console IRC client license: ISC @@ -29,6 +29,7 @@ other-modules: Client.ChannelState Client.CommandArguments Client.Commands + Client.Commands.Interpolation Client.Configuration Client.Configuration.Colors Client.Connect @@ -82,7 +83,7 @@ transformers >=0.5.2 && <0.6, unordered-containers >=0.2.7 && <0.3, vector >=0.11 && <0.12, - vty >=5.7 && <5.8, + vty >=5.8 && <5.9, 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/CommandArguments.hs b/src/Client/CommandArguments.hs --- a/src/Client/CommandArguments.hs +++ b/src/Client/CommandArguments.hs @@ -21,9 +21,9 @@ , getCommandArguments ) where -import Client.State import Control.Lens import Data.Foldable +import Data.Text (Text) import qualified Data.Text as Text import Data.Version import Development.GitRev (gitHash, gitDirty) @@ -36,9 +36,9 @@ -- | Command-line arguments data CommandArguments = CommandArguments { _cmdArgConfigFile :: Maybe FilePath -- ^ configuration file path - , _cmdArgInitialNetworks :: [NetworkName] -- ^ initial networks - , _cmdArgShowHelp :: Bool -- ^ show help message - , _cmdArgShowVersion :: Bool -- ^ show version message + , _cmdArgInitialNetworks :: [Text] -- ^ initial networks + , _cmdArgShowHelp :: Bool -- ^ show help message + , _cmdArgShowVersion :: Bool -- ^ show version message } makeLenses ''CommandArguments diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -14,10 +14,11 @@ module Client.Commands ( CommandResult(..) , execute - , executeCommand + , executeUserCommand , tabCompletion ) where +import Client.Commands.Interpolation import Client.Configuration import Client.ConnectionState import qualified Client.EditBox as Edit @@ -56,10 +57,29 @@ -- ^ Continue running the client, report an error | CommandQuit -- ^ Client should close -type ClientCommand = ClientState -> String -> IO CommandResult -type NetworkCommand = NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult -type ChannelCommand = NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult +-- | Type of commands that always work +type ClientCommand = + ClientState -> + String {- ^ command arguments -} -> + IO CommandResult +-- | Type of commands that require an active network to be focused +type NetworkCommand = + Text {- ^ focused network -} -> + ConnectionState {- ^ focused connection state -} -> + ClientState -> + String {- ^ command arguments -} -> + IO CommandResult + +-- | Type of commands that require an active channel to be focused +type ChannelCommand = + Text {- ^ focused network -} -> + ConnectionState {- ^ focused connection state -} -> + Identifier {- ^ focused channel -} -> + ClientState -> + String {- ^ command arguments -} -> + IO CommandResult + -- | Pair of implementations for executing a command and tab completing one. -- The tab-completion logic is extended with a bool -- indicating that tab completion should be reversed @@ -86,9 +106,42 @@ execute str st = case str of [] -> commandFailure st - '/':command -> executeCommand Nothing command st + '/':command -> executeUserCommand command st msg -> executeChat msg st +-- | Execute command provided by user, resolve aliases if necessary. +executeUserCommand :: String -> ClientState -> IO CommandResult +executeUserCommand command st = + let key = Text.pack (takeWhile (/=' ') command) in + + case preview (clientConfig . configMacros . ix key) st of + Nothing -> executeCommand Nothing command st + Just cmdExs -> + case traverse (resolveExpansions expandVar expandInt) cmdExs of + Nothing -> commandFailure st + Just cmds -> process cmds st + where + args = Text.words (Text.pack command) + + expandInt i = preview (ix (fromInteger i)) args + + expandVar v = + case v of + "network" -> views clientFocus focusNetwork st + "channel" -> previews (clientFocus . _ChannelFocus . _2) idText st + "nick" -> do net <- views clientFocus focusNetwork st + cs <- preview (clientConnection net) st + return (views csNick idText cs) + _ -> Nothing + + process [] st0 = commandSuccess st0 + process (c:cs) st0 = + do res <- executeCommand Nothing (Text.unpack c) st0 + case res of + CommandSuccess st1 -> process cs st1 + CommandFailure st1 -> process cs st1 -- ? + CommandQuit -> return CommandQuit + -- | Respond to the TAB key being pressed. This can dispatch to a command -- specific completion mode when relevant. Otherwise this will complete -- input based on the users of the channel related to the current buffer. @@ -341,16 +394,17 @@ sendMsg cs (ircPrivmsg (mkId tgtTxt) restTxt) chatCommand - (\src tgt -> Notice src tgt restTxt) + (\src tgt -> Privmsg src tgt restTxt) tgtTxt network cs st +-- | Common logic for @/msg@ and @/notice@ chatCommand :: (UserInfo -> Identifier -> IrcMsg) -> - Text {- ^ target -} -> - NetworkName -> - ConnectionState -> - ClientState -> + Text {- ^ target -} -> + Text {- ^ network -} -> + ConnectionState -> + ClientState -> IO CommandResult chatCommand con targetsTxt network cs st = do now <- getZonedTime @@ -492,7 +546,8 @@ _ -> commandFailure st where - timeFormats = ["%T","%R"] + -- %k doesn't require a leading 0 for times before 10AM + timeFormats = ["%k:%M:%S","%k:%M"] dateFormats = ["%F"] parse formats str = asum (map (parseTimeM False defaultTimeLocale ?? str) formats) @@ -525,7 +580,7 @@ cmdSay :: ChannelCommand cmdSay _network _cs _channelId st rest = executeChat rest st -cmdInvite :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult +cmdInvite :: ChannelCommand cmdInvite _ cs channelId st rest = case words rest of [nick] -> @@ -544,7 +599,7 @@ commandSuccess $ setStrict (clientConnections . ix networkId) cs st -cmdTopic :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult +cmdTopic :: ChannelCommand cmdTopic _ cs channelId st rest = do let cmd = case dropWhile isSpace rest of @@ -558,10 +613,7 @@ tabTopic :: Bool {- ^ reversed -} -> - NetworkName -> - ConnectionState -> - Identifier {- ^ channel -} -> - ClientState -> String -> IO CommandResult + ChannelCommand tabTopic _ _ cs channelId st rest | all isSpace rest @@ -586,7 +638,7 @@ commandSuccess (changeSubfocus (FocusMasks mode) st) _ -> commandFailure st -cmdKick :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult +cmdKick :: ChannelCommand cmdKick _ cs channelId st rest = case nextWord rest of Nothing -> commandFailure st @@ -597,7 +649,7 @@ commandSuccessUpdateCS cs' st -cmdKickBan :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult +cmdKickBan :: ChannelCommand cmdKickBan _ cs channelId st rest = case nextWord rest of Nothing -> commandFailure st @@ -619,7 +671,7 @@ Nothing -> UserInfo who "*" "*" Just (UserAndHost _ host) -> UserInfo (mkId "*") "*" host -cmdRemove :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult +cmdRemove :: ChannelCommand cmdRemove _ cs channelId st rest = case nextWord rest of Nothing -> commandFailure st @@ -629,7 +681,7 @@ cs' <- sendModeration channelId [cmd] cs commandSuccessUpdateCS cs' st -cmdJoin :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult +cmdJoin :: NetworkCommand cmdJoin network cs st rest = let ws = words rest doJoin channelStr keyStr = @@ -654,13 +706,13 @@ _ -> commandFailure st -cmdQuit :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult +cmdQuit :: NetworkCommand cmdQuit _ cs st rest = do let msg = Text.pack (dropWhile isSpace rest) sendMsg cs (ircQuit msg) commandSuccess st -cmdDisconnect :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult +cmdDisconnect :: NetworkCommand cmdDisconnect network _ st _ = do st' <- abortNetwork network st commandSuccess st' @@ -668,7 +720,7 @@ -- | Reconnect to the currently focused network. It's possible -- that we're not currently connected to a network, so -- this is implemented as a client command. -cmdReconnect :: ClientState -> String -> IO CommandResult +cmdReconnect :: ClientCommand cmdReconnect st _ | Just network <- views clientFocus focusNetwork st = @@ -678,7 +730,7 @@ | otherwise = commandFailure st -cmdIgnore :: ClientState -> String -> IO CommandResult +cmdIgnore :: ClientCommand cmdIgnore st rest = case mkId . Text.pack <$> words rest of [] -> commandFailure st @@ -709,7 +761,11 @@ tabReload :: Bool {- ^ reversed -} -> ClientCommand tabReload _ st _ = commandFailure st -modeCommand :: [Text] -> ConnectionState -> ClientState -> IO CommandResult +modeCommand :: + [Text] {- mode parameters -} -> + ConnectionState -> + ClientState -> + IO CommandResult modeCommand modes cs st = case view clientFocus st of @@ -818,7 +874,9 @@ n = length leadingPart (cursorPos, line) = clientLine st leadingPart = takeWhile (not . isSpace) line - possibilities = mkId . Text.cons '/' <$> HashMap.keys commands + possibilities = mkId . Text.cons '/' <$> commandNames + commandNames = HashMap.keys commands + ++ HashMap.keys (view (clientConfig . configMacros) st) -- | Complete the nickname at the current cursor position using the -- userlist for the currently focused channel (if any) @@ -830,7 +888,15 @@ hint = activeNicks st completions = currentCompletionList st -sendModeration :: Identifier -> [RawIrcMsg] -> ConnectionState -> IO ConnectionState +-- | 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 -} -> + ConnectionState {- ^ network state -} -> + IO ConnectionState sendModeration channel cmds cs | useChanServ channel cs = do sendMsg cs (ircPrivmsg (mkId "ChanServ") ("OP " <> idText channel)) diff --git a/src/Client/Commands/Interpolation.hs b/src/Client/Commands/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Interpolation.hs @@ -0,0 +1,60 @@ +{-# Language OverloadedStrings #-} + +{-| +Module : Client.Commands.Interpolation +Description : Parser and evaluator for string interpolation in commands +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module is able to parse commands with inline variables and then +to evaluate those variables to produce a complete command that varies +by the current context. +-} +module Client.Commands.Interpolation + ( ExpansionChunk(..) + , parseExpansion + , resolveExpansions + ) where + +import Control.Applicative +import Data.Attoparsec.Text as P +import Data.Char +import qualified Data.Text as Text +import Data.Text (Text) + +data ExpansionChunk + = LiteralChunk Text -- ^ regular text + | VariableChunk Text -- ^ inline variable @$x@ or @${x y}@ + | IntegerChunk Integer -- ^ inline variable @$1@ or @${1}@ + deriving Show + +parseExpansion :: Text -> Maybe [ExpansionChunk] +parseExpansion txt = + case parseOnly (many parseChunk <* endOfInput) txt of + Left{} -> Nothing + Right chunks -> Just chunks + +parseChunk :: Parser ExpansionChunk +parseChunk = + choice + [ LiteralChunk <$> P.takeWhile1 (/= '$') + , LiteralChunk "$" <$ P.string "$$" + , string "${" *> parseVariable <* char '}' + , char '$' *> parseVariable + ] + +parseVariable :: Parser ExpansionChunk +parseVariable = IntegerChunk <$> P.decimal + <|> VariableChunk <$> P.takeWhile1 isAlpha + +resolveExpansions :: + (Text -> Maybe Text) {- ^ variable resolution -} -> + (Integer -> Maybe Text) {- ^ argument index resolution -} -> + [ExpansionChunk] -> + Maybe Text +resolveExpansions var arg xs = Text.concat <$> traverse resolve1 xs + where + resolve1 (LiteralChunk lit) = Just lit + resolve1 (VariableChunk v) = var v + resolve1 (IntegerChunk i) = arg i diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -24,6 +24,7 @@ , configWindowNames , configNickPadding , configConfigPath + , configMacros -- * Loading configuration , loadConfiguration @@ -34,6 +35,7 @@ import Client.Image.Palette import Client.Configuration.Colors +import Client.Commands.Interpolation import Client.ServerSettings import Control.Exception import Control.Monad @@ -64,6 +66,7 @@ , _configNickPadding :: Maybe Integer -- ^ Padding of nicks , _configConfigPath :: Maybe FilePath -- ^ manually specified configuration path, used for reloading + , _configMacros :: HashMap Text [[ExpansionChunk]] -- ^ command macros } deriving Show @@ -170,6 +173,9 @@ _configWindowNames <- fromMaybe defaultWindowNames <$> sectionOpt "window-names" + _configMacros <- fromMaybe HashMap.empty + <$> sectionOptWith parseMacroMap "macros" + _configNickPadding <- sectionOpt "nick-padding" for_ _configNickPadding (\padding -> when (padding < 0) @@ -281,3 +287,19 @@ | isAbsolute path = return path | otherwise = do home <- getHomeDirectory return (home path) + +parseMacroMap :: Value -> ConfigParser (HashMap Text [[ExpansionChunk]]) +parseMacroMap v = HashMap.fromList <$> parseList parseMacro v + +parseMacro :: Value -> ConfigParser (Text, [[ExpansionChunk]]) +parseMacro = parseSections $ + do name <- sectionReq "name" + commands <- sectionReqWith (parseList parseMacroCommand) "commands" + return (name, commands) + +parseMacroCommand :: Value -> ConfigParser [ExpansionChunk] +parseMacroCommand v = + do txt <- parseConfig v + case parseExpansion txt of + Nothing -> failure "bad macro line" + Just ex -> return ex diff --git a/src/Client/ConnectionState.hs b/src/Client/ConnectionState.hs --- a/src/Client/ConnectionState.hs +++ b/src/Client/ConnectionState.hs @@ -559,7 +559,7 @@ applyOne modes (False, mode, _) = delete mode modes supportedCaps :: ConnectionState -> [Text] -supportedCaps cs = sasl ++ ["multi-prefix", "znc.in/playback", "znc.in/server-time-iso"] +supportedCaps cs = sasl ++ ["multi-prefix", "znc.in/playback", "znc.in/server-time-iso", "znc.in/self-message"] where ss = view csSettings cs sasl = ["sasl" | isJust (view ssSaslUsername ss) diff --git a/src/Client/EditBox.hs b/src/Client/EditBox.hs --- a/src/Client/EditBox.hs +++ b/src/Client/EditBox.hs @@ -156,7 +156,7 @@ leftWord c | n == 0 = case view above c of - [] -> c + [] -> c (a:as) -> leftWord . set current (endLine a) . over below (cons txt) @@ -164,7 +164,7 @@ $ c | otherwise = case search of - [] -> set (current.pos) 0 c + [] -> set (current.pos) 0 c (i,_):_ -> set (current.pos) (i+1) c where Line n txt = view current c diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -40,6 +40,8 @@ import Data.Ord import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text import Data.Time import Graphics.Vty import Irc.Codes @@ -218,7 +220,7 @@ Text {- ^ command -} -> IO ClientState processConnectCmd now cs st0 cmdTxt = - do res <- executeCommand Nothing (Text.unpack cmdTxt) st0 + do res <- executeUserCommand (Text.unpack cmdTxt) st0 return $! case res of CommandFailure st -> reportConnectCmdError now cs cmdTxt st CommandSuccess st -> st @@ -270,7 +272,10 @@ (w,h) <- displayBounds (outputIface vty) eventLoop $ set clientWidth w $ set clientHeight h st - EvPaste s -> eventLoop (over (clientTextBox . Edit.content) (Edit.insertString s) st) + EvPaste utf8 -> + let str = Text.unpack (Text.decodeUtf8With Text.lenientDecode utf8) + st' = over (clientTextBox . Edit.content) (Edit.insertString str) st + in eventLoop st' _ -> eventLoop st diff --git a/src/Client/Image/ChannelInfo.hs b/src/Client/Image/ChannelInfo.hs --- a/src/Client/Image/ChannelInfo.hs +++ b/src/Client/Image/ChannelInfo.hs @@ -24,13 +24,14 @@ import Client.MircFormatting import Client.State import Control.Lens +import Data.Text (Text) import Data.Time import Graphics.Vty.Image import Irc.Identifier -- | Render the lines used in a channel mask list channelInfoImages :: - NetworkName {- ^ network -} -> + Text {- ^ network -} -> Identifier {- ^ channel -} -> ClientState -> [Image] channelInfoImages network channelId st diff --git a/src/Client/Image/MaskList.hs b/src/Client/Image/MaskList.hs --- a/src/Client/Image/MaskList.hs +++ b/src/Client/Image/MaskList.hs @@ -31,7 +31,7 @@ -- | Render the lines used in a channel mask list maskListImages :: Char {- ^ Mask mode -} -> - NetworkName {- ^ network -} -> + Text {- ^ network -} -> Identifier {- ^ channel -} -> ClientState -> [Image] maskListImages mode network channel st = 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 @@ -266,7 +266,7 @@ parseIrcText reason Reply code params -> - renderReplyCode rm code <|> + renderReplyCode rm rp code <|> char defAttr ' ' <|> separatedParams (dropFst params) where @@ -311,12 +311,14 @@ separatedParams :: [Text] -> Image separatedParams = horizCat . intersperse separatorImage . map parseIrcText -renderReplyCode :: RenderMode -> ReplyCode -> Image -renderReplyCode rm code@(ReplyCode w) = +renderReplyCode :: RenderMode -> MessageRendererParams -> ReplyCode -> Image +renderReplyCode rm rp code@(ReplyCode w) = case rm of DetailedRender -> string attr (show w) - NormalRender -> text' attr (Text.toLower (replyCodeText info)) <|> - char defAttr ':' + NormalRender -> + rightPad rm (rendNickPadding rp) + (text' attr (Text.toLower (replyCodeText info))) <|> + char defAttr ':' where info = replyCodeInfo code 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 #-} +{-# Language TemplateHaskell, OverloadedLists #-} {-| Module : Client.Image.Palette Description : Palette of colors used to render the UI @@ -32,7 +32,6 @@ import Control.Lens import Data.Vector (Vector) -import qualified Data.Vector as Vector import Graphics.Vty.Attributes -- | Color palette used for rendering the client UI @@ -76,8 +75,7 @@ -- | Default nick highlighting colors that look nice in my dark solarized -- color scheme. defaultNickColorPalette :: Vector Attr -defaultNickColorPalette - = fmap (withForeColor defAttr) - $ Vector.fromList - [cyan, magenta, green, yellow, blue, - brightCyan, brightMagenta, brightGreen, brightBlue] +defaultNickColorPalette = + withForeColor defAttr <$> + [cyan, magenta, green, yellow, blue, + brightCyan, brightMagenta, brightGreen, brightBlue] 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 @@ -21,6 +21,7 @@ import qualified Data.Map.Strict as Map import Data.List import Data.Ord +import Data.Text (Text) import qualified Data.Text as Text import Graphics.Vty.Image import Irc.Identifier @@ -28,9 +29,10 @@ -- | Render the lines used in a simple user list window. userListImages :: - NetworkName {- ^ Focused network name -} -> - Identifier {- ^ Focused channel name -} -> - ClientState -> [Image] + Text {- ^ network -} -> + Identifier {- ^ channel -} -> + ClientState -> + [Image] userListImages network channel st = case preview (clientConnection network) st of Just cs -> userListImages' cs channel st @@ -77,9 +79,10 @@ -- | Render lines for detailed channel user list which shows full user info. userInfoImages :: - NetworkName {- ^ Focused network name -} -> - Identifier {- ^ Focused channel name -} -> - ClientState -> [Image] + Text {- ^ network -} -> + Identifier {- ^ channel -} -> + ClientState -> + [Image] userInfoImages network channel st = case preview (clientConnection network) st of Just cs -> userInfoImages' cs channel st diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -13,8 +13,7 @@ module Client.State ( -- * Client state type - NetworkName - , ClientState(..) + ClientState(..) , clientWindows , clientTextBox , clientConnections @@ -55,6 +54,9 @@ -- * Focus information , ClientFocus(..) + , _ChannelFocus + , _NetworkFocus + , _Unfocused , ClientSubfocus(..) , focusNetwork , changeFocus @@ -69,7 +71,6 @@ import Client.ConnectionState import qualified Client.EditBox as Edit import Client.Image.Message -import Client.Image.Palette import Client.Message import Client.NetworkConnection import Client.ServerSettings @@ -103,21 +104,20 @@ import Text.Regex.TDFA.Text () -- RegexLike Regex Text orphan import Network.Connection --- | Textual name of a network connection -type NetworkName = Text - -- | Currently focused window data ClientFocus - = Unfocused -- ^ No network - | NetworkFocus !NetworkName -- ^ Network - | ChannelFocus !NetworkName !Identifier -- ^ Channel on network + = Unfocused -- ^ No network + | NetworkFocus !Text -- ^ Network + | ChannelFocus !Text !Identifier -- ^ Network Channel/Nick deriving Eq +makePrisms ''ClientFocus + -- | Subfocus for a channel view data ClientSubfocus - = FocusMessages -- ^ Show chat messages - | FocusInfo -- ^ Show channel metadata - | FocusUsers -- ^ Show user list + = FocusMessages -- ^ Show chat messages + | FocusInfo -- ^ Show channel metadata + | FocusUsers -- ^ Show user list | FocusMasks !Char -- ^ Show mask list for given mode deriving Eq @@ -144,9 +144,8 @@ , _clientConnections :: !(IntMap ConnectionState) -- ^ state of active connections , _clientNextConnectionId :: !Int , _clientConnectionContext :: !ConnectionContext -- ^ network connection context - , _clientEvents :: !(TQueue NetworkEvent) -- ^ incoming network event queue - , _clientNetworkMap :: !(HashMap NetworkName NetworkId) - -- ^ network name to connection ID + , _clientEvents :: !(TQueue NetworkEvent) -- ^ incoming network event queue + , _clientNetworkMap :: !(HashMap Text NetworkId) -- ^ network name to connection ID , _clientVty :: !Vty -- ^ VTY handle , _clientTextBox :: !Edit.EditBox -- ^ primary text box @@ -164,7 +163,10 @@ -- | 'Traversal' for finding the 'ConnectionState' associated with a given network -- if that connection is currently active. -clientConnection :: Applicative f => NetworkName -> LensLike' f ClientState ConnectionState +clientConnection :: + Applicative f => + Text {- ^ network -} -> + LensLike' f ClientState ConnectionState clientConnection network f st = case view (clientNetworkMap . at network) st of Nothing -> pure st @@ -175,11 +177,11 @@ clientFirstLine = views (clientTextBox . Edit.content) Edit.firstLine -- | The line under the cursor in the edit box. -clientLine :: ClientState -> (Int, String) +clientLine :: ClientState -> (Int, String) {- ^ line number, line content -} clientLine = views (clientTextBox . Edit.line) (\(Edit.Line n t) -> (n, t)) -- | Return the network associated with the current focus -focusNetwork :: ClientFocus -> Maybe NetworkName +focusNetwork :: ClientFocus -> Maybe Text {- ^ network -} focusNetwork Unfocused = Nothing focusNetwork (NetworkFocus network) = Just network focusNetwork (ChannelFocus network _) = Just network @@ -212,7 +214,9 @@ -- | Forcefully terminate the connection currently associated -- with a given network name. -abortNetwork :: NetworkName -> ClientState -> IO ClientState +abortNetwork :: + Text {- ^ network -} -> + ClientState -> IO ClientState abortNetwork network st = case preview (clientConnection network) st of Nothing -> return st @@ -221,32 +225,29 @@ -- | Add a message to the window associated with a given channel recordChannelMessage :: - NetworkName -> + Text {- ^ network -} -> Identifier {- ^ channel -} -> - ClientMessage -> ClientState -> ClientState + ClientMessage -> + ClientState -> ClientState recordChannelMessage network channel msg st = - over (clientWindows . at focus) - (\w -> Just $! addToWindow importance wl (fromMaybe emptyWindow w)) - st + recordWindowLine focus importance wl st where - focus = ChannelFocus network channel' - wl = toWindowLine rendParams msg - myNicks = toListOf (clientConnection network . csNick) st + focus = ChannelFocus network channel' + wl = toWindowLine rendParams msg + rendParams = MessageRendererParams - { rendStatusMsg = statusModes - , rendUserSigils = computeMsgLineSigils network channel' msg st - , rendNicks = channelUserList network channel' st - , rendMyNicks = myNicks - , rendPalette = palette + { rendStatusMsg = statusModes + , rendUserSigils = computeMsgLineSigils network channel' msg st + , rendNicks = channelUserList network channel' st + , rendMyNicks = toListOf (clientConnection network . csNick) st + , rendPalette = view (clientConfig . configPalette) st , rendNickPadding = view (clientConfig . configNickPadding) st } - palette = view (clientConfig . configPalette) st - -- on failure returns mempty/"" - possibleStatusModes = view (clientConnection network . csStatusMsg) st + possibleStatusModes = view (clientConnection network . csStatusMsg) st (statusModes, channel') = splitStatusMsgModes possibleStatusModes channel - importance = msgImportance msg st + importance = msgImportance msg st -- | Compute the importance of a message to be used when computing -- change notifications in the client. @@ -310,20 +311,23 @@ -- | Record a message in the windows corresponding to the given target recordIrcMessage :: - NetworkName -> MessageTarget -> ClientMessage -> ClientState -> ClientState + Text {- ^ network -} -> + MessageTarget -> + ClientMessage -> + ClientState -> ClientState recordIrcMessage network target msg st = case target of - TargetHidden -> st - TargetNetwork -> recordNetworkMessage msg st + TargetHidden -> st + TargetNetwork -> recordNetworkMessage msg st TargetWindow chan -> recordChannelMessage network chan msg st - TargetUser user -> + TargetUser user -> foldl' (\st' chan -> overStrict (clientWindows . ix (ChannelFocus network chan)) (addToWindow WLBoring wl) st') st chans where - pal = view (clientConfig . configPalette) st - wl = toWindowLine' pal msg + cfg = view clientConfig st + wl = toWindowLine' cfg msg chans = user : case preview (clientConnection network . csChannels) st of Nothing -> [] @@ -341,7 +345,7 @@ -- | Compute the sigils of the user who sent a message. computeMsgLineSigils :: - NetworkName -> + Text {- ^ network -} -> Identifier {- ^ channel -} -> ClientMessage -> ClientState -> @@ -353,7 +357,7 @@ -- | Compute sigils for a user on a channel computeUserSigils :: - NetworkName -> + Text {- ^ network -} -> Identifier {- ^ channel -} -> Identifier {- ^ user -} -> ClientState -> @@ -365,30 +369,50 @@ -- | Record a message on a network window recordNetworkMessage :: ClientMessage -> ClientState -> ClientState -recordNetworkMessage msg st = - over (clientWindows . at (NetworkFocus network)) - (\w -> Just $! addToWindow (msgImportance msg st) wl (fromMaybe emptyWindow w)) - st +recordNetworkMessage msg st = recordWindowLine focus importance wl st where - network = view msgNetwork msg - pal = view (clientConfig . configPalette) st - wl = toWindowLine' pal msg + focus = NetworkFocus (view msgNetwork msg) + importance = msgImportance msg st + wl = toWindowLine' cfg msg + cfg = view clientConfig st + +-- | Record window line at the given focus creating the window if necessary +recordWindowLine :: + ClientFocus -> + WindowLineImportance -> + WindowLine -> + ClientState -> ClientState +recordWindowLine focus importance wl = + over (clientWindows . at focus) + (\w -> Just $! addToWindow importance wl (fromMaybe emptyWindow w)) + toWindowLine :: MessageRendererParams -> ClientMessage -> WindowLine toWindowLine params msg = WindowLine { _wlBody = view msgBody msg - , _wlText = views msgBody msgText msg - , _wlImage = force $ msgImage NormalRender (view msgTime msg) params (view msgBody msg) - , _wlFullImage = force $ msgImage DetailedRender (view msgTime msg) params (view msgBody msg) + , _wlText = msgText (view msgBody msg) + , _wlImage = mkImage NormalRender + , _wlFullImage = mkImage DetailedRender } + where + mkImage mode = + force (msgImage mode (view msgTime msg) params (view msgBody msg)) -toWindowLine' :: Palette -> ClientMessage -> WindowLine -toWindowLine' pal = toWindowLine defaultRenderParams { rendPalette = pal } +-- | 'toWindowLine' but with mostly defaulted parameters. +toWindowLine' :: Configuration -> ClientMessage -> WindowLine +toWindowLine' config = + toWindowLine defaultRenderParams + { rendPalette = view configPalette config + , rendNickPadding = view configNickPadding config + } + +-- | Function applied to the client state every redraw. clientTick :: ClientState -> ClientState clientTick = set clientBell False . markSeen +-- | Mark the messages on the current window as seen. markSeen :: ClientState -> ClientState markSeen st = case view clientSubfocus st of @@ -415,39 +439,38 @@ stepFocus isReversed st | view clientSubfocus st /= FocusMessages = changeSubfocus FocusMessages st - | isReversed, Just ((k,_),_) <- Map.maxViewWithKey l = success k - | isReversed, Just ((k,_),_) <- Map.maxViewWithKey r = success k + | isReversed, Just ((k,_),_) <- Map.maxViewWithKey l = changeFocus k st + | isReversed, Just ((k,_),_) <- Map.maxViewWithKey r = changeFocus k st - | isForward , Just ((k,_),_) <- Map.minViewWithKey r = success k - | isForward , Just ((k,_),_) <- Map.minViewWithKey l = success k + | isForward , Just ((k,_),_) <- Map.minViewWithKey r = changeFocus k st + | isForward , Just ((k,_),_) <- Map.minViewWithKey l = changeFocus k st | otherwise = st where isForward = not isReversed - - (l,r) = Map.split oldFocus windows - - success x = set clientScroll 0 - $ set clientFocus x st - oldFocus = view clientFocus st - windows = view clientWindows st + (l,r) = Map.split (view clientFocus st) (view clientWindows st) -- | Returns the current network's channels and current channel's users. currentCompletionList :: ClientState -> [Identifier] currentCompletionList st = case view clientFocus st of - NetworkFocus network -> - networkChannelList network st - ChannelFocus network chan -> - networkChannelList network st - ++ channelUserList network chan st + NetworkFocus network -> networkChannelList network st + ChannelFocus network chan -> networkChannelList network st + ++ channelUserList network chan st _ -> [] -networkChannelList :: NetworkName -> ClientState -> [Identifier] +networkChannelList :: + Text {- ^ network -} -> + ClientState -> + [Identifier] {- ^ channels -} networkChannelList network = views (clientConnection network . csChannels) HashMap.keys -channelUserList :: NetworkName -> Identifier -> ClientState -> [Identifier] +channelUserList :: + Text {- ^ network -} -> + Identifier {- ^ channel -} -> + ClientState -> + [Identifier] {- ^ nicks -} channelUserList network channel = views (clientConnection network . csChannels . ix channel . chanUsers) HashMap.keys @@ -462,10 +485,11 @@ = set clientScroll 0 . set clientSubfocus focus +-- | 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 + ("/grep" ,_:reStr) -> go True reStr ("/grepi",_:reStr) -> go False reStr _ -> const True where @@ -514,9 +538,9 @@ $ set (clientConnections . at i) (Just cs) st' applyMessageToClientState :: - ZonedTime {- ^ message received -} -> + ZonedTime {- ^ timestamp -} -> IrcMsg {- ^ message recieved -} -> - NetworkId {- ^ messge network -} -> + NetworkId {- ^ message network -} -> ConnectionState {- ^ network connection state -} -> ClientState -> ([RawIrcMsg], ClientState) {- ^ response , updated state -} @@ -524,13 +548,16 @@ cs' `seq` (reply, st') where (reply, cs') = applyMessage time irc cs - network = view csNetwork cs - st' = applyWindowRenames network irc - $ set (clientConnections . ix networkId) cs' st + network = view csNetwork cs + st' = applyWindowRenames network irc + $ set (clientConnections . ix networkId) cs' st -- | When a nick change happens and there is an open query window for that nick -- and there isn't an open query window for the new nick, rename the window. -applyWindowRenames :: NetworkName -> IrcMsg -> ClientState -> ClientState +applyWindowRenames :: + Text {- ^ network -} -> + IrcMsg -> + ClientState -> ClientState applyWindowRenames network (Nick old new) st | hasWindow old' , not (hasWindow new) = over clientFocus moveFocus diff --git a/src/Config/FromConfig.hs b/src/Config/FromConfig.hs --- a/src/Config/FromConfig.hs +++ b/src/Config/FromConfig.hs @@ -28,6 +28,7 @@ , SectionParser , parseSections , sectionReq + , sectionReqWith , sectionOpt , sectionOptWith , liftConfigParser @@ -107,10 +108,7 @@ -- | Matches 'List' values, extends the error location with a zero-based -- index instance FromConfig a => FromConfig [a] where - parseConfig (List xs) = ifor xs $ \i x -> - extendLoc (Text.pack (show (i+1))) - (parseConfig x) - parseConfig _ = failure "expected list" + parseConfig = parseList parseConfig ------------------------------------------------------------------------ @@ -154,8 +152,12 @@ -- | Parse the value at the given section or fail. sectionReq :: FromConfig a => Text -> SectionParser a -sectionReq key = - do mb <- sectionOpt key +sectionReq = sectionReqWith parseConfig + +-- | Parse the value at the given section or fail. +sectionReqWith :: (Value -> ConfigParser a) -> Text -> SectionParser a +sectionReqWith p key = + do mb <- sectionOptWith p key liftConfigParser $ case mb of Nothing -> failure ("section required: " <> key) Just x -> return x @@ -173,5 +175,6 @@ _ -> failure "Expected sections" parseList :: (Value -> ConfigParser a) -> Value -> ConfigParser [a] -parseList p (List xs) = traverse p xs +parseList p (List xs) = ifor xs $ \i x -> + extendLoc (Text.pack (show (i+1))) (p x) parseList _ _ = failure "expected list" diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -15,6 +15,7 @@ import Control.Lens import Control.Monad import Data.Default.Class +import Data.Text (Text) import Graphics.Vty import System.IO import System.Exit @@ -60,7 +61,10 @@ -- | Create connections for all the networks on the command line. -- Set the client focus to the first network listed. -addInitialNetworks :: [NetworkName] -> ClientState -> IO ClientState +addInitialNetworks :: + [Text] {- networks -} -> + ClientState -> + IO ClientState addInitialNetworks networks st = case networks of [] -> return st