diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for glirc2 +## 2.7 + +* Switch to regex-tdfa (easier to install on macOS than text-icu) +* Tab-complete starts with most recent nick +* Add `/reload` +* Add custom palette entry for self highlights +* Add ability to set background colors and styles in palette + ## 2.6 * connect-cmds now use actual client commands instead of raw IRC messages. For example `msg user my message` or `join #mychannel` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -90,7 +90,9 @@ * "/path/to/extra/certificate.pem" palette: - time: [10,10,10] -- RGB values for color for timestamps + time: + fg: [10,10,10] -- RGB values for color for timestamps + bg: blue nick-colors: [ cyan, magenta, green, yellow, blue , bright-cyan, bright-magenta, bright-green, bright-blue @@ -110,6 +112,7 @@ * `servers` - These settings are used to override defaults when the hostname matches * `palette` - Client color overrides * `window-names` - text - Names of windows (typically overridden on non QWERTY layouts) +* `nick-padding` - nonnegative integer - Nicks are padded until they have the specified length Settings -------- @@ -139,18 +142,44 @@ Palette ------- -* `nick-colors` - List of colors - Use for nick highlights -* `time` - color - color for timestamp -* `meta` - color - color for metadata -* `sigil` - color - color for sigils -* `label` - color - color for information labels -* `latency` - color - color for latency time -* `error` - color - color for error messages -* `textbox` - color - color for textbox edges -* `window-name` - color - color for current window name -* `activity` - color - color for activity notification -* `mention` - color - color for mention notification +* `nick-colors` - List of attr - Use for nick highlights +* `self` - attr - attr of our own nickname(s) outside of mentions +* `self-highlight` - attr - attr of our own nickname(s) in mentions (defaults to `self`) +* `time` - attr - attr for timestamp +* `meta` - attr - attr for metadata +* `sigil` - attr - attr for sigils +* `label` - attr - attr for information labels +* `latency` - attr - attr for latency time +* `error` - attr - attr for error messages +* `textbox` - attr - attr for textbox edges +* `window-name` - attr - attr for current window name +* `activity` - attr - attr for activity notification +* `mention` - attr - attr for mention notification +Text Attributes +--------------- + +Text attributes can be specified either as a single foreground color or section of attributes. + +* `` - Maps to a terminal color +* `` - Direct selection of standard 16 terminal colors +* `[red-number, blue-number, green-number]` - List of 3 numbers in range 0-255 map to an approximation of the RGB color. + +Attributes + +* `fg` - foreground color +* `bg` - background color +* `style` - single style or list of styles + +Styles + +* `blink` +* `bold` +* `dim` +* `standout` +* `reverse-video` +* `underline` + Commands ======== @@ -161,6 +190,8 @@ * `/connect ` - Connect to the given server * `/disconnect` - Forcefully terminate connection to the current server * `/reconnect` - Reconnect to the current server +* `/reload` - Reload the previous configuration file (not retroactive!) +* `/reload ` - Load a new configuration file Connection commands diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.6 +version: 2.7 synopsis: Console IRC client description: Console IRC client license: ISC @@ -75,7 +75,8 @@ split >=0.2 && <0.3, stm >=2.4 && <2.5, text >=1.2.2 && <1.3, - text-icu >=0.7 && <0.8, + regex-tdfa >=1.2 && <1.3, + regex-tdfa-text >=1.0 && <1.1, time >=1.6 && <1.7, tls >=1.3.8 && <1.4, transformers >=0.5.2 && <0.6, diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -18,6 +18,7 @@ , tabCompletion ) where +import Client.Configuration import Client.ConnectionState import qualified Client.EditBox as Edit import Client.Message @@ -181,6 +182,7 @@ , (["clear" ], ClientCommand cmdClear noClientTab) , (["reconnect" ], ClientCommand cmdReconnect noClientTab) , (["ignore" ], ClientCommand cmdIgnore simpleClientTab) + , (["reload" ], ClientCommand cmdReload tabReload) , (["quote" ], NetworkCommand cmdQuote simpleNetworkTab) , (["j","join" ], NetworkCommand cmdJoin simpleNetworkTab) @@ -402,7 +404,7 @@ tabFocus isReversed st _ = commandSuccess $ fromMaybe st - $ clientTextBox (wordComplete id isReversed completions) st + $ clientTextBox (wordComplete id isReversed [] completions) st where networks = map mkId $ HashMap.keys $ view clientNetworkMap st params = words $ uncurry take $ clientLine st @@ -687,6 +689,26 @@ updateIgnores s = foldl' updateIgnore s xs updateIgnore s x = over (contains x) not s +-- | Implementation of @/reload@ +-- +-- Attempt to reload the configuration file +cmdReload :: ClientCommand +cmdReload st rest = + do let path | null rest = view (clientConfig . configConfigPath) st + | otherwise = Just rest + res <- loadConfiguration path + case res of + Left{} -> commandFailure st + Right cfg -> + commandSuccess $! set clientConfig cfg st + +-- | Support file name tab completion when providing an alternative +-- configuration file. +-- +-- /NOT IMPLEMENTED/ +tabReload :: Bool {- ^ reversed -} -> ClientCommand +tabReload _ st _ = commandFailure st + modeCommand :: [Text] -> ConnectionState -> ClientState -> IO CommandResult modeCommand modes cs st = case view clientFocus st of @@ -732,26 +754,44 @@ , let parsedModesWithParams = [ (pol,mode) | (pol,mode,arg) <- parsedModes, not (Text.null arg) ] , (pol,mode):_ <- drop (paramIndex-3) parsedModesWithParams - , let completions = computeModeCompletion pol mode channel cs + , let (hint, completions) = computeModeCompletion pol mode channel cs st -> commandSuccess $ fromMaybe st - $ clientTextBox (wordComplete id isReversed completions) st + $ clientTextBox (wordComplete id isReversed hint completions) st _ -> commandSuccess st where paramIndex = length $ words $ uncurry take $ clientLine st +activeNicks :: + ClientState -> + [Identifier] +activeNicks st = + toListOf + ( clientWindows . ix focus + . winMessages . folded + . wlBody . _IrcBody + . folding msgActor . to userNick) st + where + focus = view clientFocus st + -- | Use the *!*@host masks of users for channel lists when setting list modes -- -- Use the channel's mask list for removing modes -- -- Use the nick list otherwise -computeModeCompletion :: Bool -> Char -> Identifier -> ConnectionState -> [Identifier] -computeModeCompletion pol mode channel cs +computeModeCompletion :: + Bool {- ^ mode polarity -} -> + Char {- ^ mode -} -> + Identifier {- ^ channel -} -> + ConnectionState -> + ClientState -> + ([Identifier],[Identifier]) {- ^ (hint, complete) -} +computeModeCompletion pol mode channel cs st | mode `elem` view modesLists modeSettings = - if pol then usermasks else masks - | otherwise = nicks + if pol then ([],usermasks) else ([],masks) + | otherwise = (activeNicks st, nicks) where modeSettings = view csModeTypes cs nicks = HashMap.keys (view (csChannels . ix channel . chanUsers) cs) @@ -773,7 +813,7 @@ commandNameCompletion :: Bool -> ClientState -> Maybe ClientState commandNameCompletion isReversed st = do guard (cursorPos == n) - clientTextBox (wordComplete id isReversed possibilities) st + clientTextBox (wordComplete id isReversed [] possibilities) st where n = length leadingPart (cursorPos, line) = clientLine st @@ -785,8 +825,9 @@ nickTabCompletion :: Bool {- ^ reversed -} -> ClientState -> ClientState nickTabCompletion isReversed st = fromMaybe st - $ clientTextBox (wordComplete (++": ") isReversed completions) st + $ clientTextBox (wordComplete (++": ") isReversed hint completions) st where + hint = activeNicks st completions = currentCompletionList st sendModeration :: Identifier -> [RawIrcMsg] -> ConnectionState -> IO ConnectionState diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -22,6 +22,8 @@ , configServers , configPalette , configWindowNames + , configNickPadding + , configConfigPath -- * Loading configuration , loadConfiguration @@ -38,13 +40,14 @@ import Config import Config.FromConfig import Control.Lens hiding (List) +import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Maybe import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text -import Graphics.Vty.Attributes +import qualified Data.Vector as Vector import Irc.Identifier (Identifier, mkId) import System.Directory import System.FilePath @@ -57,7 +60,10 @@ { _configDefaults :: ServerSettings -- ^ Default connection settings , _configServers :: (HashMap Text ServerSettings) -- ^ Host-specific settings , _configPalette :: Palette - , _configWindowNames :: Text -- ^ Names of windows, used when alt-jumping + , _configWindowNames :: Text -- ^ Names of windows, used when alt-jumping) + , _configNickPadding :: Maybe Integer -- ^ Padding of nicks + , _configConfigPath :: Maybe FilePath + -- ^ manually specified configuration path, used for reloading } deriving Show @@ -140,13 +146,17 @@ Left parseError -> throwIO (ConfigurationParseFailed parseError) Right rawcfg -> return rawcfg - case runConfigParser (parseConfiguration def rawcfg) of + case runConfigParser (parseConfiguration mbPath def rawcfg) of Left loadError -> throwIO (ConfigurationMalformed (Text.unpack loadError)) Right cfg -> return cfg -parseConfiguration :: ServerSettings -> Value -> ConfigParser Configuration -parseConfiguration def = parseSections $ +parseConfiguration :: + Maybe FilePath {- ^ optionally specified path to config -} -> + ServerSettings {- ^ prepopulated default server settings -} -> + Value -> + ConfigParser Configuration +parseConfiguration _configConfigPath def = parseSections $ do _configDefaults <- fromMaybe def <$> sectionOptWith (parseServerSettings def) "defaults" @@ -160,6 +170,12 @@ _configWindowNames <- fromMaybe defaultWindowNames <$> sectionOpt "window-names" + _configNickPadding <- sectionOpt "nick-padding" + for_ _configNickPadding (\padding -> + when (padding < 0) + (liftConfigParser $ + failure "nick-padding has to be a non negative number")) + return Configuration{..} parsePalette :: Value -> ConfigParser Palette @@ -168,32 +184,31 @@ paletteHelper :: Palette -> Text -> Value -> ConfigParser Palette paletteHelper p k v = case k of - "nick-colors" -> do xs <- parseColors v + "nick-colors" -> do xs <- Vector.fromList <$> parseList parseAttr v + when (null xs) (failure "Empty palette") return $! set palNicks xs p - "self" -> setAttr palSelf - "time" -> setAttr palTime - "meta" -> setAttr palMeta - "sigil" -> setAttr palSigil - "label" -> setAttr palLabel - "latency" -> setAttr palLatency - "error" -> setAttr palError - "textbox" -> setAttr palTextBox - "window-name" -> setAttr palWindowName - "activity" -> setAttr palActivity - "mention" -> setAttr palMention - _ -> failure "Unknown palette entry" + "self" -> setAttr palSelf + "self-highlight" -> setAttrMb palSelfHighlight + "time" -> setAttr palTime + "meta" -> setAttr palMeta + "sigil" -> setAttr palSigil + "label" -> setAttr palLabel + "latency" -> setAttr palLatency + "error" -> setAttr palError + "textbox" -> setAttr palTextBox + "window-name" -> setAttr palWindowName + "activity" -> setAttr palActivity + "mention" -> setAttr palMention + _ -> failure "Unknown palette entry" where setAttr l = - do x <- parseColor v - let !attr = withForeColor defAttr x + do !attr <- parseAttr v return $! set l attr p -parseSectionsWith :: (a -> Text -> Value -> ConfigParser a) -> a -> Value -> ConfigParser a -parseSectionsWith p start s = - case s of - Sections xs -> foldM (\x (Section k v) -> extendLoc k (p x k v)) start xs - _ -> failure "Expected sections" + setAttrMb l = + do !attr <- parseAttr v + return $! set l (Just attr) p parseServers :: ServerSettings -> Value -> ConfigParser (HashMap Text ServerSettings) parseServers def v = @@ -249,10 +264,6 @@ parseBoolean (Atom "yes") = return True parseBoolean (Atom "no") = return False parseBoolean _ = failure "expected yes or no" - -parseList :: (Value -> ConfigParser a) -> Value -> ConfigParser [a] -parseList p (List xs) = traverse p xs -parseList _ _ = failure "expected list" parseNum :: Num a => Value -> ConfigParser a parseNum v = fromInteger <$> parseConfig v 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 @@ -11,24 +11,57 @@ -} module Client.Configuration.Colors - ( parseColors - , parseColor + ( parseColor + , parseAttr ) where import Config import Config.FromConfig import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Foldable import Data.Ratio import Data.Text (Text) -import Data.Vector (Vector) -import qualified Data.Vector as Vector import Graphics.Vty.Attributes -parseColors :: Value -> ConfigParser (Vector Color) -parseColors (List []) = failure "Empty color palette" -parseColors (List xs) = traverse parseColor (Vector.fromList xs) -parseColors _ = failure "Expected list of colors or default" +-- | Parse a text attribute. This value should be a sections with the @fg@ and/or +-- @bg@ attributes. Otherwise it should be a color entry that will be used +-- for the foreground color. An empty sections value will result in 'defAttr' +parseAttr :: Value -> ConfigParser Attr +parseAttr (Sections xs) = parseSectionsWith parseAttrEntry defAttr (Sections xs) +parseAttr v = withForeColor defAttr <$> parseColor v + +parseAttrEntry :: Attr -> Text -> Value -> ConfigParser Attr +parseAttrEntry acc k v = + case k of + "fg" -> parseColor' withForeColor + "bg" -> parseColor' withBackColor + "style" -> parseStyle' + _ -> failure "Unknown attribute entry" + where + parseStyle' = + do xs <- parseStyles v + return $! foldl' withStyle acc xs + + parseColor' f = + do c <- parseColor v + return $! f acc c + +parseStyles :: Value -> ConfigParser [Style] +parseStyles (List xs) = parseList parseStyle (List xs) +parseStyles v = pure <$> parseStyle v + +parseStyle :: Value -> ConfigParser Style +parseStyle v = + case v of + Atom "blink" -> pure blink -- You're the boss... + Atom "bold" -> pure bold + Atom "dim" -> pure bold + Atom "reverse-video" -> pure reverseVideo + Atom "standout" -> pure standout + Atom "underline" -> pure underline + _ -> failure "expected blink, bold, dim, reverse-video, standout, underline" + -- | Parse a color. Support formats are: -- 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 @@ -12,6 +12,7 @@ module Client.Image.Message ( MessageRendererParams(..) , RenderMode(..) + , IdentifierColorMode(..) , defaultRenderParams , msgImage , metadataImg @@ -36,6 +37,7 @@ import Data.Hashable (hash) import qualified Data.HashSet as HashSet import Data.List +import Data.Maybe import qualified Data.Text as Text import Data.Text (Text) import qualified Data.Vector as Vector @@ -47,6 +49,7 @@ , rendNicks :: [Identifier] -- ^ nicknames to highlight , rendMyNicks :: [Identifier] -- ^ nicknames to highlight in red , rendPalette :: Palette -- ^ nick color palette + , rendNickPadding :: Maybe Integer -- ^ nick padding } -- | Default 'MessageRenderParams' with no sigils or nicknames specified @@ -57,6 +60,7 @@ , rendNicks = [] , rendMyNicks = [] , rendPalette = defaultPalette + , rendNickPadding = Nothing } -- | Construct a message given the time the message was received and its @@ -67,6 +71,7 @@ MessageRendererParams -> MessageBody -> Image msgImage rm when params body = horizCat [ renderTime rm (rendPalette params) when + , char defAttr ' ' , statusMsgImage (rendStatusMsg params) , bodyImage rm params body ] @@ -80,6 +85,7 @@ , string defAttr txt ] +-- | Render the given time according to the current mode and palette. renderTime :: RenderMode -> Palette -> ZonedTime -> Image renderTime DetailedRender = datetimeImage renderTime NormalRender = timeImage @@ -114,7 +120,7 @@ timeImage :: Palette -> ZonedTime -> Image timeImage palette = string (view palTime palette) - . formatTime defaultTimeLocale "%R " + . formatTime defaultTimeLocale "%R" -- | Render a 'ZonedTime' as full date and time user quiet attributes -- @@ -124,13 +130,22 @@ datetimeImage :: Palette -> ZonedTime -> Image datetimeImage palette = string (view palTime palette) - . formatTime defaultTimeLocale "%F %T " + . formatTime defaultTimeLocale "%F %T" -- | Level of detail to use when rendering data RenderMode = NormalRender -- ^ only render nicknames | DetailedRender -- ^ render full user info +-- | Optionally insert padding on the right of an 'Image' until it has +-- the minimum width. +rightPad :: RenderMode -> Maybe Integer -> Image -> Image +rightPad NormalRender (Just minWidth) i = + let h = 1 + w = max 0 (fromIntegral minWidth - imageWidth i) + in i <|> backgroundFill w h +rightPad _ _ i = i + -- | Render a chat message given a rendering mode, the sigils of the user -- who sent the message, and a list of nicknames to highlight. ircLineImage :: @@ -154,7 +169,7 @@ string (view palSigil pal) sigils <|> coloredUserInfo pal rm myNicks old <|> string defAttr " became " <|> - coloredIdentifier pal myNicks new + coloredIdentifier pal NormalIdentifier myNicks new Join nick _chan -> string quietAttr "join " <|> @@ -179,7 +194,7 @@ string (view palSigil pal) sigils <|> coloredUserInfo pal rm myNicks kicker <|> string defAttr " kicked " <|> - coloredIdentifier pal myNicks kickee <|> + coloredIdentifier pal NormalIdentifier myNicks kickee <|> string defAttr ": " <|> parseIrcText reason @@ -191,14 +206,16 @@ Notice src _dst txt -> detail (string quietAttr "note ") <|> string (view palSigil pal) sigils <|> - coloredUserInfo pal rm myNicks src <|> + rightPad rm (rendNickPadding rp) + (coloredUserInfo pal rm myNicks src) <|> string (withForeColor defAttr red) ": " <|> parseIrcTextWithNicks pal myNicks nicks txt Privmsg src _dst txt -> detail (string quietAttr "chat ") <|> string (view palSigil pal) sigils <|> - coloredUserInfo pal rm myNicks src <|> + rightPad rm (rendNickPadding rp) + (coloredUserInfo pal rm myNicks src) <|> string defAttr ": " <|> parseIrcTextWithNicks pal myNicks nicks txt @@ -311,21 +328,31 @@ attr = withForeColor defAttr color +data IdentifierColorMode + = PrivmsgIdentifier -- ^ An identifier in a PRIVMSG + | NormalIdentifier -- ^ An identifier somewhere else -- | Render a nickname in its hash-based color. coloredIdentifier :: Palette -> + IdentifierColorMode -> [Identifier] {- ^ my nicknames -} -> Identifier -> Image -coloredIdentifier palette myNicks ident = +coloredIdentifier palette icm myNicks ident = text' color (idText ident) where color - | ident `elem` myNicks = _palSelf palette - | otherwise = withForeColor defAttr $ v Vector.! i + | ident `elem` myNicks = + case icm of + PrivmsgIdentifier -> fromMaybe + (view palSelf palette) + (view palSelfHighlight palette) + NormalIdentifier -> view palSelf palette - v = _palNicks palette + | otherwise = v Vector.! i + + v = view palNicks palette i = hash ident `mod` Vector.length v -- | Render an a full user. In normal mode only the nickname will be rendered. @@ -337,10 +364,10 @@ [Identifier] {- ^ my nicks -} -> UserInfo -> Image coloredUserInfo palette NormalRender myNicks ui = - coloredIdentifier palette myNicks (userNick ui) + coloredIdentifier palette NormalIdentifier myNicks (userNick ui) coloredUserInfo palette DetailedRender myNicks !ui = horizCat - [ coloredIdentifier palette myNicks (userNick ui) + [ coloredIdentifier palette NormalIdentifier myNicks (userNick ui) , aux '!' (userName ui) , aux '@' (userHost ui) ] @@ -380,7 +407,7 @@ nickSet = HashSet.fromList nicks txtParts = nickSplit txt highlight1 part - | HashSet.member partId nickSet = coloredIdentifier palette myNicks partId + | HashSet.member partId nickSet = coloredIdentifier palette PrivmsgIdentifier myNicks partId | otherwise = text' defAttr part where partId = mkId part 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 @@ -14,6 +14,7 @@ Palette(..) , palNicks , palSelf + , palSelfHighlight , palTime , palMeta , palSigil @@ -36,18 +37,19 @@ -- | Color palette used for rendering the client UI data Palette = Palette - { _palNicks :: Vector Color -- ^ colors for highlighting nicknames - , _palSelf :: Attr -- ^ color of our own nickname(s) - , _palTime :: Attr -- ^ color of message timestamps - , _palMeta :: Attr -- ^ color of coalesced metadata - , _palSigil :: Attr -- ^ color of sigils (e.g. @+) - , _palLabel :: Attr -- ^ color of information labels - , _palLatency :: Attr -- ^ color of ping latency - , _palWindowName :: Attr -- ^ color of window name - , _palError :: Attr -- ^ color of error messages - , _palTextBox :: Attr -- ^ color of textbox markers - , _palActivity :: Attr -- ^ color of window name with activity - , _palMention :: Attr -- ^ color of window name with mention + { _palNicks :: Vector Attr -- ^ colors for highlighting nicknames + , _palSelf :: Attr -- ^ color of our own nickname(s) + , _palSelfHighlight :: Maybe Attr -- ^ color of our own nickname(s) in mentions + , _palTime :: Attr -- ^ color of message timestamps + , _palMeta :: Attr -- ^ color of coalesced metadata + , _palSigil :: Attr -- ^ color of sigils (e.g. @+) + , _palLabel :: Attr -- ^ color of information labels + , _palLatency :: Attr -- ^ color of ping latency + , _palWindowName :: Attr -- ^ color of window name + , _palError :: Attr -- ^ color of error messages + , _palTextBox :: Attr -- ^ color of textbox markers + , _palActivity :: Attr -- ^ color of window name with activity + , _palMention :: Attr -- ^ color of window name with mention } deriving Show @@ -56,23 +58,26 @@ -- | Default UI colors that look nice in my dark solarized color scheme defaultPalette :: Palette defaultPalette = Palette - { _palNicks = defaultNickColorPalette - , _palSelf = withForeColor defAttr red - , _palTime = withForeColor defAttr brightBlack - , _palMeta = withForeColor defAttr brightBlack - , _palSigil = withForeColor defAttr cyan - , _palLabel = withForeColor defAttr green - , _palLatency = withForeColor defAttr yellow - , _palWindowName = withForeColor defAttr cyan - , _palError = withForeColor defAttr red - , _palTextBox = withForeColor defAttr brightBlack - , _palActivity = withForeColor defAttr green - , _palMention = withForeColor defAttr red + { _palNicks = defaultNickColorPalette + , _palSelf = withForeColor defAttr red + , _palSelfHighlight = Nothing + , _palTime = withForeColor defAttr brightBlack + , _palMeta = withForeColor defAttr brightBlack + , _palSigil = withForeColor defAttr cyan + , _palLabel = withForeColor defAttr green + , _palLatency = withForeColor defAttr yellow + , _palWindowName = withForeColor defAttr cyan + , _palError = withForeColor defAttr red + , _palTextBox = withForeColor defAttr brightBlack + , _palActivity = withForeColor defAttr green + , _palMention = withForeColor defAttr red } -- | Default nick highlighting colors that look nice in my dark solarized -- color scheme. -defaultNickColorPalette :: Vector Color -defaultNickColorPalette = Vector.fromList - [cyan, magenta, green, yellow, blue, - brightCyan, brightMagenta, brightGreen, brightBlue] +defaultNickColorPalette :: Vector Attr +defaultNickColorPalette + = fmap (withForeColor defAttr) + $ Vector.fromList + [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 @@ -51,7 +51,7 @@ renderUser (ident, sigils) = string (view palSigil pal) sigils <|> - coloredIdentifier pal myNicks ident + coloredIdentifier pal NormalIdentifier myNicks ident gap = char defAttr ' ' diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -90,7 +90,6 @@ import Data.Monoid import Data.Text (Text) import qualified Data.Text as Text -import qualified Data.Text.ICU as ICU import Data.Time import Graphics.Vty import Irc.Codes @@ -99,6 +98,9 @@ import Irc.RawIrcMsg import Irc.UserInfo import LensUtils +import Text.Regex.TDFA +import Text.Regex.TDFA.String (compile) +import Text.Regex.TDFA.Text () -- RegexLike Regex Text orphan import Network.Connection -- | Textual name of a network connection @@ -236,6 +238,7 @@ , rendNicks = channelUserList network channel' st , rendMyNicks = myNicks , rendPalette = palette + , rendNickPadding = view (clientConfig . configNickPadding) st } palette = view (clientConfig . configPalette) st @@ -462,14 +465,14 @@ clientMatcher :: ClientState -> Text -> Bool clientMatcher st = case break (==' ') (clientFirstLine st) of - ("/grep" ,_:reStr) -> go [] reStr - ("/grepi",_:reStr) -> go [ICU.CaseInsensitive] reStr + ("/grep" ,_:reStr) -> go True reStr + ("/grepi",_:reStr) -> go False reStr _ -> const True where - go opts reStr - | not (null reStr) - , Right r <- ICU.regex' opts (Text.pack reStr) = isJust . ICU.find r - | otherwise = const True + go sensitive reStr = + case compile defaultCompOpt{caseSensitive=sensitive} defaultExecOpt reStr of + Left{} -> const True + Right r -> match r :: Text -> Bool -- | Remove a network connection and unlink it from the network map. -- This operation assumes that the networkconnection exists and should @@ -490,7 +493,9 @@ addConnection :: Text -> ClientState -> IO ClientState addConnection network st = do let defSettings = (view (clientConfig . configDefaults) st) - { _ssName = Just network } + { _ssName = Just network + , _ssHostName = Text.unpack network + } settings = fromMaybe defSettings $ preview (clientConfig . configServers . ix network) st diff --git a/src/Client/WordCompletion.hs b/src/Client/WordCompletion.hs --- a/src/Client/WordCompletion.hs +++ b/src/Client/WordCompletion.hs @@ -13,6 +13,7 @@ ) where import Irc.Identifier +import Control.Applicative import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Set as Set @@ -29,13 +30,16 @@ -- when auto-completing a nick and including a trailing colon. -- -- The @reversed@ parameter indicates that tab-completion should return the --- previous entry. +-- previous entry. When starting a fresh tab completion the priority completions +-- will be considered in order before resorting to the set of possible +-- completions. wordComplete :: (String -> String) {- ^ leading update operation -} -> Bool {- ^ reversed -} -> + [Identifier] {- ^ priority completions -} -> [Identifier] {- ^ possible completions -} -> Edit.EditBox -> Maybe Edit.EditBox -wordComplete leadingCase isReversed vals box = +wordComplete leadingCase isReversed hint vals box = do let current = currentWord box guard (not (null current)) let cur = mkId (Text.pack current) @@ -49,7 +53,8 @@ pat = mkId (Text.pack patternStr) _ -> - do next <- tabSearch isReversed cur cur vals + do next <- find (idPrefix cur) hint <|> + tabSearch isReversed cur cur vals Just $ set Edit.tabSeed (Just current) $ replaceWith leadingCase (idString next) box diff --git a/src/Config/FromConfig.hs b/src/Config/FromConfig.hs --- a/src/Config/FromConfig.hs +++ b/src/Config/FromConfig.hs @@ -21,6 +21,9 @@ , extendLoc , FromConfig(parseConfig) + -- * Parser wrappers + , parseList + -- * Section parsing , SectionParser , parseSections @@ -28,6 +31,7 @@ , sectionOpt , sectionOptWith , liftConfigParser + , parseSectionsWith ) where import Config @@ -161,3 +165,13 @@ floatingToRatio :: Integral a => Integer -> Integer -> Ratio a floatingToRatio c e = fromIntegral c * 10 ^^ e + +parseSectionsWith :: (a -> Text -> Value -> ConfigParser a) -> a -> Value -> ConfigParser a +parseSectionsWith p start s = + case s of + Sections xs -> foldM (\x (Section k v) -> extendLoc k (p x k v)) start xs + _ -> failure "Expected sections" + +parseList :: (Value -> ConfigParser a) -> Value -> ConfigParser [a] +parseList p (List xs) = traverse p xs +parseList _ _ = failure "expected list"