glirc 2.7 → 2.8
raw patch · 18 files changed
+383/−148 lines, 18 filesdep ~vty
Dependency ranges changed: vty
Files
- ChangeLog.md +6/−0
- README.md +37/−0
- glirc.cabal +3/−2
- src/Client/CommandArguments.hs +4/−4
- src/Client/Commands.hs +94/−28
- src/Client/Commands/Interpolation.hs +60/−0
- src/Client/Configuration.hs +22/−0
- src/Client/ConnectionState.hs +1/−1
- src/Client/EditBox.hs +2/−2
- src/Client/EventLoop.hs +7/−2
- src/Client/Image/ChannelInfo.hs +2/−1
- src/Client/Image/MaskList.hs +1/−1
- src/Client/Image/Message.hs +7/−5
- src/Client/Image/Palette.hs +5/−7
- src/Client/Image/UserList.hs +9/−6
- src/Client/State.hs +108/−81
- src/Config/FromConfig.hs +10/−7
- src/Main.hs +5/−1
ChangeLog.md view
@@ -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)
README.md view
@@ -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 =====
glirc.cabal view
@@ -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
src/Client/CommandArguments.hs view
@@ -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
src/Client/Commands.hs view
@@ -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))
+ src/Client/Commands/Interpolation.hs view
@@ -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
src/Client/Configuration.hs view
@@ -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
src/Client/ConnectionState.hs view
@@ -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)
src/Client/EditBox.hs view
@@ -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
src/Client/EventLoop.hs view
@@ -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
src/Client/Image/ChannelInfo.hs view
@@ -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
src/Client/Image/MaskList.hs view
@@ -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 =
src/Client/Image/Message.hs view
@@ -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
src/Client/Image/Palette.hs view
@@ -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]
src/Client/Image/UserList.hs view
@@ -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
src/Client/State.hs view
@@ -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
src/Config/FromConfig.hs view
@@ -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"
src/Main.hs view
@@ -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