diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,16 @@ # Revision history for glirc2 +## 2.15 + +* Add `/mentions` +* Add macro argument declarations +* Add indication when a command is still a prefix or not of a valid command +* Support quoted strings arguments to /exec +* Add F4 to toggle visibility of metadata lines +* tls-insecure setting was incorrectly behaving like normal insecure +* Add `C-t` to swap characters +* Add `ESC` to return to messages window + ## 2.14 * Add `/help` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -195,7 +195,7 @@ * `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`) +* `self-highlight` - attr - attr of our own nickname(s) in mentions * `time` - attr - attr for timestamp * `meta` - attr - attr for metadata * `sigil` - attr - attr for sigils @@ -207,7 +207,8 @@ * `activity` - attr - attr for activity notification * `mention` - attr - attr for mention notification * `command` - attr - attr for recognized command -* `command-ready` - attr - attr for command with successful parse +* `command-prefix` - attr - attr for prefix of known command +* `command-ready` - attr - attr for recognized command with arguments filled * `command-placeholder` - attr - attr for command argument placeholder Text Attributes @@ -247,6 +248,8 @@ * `/reconnect` - Reconnect to the current server * `/reload [path]` - Load a new configuration file (optional path) * `/windows` - List all open windows +* `/palette` - Show the client palette +* `/mentions` - Show all the highlighted lines across all windows * `/extension ` - Send the given params to the named extension * `/exec [-n network] [-c channel] ` - Execute a command, If no network or channel are provided send output to client window, if network and channel are provided send output as messages, if network is provided send output as raw IRC messages. * `/url [n]` - Execute url-opener on the nth URL in the current window (defaults to first) @@ -322,35 +325,57 @@ Keyboard Shortcuts ================== -* `^N` next channel -* `^P` previous channel +Note that these keybindings are using *Emacs* syntax. `C-a` means "hold +control and press A". `M-a` means "hold meta key and press A". On most +modern keyboards the *Meta* key is labeled *Alt* or *Option*. + +Window navigation + +* `C-n` next channel +* `C-p` previous channel * `M-#` jump to window - `1234567890qwertyuiop!@#$%^&*()QWERTYUIOP` -* `M-A` jump to activity -* `M-S` jump to previous window -* `^A` beginning of line -* `^E` end of line -* `^K` delete to end -* `^U` delete to beginning -* `^D` delete at cursor -* `^W` delete word backwards -* `^Y` paste from yank buffer -* `M-F` forward word -* `M-B` backward word -* `M-BACKSPACE` delete word backwards -* `M-D` delete word forwards -* `TAB` nickname completion +* `M-a` jump to activity +* `M-s` jump to previous window +* `ESC` return to messages view (from userlist, masklist, help, etc) + +Editing + +* `C-a` beginning of line +* `C-e` end of line +* `C-k` delete to end +* `C-u` delete to beginning +* `C-d` delete at cursor +* `C-w` delete word backwards +* `C-y` paste from yank buffer +* `C-t` swap characters at cursor +* `M-f` forward word +* `M-b` backward word +* `M-Backspace` delete word backwards +* `M-d` delete word forwards +* `M-Enter` insert newline + +* `Tab` nickname completion + +Client settings + * `F2` toggle detailed view * `F3` toggle detailed activity bar +* `F4` toggle metadata visibility + +Scrolling + * `Page Up` scroll up * `Page Down` scroll down -* `^B` bold -* `^C` color -* `^V` reverse video -* `^_` underline -* `^]` italic -* `^O` reset formatting -* `M-Enter` insert newline +Formatting + +* `C-b` bold +* `C-c` color +* `C-v` reverse video +* `C-_` underline +* `C-]` italic +* `C-o` reset formatting + Macros ====== @@ -361,6 +386,7 @@ ------------- * `name` - text - name of macro +* `arguments` - text - space separated list of argument names (suffix name with `?` when optional) * `commands` - list of text - commands to send after expansion Macro Expansions diff --git a/exec/Main.hs b/exec/Main.hs --- a/exec/Main.hs +++ b/exec/Main.hs @@ -17,21 +17,21 @@ import System.Exit import System.IO -import Client.CommandArguments import Client.Configuration import Client.EventLoop +import Client.Options import Client.State import Client.State.Focus -- | Main action for IRC client main :: IO () main = - do args <- getCommandArguments - cfg <- loadConfiguration' (view cmdArgConfigFile args) + do opts <- getOptions + cfg <- loadConfiguration' (view optConfigFile opts) runInUnboundThread $ withClientState cfg $ clientStartExtensions >=> - addInitialNetworks (view cmdArgInitialNetworks args) >=> + addInitialNetworks (view optInitialNetworks opts) >=> eventLoop -- | Load configuration and handle errors along the way. diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.14 +version: 2.15 synopsis: Console IRC client description: Console IRC client license: ISC @@ -49,14 +49,14 @@ default-language: Haskell2010 build-tools: hsc2hs - exposed-modules: Client.CommandArguments - Client.CApi + exposed-modules: Client.CApi Client.CApi.Exports Client.CApi.Types Client.Commands Client.Commands.Arguments Client.Commands.Exec Client.Commands.Interpolation + Client.Commands.Recognizer Client.Commands.WordCompletion Client.Configuration Client.Configuration.Colors @@ -68,20 +68,15 @@ Client.Hooks Client.Image Client.Image.Arguments - Client.Image.ChannelInfo - Client.Image.Help - Client.Image.MaskList Client.Image.Message Client.Image.MircFormatting Client.Image.Palette - Client.Image.PaletteView Client.Image.StatusLine Client.Image.Textbox - Client.Image.UserList - Client.Image.Windows Client.Message Client.Network.Async Client.Network.Connect + Client.Options Client.State Client.State.Channel Client.State.EditBox @@ -89,6 +84,15 @@ Client.State.Focus Client.State.Network Client.State.Window + Client.View + Client.View.ChannelInfo + Client.View.Help + Client.View.MaskList + Client.View.Mentions + Client.View.Messages + Client.View.Palette + Client.View.UserList + Client.View.Windows Config.FromConfig other-modules: LensUtils diff --git a/src/Client/CommandArguments.hs b/src/Client/CommandArguments.hs deleted file mode 100644 --- a/src/Client/CommandArguments.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# Language TemplateHaskell #-} -{-| -Module : Client.CommandArguments -Description : Processing of command-line arguments -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module process command-line arguments provided when -launching the client. - --} -module Client.CommandArguments - ( - -- * Command-line argument type - CommandArguments(..) - - -- * Lenses - , cmdArgConfigFile - , cmdArgInitialNetworks - - -- * Argument loader - , getCommandArguments - ) where - -import Control.Lens -import Data.Foldable -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Version -import Development.GitRev (gitHash, gitDirty) -import System.Console.GetOpt -import System.Environment -import System.Exit -import System.IO -import Paths_glirc (version) - --- | Command-line arguments -data CommandArguments = CommandArguments - { _cmdArgConfigFile :: Maybe FilePath -- ^ configuration file path - , _cmdArgInitialNetworks :: [Text] -- ^ initial networks - , _cmdArgShowHelp :: Bool -- ^ show help message - , _cmdArgShowVersion :: Bool -- ^ show version message - } - -makeLenses ''CommandArguments - --- | Default values for arguments -defaultCommandArguments :: CommandArguments -defaultCommandArguments = CommandArguments - { _cmdArgConfigFile = Nothing - , _cmdArgInitialNetworks = [] - , _cmdArgShowHelp = False - , _cmdArgShowVersion = False - } - --- | Option descriptions -options :: [OptDescr (CommandArguments -> CommandArguments)] -options = - [ Option "c" ["config"] (ReqArg (set cmdArgConfigFile . Just) "PATH") - "Configuration file path" - , Option "h" ["help"] (NoArg (set cmdArgShowHelp True)) - "Show help" - , Option "v" ["version"] (NoArg (set cmdArgShowVersion True)) - "Show version" - ] - --- | Load command line arguments. This action will terminate early --- in the case of the version flag, help flag, or an error. -getCommandArguments :: IO CommandArguments -getCommandArguments = - do args <- getArgs - case getOpt Permute options args of - (flags, networks, []) - | view cmdArgShowHelp cmdArgs -> putStr helpTxt >> exitSuccess - | view cmdArgShowVersion cmdArgs -> putStr versionTxt >> exitSuccess - | otherwise -> return cmdArgs - where - cmdArgs = assembleCommandArguments flags networks - (_, _, errors) -> - do traverse_ (hPutStr stderr) errors - hPutStrLn stderr "Run 'glirc2 --help' to see a list of available command line options." - exitFailure - -assembleCommandArguments :: [CommandArguments -> CommandArguments] -> [String] -> CommandArguments -assembleCommandArguments flags networks = - let flagArgs = foldl' (\acc f -> f acc) defaultCommandArguments flags - in flagArgs { _cmdArgInitialNetworks = Text.pack <$> networks } - -helpTxt :: String -helpTxt = usageInfo "glirc2 [FLAGS] INITIAL_NETWORKS..." options - -versionTxt :: String -versionTxt = unlines - [ "glirc-" ++ showVersion version ++ gitHashTxt ++ gitDirtyTxt - , "Copyright 2016 Eric Mertens" - ] - --- | Returns @"-SOMEHASH"@ when in a git repository, @""@ otherwise. -gitHashTxt :: String -gitHashTxt - | hashTxt == "UNKNOWN" = "" - | otherwise = '-':hashTxt - where - hashTxt = $gitHash - --- | Returns @"-dirty"@ when in a dirty git repository, @""@ otherwise. -gitDirtyTxt :: String -gitDirtyTxt - | $gitDirty = "-dirty" - | otherwise = "" diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -28,6 +28,7 @@ import Client.Commands.Arguments import Client.Commands.Exec import Client.Commands.Interpolation +import Client.Commands.Recognizer import Client.Commands.WordCompletion import Client.Configuration import Client.Configuration.ServerSettings @@ -42,9 +43,7 @@ import Control.Exception (displayException, try) import Control.Lens import Control.Monad -import Data.Char import Data.Foldable -import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.Split @@ -130,13 +129,14 @@ executeUserCommand :: Maybe Text -> String -> ClientState -> IO CommandResult executeUserCommand discoTime command st = do let key = Text.takeWhile (/=' ') tcmd + rest = dropWhile (==' ') . dropWhile (/=' ') $ command - case preview (clientConfig . configMacros . ix key) st of - Nothing -> executeCommand Nothing command st - Just cmdExs -> - case traverse resolveMacro cmdExs of + case views (clientConfig . configMacros) (recognize key) st of + Exact (Macro (MacroSpec spec) cmdExs) -> + case parseArguments spec rest *> traverse resolveMacro cmdExs of Nothing -> commandFailureMsg "Macro expansions failed" st Just cmds -> process cmds st + _ -> executeCommand Nothing command st where resolveMacro = resolveMacroExpansions (commandExpansion discoTime st) expandInt @@ -220,14 +220,9 @@ Nothing -> commandFailure st Just arg -> exec st arg in - case HashMap.lookup cmdTxt commands of - - Nothing -> - case tabCompleteReversed of - Nothing -> commandFailureMsg "Unknown command" st - Just isReversed -> nickTabCompletion isReversed st + case recognize cmdTxt commands of - Just (Command argSpec _docs impl) -> + Exact (Command argSpec _docs impl) -> case impl of ClientCommand exec tab -> finish argSpec exec tab @@ -251,6 +246,11 @@ finish argSpec (exec channelId cs) (\x -> tab x channelId cs) | otherwise -> commandFailureMsg "This command requires an active chat window" st + _ -> case tabCompleteReversed of + Just isReversed -> nickTabCompletion isReversed st + Nothing -> commandFailureMsg "Unknown command" st + + -- | Expands each alias to have its own copy of the command callbacks expandAliases :: [(NonEmpty a,b)] -> [(a,b)] expandAliases xs = [ (a,b) | (as,b) <- xs, a <- toList as ] @@ -258,8 +258,8 @@ -- | Map of built-in client commands to their implementations, tab completion -- logic, and argument structures. -commands :: HashMap Text Command -commands = HashMap.fromList (expandAliases commandsList) +commands :: Recognizer Command +commands = fromCommands (expandAliases commandsList) commandsList :: [(NonEmpty Text,Command)] commandsList = @@ -330,6 +330,11 @@ "Show a list of all client message windows.\n" $ ClientCommand cmdWindows noClientTab ) + , ( pure "mentions" + , Command NoArg + "Show a list of all message that were highlighted as important.\n" + $ ClientCommand cmdMentions noClientTab + ) , ( pure "palette" , Command NoArg "Show the current palette settings and a color chart to help pick new colors.\n" @@ -347,6 +352,10 @@ \When \^Bnetwork\^B is specified output is sent as raw IRC traffic to the network.\n\ \When \^Bchannel\^B is specified output is sent as chat to the given channel on the current network.\n\ \When \^Bnetwork\^B and \^Bchannel\^B are specified output is sent as chat to the given channel on the given network.\n\ + \\n\ + \\^Barguments\^B is divided on spaces into words before being processed\ + \ by getopt. Use Haskell string literal syntax to create arguments with\ + \ escaped characters and spaces inside.\n\ \\n" $ ClientCommand cmdExec simpleClientTab ) @@ -802,6 +811,10 @@ cmdWindows :: ClientCommand () cmdWindows st _ = commandSuccess (changeSubfocus FocusWindows st) +-- | Implementation of @/mentions@ command. Set subfocus to Windows. +cmdMentions :: ClientCommand () +cmdMentions st _ = commandSuccess (changeSubfocus FocusMentions st) + -- | Implementation of @/palette@ command. Set subfocus to Windows. cmdPalette :: ClientCommand () cmdPalette st _ = commandSuccess (changeSubfocus FocusPalette st) @@ -998,7 +1011,7 @@ ChannelCommand String tabTopic _ channelId cs st rest - | all isSpace rest + | all (==' ') rest , Just topic <- preview (csChannels . ix channelId . chanTopic) cs = do let textBox = set Edit.line (Edit.endLine $ "/topic " ++ Text.unpack topic) commandSuccess (over clientTextBox textBox st) @@ -1258,10 +1271,10 @@ where n = length leadingPart (cursorPos, line) = clientLine st - leadingPart = takeWhile (not . isSpace) line + leadingPart = takeWhile (/=' ') line possibilities = Text.cons '/' <$> commandNames - commandNames = HashMap.keys commands - ++ HashMap.keys (view (clientConfig . configMacros) st) + commandNames = keys commands + ++ keys (view (clientConfig . configMacros) st) -- | Complete the nickname at the current cursor position using the -- userlist for the currently focused channel (if any) diff --git a/src/Client/Commands/Arguments.hs b/src/Client/Commands/Arguments.hs --- a/src/Client/Commands/Arguments.hs +++ b/src/Client/Commands/Arguments.hs @@ -35,6 +35,18 @@ -- | No arguments NoArg :: ArgumentSpec () +instance Show (ArgumentSpec s) where + showsPrec p spec = + case spec of + ReqTokenArg s rest -> showParen (p >= 11) + $ showString "ReqTokenArg " + . showsPrec 11 s . showChar ' ' . showsPrec 11 rest + OptTokenArg s rest -> showParen (p >= 11) + $ showString "OptTokenArg " + . showsPrec 11 s . showChar ' ' . showsPrec 11 rest + RemainingArg s -> showParen (p >= 11) + $ showString "RemainingArg " . showsPrec 11 s + NoArg -> showString "NoArg" -- | Parse the given input string using an argument specification. -- The arguments should start with a space but might have more. diff --git a/src/Client/Commands/Exec.hs b/src/Client/Commands/Exec.hs --- a/src/Client/Commands/Exec.hs +++ b/src/Client/Commands/Exec.hs @@ -26,6 +26,7 @@ import Control.Exception import Control.Lens +import Data.List import System.Console.GetOpt import System.Process @@ -78,13 +79,11 @@ -- | Parse the arguments to @/exec@ looking for various flags -- and the command and its arguments. --- --- TODO: support quoted strings parseExecCmd :: String {- ^ exec arguments -} -> Either [String] ExecCmd {- ^ error or parsed command -} parseExecCmd str = - case getOpt RequireOrder options (words str) of + case getOpt RequireOrder options (powerWords str) of (_, [] , errs) -> Left ("No command specified":errs) (fs, cmd:args, []) -> Right $ foldl (\x f -> f x) ?? fs @@ -105,3 +104,16 @@ return $ case res of Left er -> Left [show (er :: IOError)] Right x -> Right (lines x) + +-- | Power words is similar to 'words' except that when it encounters +-- a word formatted as a Haskell 'String' literal it parses it as +-- such. Only space is used as a delimiter. +powerWords :: String -> [String] +powerWords = unfoldr (splitWord . dropWhile isSp) + where + isSp x = x == ' ' + + splitWord xs + | null xs = Nothing + | [x] <- reads xs = Just x + | otherwise = Just (break isSp xs) diff --git a/src/Client/Commands/Interpolation.hs b/src/Client/Commands/Interpolation.hs --- a/src/Client/Commands/Interpolation.hs +++ b/src/Client/Commands/Interpolation.hs @@ -1,4 +1,4 @@ -{-# Language OverloadedStrings #-} +{-# Language OverloadedStrings, GADTs #-} {-| Module : Client.Commands.Interpolation @@ -15,6 +15,10 @@ ( ExpansionChunk(..) , parseExpansion , resolveMacroExpansions + , Macro(..) + , MacroSpec(..) + , parseMacroSpecs + , noMacroArguments ) where import Control.Applicative @@ -23,6 +27,8 @@ import qualified Data.Text as Text import Data.Text (Text) +import Client.Commands.Arguments + -- | Parsed chunk of an expandable command data ExpansionChunk -- | regular text @@ -34,6 +40,41 @@ -- | bracketed variable with default @${x|lit}@ | DefaultChunk ExpansionChunk Text deriving Show + +data Macro + = Macro + { macroSpec :: MacroSpec + , macroCommands :: [[ExpansionChunk]] + } deriving Show + +data MacroSpec where + MacroSpec :: ArgumentSpec s -> MacroSpec + +instance Show MacroSpec where + showsPrec p (MacroSpec as) + = showParen (p >= 11) + $ showString "MacroSpec " . showsPrec 11 as + +-- | Specification used when unspecified, no arguments. +noMacroArguments :: MacroSpec +noMacroArguments = MacroSpec NoArg + +parseMacroSpecs :: Text -> Maybe MacroSpec +parseMacroSpecs txt = + case parseOnly (macroSpecs <* endOfInput) txt of + Left{} -> Nothing + Right spec -> Just spec + +macroSpecs :: Parser MacroSpec +macroSpecs = + cons <$> P.takeWhile1 isAlpha + <*> optional (char '?') + <* P.skipSpace + <*> macroSpecs + <|> pure (MacroSpec NoArg) + where + cons desc (Just _) (MacroSpec rest) = MacroSpec (OptTokenArg (Text.unpack desc) rest) + cons desc Nothing (MacroSpec rest) = MacroSpec (ReqTokenArg (Text.unpack desc) rest) -- | Parse a 'Text' searching for the expansions as specified in -- 'ExpansionChunk'. @$$@ is used to escape a single @$@. diff --git a/src/Client/Commands/Recognizer.hs b/src/Client/Commands/Recognizer.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Recognizer.hs @@ -0,0 +1,127 @@ +{-# Language OverloadedStrings, DeriveFunctor #-} + +{-| +Module : Client.Commands.Recognizer +Description : Trie for recognizing commands +Copyright : (c) Dan Doel, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module implements a trie for recognizing valid commands. This +allows entered strings to be classified as either a valid command +(with an associated value), the prefix of a valid command, or invalid. +-} + +module Client.Commands.Recognizer + ( Recognizer + , recognize + , Recognition(..) + , fromCommands + , addCommand + , keys + ) where + +import Control.Monad +import Control.Applicative hiding (empty) + +import Data.HashMap.Strict (lookup,insertWith,HashMap,empty,unionWith,fromList,toList) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Maybe + +import Prelude hiding (all,lookup) + +-- | A map from 'Text' values to 'a' values that is capable of yielding more +-- detailed information when looking up keys that are not actually in the map. +data Recognizer a + = Branch !Text !(Maybe a) !(HashMap Char (Recognizer a)) + deriving (Show, Functor) + +instance Monoid (Recognizer a) where + mempty = Branch "" Nothing empty + mappend = both + +-- | Possible results of recognizing text. +data Recognition a + = Exact a -- ^ text matched exactly, yielding the given value + | Prefix [Text] -- ^ text would be recognized if joined to the given suffixes + | Invalid -- ^ text could not possibly be recognized + deriving (Show, Functor) + +-- | Match common prefixes of two strings in a more convenient form than +-- available from 'Data.Text' +splitCommon :: Text -> Text -> (Text, Text, Text) +splitCommon l r = fromMaybe ("", l, r) $ Text.commonPrefixes l r + +-- | Attempt to recognize a string, yielding a 'Recognition' result. +recognize :: Text -> Recognizer a -> Recognition a +recognize tx (Branch pf contained children) + = case splitCommon pf tx of + (_, pfsfx, txsfx) -> case Text.uncons txsfx of + Nothing + | Text.null pfsfx + , Just a <- contained -> Exact a + | otherwise -> Prefix $ keys (Branch pfsfx contained children) + Just (c, txrest) + | Text.null pfsfx + , Just rec <- lookup c children + -> recognize txrest rec + _ -> Invalid + +-- | Create a singleton 'Recognizer' associating the given 'Text' and value. +single :: Text -> a -> Recognizer a +single tx v = Branch tx (Just $! v) empty + +-- | Union two 'Recognizers'. The stored values in the result are biased to the +-- left if there is key overlap. +both :: Recognizer a -> Recognizer a -> Recognizer a +both l@(Branch pfl conl chil) r@(Branch pfr conr chir) + | Text.null pfl && null conl && null chil = r + | Text.null pfr && null conr && null chir = l + | otherwise + = case splitCommon pfl pfr of + (common, lsfx, rsfx) -> Branch common contained children + where + contained = (guard (Text.null lsfx) *> conl) + <|> (guard (Text.null rsfx) *> conr) + children = case (Text.uncons lsfx, Text.uncons rsfx) of + (Nothing, Nothing) + -> unionWith both chil chir + (Just (l',lest), Nothing) + -> insertWith (flip both) l' (Branch lest conl chil) chir + (Nothing, Just (r',rest)) + -> insertWith both r' (Branch rest conr chir) chil + (Just (l',lest), Just (r',rest)) + -> fromList [ (l', Branch lest conl chil) + , (r', Branch rest conr chir) + ] + +-- | Union an arbitrary number of 'Recognizers' as with 'both'. +all :: [Recognizer a] -> Recognizer a +all [] = mempty +all [r] = r +all rs = all $ pair rs + where + pair (l:r:rest) = both l r : pair rest + pair rest = rest + +-- | Create a 'Recognizer' from an association list. If a key appears twice, the +-- earliest associated value will be used. +fromCommands :: [(Text, a)] -> Recognizer a +fromCommands = all . map (uncurry single) + +-- | Add a key-value pair to a 'Recognizer'. This will override the value +-- already present if one exists. +addCommand :: Text -> a -> Recognizer a -> Recognizer a +addCommand tx v = both $ single tx v + +-- | Compute all strings that will be recognized by a 'Recognizer'. +keys :: Recognizer a -> [Text] +keys (Branch pf contained children) + = maybeToList (pf <$ contained) + ++ (mappend pf <$> childKeys children) + +-- | Auxiliary function for 'keys'. +childKeys :: HashMap Char (Recognizer a) -> [Text] +childKeys children = toList children >>= \(c,rec) -> Text.cons c <$> keys rec diff --git a/src/Client/Commands/WordCompletion.hs b/src/Client/Commands/WordCompletion.hs --- a/src/Client/Commands/WordCompletion.hs +++ b/src/Client/Commands/WordCompletion.hs @@ -101,20 +101,20 @@ toString = Text.unpack -tabSearch :: Prefix a => Bool -> a -> a -> [a] -> Maybe a +tabSearch :: + Prefix a => + Bool {- ^ reversed -} -> + a {- ^ search prefix -} -> + a {- ^ previous result -} -> + [a] {- ^ posibilities -} -> + Maybe a tabSearch isReversed pat cur vals - | Just next <- advanceFun cur valSet - , isPrefix pat next - = Just next - - | isReversed = find (isPrefix pat) (Set.toDescList valSet) - - | otherwise = do x <- Set.lookupGE pat valSet - guard (isPrefix pat x) - Just x + | Set.null valSet = Nothing + | Just next <- advanceFun cur valSet = Just next + | isReversed = Just $! Set.findMax valSet + | otherwise = Just $! Set.findMin valSet where - valSet = Set.fromList vals + valSet = Set.fromList (filter (isPrefix pat) vals) advanceFun | isReversed = Set.lookupLT | otherwise = Set.lookupGT - diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -44,6 +44,7 @@ import Client.Configuration.Colors import Client.Configuration.ServerSettings import Client.Commands.Interpolation +import Client.Commands.Recognizer import Control.Exception import Control.Monad import Config @@ -78,7 +79,7 @@ , _configNickPadding :: Maybe Integer -- ^ Padding of nicks , _configConfigPath :: Maybe FilePath -- ^ manually specified configuration path, used for reloading - , _configMacros :: HashMap Text [[ExpansionChunk]] -- ^ command macros + , _configMacros :: Recognizer Macro -- ^ command macros , _configExtensions :: [FilePath] -- ^ paths to shared library , _configUrlOpener :: Maybe FilePath -- ^ paths to url opening executable , _configIgnores :: HashSet Identifier -- ^ initial ignore list @@ -197,7 +198,7 @@ _configWindowNames <- fromMaybe defaultWindowNames <$> sectionOpt "window-names" - _configMacros <- fromMaybe HashMap.empty + _configMacros <- fromMaybe mempty <$> sectionOptWith parseMacroMap "macros" _configExtensions <- fromMaybe [] @@ -231,31 +232,10 @@ "nick-colors" -> do xs <- Vector.fromList <$> parseList parseAttr v when (null xs) (failure "Empty palette") return $! set palNicks xs p - - "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 - "command" -> setAttr palCommand - "command-ready" -> setAttr palCommandReady - "command-placeholder" -> setAttr palCommandPlaceholder - _ -> failure "Unknown palette entry" - where - setAttr l = - do !attr <- parseAttr v - return $! set l attr p - - setAttrMb l = - do !attr <- parseAttr v - return $! set l (Just attr) p + _ | Just (Lens l) <- lookup k paletteMap -> + do !attr <- parseAttr v + return $! set l attr p + _ -> failure "Unknown palette entry" parseServers :: ServerSettings -> Value -> ConfigParser (HashMap Text ServerSettings) parseServers def v = @@ -317,7 +297,7 @@ parseUseTls :: Value -> ConfigParser UseTls parseUseTls (Atom "yes") = return UseTls -parseUseTls (Atom "yes-insecure") = return UseInsecure +parseUseTls (Atom "yes-insecure") = return UseInsecureTls parseUseTls (Atom "no") = return UseInsecure parseUseTls _ = failure "expected yes, yes-insecure, or no" @@ -338,14 +318,23 @@ | otherwise = do home <- getHomeDirectory return (home path) -parseMacroMap :: Value -> ConfigParser (HashMap Text [[ExpansionChunk]]) -parseMacroMap v = HashMap.fromList <$> parseList parseMacro v +parseMacroMap :: Value -> ConfigParser (Recognizer Macro) +parseMacroMap v = fromCommands <$> parseList parseMacro v -parseMacro :: Value -> ConfigParser (Text, [[ExpansionChunk]]) +parseMacro :: Value -> ConfigParser (Text, Macro) parseMacro = parseSections $ do name <- sectionReq "name" + spec <- fromMaybe noMacroArguments + <$> sectionOptWith parseMacroArguments "arguments" commands <- sectionReqWith (parseList parseMacroCommand) "commands" - return (name, commands) + return (name, Macro spec commands) + +parseMacroArguments :: Value -> ConfigParser MacroSpec +parseMacroArguments v = + do txt <- parseConfig v + case parseMacroSpecs txt of + Nothing -> failure "bad macro argument specs" + Just ex -> return ex parseMacroCommand :: Value -> ConfigParser [ExpansionChunk] parseMacroCommand v = diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -18,7 +18,6 @@ import Client.CApi import Client.Commands import Client.Commands.Interpolation -import Client.Configuration import Client.Configuration.ServerSettings import Client.EventLoop.Errors (exceptionToLines) import Client.Hook @@ -28,6 +27,7 @@ import Client.Network.Async import Client.State import qualified Client.State.EditBox as Edit +import Client.State.Focus import Client.State.Network import Control.Concurrent.STM import Control.Exception @@ -50,6 +50,7 @@ import Irc.Codes import Irc.Message import Irc.RawIrcMsg +import LensUtils import Network.Connection reconnectAttempts :: Int @@ -115,6 +116,7 @@ case networkEvent of NetworkLine network time line -> doNetworkLine network time line st NetworkError network time ex -> doNetworkError network time ex st + NetworkOpen network time -> doNetworkOpen network time st NetworkClose network time -> doNetworkClose network time st -- | Sound the terminal bell assuming that the @BEL@ control code @@ -122,10 +124,29 @@ beep :: Vty -> IO () beep = ringTerminalBell . outputIface +-- | Respond to a network connection successfully connecting. +doNetworkOpen :: + NetworkId {- ^ network id -} -> + ZonedTime {- ^ event time -} -> + ClientState {- ^ client state -} -> + IO () +doNetworkOpen networkId time st = + case view (clientConnections . at networkId) st of + Nothing -> error "doNetworkOpen: Network missing" + Just cs -> + let msg = ClientMessage + { _msgTime = time + , _msgNetwork = view csNetwork cs + , _msgBody = NormalBody "connection opened" + } + in eventLoop $ recordNetworkMessage msg + $ overStrict (clientConnections . ix networkId . csLastReceived) + (\old -> old `seq` Just $! zonedTimeToUTC time) st + -- | Respond to a network connection closing normally. doNetworkClose :: - NetworkId {- ^ finished network -} -> - ZonedTime {- ^ current time -} -> + NetworkId {- ^ network id -} -> + ZonedTime {- ^ event time -} -> ClientState -> IO () doNetworkClose networkId time st = let (cs,st') = removeNetwork networkId st @@ -355,6 +376,7 @@ KChar 'u' -> changeEditor Edit.killHome KChar 'k' -> changeEditor Edit.killEnd KChar 'y' -> changeEditor Edit.yank + KChar 't' -> changeContent Edit.toggle KChar 'w' -> changeEditor (Edit.killWordBackward True) KChar 'b' -> changeEditor (Edit.insert '\^B') KChar 'c' -> changeEditor (Edit.insert '\^C') @@ -376,13 +398,14 @@ KChar 'f' -> changeContent Edit.rightWord KChar 'a' -> eventLoop (jumpToActivity st) KChar 's' -> eventLoop (returnFocus st) - KChar c | let names = view (clientConfig . configWindowNames) st - , Just i <- Text.findIndex (==c) names -> + KChar c | let names = clientWindowNames st + , Just i <- elemIndex c names -> eventLoop (jumpFocus i st) _ -> eventLoop st [] -> -- no modifier case key of + KEsc -> eventLoop (changeSubfocus FocusMessages st) KBS -> changeContent Edit.backspace KDel -> changeContent Edit.delete KLeft -> changeContent Edit.left @@ -399,8 +422,12 @@ KChar '\t' -> doCommandResult False =<< tabCompletion False st KChar c -> changeEditor (Edit.insert c) + + -- toggles KFun 2 -> eventLoop (over clientDetailView not st) KFun 3 -> eventLoop (over clientActivityBar not st) + KFun 4 -> eventLoop (over clientShowMetadata not st) + _ -> eventLoop st _ -> eventLoop st -- unsupported modifier diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -11,26 +11,13 @@ -} module Client.Image (clientPicture) where -import Client.Configuration -import Client.Image.ChannelInfo -import Client.Image.Help -import Client.Image.MaskList -import Client.Image.Message -import Client.Image.Palette -import Client.Image.PaletteView import Client.Image.StatusLine import Client.Image.Textbox -import Client.Image.UserList -import Client.Image.Windows -import Client.Message import Client.State -import Client.State.Focus -import Client.State.Network -import Client.State.Window +import Client.View import Control.Lens import Graphics.Vty (Background(..), Picture(..), Cursor(..)) import Graphics.Vty.Image -import Irc.Identifier (Identifier) -- | Generate a 'Picture' for the current client state. The resulting -- client state is updated for render specific information like scrolling. @@ -53,46 +40,10 @@ (pos, tbImg) = textboxImage st' img = mp <-> statusLineImage st' <-> tbImg -messagePaneImages :: ClientState -> [Image] -messagePaneImages !st = - case (view clientFocus st, view clientSubfocus st) of - (ChannelFocus network channel, FocusInfo) -> - channelInfoImages network channel st - (ChannelFocus network channel, FocusUsers) - | view clientDetailView st -> userInfoImages network channel st - | otherwise -> userListImages network channel st - (ChannelFocus network channel, FocusMasks mode) -> - maskListImages mode network channel st - (_, FocusWindows) -> windowsImages st - (_, FocusPalette) -> paletteViewLines pal - (_, FocusHelp mb) -> helpImageLines mb pal - - _ -> chatMessageImages st - where - pal = view (clientConfig . configPalette) st - -chatMessageImages :: ClientState -> [Image] -chatMessageImages st = windowLineProcessor focusedMessages - where - matcher = clientMatcher st - - focusedMessages - = filter (views wlText matcher) - $ view (clientWindows . ix (view clientFocus st) . winMessages) st - - windowLineProcessor - | view clientDetailView st = map (view wlFullImage) - | otherwise = windowLinesToImages st . filter (not . isNoisy) - - isNoisy msg = - case view wlBody msg of - IrcBody irc -> squelchIrcMsg irc - _ -> False - messagePane :: ClientState -> (Image, ClientState) messagePane st = (img, st') where - images = messagePaneImages st + images = viewLines st vimg = assemble emptyImage images vimg1 = cropBottom h vimg img = pad 0 (h - imageHeight vimg1) 0 0 vimg1 @@ -114,80 +65,6 @@ h = view clientHeight st - reservedLines w = view clientWidth st - -windowLinesToImages :: ClientState -> [WindowLine] -> [Image] -windowLinesToImages st wwls = - case gatherMetadataLines st wwls of - ([], []) -> [] - ([], w:ws) -> view wlImage w : windowLinesToImages st ws - ((img,who,mbnext):mds, wls) -> - startMetadata img mbnext who mds palette - : windowLinesToImages st wls - where - palette = view (clientConfig . configPalette) st - ------------------------------------------------------------------------- - -type MetadataState = - Identifier {- ^ current nick -} -> - [(Image,Identifier,Maybe Identifier)] {- ^ metadata -} -> - Palette {- ^ palette -} -> - Image - -startMetadata :: - Image {- ^ metadata image -} -> - Maybe Identifier {- ^ possible nick transition -} -> - MetadataState -startMetadata img mbnext who mds palette = - quietIdentifier palette who - <|> img - <|> transitionMetadata mbnext who mds palette - -transitionMetadata :: - Maybe Identifier {- ^ possible nick transition -} -> - MetadataState -transitionMetadata mbwho who mds palette = - case mbwho of - Nothing -> continueMetadata who mds palette - Just who' -> quietIdentifier palette who' - <|> continueMetadata who' mds palette - -continueMetadata :: MetadataState -continueMetadata _ [] _ = emptyImage -continueMetadata who1 ((img, who2, mbwho3):mds) palette - | who1 == who2 = img - <|> transitionMetadata mbwho3 who2 mds palette - | otherwise = char defAttr ' ' - <|> startMetadata img mbwho3 who2 mds palette - ------------------------------------------------------------------------- - -gatherMetadataLines :: - ClientState -> - [WindowLine] -> - ( [(Image, Identifier, Maybe Identifier)] , [ WindowLine ] ) - -- ^ metadata entries are reversed -gatherMetadataLines st = go [] - where - go acc (w:ws) - | Just (img,who,mbnext) <- metadataWindowLine st w = - go ((img,who,mbnext) : acc) ws - - go acc ws = (acc,ws) - - --- | Classify window lines for metadata coalesence -metadataWindowLine :: - ClientState -> - WindowLine -> - Maybe (Image, Identifier, Maybe Identifier) - {- ^ Image, incoming identifier, outgoing identifier if changed -} -metadataWindowLine st wl = - case view wlBody wl of - IrcBody irc - | Just who <- ircIgnorable irc st -> Just (ignoreImage, who, Nothing) - | otherwise -> metadataImg irc - _ -> Nothing lineWrap :: Int -> Image -> Image lineWrap w img diff --git a/src/Client/Image/ChannelInfo.hs b/src/Client/Image/ChannelInfo.hs deleted file mode 100644 --- a/src/Client/Image/ChannelInfo.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# Language OverloadedStrings #-} -{-# Language BangPatterns #-} - -{-| -Module : Client.Image.ChannelInfo -Description : Channel information renderer -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module implements a renderer for the window that shows -channel metadata. - --} -module Client.Image.ChannelInfo - ( channelInfoImages - ) where - -import Client.Configuration -import Client.Image.Message -import Client.Image.MircFormatting -import Client.Image.Palette -import Client.State -import Client.State.Channel -import Client.State.Network -import Control.Lens -import Data.HashSet (HashSet) -import Data.Text (Text) -import Data.Time -import Graphics.Vty.Image -import Irc.Identifier - --- | Render the lines used in a channel mask list -channelInfoImages :: - Text {- ^ network -} -> - Identifier {- ^ channel -} -> - ClientState -> [Image] -channelInfoImages network channelId st - - | Just cs <- preview (clientConnection network) st - , Just channel <- preview (csChannels . ix channelId) cs - = channelInfoImages' pal (clientHighlights cs st) channel - - | otherwise = [text' (view palError pal) "No channel information"] - where - pal = view (clientConfig . configPalette) st - -channelInfoImages' :: Palette -> HashSet Identifier -> ChannelState -> [Image] -channelInfoImages' pal myNicks !channel - = topicLine - : provenanceLines - ++ creationLines - ++ urlLines - - where - label = text' (view palLabel pal) - - topicLine = label "Topic: " <|> parseIrcText (view chanTopic channel) - - - utcTimeImage = string defAttr . formatTime defaultTimeLocale "%F %T" - - provenanceLines = - case view chanTopicProvenance channel of - Nothing -> [] - Just !prov -> - [ label "Topic set by: " <|> - coloredUserInfo pal DetailedRender myNicks (view topicAuthor prov) - , label "Topic set on: " <|> utcTimeImage (view topicTime prov) - ] - - creationLines = - case view chanCreation channel of - Nothing -> [] - Just time -> [label "Created on: " <|> utcTimeImage time] - - urlLines = - case view chanUrl channel of - Nothing -> [] - Just url -> [ label "Channel URL: " <|> parseIrcText url ] - diff --git a/src/Client/Image/Help.hs b/src/Client/Image/Help.hs deleted file mode 100644 --- a/src/Client/Image/Help.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-| -Module : Client.Image.Help -Description : Renderer for help lines -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module provides the rendering used for the @/help@ command. - --} -module Client.Image.Help - ( helpImageLines - ) where - -import Client.Image.Arguments -import Client.Image.Palette -import Client.Image.MircFormatting -import Client.Commands -import Client.Commands.Arguments -import Control.Lens -import Data.List.NonEmpty (NonEmpty((:|))) -import Data.Text (Text) -import qualified Data.Text as Text -import Graphics.Vty.Image - --- | Generate either the list of all commands and their arguments, --- or when given a command name generate the detailed help text --- for that command. -helpImageLines :: - Maybe Text {- ^ optional command name -} -> - Palette {- ^ palette -} -> - [Image] {- ^ lines -} -helpImageLines mbCmd pal = - case mbCmd of - Nothing -> listAllCommands pal - Just cmd -> commandHelpLines cmd pal - -commandHelpLines :: Text -> Palette -> [Image] -commandHelpLines cmdName pal = - case view (at cmdName) commands of - Nothing -> [string (view palError pal) "Unknown command, try /help"] - Just (Command args doc impl) -> - reverse $ commandSummary pal (pure cmdName) args - : emptyImage - : explainContext impl - : emptyImage - : map parseIrcText docs - where - docs = Text.lines doc - -explainContext :: CommandImpl a -> Image -explainContext impl = - case impl of - ClientCommand {} -> go "client command" "works everywhere" - NetworkCommand{} -> go "network command" "works when focused on active network" - ChannelCommand{} -> go "channel command" "works when focused on active channel" - ChatCommand {} -> go "chat command" "works when focused on an active channel or private message" - where - go x y = string (withStyle defAttr bold) x <|> - string defAttr (": " ++ y) - -listAllCommands :: Palette -> [Image] -listAllCommands pal = - reverse - [ commandSummary pal name args - | (name, Command args _ _) <- commandsList ] - -commandSummary :: Palette -> NonEmpty Text -> ArgumentSpec a -> Image -commandSummary pal (cmd :| _) args = - char defAttr '/' <|> - text' (view palCommand pal) cmd <|> - argumentsImage pal' args "" - - where - pal' = set palCommandPlaceholder defAttr pal diff --git a/src/Client/Image/MaskList.hs b/src/Client/Image/MaskList.hs deleted file mode 100644 --- a/src/Client/Image/MaskList.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# Language OverloadedStrings #-} -{-| -Module : Client.Image.MaskList -Description : Line renderers for channel mask list view -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module renders the lines used in the channel mask list. A mask list -can show channel bans, quiets, invites, and exceptions. --} -module Client.Image.MaskList - ( maskListImages - ) where - -import Client.Configuration -import Client.Image.Palette -import Client.State -import Client.State.Channel -import Client.State.Network -import Control.Lens -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.List -import Data.Ord -import Data.Text (Text) -import Data.Time -import Graphics.Vty.Image -import Irc.Identifier - --- | Render the lines used in a channel mask list -maskListImages :: - Char {- ^ Mask mode -} -> - Text {- ^ network -} -> - Identifier {- ^ channel -} -> - ClientState -> [Image] -maskListImages mode network channel st = - case mbEntries of - Nothing -> [text' (view palError pal) "Mask list not loaded"] - Just entries -> maskListImages' entries st - - where - pal = view (clientConfig . configPalette) st - mbEntries = preview - ( clientConnection network - . csChannels . ix channel - . chanLists . ix mode - ) st - -maskListImages' :: HashMap Text MaskListEntry -> ClientState -> [Image] -maskListImages' entries st = countImage : images - where - pal = view (clientConfig . configPalette) st - - countImage = text' (view palLabel pal) "Masks (visible/total): " <|> - string defAttr (show (length entryList)) <|> - char (view palLabel pal) '/' <|> - string defAttr (show (HashMap.size entries)) - - matcher = clientMatcher st - - matcher' (mask,entry) = matcher mask || matcher (view maskListSetter entry) - - entryList = sortBy (flip (comparing (view (_2 . maskListTime)))) - $ filter matcher' - $ HashMap.toList entries - - renderWhen = formatTime defaultTimeLocale " %F %T" - - (masks, whoWhens) = unzip entryList - maskImages = text' defAttr <$> masks - maskColumnWidth = maximum (imageWidth <$> maskImages) + 1 - paddedMaskImages = resizeWidth maskColumnWidth <$> maskImages - width = max 1 (view clientWidth st) - - images = [ cropLine $ mask <|> - text' defAttr who <|> - string defAttr (renderWhen when) - | (mask, MaskListEntry who when) <- zip paddedMaskImages whoWhens ] - - cropLine img - | imageWidth img > width = cropRight width img - | otherwise = img 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 @@ -31,7 +31,6 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List -import Data.Maybe import Data.Text (Text) import qualified Data.Text as Text import Data.Time @@ -53,7 +52,7 @@ , rendNickPadding :: Maybe Integer -- ^ nick padding } --- | Default 'MessageRenderParams' with no sigils or nicknames specified +-- | Default 'MessageRendererParams' with no sigils or nicknames specified defaultRenderParams :: MessageRendererParams defaultRenderParams = MessageRendererParams { rendStatusMsg = "" @@ -368,9 +367,7 @@ color | ident `HashSet.member` myNicks = case icm of - PrivmsgIdentifier -> fromMaybe - (view palSelf palette) - (view palSelfHighlight palette) + PrivmsgIdentifier -> view palSelfHighlight palette NormalIdentifier -> view palSelf palette | otherwise = v Vector.! i 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 @@ -30,6 +30,8 @@ , palCommand , palCommandReady , palCommandPlaceholder + , palCommandPrefix + , palCommandError , paletteMap @@ -46,7 +48,7 @@ data Palette = Palette { _palNicks :: Vector Attr -- ^ highlighting nicknames , _palSelf :: Attr -- ^ own nickname(s) - , _palSelfHighlight :: Maybe Attr -- ^ own nickname(s) in mentions + , _palSelfHighlight :: Attr -- ^ own nickname(s) in mentions , _palTime :: Attr -- ^ message timestamps , _palMeta :: Attr -- ^ coalesced metadata , _palSigil :: Attr -- ^ sigils (e.g. @+) @@ -59,6 +61,8 @@ , _palMention :: Attr -- ^ window name with mention , _palCommand :: Attr -- ^ known command , _palCommandReady :: Attr -- ^ known command with complete arguments + , _palCommandPrefix :: Attr -- ^ prefix of known command + , _palCommandError :: Attr -- ^ unknown command , _palCommandPlaceholder :: Attr -- ^ command argument placeholder } deriving Show @@ -70,7 +74,7 @@ defaultPalette = Palette { _palNicks = defaultNickColorPalette , _palSelf = withForeColor defAttr red - , _palSelfHighlight = Nothing + , _palSelfHighlight = withForeColor defAttr red , _palTime = withForeColor defAttr brightBlack , _palMeta = withForeColor defAttr brightBlack , _palSigil = withForeColor defAttr cyan @@ -83,6 +87,8 @@ , _palMention = withForeColor defAttr red , _palCommand = withForeColor defAttr yellow , _palCommandReady = withForeColor defAttr green + , _palCommandPrefix = withForeColor defAttr blue + , _palCommandError = withForeColor defAttr red , _palCommandPlaceholder = withStyle defAttr reverseVideo } @@ -97,6 +103,7 @@ paletteMap :: [(Text, ReifiedLens' Palette Attr)] paletteMap = [ ("self" , Lens palSelf) + , ("self-highlight" , Lens palSelfHighlight) , ("time" , Lens palTime) , ("meta" , Lens palMeta) , ("sigil" , Lens palSigil) @@ -110,4 +117,6 @@ , ("command" , Lens palCommand) , ("command-ready" , Lens palCommandReady) , ("command-placeholder", Lens palCommandPlaceholder) + , ("command-prefix" , Lens palCommandPrefix) + , ("command-error" , Lens palCommandError) ] diff --git a/src/Client/Image/PaletteView.hs b/src/Client/Image/PaletteView.hs deleted file mode 100644 --- a/src/Client/Image/PaletteView.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-| -Module : Client.Image.PaletteView -Description : View current palette and to see all terminal colors -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -Lines for the @/palette@ command. This view shows all the colors of -the current palette as well as the colors available in the terminal. - --} - -module Client.Image.PaletteView - ( paletteViewLines - ) where - -import Client.Image.Palette -import Control.Lens -import Data.List -import Graphics.Vty.Image - -digits :: String -digits = "0123456789ABCDEF" - -digitImage :: Char -> Image -digitImage d = string defAttr [' ',d,' '] - -columns :: [Image] -> Image -columns = horizCat . intersperse (char defAttr ' ') - --- | Generate lines used for @/palette@. These lines show --- all the colors used in the current palette as well as --- the colors available for use in palettes. -paletteViewLines :: Palette -> [Image] -paletteViewLines pal = - [ columns - $ digitImage digit - : [ string (withBackColor defAttr c) " " - | col <- [0 .. 15] - , let c = Color240 (row * 16 + col) - ] - | (digit,row) <- reverse $ take 15 $ zip (drop 1 digits) [0 ..] - ] ++ - [ columns - $ digitImage '0' - : [ string (withBackColor defAttr (ISOColor c)) " " - | c <- [0..15] - ] - - , columns (map digitImage (' ':digits)) - , emptyImage - , columns - [ text' (view l pal) name - | (name, Lens l) <- paletteMap - ] - , emptyImage - , columns - [ string attr "nicks" - | attr <- toListOf (palNicks . folded) pal - ] - ] diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs --- a/src/Client/Image/StatusLine.hs +++ b/src/Client/Image/StatusLine.hs @@ -14,7 +14,6 @@ ( statusLineImage ) where -import Client.Configuration import Client.Image.Palette import Client.State import Client.State.Channel @@ -23,6 +22,7 @@ import Client.State.Window import Control.Lens import qualified Data.Map.Strict as Map +import Data.Maybe import Data.Text (Text) import qualified Data.Text as Text import Graphics.Vty.Image @@ -42,6 +42,7 @@ , focusImage st , activitySummary , detailImage st + , nometaImage st , scrollImage st , latencyImage st ] @@ -56,7 +57,8 @@ , string defAttr ")" ] where - attr = view (clientConfig . configPalette . palLabel) st + pal = clientPalette st + attr = view palLabel pal latencyImage :: ClientState -> Image latencyImage st @@ -76,7 +78,7 @@ | otherwise = emptyImage | otherwise = emptyImage where - pal = view (clientConfig . configPalette) st + pal = clientPalette st infoBubble :: Image -> Image infoBubble img = string defAttr "─(" <|> img <|> string defAttr ")" @@ -86,8 +88,17 @@ | view clientDetailView st = infoBubble (string attr "detail") | otherwise = emptyImage where - attr = view (clientConfig . configPalette . palLabel) st + pal = clientPalette st + attr = view palLabel pal +nometaImage :: ClientState -> Image +nometaImage st + | view clientShowMetadata st = emptyImage + | otherwise = infoBubble (string attr "nometa") + where + pal = clientPalette st + attr = view palLabel pal + activityImages :: ClientState -> (Image, Image) activityImages st = (summary, activityBar) where @@ -121,7 +132,7 @@ string defAttr "]" <|> rest where n = view winUnread w - pal = view (clientConfig . configPalette) st + pal = clientPalette st attr | view winMention w = view palMention pal | otherwise = view palActivity pal focusText = @@ -130,16 +141,15 @@ NetworkFocus net -> net ChannelFocus _ chan -> idText chan - windows = views clientWindows Map.elems st - windowNames = view (clientConfig . configWindowNames) st - winNames = Text.unpack windowNames ++ repeat '?' + windows = views clientWindows Map.elems st + winNames = clientWindowNames st ++ repeat '?' indicators = foldr aux [] (zip winNames windows) aux (i,w) rest | view winUnread w == 0 = rest | otherwise = char attr i : rest where - pal = view (clientConfig . configPalette) st + pal = clientPalette st attr | view winMention w = view palMention pal | otherwise = view palActivity pal @@ -151,7 +161,7 @@ ChannelFocus network chan -> nickPart network (Just chan) Unfocused -> emptyImage where - pal = view (clientConfig . configPalette) st + pal = clientPalette st nickPart network mbChan = case preview (clientConnection network) st of Nothing -> emptyImage @@ -176,14 +186,13 @@ , renderedFocus ] - pal = view (clientConfig . configPalette) st - focus = view clientFocus st - windowNames = view (clientConfig . configWindowNames) st + pal = clientPalette st + focus = view clientFocus st + windowNames = clientWindowNames st - windowName = - case Map.lookupIndex focus (view clientWindows st) of - Just i | i < Text.length windowNames -> Text.index windowNames i - _ -> '?' + windowName = fromMaybe '?' + $ do i <- Map.lookupIndex focus (view clientWindows st) + preview (ix i) windowNames subfocusName = case view clientSubfocus st of @@ -191,6 +200,7 @@ FocusWindows -> Just $ string (view palLabel pal) "windows" FocusInfo -> Just $ string (view palLabel pal) "info" FocusUsers -> Just $ string (view palLabel pal) "users" + FocusMentions -> Just $ string (view palLabel pal) "mentions" FocusPalette -> Just $ string (view palLabel pal) "palette" FocusHelp mb -> Just $ string (view palLabel pal) "help" <|> foldMap (\cmd -> char defAttr ':' <|> diff --git a/src/Client/Image/Textbox.hs b/src/Client/Image/Textbox.hs --- a/src/Client/Image/Textbox.hs +++ b/src/Client/Image/Textbox.hs @@ -18,6 +18,8 @@ import Client.Configuration import Client.Commands import Client.Commands.Arguments +import Client.Commands.Interpolation +import Client.Commands.Recognizer import Client.Image.Arguments import Client.Image.MircFormatting import Client.Image.Palette @@ -26,6 +28,7 @@ import Control.Lens import Data.Char import Data.List +import Data.Monoid import qualified Data.Text as Text import Graphics.Vty.Image @@ -37,13 +40,12 @@ = (pos, croppedImage) where width = view clientWidth st + macros = views (clientConfig . configMacros) (fmap macroSpec) st (txt, content) = - views (clientTextBox . Edit.content) (renderContent pal) st + views (clientTextBox . Edit.content) (renderContent macros pal) st pos = min (width-1) leftOfCurWidth - pal = view (clientConfig . configPalette) st - lineImage = beginning <|> content <|> ending leftOfCurWidth = myWcswidth ('^':txt) @@ -52,7 +54,8 @@ | leftOfCurWidth < width = lineImage | otherwise = cropLeft width (cropRight (leftOfCurWidth+1) lineImage) - attr = view (clientConfig . configPalette . palTextBox) st + pal = clientPalette st + attr = view palTextBox pal beginning = char attr '^' ending = char attr '$' @@ -60,10 +63,11 @@ -- corresponding to the rendered image which can be used for computing -- the logical cursor position of the cropped version of the text box. renderContent :: + Recognizer MacroSpec {- ^ macro completions -} -> Palette {- ^ palette -} -> Edit.Content {- ^ content -} -> (String, Image) {- ^ plain text rendering, image rendering -} -renderContent pal c = (txt, wholeImg) +renderContent macros pal c = (txt, wholeImg) where as = reverse (view Edit.above c) bs = view Edit.below c @@ -78,7 +82,7 @@ wholeImg = horizCat $ intersperse (plainText "\n") $ map renderOtherLine as - ++ renderLine pal curTxt + ++ renderLine macros pal curTxt : map renderOtherLine bs @@ -101,17 +105,35 @@ -- | Render the active text box line using command highlighting and -- placeholders, and WYSIWYG mIRC formatting control characters. -renderLine :: Palette -> String -> Image +renderLine :: Recognizer MacroSpec -> Palette -> String -> Image +renderLine macros pal ('/':xs) + = char defAttr '/' <|> string attr cmd <|> continue rest + where + specAttr spec = + case parseArguments spec rest of + Nothing -> view palCommand pal + Just{} -> view palCommandReady pal -renderLine pal ('/':xs) - | (cmd,rest) <- break isSpace xs - , Just (Command spec _ _) <- view (at (Text.pack cmd)) commands - , let attr = - case parseArguments spec rest of - Nothing -> view palCommand pal - Just{} -> view palCommandReady pal - = char defAttr '/' <|> - string attr cmd <|> - argumentsImage pal spec rest + (cmd, rest) = break isSpace xs + allCommands = (Left <$> macros) <> (Right <$> commands) + (attr, continue) + = case recognize (Text.pack cmd) allCommands of + Exact (Right (Command spec _ _)) -> + ( specAttr spec + , argumentsImage pal spec + ) + Exact (Left (MacroSpec spec)) -> + ( specAttr spec + , argumentsImage pal spec + ) + Prefix _ -> + ( view palCommandPrefix pal + , renderOtherLine + ) + Invalid -> + ( view palCommandError pal + , renderOtherLine + ) -renderLine _ xs = parseIrcTextExplicit (Text.pack xs) +renderLine _ _ xs = parseIrcTextExplicit (Text.pack xs) + diff --git a/src/Client/Image/UserList.hs b/src/Client/Image/UserList.hs deleted file mode 100644 --- a/src/Client/Image/UserList.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# Language OverloadedStrings #-} -{-| -Module : Client.Image.UserList -Description : Line renderers for channel user list view -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module renders the lines used in the channel user list. --} -module Client.Image.UserList - ( userListImages - , userInfoImages - ) where - -import Client.Configuration -import Client.Image.Message -import Client.Image.Palette -import Client.State -import Client.State.Channel -import Client.State.Network -import Control.Lens -import qualified Data.HashMap.Strict as HashMap -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 -import Irc.UserInfo - --- | Render the lines used by the @/users@ command in normal mode. --- These lines show the count of users having each channel mode --- in addition to the nicknames of the users. -userListImages :: - Text {- ^ network -} -> - Identifier {- ^ channel -} -> - ClientState -> - [Image] -userListImages network channel st = - case preview (clientConnection network) st of - Just cs -> userListImages' cs channel st - Nothing -> [text' (view palError pal) "No connection"] - where - pal = view (clientConfig . configPalette) st - -userListImages' :: NetworkState -> Identifier -> ClientState -> [Image] -userListImages' cs channel st = - [countImage, horizCat (intersperse gap (map renderUser usersList))] - where - countImage = text' (view palLabel pal) "Users:" <|> - sigilCountImage - - matcher = clientMatcher st - - myNicks = clientHighlights cs st - - renderUser (ident, sigils) = - string (view palSigil pal) sigils <|> - coloredIdentifier pal NormalIdentifier myNicks ident - - gap = char defAttr ' ' - - matcher' (ident,sigils) = matcher (Text.pack sigils `Text.append` idText ident) - - usersList = sortBy (comparing fst) - $ filter matcher' - $ HashMap.toList usersHashMap - - sigilCounts = Map.fromListWith (+) - [ (take 1 sigil, 1::Int) | (_,sigil) <- usersList ] - - sigilCountImage = horizCat - [ string (view palSigil pal) (' ':sigil) <|> - string defAttr (show n) - | (sigil,n) <- Map.toList sigilCounts - ] - - pal = view (clientConfig . configPalette) st - - usersHashMap = - view (csChannels . ix channel . chanUsers) cs - --- | Render lines for the @/users@ command in detailed view. --- Each user will be rendered on a separate line with username --- and host visible when known. -userInfoImages :: - Text {- ^ network -} -> - Identifier {- ^ channel -} -> - ClientState -> - [Image] -userInfoImages network channel st = - case preview (clientConnection network) st of - Just cs -> userInfoImages' cs channel st - Nothing -> [text' (view palError pal) "No connection"] - where - pal = view (clientConfig . configPalette) st - -userInfoImages' :: NetworkState -> Identifier -> ClientState -> [Image] -userInfoImages' cs channel st = renderEntry <$> usersList - where - matcher = clientMatcher st - - myNicks = clientHighlights cs st - - pal = view (clientConfig . configPalette) st - - renderEntry (info, sigils) = - string (view palSigil pal) sigils <|> - coloredUserInfo pal DetailedRender myNicks info - - matcher' (info,sigils) = - matcher (Text.pack sigils `Text.append` renderUserInfo info) - - userInfos = view csUsers cs - - toInfo nick = - case view (at nick) userInfos of - Just (UserAndHost n h) -> UserInfo nick n h - Nothing -> UserInfo nick "" "" - - usersList = sortBy (flip (comparing (userNick . fst))) - $ filter matcher' - $ map (over _1 toInfo) - $ HashMap.toList usersHashMap - - usersHashMap = view (csChannels . ix channel . chanUsers) cs diff --git a/src/Client/Image/Windows.hs b/src/Client/Image/Windows.hs deleted file mode 100644 --- a/src/Client/Image/Windows.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-| -Module : Client.Image.Windows -Description : View of the list of open windows -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module implements the rendering of the client window list. - --} -module Client.Image.Windows - ( windowsImages - ) where - -import Client.Configuration -import Client.Image.Palette -import Client.State -import Client.State.Focus -import Client.State.Window -import Control.Lens -import Data.List -import qualified Data.Map as Map -import qualified Data.Text as Text -import Graphics.Vty.Image -import Irc.Identifier - --- | Draw the image lines associated with the @/windows@ command. -windowsImages :: ClientState -> [Image] -windowsImages st - = reverse - $ createColumns - $ zipWith (renderWindowColumns pal) names windows - where - cfg = view clientConfig st - windows = views clientWindows Map.toAscList st - - pal = view configPalette cfg - names = views configWindowNames Text.unpack cfg ++ repeat '?' - -renderWindowColumns :: Palette -> Char -> (Focus, Window) -> [Image] -renderWindowColumns pal name (focus, win) = - [ char (view palWindowName pal) name - , renderedFocus pal focus - , renderedWindowInfo pal win - ] - -createColumns :: [[Image]] -> [Image] -createColumns xs = map makeRow xs - where - columnWidths = maximum . map imageWidth <$> transpose xs - makeRow = horizCat - . intersperse (char defAttr ' ') - . zipWith resizeWidth columnWidths - -renderedFocus :: Palette -> Focus -> Image -renderedFocus pal focus = - case focus of - Unfocused -> - char (view palError pal) '*' - NetworkFocus network -> - text' (view palLabel pal) network - ChannelFocus network channel -> - text' (view palLabel pal) network <|> - char defAttr ':' <|> - text' (view palLabel pal) (idText channel) - -renderedWindowInfo :: Palette -> Window -> Image -renderedWindowInfo pal win = - string (view newMsgAttrLens pal) (views winUnread show win) <|> - char defAttr '/' <|> - string (view palActivity pal) (views winTotal show win) - where - newMsgAttrLens - | view winMention win = palMention - | otherwise = palActivity diff --git a/src/Client/Network/Async.hs b/src/Client/Network/Async.hs --- a/src/Client/Network/Async.hs +++ b/src/Client/Network/Async.hs @@ -62,12 +62,14 @@ -- are annotated with a network ID matching that given when the connection -- was created as well as the time at which the message was recieved. data NetworkEvent - = NetworkLine !NetworkId !ZonedTime !ByteString - -- ^ Event for a new recieved line (newline removed) + -- | Event for successful connection to host + = NetworkOpen !NetworkId !ZonedTime + -- | Event for a new recieved line (newline removed) + | NetworkLine !NetworkId !ZonedTime !ByteString + -- | Final message indicating the network connection failed | NetworkError !NetworkId !ZonedTime !SomeException - -- ^ Final message indicating the network connection failed + -- | Final message indicating the network connection finished | NetworkClose !NetworkId !ZonedTime - -- ^ Final message indicating the network connection finished instance Show NetworkConnection where showsPrec p _ = showParen (p > 10) @@ -142,19 +144,25 @@ TQueue NetworkEvent -> TQueue ByteString -> IO () -startConnection network cxt settings onInput outQueue = +startConnection network cxt settings inQueue outQueue = do rate <- newRateLimit (view ssFloodPenalty settings) (view ssFloodThreshold settings) withConnection cxt settings $ \h -> - withAsync (sendLoop h outQueue rate) $ \sender -> - withAsync (receiveLoop network h onInput) $ \receiver -> - do res <- waitEitherCatch sender receiver - case res of - Left Right{} -> fail "PANIC: sendLoop returned" - Right Right{} -> return () - Left (Left e) -> throwIO e - Right (Left e) -> throwIO e + do reportNetworkOpen network inQueue + withAsync (sendLoop h outQueue rate) $ \sender -> + withAsync (receiveLoop network h inQueue) $ \receiver -> + do res <- waitEitherCatch sender receiver + case res of + Left Right{} -> fail "PANIC: sendLoop returned" + Right Right{} -> return () + Left (Left e) -> throwIO e + Right (Left e) -> throwIO e + +reportNetworkOpen :: NetworkId -> TQueue NetworkEvent -> IO () +reportNetworkOpen network inQueue = + do now <- getZonedTime + atomically (writeTQueue inQueue (NetworkOpen network now)) sendLoop :: Connection -> TQueue ByteString -> RateLimit -> IO () sendLoop h outQueue rate = diff --git a/src/Client/Options.hs b/src/Client/Options.hs new file mode 100644 --- /dev/null +++ b/src/Client/Options.hs @@ -0,0 +1,117 @@ +{-# Language TemplateHaskell, MultiWayIf #-} +{-| +Module : Client.Options +Description : Processing of command-line options +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module process command-line options provided when launching the client. + +-} +module Client.Options + ( + -- * Command-line options + Options(..) + + -- * Lenses + , optConfigFile + , optInitialNetworks + + -- * Options loader + , getOptions + ) where + +import Control.Lens +import Data.Foldable +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Version +import Development.GitRev (gitHash, gitDirty) +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Paths_glirc (version) + +-- | Command-line options +data Options = Options + { _optConfigFile :: Maybe FilePath -- ^ configuration file path + , _optInitialNetworks :: [Text] -- ^ initial networks + , _optShowHelp :: Bool -- ^ show help message + , _optShowVersion :: Bool -- ^ show version message + } + +makeLenses ''Options + +-- | Default values for 'Options' +defaultOptions :: Options +defaultOptions = Options + { _optConfigFile = Nothing + , _optInitialNetworks = [] + , _optShowHelp = False + , _optShowVersion = False + } + +-- | Option descriptions +options :: [OptDescr (Options -> Options)] +options = + [ Option "c" ["config"] (ReqArg (set optConfigFile . Just) "PATH") + "Configuration file path" + , Option "h" ["help"] (NoArg (set optShowHelp True)) + "Show help" + , Option "v" ["version"] (NoArg (set optShowVersion True)) + "Show version" + ] + +optOrder :: ArgOrder (Options -> Options) +optOrder = ReturnInOrder (\x -> optInitialNetworks <>~ [Text.pack x]) + +-- | Load command line options. This action will terminate early +-- in the case of the version flag, help flag, or an error. +getOptions :: IO Options +getOptions = + do (flags, _, errors) <- getOpt optOrder options <$> getArgs + + let opts = foldl' (\acc f -> f acc) defaultOptions flags + + bullet x = "• " ++ x + + reportErrors = + do hPutStrLn stderr "Errors processing command-line options:" + traverse_ (hPutStr stderr) (map bullet errors) + hPutStrLn stderr tryHelpTxt + + if | view optShowHelp opts -> putStr helpTxt >> exitSuccess + | view optShowVersion opts -> putStr versionTxt >> exitSuccess + | null errors -> return opts + | otherwise -> reportErrors >> exitFailure + +helpTxt :: String +helpTxt = usageInfo "glirc2 [FLAGS] INITIAL_NETWORKS..." options + +tryHelpTxt :: String +tryHelpTxt = + "Run 'glirc2 --help' to see a list of available command line options." + +versionTxt :: String +versionTxt = unlines + [ "glirc-" ++ showVersion version ++ gitHashTxt ++ gitDirtyTxt + , "Copyright 2016 Eric Mertens" + ] + +-- git version information --------------------------------------------- + +-- | Returns @"-SOMEHASH"@ when in a git repository, @""@ otherwise. +gitHashTxt :: String +gitHashTxt + | hashTxt == "UNKNOWN" = "" + | otherwise = '-':hashTxt + where + hashTxt = $gitHash + +-- | Returns @"-dirty"@ when in a dirty git repository, @""@ otherwise. +gitDirtyTxt :: String +gitDirtyTxt + | $gitDirty = "-dirty" + | otherwise = "" diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -29,6 +29,7 @@ , clientScroll , clientDetailView , clientActivityBar + , clientShowMetadata , clientSubfocus , clientNextConnectionId , clientNetworkMap @@ -56,6 +57,8 @@ , clientTick , applyMessageToClientState , clientHighlights + , clientWindowNames + , clientPalette -- * Add messages to buffers , recordChannelMessage @@ -85,6 +88,7 @@ import Client.Configuration import Client.Configuration.ServerSettings import Client.Image.Message +import Client.Image.Palette import Client.Message import Client.Network.Async import Client.State.Channel @@ -139,14 +143,18 @@ , _clientEvents :: !(TQueue NetworkEvent) -- ^ incoming network event queue , _clientNetworkMap :: !(HashMap Text NetworkId) -- ^ network name to connection ID + , _clientConfig :: !Configuration -- ^ client configuration + , _clientVty :: !Vty -- ^ VTY handle , _clientTextBox :: !Edit.EditBox -- ^ primary text box , _clientWidth :: !Int -- ^ current terminal width , _clientHeight :: !Int -- ^ current terminal height - , _clientConfig :: !Configuration -- ^ client configuration + , _clientScroll :: !Int -- ^ buffer scroll lines , _clientDetailView :: !Bool -- ^ use detailed rendering mode , _clientActivityBar :: !Bool -- ^ visible activity bar + , _clientShowMetadata :: !Bool -- ^ visible activity bar + , _clientBell :: !Bool -- ^ sound a bell next draw , _clientIgnores :: !(HashSet Identifier) -- ^ ignored nicknames @@ -218,6 +226,7 @@ , _clientConfig = cfg , _clientScroll = 0 , _clientDetailView = False + , _clientShowMetadata = True , _clientActivityBar = view configActivityBar cfg , _clientNextConnectionId = 0 , _clientBell = False @@ -257,17 +266,17 @@ ClientMessage -> ClientState -> ClientState recordChannelMessage network channel msg st = - recordWindowLine focus importance wl st + recordWindowLine focus wl st where focus = ChannelFocus network channel' - wl = toWindowLine rendParams msg + wl = toWindowLine rendParams importance msg rendParams = MessageRendererParams { rendStatusMsg = statusModes , rendUserSigils = computeMsgLineSigils network channel' msg st , rendNicks = HashSet.fromList (channelUserList network channel' st) , rendMyNicks = highlights - , rendPalette = view (clientConfig . configPalette) st + , rendPalette = clientPalette st , rendNickPadding = view (clientConfig . configNickPadding) st } @@ -364,11 +373,11 @@ TargetUser user -> foldl' (\st' chan -> overStrict (clientWindows . ix (ChannelFocus network chan)) - (addToWindow WLBoring wl) st') + (addToWindow wl) st') st chans where cfg = view clientConfig st - wl = toWindowLine' cfg msg + wl = toWindowLine' cfg WLBoring msg chans = user : case preview (clientConnection network . csChannels) st of Nothing -> [] @@ -401,39 +410,40 @@ -- | Record a message on a network window recordNetworkMessage :: ClientMessage -> ClientState -> ClientState -recordNetworkMessage msg st = recordWindowLine focus importance wl st +recordNetworkMessage msg st = recordWindowLine focus wl st where network = view msgNetwork msg focus | Text.null network = Unfocused | otherwise = NetworkFocus (view msgNetwork msg) importance = msgImportance msg st - wl = toWindowLine' cfg msg + wl = toWindowLine' cfg importance msg cfg = view clientConfig st -- | Record window line at the given focus creating the window if necessary recordWindowLine :: Focus -> - WindowLineImportance -> WindowLine -> ClientState -> ClientState -recordWindowLine focus importance wl = +recordWindowLine focus wl = over (clientWindows . at focus) - (\w -> Just $! addToWindow importance wl (fromMaybe emptyWindow w)) + (\w -> Just $! addToWindow wl (fromMaybe emptyWindow w)) -toWindowLine :: MessageRendererParams -> ClientMessage -> WindowLine -toWindowLine params msg = WindowLine - { _wlBody = view msgBody msg - , _wlText = msgText (view msgBody msg) - , _wlImage = mkImage NormalRender - , _wlFullImage = mkImage DetailedRender +toWindowLine :: MessageRendererParams -> WindowLineImportance -> ClientMessage -> WindowLine +toWindowLine params importance msg = WindowLine + { _wlBody = view msgBody msg + , _wlText = msgText (view msgBody msg) + , _wlImage = mkImage NormalRender + , _wlFullImage = mkImage DetailedRender + , _wlImportance = importance + , _wlTimestamp = zonedTimeToUTC (view msgTime msg) } where mkImage mode = force (msgImage mode (view msgTime msg) params (view msgBody msg)) -- | 'toWindowLine' but with mostly defaulted parameters. -toWindowLine' :: Configuration -> ClientMessage -> WindowLine +toWindowLine' :: Configuration -> WindowLineImportance -> ClientMessage -> WindowLine toWindowLine' config = toWindowLine defaultRenderParams { rendPalette = view configPalette config @@ -755,3 +765,13 @@ case preview (clientConnection network) st of Just cs -> clientHighlights cs st Nothing -> view (clientConfig . configExtraHighlights) st + +-- | Produce the list of window names configured for the client. +clientWindowNames :: + ClientState -> + [Char] +clientWindowNames = views (clientConfig . configWindowNames) Text.unpack + +-- | Produce the list of window names configured for the client. +clientPalette :: ClientState -> Palette +clientPalette = view (clientConfig . configPalette) diff --git a/src/Client/State/EditBox.hs b/src/Client/State/EditBox.hs --- a/src/Client/State/EditBox.hs +++ b/src/Client/State/EditBox.hs @@ -43,6 +43,7 @@ , killWordBackward , killWordForward , yank + , toggle , left , right , leftWord diff --git a/src/Client/State/EditBox/Content.hs b/src/Client/State/EditBox/Content.hs --- a/src/Client/State/EditBox/Content.hs +++ b/src/Client/State/EditBox/Content.hs @@ -1,4 +1,4 @@ -{-# Language TemplateHaskell #-} +{-# Language TemplateHaskell, BangPatterns #-} {-| Module : Client.State.EditBox.Content Description : Multiline text container with cursor @@ -42,6 +42,7 @@ , insertPastedString , insertString , insertChar + , toggle ) where import Control.Lens hiding (below) @@ -253,3 +254,18 @@ $! over below (view text c :) $ set above as $ set line (endLine a) c + +toggle :: Content -> Content +toggle !c + | p < 1 = c + | n < 2 = c + | n == p = over text (swapAt (p-2)) c + | otherwise = set pos (p+1) + $ over text (swapAt (p-1)) c + where + p = view pos c + n = views text length c + + swapAt 0 (x:y:z) = y:x:z + swapAt i (x:xs) = x:swapAt (i-1) xs + swapAt _ _ = error "toggle: PANIC! Invalid argument" diff --git a/src/Client/State/Focus.hs b/src/Client/State/Focus.hs --- a/src/Client/State/Focus.hs +++ b/src/Client/State/Focus.hs @@ -24,13 +24,6 @@ , _ChannelFocus , _NetworkFocus , _Unfocused - - -- * Subfocus Prisms - , _FocusMessages - , _FocusInfo - , _FocusUsers - , _FocusMasks - , _FocusWindows ) where import Control.Lens @@ -55,10 +48,9 @@ | FocusMasks !Char -- ^ Show channel mask list for given mode | FocusWindows -- ^ Show client windows | FocusPalette -- ^ Show current palette + | FocusMentions -- ^ Show all mentions | FocusHelp (Maybe Text) -- ^ Show help window with optional command deriving (Eq,Show) - -makePrisms ''Subfocus -- | Unfocused first, followed by focuses sorted by network. -- Within the same network the network focus comes first and diff --git a/src/Client/State/Window.hs b/src/Client/State/Window.hs --- a/src/Client/State/Window.hs +++ b/src/Client/State/Window.hs @@ -26,6 +26,8 @@ , wlText , wlImage , wlFullImage + , wlImportance + , wlTimestamp -- * Window line importance , WindowLineImportance(..) @@ -39,14 +41,17 @@ import Client.Message import Control.Lens import Data.Text (Text) +import Data.Time (UTCTime) import Graphics.Vty.Image (Image) -- | A single message to be displayed in a window data WindowLine = WindowLine - { _wlBody :: !MessageBody -- ^ Original Haskell value - , _wlText :: {-# UNPACK #-} !Text -- ^ Searchable text form - , _wlImage :: !Image -- ^ Normal rendered image - , _wlFullImage :: !Image -- ^ Detailed rendered image + { _wlBody :: !MessageBody -- ^ Original Haskell value + , _wlText :: {-# UNPACK #-} !Text -- ^ Searchable text form + , _wlImage :: !Image -- ^ Normal rendered image + , _wlFullImage :: !Image -- ^ Detailed rendered image + , _wlImportance :: !WindowLineImportance -- ^ Importance of message + , _wlTimestamp :: {-# UNPACK #-} !UTCTime } -- | A 'Window' tracks all of the messages and metadata for a particular @@ -79,14 +84,14 @@ -- | Adds a given line to a window as the newest message. Window's -- unread count will be updated according to the given importance. -addToWindow :: WindowLineImportance -> WindowLine -> Window -> Window -addToWindow importance !msg !win = Window - { _winMessages = msg : _winMessages win - , _winTotal = _winTotal win + 1 - , _winUnread = _winUnread win - + (if importance == WLBoring then 0 else 1) - , _winMention = _winMention win - || importance == WLImportant +addToWindow :: WindowLine -> Window -> Window +addToWindow !msg !win = Window + { _winMessages = msg : view winMessages win + , _winTotal = view winTotal win + 1 + , _winUnread = view winUnread win + + (if view wlImportance msg == WLBoring then 0 else 1) + , _winMention = view winMention win + || view wlImportance msg == WLImportant } -- | Update the window clearing the unread count and important flag. diff --git a/src/Client/View.hs b/src/Client/View.hs new file mode 100644 --- /dev/null +++ b/src/Client/View.hs @@ -0,0 +1,46 @@ +{-# Language BangPatterns #-} +{-| +Module : Client.View +Description : View selection module +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module selects the correct view based on the current state. + +-} +module Client.View + ( viewLines + ) where + +import Client.State +import Client.State.Focus +import Client.View.ChannelInfo +import Client.View.Help +import Client.View.MaskList +import Client.View.Mentions +import Client.View.Messages +import Client.View.Palette +import Client.View.UserList +import Client.View.Windows +import Control.Lens +import Graphics.Vty.Image + +viewLines :: ClientState -> [Image] +viewLines !st = + case (view clientFocus st, view clientSubfocus st) of + (ChannelFocus network channel, FocusInfo) -> + channelInfoImages network channel st + (ChannelFocus network channel, FocusUsers) + | view clientDetailView st -> userInfoImages network channel st + | otherwise -> userListImages network channel st + (ChannelFocus network channel, FocusMasks mode) -> + maskListImages mode network channel st + (_, FocusWindows) -> windowsImages st + (_, FocusMentions) -> mentionsViewLines st + (_, FocusPalette) -> paletteViewLines pal + (_, FocusHelp mb) -> helpImageLines mb pal + + _ -> chatMessageImages st + where + pal = clientPalette st diff --git a/src/Client/View/ChannelInfo.hs b/src/Client/View/ChannelInfo.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/ChannelInfo.hs @@ -0,0 +1,80 @@ +{-# Language OverloadedStrings #-} +{-# Language BangPatterns #-} + +{-| +Module : Client.View.ChannelInfo +Description : Channel information renderer +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module implements a renderer for the window that shows +channel metadata. + +-} +module Client.View.ChannelInfo + ( channelInfoImages + ) where + +import Client.Image.Message +import Client.Image.MircFormatting +import Client.Image.Palette +import Client.State +import Client.State.Channel +import Client.State.Network +import Control.Lens +import Data.HashSet (HashSet) +import Data.Text (Text) +import Data.Time +import Graphics.Vty.Image +import Irc.Identifier + +-- | Render the lines used in a channel mask list +channelInfoImages :: + Text {- ^ network -} -> + Identifier {- ^ channel -} -> + ClientState -> [Image] +channelInfoImages network channelId st + + | Just cs <- preview (clientConnection network) st + , Just channel <- preview (csChannels . ix channelId) cs + = channelInfoImages' pal (clientHighlights cs st) channel + + | otherwise = [text' (view palError pal) "No channel information"] + where + pal = clientPalette st + +channelInfoImages' :: Palette -> HashSet Identifier -> ChannelState -> [Image] +channelInfoImages' pal myNicks !channel + = topicLine + : provenanceLines + ++ creationLines + ++ urlLines + + where + label = text' (view palLabel pal) + + topicLine = label "Topic: " <|> parseIrcText (view chanTopic channel) + + + utcTimeImage = string defAttr . formatTime defaultTimeLocale "%F %T" + + provenanceLines = + case view chanTopicProvenance channel of + Nothing -> [] + Just !prov -> + [ label "Topic set by: " <|> + coloredUserInfo pal DetailedRender myNicks (view topicAuthor prov) + , label "Topic set on: " <|> utcTimeImage (view topicTime prov) + ] + + creationLines = + case view chanCreation channel of + Nothing -> [] + Just time -> [label "Created on: " <|> utcTimeImage time] + + urlLines = + case view chanUrl channel of + Nothing -> [] + Just url -> [ label "Channel URL: " <|> parseIrcText url ] + diff --git a/src/Client/View/Help.hs b/src/Client/View/Help.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/Help.hs @@ -0,0 +1,100 @@ +{-# Language OverloadedStrings #-} + +{-| +Module : Client.View.Help +Description : Renderer for help lines +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides the rendering used for the @/help@ command. + +-} +module Client.View.Help + ( helpImageLines + ) where + +import Client.Commands +import Client.Commands.Arguments +import Client.Image.Arguments +import Client.Image.MircFormatting +import Client.Image.Palette +import Client.Commands.Recognizer +import Control.Lens +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as Text +import Graphics.Vty.Image + +-- | Generate either the list of all commands and their arguments, +-- or when given a command name generate the detailed help text +-- for that command. +helpImageLines :: + Maybe Text {- ^ optional command name -} -> + Palette {- ^ palette -} -> + [Image] {- ^ help lines -} +helpImageLines mbCmd pal = + case mbCmd of + Nothing -> listAllCommands pal + Just cmd -> commandHelpLines cmd pal + +-- | Generate detailed help lines for the command with the given name. +commandHelpLines :: + Text {- ^ command name -} -> + Palette {- ^ palette -} -> + [Image] {- ^ lines -} +commandHelpLines cmdName pal = + case recognize cmdName commands of + Invalid -> [string (view palError pal) "Unknown command, try /help"] + Prefix sfxs -> + [string (view palError pal) $ "Unknown command, did you mean: " ++ suggestions] + where + suggestions = Text.unpack $ Text.intercalate " " ((cmdName <>) <$> sfxs) + Exact (Command args doc impl) -> + reverse $ commandSummary pal (pure cmdName) args + : emptyImage + : explainContext impl + : emptyImage + : map parseIrcText docs + where + docs = Text.lines doc + +-- | Generate an explanation of the context where the given command +-- implementation will be valid. +explainContext :: + CommandImpl a {- ^ command implementation -} -> + Image {- ^ help line -} +explainContext impl = + case impl of + ClientCommand {} -> go "client command" "works everywhere" + NetworkCommand{} -> go "network command" "works when focused on active network" + ChannelCommand{} -> go "channel command" "works when focused on active channel" + ChatCommand {} -> go "chat command" "works when focused on an active channel or private message" + where + go x y = string (withStyle defAttr bold) x <|> + string defAttr (": " ++ y) + +-- | Generate the lines for the help window showing all commands. +listAllCommands :: + Palette {- ^ palette -} -> + [Image] {- ^ help lines -} +listAllCommands pal = + reverse + [ commandSummary pal name args + | (name, Command args _ _) <- commandsList ] + +-- | Generate the help line for the given command and its +-- specification for use in the list of commands. +commandSummary :: + Palette {- ^ palette -} -> + NonEmpty Text {- ^ command name and aliases -} -> + ArgumentSpec a {- ^ argument specification -} -> + Image {- ^ summary help line -} +commandSummary pal (cmd :| _) args = + char defAttr '/' <|> + text' (view palCommand pal) cmd <|> + argumentsImage pal' args "" + + where + pal' = set palCommandPlaceholder defAttr pal diff --git a/src/Client/View/MaskList.hs b/src/Client/View/MaskList.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/MaskList.hs @@ -0,0 +1,82 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.View.MaskList +Description : Line renderers for channel mask list view +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module renders the lines used in the channel mask list. A mask list +can show channel bans, quiets, invites, and exceptions. +-} +module Client.View.MaskList + ( maskListImages + ) where + +import Client.Image.Palette +import Client.State +import Client.State.Channel +import Client.State.Network +import Control.Lens +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.List +import Data.Ord +import Data.Text (Text) +import Data.Time +import Graphics.Vty.Image +import Irc.Identifier + +-- | Render the lines used in a channel mask list +maskListImages :: + Char {- ^ Mask mode -} -> + Text {- ^ network -} -> + Identifier {- ^ channel -} -> + ClientState -> [Image] +maskListImages mode network channel st = + case mbEntries of + Nothing -> [text' (view palError pal) "Mask list not loaded"] + Just entries -> maskListImages' entries st + + where + pal = clientPalette st + mbEntries = preview + ( clientConnection network + . csChannels . ix channel + . chanLists . ix mode + ) st + +maskListImages' :: HashMap Text MaskListEntry -> ClientState -> [Image] +maskListImages' entries st = countImage : images + where + pal = clientPalette st + + countImage = text' (view palLabel pal) "Masks (visible/total): " <|> + string defAttr (show (length entryList)) <|> + char (view palLabel pal) '/' <|> + string defAttr (show (HashMap.size entries)) + + matcher = clientMatcher st + + matcher' (mask,entry) = matcher mask || matcher (view maskListSetter entry) + + entryList = sortBy (flip (comparing (view (_2 . maskListTime)))) + $ filter matcher' + $ HashMap.toList entries + + renderWhen = formatTime defaultTimeLocale " %F %T" + + (masks, whoWhens) = unzip entryList + maskImages = text' defAttr <$> masks + maskColumnWidth = maximum (imageWidth <$> maskImages) + 1 + paddedMaskImages = resizeWidth maskColumnWidth <$> maskImages + width = max 1 (view clientWidth st) + + images = [ cropLine $ mask <|> + text' defAttr who <|> + string defAttr (renderWhen when) + | (mask, MaskListEntry who when) <- zip paddedMaskImages whoWhens ] + + cropLine img + | imageWidth img > width = cropRight width img + | otherwise = img diff --git a/src/Client/View/Mentions.hs b/src/Client/View/Mentions.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/Mentions.hs @@ -0,0 +1,109 @@ +{-# Language BangPatterns #-} +{-| +Module : Client.View.Mentions +Description : Mentions view +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides the lines that have been highlighted +across the client in sorted order. + +-} +module Client.View.Mentions + ( mentionsViewLines + ) where + +import Client.Image.Palette +import Client.State +import Client.State.Focus +import Client.State.Window +import qualified Data.Map as Map +import Control.Lens +import Data.Text (Text) +import Data.Time (UTCTime) +import Irc.Identifier (idText) +import Graphics.Vty.Image + +-- | Generate the list of message lines marked important ordered by +-- time. Each run of lines from the same channel will be grouped +-- together. Messages are headed by their window, network, and channel. +mentionsViewLines :: ClientState -> [Image] +mentionsViewLines st = addMarkers pal entries + + where + pal = clientPalette st + + names = clientWindowNames st ++ repeat '?' + + detail = view clientDetailView st + + entries = merge + [windowEntries detail n net (idText chan) v + | (n,(ChannelFocus net chan, v)) + <- names `zip` Map.toList (view clientWindows st) ] + +data MentionLine = MentionLine + { mlTimestamp :: UTCTime + , mlWindowName :: Char + , mlNetwork :: Text + , mlChannel :: Text + , mlImage :: Image + } + +addMarkers :: + Palette {- ^ palette -} -> + [MentionLine] {- ^ list of mentions in time order -} -> + [Image] {- ^ mention images and channel labels -} +addMarkers _ [] = [] +addMarkers !pal (!ml : xs) = + mlImage ml : map mlImage same ++ windowMarker : addMarkers pal rest + where + isSame ml' = mlWindowName ml == mlWindowName ml' + && mlNetwork ml == mlNetwork ml' + && mlChannel ml == mlChannel ml' + + (same,rest) = span isSame xs + + windowMarker = char (view palWindowName pal) (mlWindowName ml) <|> + char defAttr ':' <|> + text' (view palLabel pal) (mlNetwork ml) <|> + char defAttr ':' <|> + text' (view palLabel pal) (mlChannel ml) + +windowEntries :: + Bool {- ^ detailed view -} -> + Char {- ^ window name -} -> + Text {- ^ network name -} -> + Text {- ^ channel name -} -> + Window {- ^ window -} -> + [MentionLine] +windowEntries !detailed name net chan w = + [ MentionLine + { mlTimestamp = view wlTimestamp l + , mlWindowName = name + , mlNetwork = net + , mlChannel = chan + , mlImage = if detailed then view wlFullImage l else view wlImage l + } + | l <- view winMessages w + , WLImportant == view wlImportance l + ] + +-- | Merge a list of sorted lists of mention lines into a single sorted list +-- in descending order. +merge :: [[MentionLine]] -> [MentionLine] +merge [] = [] +merge [x] = x +merge xss = merge (merge2s xss) + +merge2s :: [[MentionLine]] -> [[MentionLine]] +merge2s (x:y:z) = merge2 x y : merge2s z +merge2s xs = xs + +merge2 :: [MentionLine] -> [MentionLine] -> [MentionLine] +merge2 [] ys = ys +merge2 xs [] = xs +merge2 xxs@(x:xs) yys@(y:ys) + | mlTimestamp x >= mlTimestamp y = x : merge2 xs yys + | otherwise = y : merge2 xxs ys diff --git a/src/Client/View/Messages.hs b/src/Client/View/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/Messages.hs @@ -0,0 +1,134 @@ +{-| +Module : Client.View.Messages +Description : Chat message view +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module returns the chat messages for the currently focused +window in message view and gathers metadata entries into single +lines. + +-} +module Client.View.Messages + ( chatMessageImages + ) where + +import Client.Image.Palette +import Client.Image.Message +import Client.State +import Client.State.Network +import Client.State.Window +import Client.Message +import Control.Lens +import Irc.Identifier +import Graphics.Vty.Image + +chatMessageImages :: ClientState -> [Image] +chatMessageImages st = windowLineProcessor focusedMessages + where + matcher = clientMatcher st + + focusedMessages + = filter (views wlText matcher) + $ view (clientWindows . ix (view clientFocus st) . winMessages) st + + windowLineProcessor + + | view clientDetailView st = + if view clientShowMetadata st + then map (view wlFullImage) + else detailedImagesWithoutMetadata st + + | otherwise = windowLinesToImages st . filter (not . isNoisy) + + isNoisy msg = + case view wlBody msg of + IrcBody irc -> squelchIrcMsg irc + _ -> False + +detailedImagesWithoutMetadata :: ClientState -> [WindowLine] -> [Image] +detailedImagesWithoutMetadata st wwls = + case gatherMetadataLines st wwls of + ([], []) -> [] + ([], w:ws) -> view wlFullImage w : detailedImagesWithoutMetadata st ws + (_:_, wls) -> detailedImagesWithoutMetadata st wls + +windowLinesToImages :: ClientState -> [WindowLine] -> [Image] +windowLinesToImages st wwls = + case gatherMetadataLines st wwls of + ([], []) -> [] + ([], w:ws) -> view wlImage w : windowLinesToImages st ws + ((img,who,mbnext):mds, wls) + + | view clientShowMetadata st -> + startMetadata img mbnext who mds palette + : windowLinesToImages st wls + + | otherwise -> windowLinesToImages st wls + where + palette = clientPalette st + +------------------------------------------------------------------------ + +type MetadataState = + Identifier {- ^ current nick -} -> + [(Image,Identifier,Maybe Identifier)] {- ^ metadata -} -> + Palette {- ^ palette -} -> + Image + +startMetadata :: + Image {- ^ metadata image -} -> + Maybe Identifier {- ^ possible nick transition -} -> + MetadataState +startMetadata img mbnext who mds palette = + quietIdentifier palette who + <|> img + <|> transitionMetadata mbnext who mds palette + +transitionMetadata :: + Maybe Identifier {- ^ possible nick transition -} -> + MetadataState +transitionMetadata mbwho who mds palette = + case mbwho of + Nothing -> continueMetadata who mds palette + Just who' -> quietIdentifier palette who' + <|> continueMetadata who' mds palette + +continueMetadata :: MetadataState +continueMetadata _ [] _ = emptyImage +continueMetadata who1 ((img, who2, mbwho3):mds) palette + | who1 == who2 = img + <|> transitionMetadata mbwho3 who2 mds palette + | otherwise = char defAttr ' ' + <|> startMetadata img mbwho3 who2 mds palette + +------------------------------------------------------------------------ + +gatherMetadataLines :: + ClientState -> + [WindowLine] -> + ( [(Image, Identifier, Maybe Identifier)] , [ WindowLine ] ) + -- ^ metadata entries are reversed +gatherMetadataLines st = go [] + where + go acc (w:ws) + | Just (img,who,mbnext) <- metadataWindowLine st w = + go ((img,who,mbnext) : acc) ws + + go acc ws = (acc,ws) + + +-- | Classify window lines for metadata coalesence +metadataWindowLine :: + ClientState -> + WindowLine -> + Maybe (Image, Identifier, Maybe Identifier) + {- ^ Image, incoming identifier, outgoing identifier if changed -} +metadataWindowLine st wl = + case view wlBody wl of + IrcBody irc + | Just who <- ircIgnorable irc st -> Just (ignoreImage, who, Nothing) + | otherwise -> metadataImg irc + _ -> Nothing + diff --git a/src/Client/View/Palette.hs b/src/Client/View/Palette.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/Palette.hs @@ -0,0 +1,61 @@ +{-| +Module : Client.View.Palette +Description : View current palette and to see all terminal colors +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +Lines for the @/palette@ command. This view shows all the colors of +the current palette as well as the colors available in the terminal. + +-} + +module Client.View.Palette + ( paletteViewLines + ) where + +import Client.Image.Palette +import Control.Lens +import Data.List +import Graphics.Vty.Image + +digits :: String +digits = "0123456789ABCDEF" + +digitImage :: Char -> Image +digitImage d = string defAttr [' ',d,' '] + +columns :: [Image] -> Image +columns = horizCat . intersperse (char defAttr ' ') + +-- | Generate lines used for @/palette@. These lines show +-- all the colors used in the current palette as well as +-- the colors available for use in palettes. +paletteViewLines :: Palette -> [Image] +paletteViewLines pal = + [ columns + $ digitImage digit + : [ string (withBackColor defAttr c) " " + | col <- [0 .. 15] + , let c = Color240 (row * 16 + col) + ] + | (digit,row) <- reverse $ take 15 $ zip (drop 1 digits) [0 ..] + ] ++ + [ columns + $ digitImage '0' + : [ string (withBackColor defAttr (ISOColor c)) " " + | c <- [0..15] + ] + + , columns (map digitImage (' ':digits)) + , emptyImage + , columns + [ text' (view l pal) name + | (name, Lens l) <- paletteMap + ] + , emptyImage + , columns + [ string attr "nicks" + | attr <- toListOf (palNicks . folded) pal + ] + ] diff --git a/src/Client/View/UserList.hs b/src/Client/View/UserList.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/UserList.hs @@ -0,0 +1,127 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.View.UserList +Description : Line renderers for channel user list view +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module renders the lines used in the channel user list. +-} +module Client.View.UserList + ( userListImages + , userInfoImages + ) where + +import Client.Image.Message +import Client.Image.Palette +import Client.State +import Client.State.Channel +import Client.State.Network +import Control.Lens +import qualified Data.HashMap.Strict as HashMap +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 +import Irc.UserInfo + +-- | Render the lines used by the @/users@ command in normal mode. +-- These lines show the count of users having each channel mode +-- in addition to the nicknames of the users. +userListImages :: + Text {- ^ network -} -> + Identifier {- ^ channel -} -> + ClientState -> + [Image] +userListImages network channel st = + case preview (clientConnection network) st of + Just cs -> userListImages' cs channel st + Nothing -> [text' (view palError pal) "No connection"] + where + pal = clientPalette st + +userListImages' :: NetworkState -> Identifier -> ClientState -> [Image] +userListImages' cs channel st = + [countImage, horizCat (intersperse gap (map renderUser usersList))] + where + countImage = text' (view palLabel pal) "Users:" <|> + sigilCountImage + + matcher = clientMatcher st + + myNicks = clientHighlights cs st + + renderUser (ident, sigils) = + string (view palSigil pal) sigils <|> + coloredIdentifier pal NormalIdentifier myNicks ident + + gap = char defAttr ' ' + + matcher' (ident,sigils) = matcher (Text.pack sigils `Text.append` idText ident) + + usersList = sortBy (comparing fst) + $ filter matcher' + $ HashMap.toList usersHashMap + + sigilCounts = Map.fromListWith (+) + [ (take 1 sigil, 1::Int) | (_,sigil) <- usersList ] + + sigilCountImage = horizCat + [ string (view palSigil pal) (' ':sigil) <|> + string defAttr (show n) + | (sigil,n) <- Map.toList sigilCounts + ] + + pal = clientPalette st + + usersHashMap = + view (csChannels . ix channel . chanUsers) cs + +-- | Render lines for the @/users@ command in detailed view. +-- Each user will be rendered on a separate line with username +-- and host visible when known. +userInfoImages :: + Text {- ^ network -} -> + Identifier {- ^ channel -} -> + ClientState -> + [Image] +userInfoImages network channel st = + case preview (clientConnection network) st of + Just cs -> userInfoImages' cs channel st + Nothing -> [text' (view palError pal) "No connection"] + where + pal = clientPalette st + +userInfoImages' :: NetworkState -> Identifier -> ClientState -> [Image] +userInfoImages' cs channel st = renderEntry <$> usersList + where + matcher = clientMatcher st + + myNicks = clientHighlights cs st + + pal = clientPalette st + + renderEntry (info, sigils) = + string (view palSigil pal) sigils <|> + coloredUserInfo pal DetailedRender myNicks info + + matcher' (info,sigils) = + matcher (Text.pack sigils `Text.append` renderUserInfo info) + + userInfos = view csUsers cs + + toInfo nick = + case view (at nick) userInfos of + Just (UserAndHost n h) -> UserInfo nick n h + Nothing -> UserInfo nick "" "" + + usersList = sortBy (flip (comparing (userNick . fst))) + $ filter matcher' + $ map (over _1 toInfo) + $ HashMap.toList usersHashMap + + usersHashMap = view (csChannels . ix channel . chanUsers) cs diff --git a/src/Client/View/Windows.hs b/src/Client/View/Windows.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/Windows.hs @@ -0,0 +1,72 @@ +{-| +Module : Client.View.Windows +Description : View of the list of open windows +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module implements the rendering of the client window list. + +-} +module Client.View.Windows + ( windowsImages + ) where + +import Client.Image.Palette +import Client.State +import Client.State.Focus +import Client.State.Window +import Control.Lens +import Data.List +import qualified Data.Map as Map +import Graphics.Vty.Image +import Irc.Identifier + +-- | Draw the image lines associated with the @/windows@ command. +windowsImages :: ClientState -> [Image] +windowsImages st + = reverse + $ createColumns + $ zipWith (renderWindowColumns pal) names windows + where + windows = views clientWindows Map.toAscList st + + pal = clientPalette st + names = clientWindowNames st ++ repeat '?' + +renderWindowColumns :: Palette -> Char -> (Focus, Window) -> [Image] +renderWindowColumns pal name (focus, win) = + [ char (view palWindowName pal) name + , renderedFocus pal focus + , renderedWindowInfo pal win + ] + +createColumns :: [[Image]] -> [Image] +createColumns xs = map makeRow xs + where + columnWidths = maximum . map imageWidth <$> transpose xs + makeRow = horizCat + . intersperse (char defAttr ' ') + . zipWith resizeWidth columnWidths + +renderedFocus :: Palette -> Focus -> Image +renderedFocus pal focus = + case focus of + Unfocused -> + char (view palError pal) '*' + NetworkFocus network -> + text' (view palLabel pal) network + ChannelFocus network channel -> + text' (view palLabel pal) network <|> + char defAttr ':' <|> + text' (view palLabel pal) (idText channel) + +renderedWindowInfo :: Palette -> Window -> Image +renderedWindowInfo pal win = + string (view newMsgAttrLens pal) (views winUnread show win) <|> + char defAttr '/' <|> + string (view palActivity pal) (views winTotal show win) + where + newMsgAttrLens + | view winMention win = palMention + | otherwise = palActivity