diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Revision history for glirc2 +## 2.21 + +* Make metadata toggle (F4) a window-level setting instead of client level +* Add configuration option to hide metadata by default `hide-metadata` +* Make keymap configurable under `key-bindings`, add `/keymap` command +* Add transient error message view, press ESC to clear +* Implement two-column split window mode: `/toggle-layout` and F5 +* Implement word-boundary based line wrapping + ## 2.20.6 * Switch to new `config-schema` package for configuration file loading. diff --git a/exec/Main.hs b/exec/Main.hs --- a/exec/Main.hs +++ b/exec/Main.hs @@ -54,10 +54,10 @@ Right cfg -> return cfg Left (ConfigurationReadFailed e) -> report "Failed to open configuration:" e - Left (ConfigurationParseFailed e) -> - report "Failed to parse configuration:" e - Left (ConfigurationMalformed e) -> - report "Configuration malformed (try --config-format): " e + Left (ConfigurationParseFailed path e) -> + report ("Failed to parse configuration file: " ++ path) e + Left (ConfigurationMalformed path e) -> + report ("Malformed configuration file: " ++ path ++ "\n(try --config-format)") e where report problem msg = do hPutStrLn stderr problem diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.20.6 +version: 2.21 synopsis: Console IRC client description: Console IRC client . @@ -54,6 +54,7 @@ build-depends: base, glirc, lens, text, vty library + ghc-options: -Wall hs-source-dirs: src include-dirs: include includes: include/glirc-api.h @@ -73,21 +74,24 @@ Client.Commands.WordCompletion Client.Configuration Client.Configuration.Colors + Client.Configuration.Macros Client.Configuration.ServerSettings Client.EventLoop + Client.EventLoop.Actions Client.EventLoop.Errors Client.Hook Client.Hook.Znc.Buffextras Client.Hooks Client.Image Client.Image.Arguments + Client.Image.Layout + Client.Image.LineWrap Client.Image.Message Client.Image.MircFormatting Client.Image.PackedImage Client.Image.Palette Client.Image.StatusLine Client.Image.Textbox - Client.Image.Utils Client.Log Client.Message Client.Network.Async @@ -104,6 +108,7 @@ Client.View.ChannelInfo Client.View.Digraphs Client.View.Help + Client.View.KeyMap Client.View.MaskList Client.View.Mentions Client.View.Messages @@ -123,8 +128,8 @@ attoparsec >=0.13 && <0.14, bytestring >=0.10.8 && <0.11, base64-bytestring >=1.0.0.1 && <1.1, - config-value >=0.5 && <0.6, - config-schema >=0.1 && <0.2, + config-value >=0.6 && <0.7, + config-schema >=0.3 && <0.4, containers >=0.5.7 && <0.6, directory >=1.2.6 && <1.4, filepath >=1.4.1 && <1.5, @@ -137,7 +142,7 @@ network >=2.6.2 && <2.7, process >=1.4.2 && <1.7, regex-tdfa >=1.2 && <1.3, - semigroupoids >=5.2 && <5.3, + semigroupoids >=5.1 && <5.3, socks >=0.5.5 && <0.6, split >=0.2 && <0.3, stm >=2.4 && <2.5, diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -132,8 +132,7 @@ -- | Command failure with an error message printed to client window commandFailureMsg :: Text -> ClientState -> IO CommandResult commandFailureMsg e st = - do now <- getZonedTime - return $! CommandFailure $! recordError now st e + return $! CommandFailure $! set clientErrorMsg (Just e) st -- | Interpret the given chat message or command. Leading @/@ indicates a -- command. Otherwise if a channel or user query is focused a chat message @@ -156,9 +155,9 @@ 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 + Nothing -> commandFailureMsg "macro expansions failed" st Just cmds -> process cmds st - _ -> executeCommand Nothing command st + _ -> executeCommand Nothing command st where resolveMacro = resolveMacroExpansions (commandExpansion discoTime st) expandInt @@ -219,7 +218,7 @@ sendMsg cs ircMsg commandSuccess $! recordChannelMessage network channel entry st - _ -> commandFailureMsg "This command requires an active channel" st + _ -> commandFailureMsg "cannot send chat messages to this window" st -- | Parse and execute the given command. When the first argument is Nothing @@ -239,7 +238,7 @@ Just isReversed -> tab isReversed st rest Nothing -> case parseArguments spec rest of - Nothing -> commandFailure st + Nothing -> commandFailureMsg "bad command arguments" st Just arg -> exec st arg in case recognize cmdTxt commands of @@ -253,24 +252,24 @@ | Just network <- views clientFocus focusNetwork st , Just cs <- preview (clientConnection network) st -> finish argSpec (exec cs) (\x -> tab x cs) - | otherwise -> commandFailureMsg "This command requires an active network" st + | otherwise -> commandFailureMsg "command requires focused network" st ChannelCommand exec tab | ChannelFocus network channelId <- view clientFocus st , Just cs <- preview (clientConnection network) st , isChannelIdentifier cs channelId -> finish argSpec (exec channelId cs) (\x -> tab x channelId cs) - | otherwise -> commandFailureMsg "This command requires an active channel" st + | otherwise -> commandFailureMsg "command requires focused channel" st ChatCommand exec tab | ChannelFocus network channelId <- view clientFocus st , Just cs <- preview (clientConnection network) st -> finish argSpec (exec channelId cs) (\x -> tab x channelId cs) - | otherwise -> commandFailureMsg "This command requires an active chat window" st + | otherwise -> commandFailureMsg "command requires focused chat window" st _ -> case tabCompleteReversed of Just isReversed -> nickTabCompletion isReversed st - Nothing -> commandFailureMsg "Unknown command" st + Nothing -> commandFailureMsg "unknown command" st -- | Expands each alias to have its own copy of the command callbacks @@ -331,6 +330,14 @@ $ ClientCommand cmdDigraphs noClientTab , Command + (pure "keymap") + NoArg + "Show the key binding map.\n\ + \\n\ + \Key bindings can be changed in configuration file. See `glirc2 --config-format`.\n" + $ ClientCommand cmdKeyMap noClientTab + + , Command (pure "exec") (RemainingArg "arguments") "Execute a command synchnonously sending the to a configuration destination.\n\ @@ -372,6 +379,34 @@ $ ClientCommand cmdHelp tabHelp ------------------------------------------------------------------------ + ] , CommandSection "View toggles" + ------------------------------------------------------------------------ + + [ Command + (pure "toggle-detail") + NoArg + "Toggle detailed message view.\n" + $ ClientCommand cmdToggleDetail noClientTab + + , Command + (pure "toggle-activity-bar") + NoArg + "Toggle detailed detailed activity information in status bar.\n" + $ ClientCommand cmdToggleActivityBar noClientTab + + , Command + (pure "toggle-metadata") + NoArg + "Toggle visibility of metadata in chat windows.\n" + $ ClientCommand cmdToggleMetadata noClientTab + + , Command + (pure "toggle-layout") + NoArg + "Toggle multi-window layout mode.\n" + $ ClientCommand cmdToggleLayout noClientTab + + ------------------------------------------------------------------------ ] , CommandSection "Connection commands" ------------------------------------------------------------------------ @@ -464,37 +499,45 @@ \\^Bfocuses\^B: space delimited list of focus names.\n\ \\n\ \Client: *\n\ - \Network: \^BNETWORK\^B\n\ + \Network: \^BNETWORK\^B:\n\ \Channel: \^BNETWORK\^B:\^B#CHANNEL\^B\n\ \User: \^BNETWORK\^B:\^BNICK\^B\n\ \\n\ + \If the network part is omitted, the current network will be used\n\ + \\n\ \Not providing an argument unsplits the current windows.\n" $ ClientCommand cmdSplits tabSplits , Command (pure "splits+") (RemainingArg "focuses") - "Add windows to the splits list.\n\ + "Add windows to the splits list. Omit the list of focuses to add the\ + \ current window.\n\ \\n\ \\^Bfocuses\^B: space delimited list of focus names.\n\ \\n\ \Client: *\n\ \Network: \^BNETWORK\^B\n\ \Channel: \^BNETWORK\^B:\^B#CHANNEL\^B\n\ - \User: \^BNETWORK\^B:\^BNICK\^B\n" + \User: \^BNETWORK\^B:\^BNICK\^B\n\ + \\n\ + \If the network part is omitted, the current network will be used\n" $ ClientCommand cmdSplitsAdd tabSplits , Command (pure "splits-") (RemainingArg "focuses") - "Remove windows from the splits list.\n\ + "Remove windows from the splits list. Omit the list of focuses to\ + \ remove the current window.\n\ \\n\ \\^Bfocuses\^B: space delimited list of focus names.\n\ \\n\ \Client: *\n\ \Network: \^BNETWORK\^B\n\ \Channel: \^BNETWORK\^B:\^B#CHANNEL\^B\n\ - \User: \^BNETWORK\^B:\^BNICK\^B\n" + \User: \^BNETWORK\^B:\^BNICK\^B\n\ + \\n\ + \If the network part is omitted, the current network will be used\n" $ ClientCommand cmdSplitsDel tabActiveSplits , Command @@ -818,6 +861,22 @@ cmdExit :: ClientCommand () cmdExit st _ = return (CommandQuit st) + +cmdToggleDetail :: ClientCommand () +cmdToggleDetail st _ = commandSuccess (over clientDetailView not st) + +cmdToggleActivityBar :: ClientCommand () +cmdToggleActivityBar st _ = commandSuccess (over clientActivityBar not st) + +cmdToggleMetadata :: ClientCommand () +cmdToggleMetadata st _ = commandSuccess (clientToggleHideMeta st) + +cmdToggleLayout :: ClientCommand () +cmdToggleLayout st _ = commandSuccess (set clientScroll 0 (over clientLayout aux st)) + where + aux OneColumn = TwoColumn + aux TwoColumn = OneColumn + -- | When used on a channel that the user is currently -- joined to this command will clear the messages but -- preserve the window. When used on a window that the @@ -869,7 +928,7 @@ cmdQuote :: NetworkCommand String cmdQuote cs st rest = case parseRawIrcMsg (Text.pack rest) of - Nothing -> commandFailureMsg "Failed to parse IRC command" st + Nothing -> commandFailureMsg "failed to parse raw IRC command" st Just raw -> do sendMsg cs raw commandSuccess st @@ -905,7 +964,7 @@ -- | Implementation of @/notice@ cmdNotice :: NetworkCommand (String, String) cmdNotice cs st (target, rest) - | null rest = commandFailure st + | null rest = commandFailureMsg "empty message" st | otherwise = do let restTxt = Text.pack rest tgtTxt = Text.pack target @@ -918,7 +977,7 @@ -- | Implementation of @/msg@ cmdMsg :: NetworkCommand (String, String) cmdMsg cs st (target, rest) - | null rest = commandFailure st + | null rest = commandFailureMsg "empty message" st | otherwise = do let restTxt = Text.pack rest tgtTxt = Text.pack target @@ -1020,6 +1079,10 @@ cmdDigraphs :: ClientCommand () cmdDigraphs st _ = commandSuccess (changeSubfocus FocusDigraphs st) +-- | Implementation of @/keymap@ command. Set subfocus to Keymap. +cmdKeyMap :: ClientCommand () +cmdKeyMap st _ = commandSuccess (changeSubfocus FocusKeyMap st) + -- | Implementation of @/help@ command. Set subfocus to Help. cmdHelp :: ClientCommand (Maybe (String, ())) cmdHelp st mb = commandSuccess (changeSubfocus focus st) @@ -1031,19 +1094,26 @@ -- all of the currently available windows. tabSplits :: Bool -> ClientCommand String tabSplits isReversed st rest + + -- If no arguments, populate the current splits | all (' '==) rest = - do let cmd = unwords ("/splits" : map (Text.unpack . renderFocus) currentExtras) - newline = Edit.endLine cmd - commandSuccess (set (clientTextBox . Edit.line) newline st) + let cmd = unwords $ "/splits" + : map (Text.unpack . renderSplitFocus) currentExtras + currentExtras = view clientExtraFocus st + newline = Edit.endLine cmd + in commandSuccess (set (clientTextBox . Edit.line) newline st) + + -- Tab complete the available windows. Accepts either fully qualified + -- window names or current network names without the ':' | otherwise = - simpleTabCompletion plainWordCompleteMode [] completions isReversed st - where - currentExtras = view clientExtraFocus st + let completions = currentNet <> allWindows + allWindows = renderSplitFocus <$> views clientWindows Map.keys st + currentNet = case views clientFocus focusNetwork st of + Just net -> idText <$> channelWindowsOnNetwork net st + Nothing -> [] + in simpleTabCompletion plainWordCompleteMode [] completions isReversed st - completions = map renderFocus - $ Map.keys - $ view clientWindows st -- | Tab completion for @/splits-@. This completes only from the list of active -- entries in the splits list. @@ -1051,48 +1121,79 @@ tabActiveSplits isReversed st _ = simpleTabCompletion plainWordCompleteMode [] completions isReversed st where - completions = renderFocus <$> view clientExtraFocus st + completions = currentNetSplits <> currentSplits + currentSplits = renderSplitFocus <$> view clientExtraFocus st + currentNetSplits = + [ idText chan + | ChannelFocus net chan <- view clientExtraFocus st + , views clientFocus focusNetwork st == Just net + ] --- | Parses a list of entries in the format used by @/splits[+-]@ to specify windows. -parseFocuses :: String -> [Focus] -parseFocuses = map parseFocus . words +withSplitFocuses :: + ClientState -> + String -> + ([Focus] -> IO CommandResult) -> + IO CommandResult +withSplitFocuses st str k = + case mb of + Nothing -> commandFailureMsg "unable to parse arguments" st + Just args -> k args + where + mb = traverse + (parseSplitFocus (views clientFocus focusNetwork st)) + (words str) --- | Parses a single entry in the format used by @/splits[+-]@ to specify windows. -parseFocus :: String -> Focus -parseFocus x = +-- | Parses a single entry in the format used by @/splits[+-]@ to specify +-- windows. +parseSplitFocus :: Maybe Text -> String -> Maybe Focus +parseSplitFocus mbNet x = case break (==':') x of - ("*","") -> Unfocused - (net,"") -> NetworkFocus (Text.pack net) - (net,_:chan) -> ChannelFocus (Text.pack net) (mkId (Text.pack chan)) + ("*","") -> Just Unfocused + (net,_:"") -> Just (NetworkFocus (Text.pack net)) + (net,_:chan) -> Just (ChannelFocus (Text.pack net) (mkId (Text.pack chan))) + (chan,"") -> do net <- mbNet + Just (ChannelFocus net (mkId (Text.pack chan))) -- | Render a entry from splits back to the textual format. -renderFocus :: Focus -> Text -renderFocus Unfocused = "*" -renderFocus (NetworkFocus x) = x -renderFocus (ChannelFocus x y) = x <> ":" <> idText y +renderSplitFocus :: Focus -> Text +renderSplitFocus Unfocused = "*" +renderSplitFocus (NetworkFocus x) = x <> ":" +renderSplitFocus (ChannelFocus x y) = x <> ":" <> idText y -- | Implementation of @/splits@ cmdSplits :: ClientCommand String -cmdSplits st str = commandSuccess (setExtraFocus extras st) - where - extras = nub (parseFocuses str) +cmdSplits st str = + withSplitFocuses st str $ \args -> + commandSuccess (setExtraFocus (nub args) st) --- | Implementation of @/splits+@ +-- | Implementation of @/splits+@. When no focuses are provided +-- the current focus is used instead. cmdSplitsAdd :: ClientCommand String -cmdSplitsAdd st str = commandSuccess (setExtraFocus extras st) - where - extras = nub (parseFocuses str ++ view clientExtraFocus st) +cmdSplitsAdd st str = + withSplitFocuses st str $ \args -> + let args' + | null args = st ^.. clientFocus + | otherwise = args + extras = nub (args' ++ view clientExtraFocus st) --- | Implementation of @/splits-@ + in commandSuccess (setExtraFocus extras st) + +-- | Implementation of @/splits-@. When no focuses are provided +-- the current focus is used instead. cmdSplitsDel :: ClientCommand String -cmdSplitsDel st str = commandSuccess (setExtraFocus extras st) - where - extras = view clientExtraFocus st \\ parseFocuses str +cmdSplitsDel st str = + withSplitFocuses st str $ \args -> + let args' + | null args = st ^.. clientFocus + | otherwise = args + extras = view clientExtraFocus st \\ args' + in commandSuccess (setExtraFocus extras st) + tabHelp :: Bool -> ClientCommand String tabHelp isReversed st _ = simpleTabCompletion plainWordCompleteMode [] commandNames isReversed st @@ -1217,7 +1318,7 @@ { localTimeOfDay = tod , localDay = day } } - _ -> commandFailureMsg "Unable to parse date/time arguments" st + _ -> commandFailureMsg "unable to parse date/time arguments" st where -- %k doesn't require a leading 0 for times before 10AM @@ -1302,7 +1403,7 @@ commandSuccess (changeSubfocus (FocusMasks mode) st) - _ -> commandFailureMsg "Unknown mask mode" st + _ -> commandFailureMsg "unknown mask mode" st cmdKick :: ChannelCommand (String, String) cmdKick channelId cs st (who,reason) = @@ -1397,12 +1498,12 @@ commandSuccess $ changeFocus (NetworkFocus network) st' - | otherwise = commandFailureMsg "/reconnect requires focused network" st + | otherwise = commandFailureMsg "command requires focused network" st cmdIgnore :: ClientCommand String cmdIgnore st rest = case mkId . Text.pack <$> words rest of - [] -> commandFailure st + [] -> commandFailureMsg "bad arguments" st xs -> commandSuccess $ over clientIgnores updateIgnores st where @@ -1428,9 +1529,9 @@ describeProblem err = Text.pack $ case err of - ConfigurationReadFailed e -> "Failed to open configuration:" ++ e - ConfigurationParseFailed e -> "Failed to parse configuration:" ++ e - ConfigurationMalformed e -> "Configuration malformed: " ++ e + ConfigurationReadFailed e -> "Failed to open configuration: " ++ e + ConfigurationParseFailed _ e -> "Failed to parse configuration: " ++ e + ConfigurationMalformed _ e -> "Configuration malformed: " ++ e -- | Support file name tab completion when providing an alternative -- configuration file. @@ -1456,7 +1557,7 @@ [] -> success False [[]] flags:params -> case splitModes (view csModeTypes cs) flags params of - Nothing -> commandFailureMsg "Failed to parse modes" st + Nothing -> commandFailureMsg "failed to parse modes" st Just parsedModes -> success needOp (unsplitModes <$> chunksOf (view csModeCount cs) parsedModes') where @@ -1589,7 +1690,7 @@ cmdExtension st (name,params) = case find (\ae -> aeName ae == Text.pack name) (view (clientExtensions . esActive) st) of - Nothing -> commandFailureMsg "Unknown extension" st + Nothing -> commandFailureMsg "unknown extension" st Just ae -> do (st',_) <- clientPark st $ \ptr -> commandExtension ptr (Text.pack <$> words params) ae @@ -1676,14 +1777,14 @@ cmdUrl :: ClientCommand (Maybe (String, ())) cmdUrl st mbArg = case view (clientConfig . configUrlOpener) st of - Nothing -> commandFailureMsg "/url requires url-opener to be configured" st + Nothing -> commandFailureMsg "url-opener not configured" st Just opener -> case mbArg of Nothing -> doUrlOpen opener 0 Just (arg,_) -> case readMaybe arg of Just n | n > 0 -> doUrlOpen opener (n-1) - _ -> commandFailureMsg "/url expected positive integer argument" st + _ -> commandFailureMsg "bad url number" st where focus = view clientFocus st @@ -1693,7 +1794,7 @@ doUrlOpen opener n = case preview (ix n) urls of Just url -> openUrl opener (Text.unpack url) st - Nothing -> commandFailureMsg "/url couldn't find requested URL" st + Nothing -> commandFailureMsg "bad url number" st openUrl :: FilePath -> String -> ClientState -> IO CommandResult openUrl opener url st = diff --git a/src/Client/Commands/Recognizer.hs b/src/Client/Commands/Recognizer.hs --- a/src/Client/Commands/Recognizer.hs +++ b/src/Client/Commands/Recognizer.hs @@ -25,7 +25,7 @@ import Control.Applicative hiding (empty) import Data.HashMap.Strict (lookup,insertWith,HashMap,empty,unionWith,fromList,toList) -import Data.Monoid +import Data.Semigroup import Data.Text (Text) import qualified Data.Text as Text import Data.Maybe @@ -41,6 +41,9 @@ instance Monoid (Recognizer a) where mempty = Branch "" Nothing empty mappend = both + +instance Semigroup (Recognizer a) where + (<>) = both -- | Possible results of recognizing text. data Recognition a diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -19,6 +19,7 @@ -- * Configuration type Configuration(..) , ConfigurationFailure(..) + , LayoutMode(..) -- * Lenses , configDefaults @@ -35,12 +36,17 @@ , configIgnores , configActivityBar , configBellOnMention + , configHideMeta + , configKeyMap + , configLayout + , configJumpModifier -- * Loading configuration , loadConfiguration -- * Resolving paths , resolveConfigurationPath + , getNewConfigPath -- * Specification , configurationSpec @@ -48,30 +54,30 @@ import Client.Commands.Interpolation import Client.Commands.Recognizer -import Client.Commands.WordCompletion import Client.Configuration.Colors +import Client.Configuration.Macros (macroMapSpec) import Client.Configuration.ServerSettings +import Client.EventLoop.Actions import Client.Image.Palette import Config import Config.Schema -import Control.Applicative import Control.Exception import Control.Lens hiding (List) -import Data.Foldable (find, foldl') +import Data.Foldable (toList, find) import Data.Functor.Alt (()) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet -import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe -import Data.Monoid ((<>)) +import Data.Monoid (Endo(..), (<>)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Data.Vector as Vector -import Irc.Identifier (Identifier, mkId) +import Graphics.Vty.Input.Events (Modifier(..), Key(..)) +import Irc.Identifier (Identifier) import System.Directory import System.FilePath import System.IO.Error @@ -95,9 +101,20 @@ , _configIgnores :: HashSet Identifier -- ^ initial ignore list , _configActivityBar :: Bool -- ^ initially visibility of the activity bar , _configBellOnMention :: Bool -- ^ notify terminal on mention + , _configHideMeta :: Bool -- ^ default setting for hidemeta on new windows + , _configKeyMap :: KeyMap -- ^ keyboard bindings + , _configLayout :: LayoutMode -- ^ Default layout on startup + , _configJumpModifier :: [Modifier] -- ^ Modifier used for jumping windows } deriving Show +data LayoutMode + -- | Vertically stack all windows in a single column + = OneColumn + -- | Vertically stack extra windows in a second column + | TwoColumn + deriving Show + makeLenses ''Configuration -- | Failure cases when loading a configuration file. @@ -107,10 +124,10 @@ = ConfigurationReadFailed String -- | Error message from parser or lexer - | ConfigurationParseFailed String + | ConfigurationParseFailed FilePath String -- | Error message from loading parsed configuration - | ConfigurationMalformed String + | ConfigurationMalformed FilePath String deriving Show -- | default instance @@ -141,14 +158,14 @@ -- exception is throw. readFileCatchNotFound :: FilePath {- ^ file to read -} -> - (IOError -> IO Text) {- ^ error handler for not found case -} -> - IO Text + (IOError -> IO (FilePath, Text)) {- ^ error handler for not found case -} -> + IO (FilePath, Text) readFileCatchNotFound path onNotFound = do res <- try (Text.readFile path) case res of Left e | isDoesNotExistError e -> onNotFound e | otherwise -> throwIO (ConfigurationReadFailed (show e)) - Right txt -> return txt + Right txt -> return (path, txt) -- | Either read a configuration file from one of the default -- locations, in which case no configuration found is equivalent @@ -156,7 +173,7 @@ -- no configuration found is an error. readConfigurationFile :: Maybe FilePath {- ^ just file or use default search paths -} -> - IO Text + IO (FilePath, Text) readConfigurationFile mbPath = case mbPath of @@ -169,7 +186,7 @@ readFileCatchNotFound newPath $ \_ -> do oldPath <- getOldConfigPath readFileCatchNotFound oldPath $ \_ -> - return emptyConfigFile + return ("", emptyConfigFile) -- | Load the configuration file defaulting to @~/.glirc/config@. @@ -177,69 +194,131 @@ Maybe FilePath {- ^ path to configuration file -} -> IO (Either ConfigurationFailure Configuration) loadConfiguration mbPath = try $ - do file <- readConfigurationFile mbPath + do (path,txt) <- readConfigurationFile mbPath def <- loadDefaultServerSettings rawcfg <- - case parse file of - Left parseError -> throwIO (ConfigurationParseFailed parseError) + case parse txt of + Left e -> throwIO (ConfigurationParseFailed path (displayException e)) Right rawcfg -> return rawcfg case loadValue configurationSpec rawcfg of Left es -> throwIO - $ ConfigurationMalformed + $ ConfigurationMalformed path $ Text.unpack - $ Text.unlines $ map explainLoadError es + $ Text.unlines + $ map explainLoadError (toList es) Right cfg -> return (cfg mbPath def) explainLoadError :: LoadError -> Text -explainLoadError (LoadError path problem) = - Text.intercalate "." path <> ": " <> - case problem of - UnusedSections xs -> "Unknown sections: " <> Text.intercalate ", " xs - MissingSection s -> "Missing required section: " <> s - SpecMismatch s -> "Expected " <> s +explainLoadError (LoadError pos path problem) = + Text.concat [ positionText, " at ", pathText, ": ", problemText] + where + positionText = + Text.unwords ["line" , Text.pack (show (posLine pos)), + "column", Text.pack (show (posColumn pos))] -configurationSpec :: ValueSpecs (Maybe FilePath -> ServerSettings -> Configuration) -configurationSpec = sectionsSpec "" $ + pathText + | null path = "top-level" + | otherwise = Text.intercalate ":" path - do ssDefUpdate <- fromMaybe id <$> optSection' "defaults" "" serverSpec - ssUpdates <- fromMaybe [] <$> optSection' "servers" "" (listSpec serverSpec) + problemText = + case problem of + UnusedSection s -> "unknown section `" <> s <> "`" + MissingSection s -> "missing required section `" <> s <> "`" + SpecMismatch t -> "expected " <> t - _configPalette <- fromMaybe defaultPalette - <$> optSection' "palette" "" paletteSpec - _configWindowNames <- fromMaybe defaultWindowNames - <$> optSection "window-names" "" +configurationSpec :: ValueSpecs (Maybe FilePath -> ServerSettings -> Configuration) +configurationSpec = sectionsSpec "" $ - _configMacros <- fromMaybe mempty - <$> optSection' "macros" "" macroMapSpec + do let sec' def name spec info = fromMaybe def <$> optSection' name spec info + identifierSetSpec = HashSet.fromList <$> listSpec identifierSpec - _configExtensions <- fromMaybe [] <$> optSection' "extensions" "" (listSpec stringSpec) + ssDefUpdate <- sec' id "defaults" serverSpec + "Default values for use across all server configurations" + ssUpdates <- sec' [] "servers" (listSpec serverSpec) + "Configuration parameters for IRC servers" + _configPalette <- sec' defaultPalette "palette" paletteSpec + "Customize the client color choices" + _configWindowNames <- sec' defaultWindowNames "window-names" valuesSpec + "Window names to use for quick jumping with jump-modifier key" + _configJumpModifier <- sec' [MMeta] "jump-modifier" modifierSpec + "Modifier used to jump to a window by name. Defaults to `meta`." + _configMacros <- sec' mempty "macros" macroMapSpec + "Programmable macro commands" + _configExtensions <- sec' [] "extensions" (listSpec stringSpec) + "Filenames of extension libraries to load at startup" + _configUrlOpener <- optSection' "url-opener" stringSpec + "External command used by /url command" + _configExtraHighlights <- sec' mempty "extra-highlights" identifierSetSpec + "Extra words to highlight in chat messages" + _configNickPadding <- optSection' "nick-padding" nonnegativeSpec + "Amount of space to reserve for nicknames in chat messages" + _configIndentWrapped <- optSection' "indent-wrapped-lines" nonnegativeSpec + "Amount of indentation for wrapped message lines" + _configIgnores <- sec' mempty "ignores" identifierSetSpec + "Set of nicknames to ignore on startup" + _configActivityBar <- sec' False "activity-bar" yesOrNoSpec + "Show channel names and message counts for activity on\ + \ unfocused channels." + _configBellOnMention <- sec' False "bell-on-mention" yesOrNoSpec + "Emit bell character to terminal on mention" + _configHideMeta <- sec' False "hide-metadata" yesOrNoSpec + "Initial setting for hiding metadata on new windows" + bindings <- sec' [] "key-bindings" (listSpec keyBindingSpec) + "Extra key bindings" + _configLayout <- sec' OneColumn "layout" layoutSpec + "Initial setting for window layout" + return (\_configConfigPath def -> + let _configDefaults = ssDefUpdate def + _configServers = buildServerMap _configDefaults ssUpdates + _configKeyMap = foldl (\acc f -> f acc) initialKeyMap bindings + in Configuration{..}) - _configUrlOpener <- optSection' "url-opener" "" stringSpec +modifierSpec :: ValueSpecs [Modifier] +modifierSpec = toList <$> oneOrNonemptySpec modifier1Spec + where + modifier1Spec = namedSpec "modifier" + $ MMeta <$ atomSpec "meta" + MAlt <$ atomSpec "alt" + MCtrl <$ atomSpec "ctrl" - _configExtraHighlights <- maybe HashSet.empty (HashSet.fromList . map mkId) - <$> optSection "extra-highlights" "" +layoutSpec :: ValueSpecs LayoutMode +layoutSpec = OneColumn <$ atomSpec "one-column" + TwoColumn <$ atomSpec "two-column" - _configNickPadding <- optSection' "nick-padding" "" nonnegativeSpec +keyBindingSpec :: ValueSpecs (KeyMap -> KeyMap) +keyBindingSpec = actBindingSpec cmdBindingSpec unbindingSpec - _configIndentWrapped <- optSection' "indent-wrapped-lines" "" nonnegativeSpec +actBindingSpec :: ValueSpecs (KeyMap -> KeyMap) +actBindingSpec = sectionsSpec "action-binding" $ + do (m,k) <- reqSection' "bind" keySpec + "Key to be bound (e.g. a, C-b, M-c C-M-d)" + a <- reqSection "action" + "Action name (see `/keymap`)" + return (addKeyBinding m k a) - _configIgnores <- maybe HashSet.empty (HashSet.fromList . map mkId) - <$> optSection "ignores" "" +cmdBindingSpec :: ValueSpecs (KeyMap -> KeyMap) +cmdBindingSpec = sectionsSpec "command-binding" $ + do (m,k) <- reqSection' "bind" keySpec + "Key to be bound (e.g. a, C-b, M-c C-M-d)" + cmd <- reqSection "command" + "Client command to execute (exclude leading `/`)" + return (addKeyBinding m k (ActCommand cmd)) - _configActivityBar <- fromMaybe False - <$> optSection' "activity-bar" "" yesOrNoSpec +unbindingSpec :: ValueSpecs (KeyMap -> KeyMap) +unbindingSpec = sectionsSpec "remove-binding" $ + do (m,k) <- reqSection' "unbind" keySpec + "Key to be unbound (e.g. a, C-b, M-c C-M-d)" + return (removeKeyBinding m k) - _configBellOnMention <- fromMaybe False <$> optSection' "bell-on-mention" "" yesOrNoSpec - return (\_configConfigPath def -> - let _configDefaults = ssDefUpdate def - _configServers = buildServerMap _configDefaults ssUpdates - in Configuration{..}) +-- | Custom configuration specification for emacs-style key descriptions +keySpec :: ValueSpecs ([Modifier], Key) +keySpec = customSpec "emacs-key" stringSpec parseKey nonnegativeSpec :: (Ord a, Num a) => ValueSpecs a @@ -248,18 +327,17 @@ paletteSpec :: ValueSpecs Palette paletteSpec = sectionsSpec "palette" $ - do updates <- catMaybes <$> sequenceA - [ fmap (set l) <$> optSection' lbl "" attrSpec | (lbl, Lens l) <- paletteMap ] - nickColors <- optSection' "nick-colors" "" (nonemptyList attrSpec) - return (let pal1 = foldl' (\acc f -> f acc) defaultPalette updates - in case nickColors of - Nothing -> pal1 - Just xs -> set palNicks (Vector.fromList (NonEmpty.toList xs)) pal1) + (ala Endo (foldMap . foldMap) ?? defaultPalette) <$> sequenceA fields -nonemptyList :: ValueSpecs a -> ValueSpecs (NonEmpty a) -nonemptyList s = customSpec "non-empty" (listSpec s) NonEmpty.nonEmpty + where + nickColorsSpec = set palNicks . Vector.fromList . NonEmpty.toList <$> nonemptySpec attrSpec + fields :: [SectionSpecs (Maybe (Palette -> Palette))] + fields = optSection' "nick-colors" nickColorsSpec + "Colors used to highlight nicknames" + : [ optSection' lbl (set l <$> attrSpec) "" | (lbl, Lens l) <- paletteMap ] + buildServerMap :: ServerSettings -> [ServerSettings -> ServerSettings] -> HashMap Text ServerSettings buildServerMap def ups = HashMap.fromList [ (serverSettingName ss, ss) | up <- ups, let ss = up def ] @@ -268,88 +346,7 @@ fromMaybe (views ssHostName Text.pack ss) (view ssName ss) -serverSpec :: ValueSpecs (ServerSettings -> ServerSettings) -serverSpec = sectionsSpec "server-settings" $ - do updates <- catMaybes <$> sequenceA settings - return (foldr (.) id updates) - where - req l s = set l <$> s - opt l s = set l . Just <$> s - set l Nothing <$ atomSpec "clear" - - settings = - [ optSection' "name" "The name used to identify this server in the client" - $ opt ssName valuesSpec - , optSection' "hostname" "Hostname of server" - $ req ssHostName stringSpec - , optSection' "port" "Port number of server. Default 6667 without TLS or 6697 with TLS" - $ opt ssPort numSpec - , optSection' "nick" "Nicknames to connect with in order" - $ req ssNicks nicksSpec - , optSection' "password" "Server password" - $ opt ssPassword valuesSpec - , optSection' "username" "Second component of _!_@_ usermask" - $ req ssUser valuesSpec - , optSection' "realname" "\"GECOS\" name sent to server visible in /whois" - $ req ssReal valuesSpec - , optSection' "userinfo" "CTCP userinfo (currently unused)" - $ req ssUserInfo valuesSpec - , optSection' "sasl-username" "Username for SASL authentication to NickServ" - $ opt ssSaslUsername valuesSpec - , optSection' "sasl-password" "Password for SASL authentication to NickServ" - $ opt ssSaslPassword valuesSpec - , optSection' "sasl-ecdsa-key" "Path to ECDSA key for non-password SASL authentication" - $ opt ssSaslEcdsaFile stringSpec - , optSection' "tls" "Set to `yes` to enable secure connect. Set to `yes-insecure` to disable certificate checking." - $ req ssTls useTlsSpec - , optSection' "tls-client-cert" "Path to TLS client certificate" - $ opt ssTlsClientCert stringSpec - , optSection' "tls-client-key" "Path to TLS client key" - $ opt ssTlsClientKey stringSpec - , optSection' "tls-server-cert" "Path to CA certificate bundle" - $ opt ssTlsServerCert stringSpec - , optSection' "tls-ciphers" "OpenSSL cipher specification. Default to \"HIGH\"" - $ req ssTlsCiphers stringSpec - , optSection' "socks-host" "Hostname of SOCKS5 proxy server" - $ opt ssSocksHost stringSpec - , optSection' "socks-port" "Port number of SOCKS5 proxy server" - $ req ssSocksPort numSpec - , optSection' "connect-cmds" "Command to be run upon successful connection to server" - $ req ssConnectCmds $ listSpec macroCommandSpec - , optSection' "chanserv-channels" "Channels with ChanServ permissions available" - $ req ssChanservChannels $ listSpec identifierSpec - , optSection' "flood-penalty" "RFC 1459 rate limiting, seconds of penalty per message (default 2)" - $ req ssFloodPenalty valuesSpec - , optSection' "flood-threshold" "RFC 1459 rate limiting, seconds of allowed penalty accumulation (default 10)" - $ req ssFloodThreshold valuesSpec - , optSection' "message-hooks" "Special message hooks to enable: \"buffextras\" available" - $ req ssMessageHooks valuesSpec - , optSection' "reconnect-attempts" "Number of reconnection attempts on lost connection" - $ req ssReconnectAttempts valuesSpec - , optSection' "autoconnect" "Set to `yes` to automatically connect at client startup" - $ req ssAutoconnect yesOrNoSpec - , optSection' "nick-completion" "Behavior for nickname completion with TAB" - $ req ssNickCompletion nickCompletionSpec - , optSection' "log-dir" "Path to log file directory for this server" - $ opt ssLogDir stringSpec - ] - - -nicksSpec :: ValueSpecs (NonEmpty Text) -nicksSpec = pure <$> valuesSpec - nonemptyList valuesSpec - - -useTlsSpec :: ValueSpecs UseTls -useTlsSpec = - UseTls <$ atomSpec "yes" - UseInsecureTls <$ atomSpec "yes-insecure" - UseInsecure <$ atomSpec "no" - -identifierSpec :: ValueSpecs Identifier -identifierSpec = mkId <$> valuesSpec - -- | Resolve relative paths starting at the home directory rather than -- the current directory of the client. resolveConfigurationPath :: FilePath -> IO FilePath @@ -357,25 +354,3 @@ | isAbsolute path = return path | otherwise = do home <- getHomeDirectory return (home path) - -macroMapSpec :: ValueSpecs (Recognizer Macro) -macroMapSpec = fromCommands <$> listSpec macroValueSpecs - -macroValueSpecs :: ValueSpecs (Text, Macro) -macroValueSpecs = sectionsSpec "macro" $ - do name <- reqSection "name" "" - spec <- fromMaybe noMacroArguments - <$> optSection' "arguments" "" macroArgumentsSpec - commands <- reqSection' "commands" "" (listSpec macroCommandSpec) - return (name, Macro spec commands) - -macroArgumentsSpec :: ValueSpecs MacroSpec -macroArgumentsSpec = customSpec "macro arguments" valuesSpec parseMacroSpecs - -macroCommandSpec :: ValueSpecs [ExpansionChunk] -macroCommandSpec = customSpec "macro command" valuesSpec parseExpansion - -nickCompletionSpec :: ValueSpecs WordCompletionMode -nickCompletionSpec = - defaultNickWordCompleteMode <$ atomSpec "default" - slackNickWordCompleteMode <$ atomSpec "slack" diff --git a/src/Client/Configuration/Colors.hs b/src/Client/Configuration/Colors.hs --- a/src/Client/Configuration/Colors.hs +++ b/src/Client/Configuration/Colors.hs @@ -17,7 +17,6 @@ ) where import Config.Schema -import Control.Applicative import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Functor.Alt (()) @@ -34,9 +33,9 @@ fullAttrSpec :: ValueSpecs Attr fullAttrSpec = sectionsSpec "full-attr" $ - do mbFg <- optSection' "fg" "Foreground color" colorSpec - mbBg <- optSection' "bg" "Background color" colorSpec - mbSt <- optSection' "style" "Terminal font style" stylesSpec + do mbFg <- optSection' "fg" colorSpec "Foreground color" + mbBg <- optSection' "bg" colorSpec "Background color" + mbSt <- optSection' "style" stylesSpec "Terminal font style" return ( aux withForeColor mbFg $ aux withBackColor mbBg $ aux (foldl withStyle) mbSt diff --git a/src/Client/Configuration/Macros.hs b/src/Client/Configuration/Macros.hs new file mode 100644 --- /dev/null +++ b/src/Client/Configuration/Macros.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ApplicativeDo, OverloadedStrings #-} + +{-| +Module : Client.Configuration.Macros +Description : Configuration schema for macros +Copyright : (c) Eric Mertens, 2017 +License : ISC +Maintainer : emertens@gmail.com + +-} + +module Client.Configuration.Macros + ( macroMapSpec + , macroCommandSpec + ) where + +import Config.Schema.Spec +import Client.Commands.Interpolation +import Client.Commands.Recognizer +import Data.Maybe (fromMaybe) +import Data.Text (Text) + +macroMapSpec :: ValueSpecs (Recognizer Macro) +macroMapSpec = fromCommands <$> listSpec macroValueSpecs + +macroValueSpecs :: ValueSpecs (Text, Macro) +macroValueSpecs = sectionsSpec "macro" $ + do name <- reqSection "name" "" + spec <- fromMaybe noMacroArguments + <$> optSection' "arguments" macroArgumentsSpec "" + commands <- reqSection' "commands" (listSpec macroCommandSpec) "" + return (name, Macro spec commands) + +macroArgumentsSpec :: ValueSpecs MacroSpec +macroArgumentsSpec = customSpec "macro arguments" valuesSpec parseMacroSpecs + +macroCommandSpec :: ValueSpecs [ExpansionChunk] +macroCommandSpec = customSpec "macro command" valuesSpec parseExpansion diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs --- a/src/Client/Configuration/ServerSettings.hs +++ b/src/Client/Configuration/ServerSettings.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ApplicativeDo, TemplateHaskell, OverloadedStrings #-} {-| Module : Client.Configuration.ServerSettings @@ -16,6 +16,8 @@ ( -- * Server settings type ServerSettings(..) + , serverSpec + , identifierSpec -- * Lenses , ssNicks @@ -56,13 +58,16 @@ import Client.Commands.Interpolation import Client.Commands.WordCompletion +import Client.Configuration.Macros (macroCommandSpec) +import Config.Schema.Spec import Control.Lens +import Data.Functor.Alt (()) import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromMaybe) +import Data.Monoid import Data.Text (Text) import qualified Data.Text as Text -import Irc.Identifier (Identifier) +import Irc.Identifier (Identifier, mkId) import Network.Socket (HostName, PortNumber) import System.Environment @@ -98,6 +103,7 @@ } deriving Show +-- | Security setting for network connection data UseTls = UseTls -- ^ TLS connection | UseInsecureTls -- ^ TLS connection without certificate checking @@ -109,13 +115,13 @@ -- | Load the defaults for server settings based on the environment -- variables. -- --- @USER@, @IRCPASSSWORD@, and @SASLPASSWORD@ are used. +-- Environment variables @USER@, @IRCPASSSWORD@, and @SASLPASSWORD@ are used. loadDefaultServerSettings :: IO ServerSettings loadDefaultServerSettings = do env <- getEnvironment let username = Text.pack (fromMaybe "guest" (lookup "USER" env)) return ServerSettings - { _ssNicks = username NonEmpty.:| [] + { _ssNicks = pure username , _ssUser = username , _ssReal = username , _ssUserInfo = username @@ -143,3 +149,121 @@ , _ssNickCompletion = defaultNickWordCompleteMode , _ssLogDir = Nothing } + +serverSpec :: ValueSpecs (ServerSettings -> ServerSettings) +serverSpec = sectionsSpec "server-settings" $ + composeMaybe <$> sequenceA settings + where + composeMaybe :: [Maybe (a -> a)] -> a -> a + composeMaybe = ala Endo (foldMap . foldMap) + + req name l s info = optSection' name ?? info + $ set l <$> s + + opt name l s info = optSection' name ?? info + $ set l . Just <$> s + set l Nothing <$ atomSpec "clear" + + settings = + [ opt "name" ssName valuesSpec + "The name used to identify this server in the client" + + , req "hostname" ssHostName stringSpec + "Hostname of server" + + , opt "port" ssPort numSpec + "Port number of server. Default 6667 without TLS or 6697 with TLS" + + , req "nick" ssNicks nicksSpec + "Nicknames to connect with in order" + + , opt "password" ssPassword valuesSpec + "Server password" + + , req "username" ssUser valuesSpec + "Second component of _!_@_ usermask" + + , req "realname" ssReal valuesSpec + "\"GECOS\" name sent to server visible in /whois" + + , req "userinfo" ssUserInfo valuesSpec + "CTCP userinfo (currently unused)" + + , opt "sasl-username" ssSaslUsername valuesSpec + "Username for SASL authentication to NickServ" + + , opt "sasl-password" ssSaslPassword valuesSpec + "Password for SASL authentication to NickServ" + + , opt "sasl-ecdsa-key" ssSaslEcdsaFile stringSpec + "Path to ECDSA key for non-password SASL authentication" + + , req "tls" ssTls useTlsSpec + "Set to `yes` to enable secure connect. Set to `yes-insecure` to disable certificate checking." + + , opt "tls-client-cert" ssTlsClientCert stringSpec + "Path to TLS client certificate" + + , opt "tls-client-key" ssTlsClientKey stringSpec + "Path to TLS client key" + + , opt "tls-server-cert" ssTlsServerCert stringSpec + "Path to CA certificate bundle" + + , req "tls-ciphers" ssTlsCiphers stringSpec + "OpenSSL cipher specification. Default to \"HIGH\"" + + , opt "socks-host" ssSocksHost stringSpec + "Hostname of SOCKS5 proxy server" + + , req "socks-port" ssSocksPort numSpec + "Port number of SOCKS5 proxy server" + + , req "connect-cmds" ssConnectCmds (listSpec macroCommandSpec) + "Command to be run upon successful connection to server" + + , req "chanserv-channels" ssChanservChannels (listSpec identifierSpec) + "Channels with ChanServ permissions available" + + , req "flood-penalty" ssFloodPenalty valuesSpec + "RFC 1459 rate limiting, seconds of penalty per message (default 2)" + + , req "flood-threshold" ssFloodThreshold valuesSpec + "RFC 1459 rate limiting, seconds of allowed penalty accumulation (default 10)" + + , req "message-hooks" ssMessageHooks valuesSpec + "Special message hooks to enable: \"buffextras\" available" + + , req "reconnect-attempts" ssReconnectAttempts valuesSpec + "Number of reconnection attempts on lost connection" + + , req "autoconnect" ssAutoconnect yesOrNoSpec + "Set to `yes` to automatically connect at client startup" + + , req "nick-completion" ssNickCompletion nickCompletionSpec + "Behavior for nickname completion with TAB" + + , opt "log-dir" ssLogDir stringSpec + "Path to log file directory for this server" + ] + + +nicksSpec :: ValueSpecs (NonEmpty Text) +nicksSpec = oneOrNonemptySpec valuesSpec + + +useTlsSpec :: ValueSpecs UseTls +useTlsSpec = + UseTls <$ atomSpec "yes" + UseInsecureTls <$ atomSpec "yes-insecure" + UseInsecure <$ atomSpec "no" + + +nickCompletionSpec :: ValueSpecs WordCompletionMode +nickCompletionSpec = + defaultNickWordCompleteMode <$ atomSpec "default" + slackNickWordCompleteMode <$ atomSpec "slack" + + +identifierSpec :: ValueSpecs Identifier +identifierSpec = mkId <$> valuesSpec diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -20,11 +20,14 @@ import Client.CApi import Client.Commands import Client.Commands.Interpolation +import Client.Configuration (configJumpModifier, configKeyMap, configWindowNames) import Client.Configuration.ServerSettings +import Client.EventLoop.Actions import Client.EventLoop.Errors (exceptionToLines) import Client.Hook import Client.Hooks import Client.Image +import Client.Image.Layout (scrollAmount) import Client.Log import Client.Message import Client.Network.Async @@ -392,7 +395,13 @@ IO (Maybe ClientState) {- ^ nothing when finished -} doVtyEvent vty vtyEvent st = case vtyEvent of - EvKey k modifier -> doKey vty k modifier st + EvKey k modifier -> + let cfg = view clientConfig st + keymap = view configKeyMap cfg + winnames = view configWindowNames cfg + winmods = view configJumpModifier cfg + action = keyToAction keymap winmods winnames modifier k + in doAction vty action st -- ignore event parameters due to raw TChan use EvResize{} -> Just <$> updateTerminalSize vty st EvPaste utf8 -> @@ -402,16 +411,15 @@ -- | Map keyboard inputs to actions in the client -doKey :: +doAction :: Vty {- ^ vty handle -} -> - Key {- ^ key pressed -} -> - [Modifier] {- ^ modifiers held -} -> + Action {- ^ action -} -> ClientState {- ^ client state -} -> IO (Maybe ClientState) -doKey vty key modifier st = +doAction vty action st = let continue !out -- detect when chains of M-a are broken - | modifier == [MMeta] && key == KChar 'a' = return (Just out) + | action == ActJumpToActivity = return (Just out) | otherwise = return $! Just $! set clientActivityReturn (view clientFocus out) out changeEditor f = continue (over clientTextBox f st) @@ -424,75 +432,62 @@ Nothing -> continue $! set clientBell True st Just st' -> continue st' in - case modifier of - [MCtrl] -> - case key of - KChar 'd' -> changeContent Edit.delete - KChar 'a' -> changeEditor Edit.home - KChar 'e' -> changeEditor Edit.end - 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') - KChar ']' -> changeEditor (Edit.insert '\^]') - KChar '_' -> changeEditor (Edit.insert '\^_') - KChar 'o' -> changeEditor (Edit.insert '\^O') - KChar 'v' -> changeEditor (Edit.insert '\^V') - KChar 'p' -> continue (retreatFocus st) - KChar 'n' -> continue (advanceFocus st) - KChar 'x' -> continue (advanceNetworkFocus st) - KChar 'l' -> do refresh vty - continue st - _ -> continue st + case action of + -- movements + ActHome -> changeEditor Edit.home + ActEnd -> changeEditor Edit.end + ActLeft -> changeContent Edit.left + ActRight -> changeContent Edit.right + ActBackWord -> changeContent Edit.leftWord + ActForwardWord -> changeContent Edit.rightWord - [MMeta] -> - case key of - KChar c | let names = clientWindowNames st - , Just i <- elemIndex c names -> - continue (jumpFocus i st) - KEnter -> changeEditor (Edit.insert '\^J') - KBS -> changeEditor (Edit.killWordBackward True) - KChar 'd' -> changeEditor (Edit.killWordForward True) - KChar 'b' -> changeContent Edit.leftWord - KChar 'f' -> changeContent Edit.rightWord - KLeft -> changeContent Edit.leftWord - KRight -> changeContent Edit.rightWord - KChar 'a' -> continue (jumpToActivity st) - KChar 's' -> continue (returnFocus st) - KChar 'k' -> mbChangeEditor Edit.insertDigraph - _ -> continue st + -- edits + ActKillHome -> changeEditor Edit.killHome + ActKillEnd -> changeEditor Edit.killEnd + ActKillWordBack -> changeEditor (Edit.killWordBackward True) + ActKillWordForward -> changeEditor (Edit.killWordForward True) + ActYank -> changeEditor Edit.yank + ActToggle -> changeContent Edit.toggle + ActDelete -> changeContent Edit.delete + ActBackspace -> changeContent Edit.backspace - [] -> -- no modifier - case key of - KEsc -> continue (changeSubfocus FocusMessages st) - KBS -> changeContent Edit.backspace - KDel -> changeContent Edit.delete - KLeft -> changeContent Edit.left - KRight -> changeContent Edit.right - KHome -> changeEditor Edit.home - KEnd -> changeEditor Edit.end - KUp -> changeEditor $ \ed -> fromMaybe ed $ Edit.earlier ed - KDown -> changeEditor $ \ed -> fromMaybe ed $ Edit.later ed - KPageUp -> continue (scrollClient ( scrollAmount st) st) - KPageDown -> continue (scrollClient (-scrollAmount st) st) + -- special inserts + ActBold -> changeEditor (Edit.insert '\^B') + ActColor -> changeEditor (Edit.insert '\^C') + ActItalic -> changeEditor (Edit.insert '\^]') + ActUnderline -> changeEditor (Edit.insert '\^_') + ActClearFormat -> changeEditor (Edit.insert '\^O') + ActReverseVideo -> changeEditor (Edit.insert '\^V') + ActDigraph -> mbChangeEditor Edit.insertDigraph + ActInsertEnter -> changeEditor (Edit.insert '\^J') - KEnter -> doCommandResult True =<< executeInput st - KBackTab -> doCommandResult False =<< tabCompletion True st - KChar '\t' -> doCommandResult False =<< tabCompletion False st + -- focus jumps + ActJump i -> continue (jumpFocus i st) + ActJumpToActivity -> continue (jumpToActivity st) + ActJumpPrevious -> continue (returnFocus st) + ActRetreatFocus -> continue (retreatFocus st) + ActAdvanceFocus -> continue (advanceFocus st) + ActAdvanceNetwork -> continue (advanceNetworkFocus st) - KChar c -> changeEditor (Edit.insert c) + ActReset -> continue (changeSubfocus FocusMessages st) + ActOlderLine -> changeEditor $ \ed -> fromMaybe ed $ Edit.earlier ed + ActNewerLine -> changeEditor $ \ed -> fromMaybe ed $ Edit.later ed + ActScrollUp -> continue (scrollClient ( scrollAmount st) st) + ActScrollDown -> continue (scrollClient (-scrollAmount st) st) - -- toggles - KFun 2 -> continue (over clientDetailView not st) - KFun 3 -> continue (over clientActivityBar not st) - KFun 4 -> continue (over clientShowMetadata not st) + ActTabCompleteBack -> doCommandResult False =<< tabCompletion True st + ActTabComplete -> doCommandResult False =<< tabCompletion False st - _ -> continue st + ActInsert c -> changeEditor (Edit.insert c) + ActEnter -> doCommandResult True =<< executeInput st + ActRefresh -> refresh vty >> continue st + ActCommand cmd -> do resp <- executeUserCommand Nothing (Text.unpack cmd) st + case resp of + CommandSuccess st1 -> continue st1 + CommandFailure st1 -> continue st1 + CommandQuit _ -> return Nothing - _ -> continue st -- unsupported modifier + ActIgnored -> continue st -- | Process 'CommandResult' and update the 'ClientState' textbox diff --git a/src/Client/EventLoop/Actions.hs b/src/Client/EventLoop/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Client/EventLoop/Actions.hs @@ -0,0 +1,293 @@ +{-# Language RankNTypes, OverloadedStrings #-} +{-| +Module : Client.EventLoop.Actions +Description : Programmable keyboard actions +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +-} + +module Client.EventLoop.Actions + ( Action(..) + , KeyMap + , keyToAction + , initialKeyMap + , addKeyBinding + , removeKeyBinding + , keyMapEntries + + -- * Keys as text + , parseKey + , prettyModifierKey + , actionName + ) where + +import Graphics.Vty.Input.Events +import Config.Schema.Spec +import Control.Applicative +import Control.Lens +import Data.Char (showLitChar) +import Data.Functor.Compose +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +import Data.Semigroup ((<>)) +import Data.Text (Text) +import qualified Data.Text as Text +import Text.Read + +-- | Actions that can be invoked using the keyboard. +data Action + + = ActBackspace + | ActDelete + | ActLeft + | ActRight + | ActHome + | ActEnd + | ActOlderLine + | ActNewerLine + | ActScrollUp + | ActScrollDown + | ActBackWord + | ActForwardWord + + | ActYank + | ActKillHome + | ActKillEnd + | ActKillWordBack + | ActKillWordForward + | ActToggle + + | ActBold + | ActColor + | ActItalic + | ActUnderline + | ActReverseVideo + | ActClearFormat + | ActInsertEnter + | ActDigraph + + | ActRetreatFocus + | ActAdvanceFocus + | ActAdvanceNetwork + | ActJumpToActivity + | ActJumpPrevious + | ActJump Int + + | ActTabComplete + | ActTabCompleteBack + + | ActEnter + | ActReset + | ActRefresh + | ActCommand Text + | ActInsert Char + | ActIgnored + deriving (Eq, Ord, Read, Show) + +-- | Lookup table for keyboard events to actions. Use with +-- keyToAction. +newtype KeyMap = KeyMap (Map [Modifier] (Map Key Action)) + deriving (Show) + +keyMapEntries :: KeyMap -> [([Modifier], Key, Action)] +keyMapEntries (KeyMap m) = + [ (mods, k, a) + | (mods, m1) <- Map.toList m + , (k,a) <- Map.toList m1 + ] + +instance Spec Action where + valuesSpec = customSpec "action" anyAtomSpec $ \a -> + fst <$> HashMap.lookup a actionInfos + + +-- | Names and default key bindings for each action. +-- +-- Note that Jump, Insert and Ignored are excluded. These will +-- be computed on demand by keyToAction. +actionInfos :: HashMap Text (Action, [([Modifier],Key)]) +actionInfos = + let norm = (,) [ ] + ctrl = (,) [MCtrl] + meta = (,) [MMeta] in + + HashMap.fromList + + [("delete" , (ActDelete , [meta (KChar 'd'), norm KDel])) + ,("backspace" , (ActBackspace , [norm KBS])) + ,("home" , (ActHome , [norm KHome, ctrl (KChar 'a')])) + ,("end" , (ActEnd , [norm KEnd , ctrl (KChar 'e')])) + ,("kill-home" , (ActKillHome , [ctrl (KChar 'u')])) + ,("kill-end" , (ActKillEnd , [ctrl (KChar 'k')])) + ,("yank" , (ActYank , [ctrl (KChar 'y')])) + ,("toggle" , (ActToggle , [ctrl (KChar 't')])) + ,("kill-word-left" , (ActKillWordBack , [ctrl (KChar 'w'), meta KBS])) + ,("kill-word-right" , (ActKillWordForward , [meta (KChar 'd')])) + + ,("bold" , (ActBold , [ctrl (KChar 'b')])) + ,("color" , (ActColor , [ctrl (KChar 'c')])) + ,("italic" , (ActItalic , [ctrl (KChar ']')])) + ,("underline" , (ActUnderline , [ctrl (KChar '_')])) + ,("clear-format" , (ActClearFormat , [ctrl (KChar 'o')])) + ,("reverse-video" , (ActReverseVideo , [ctrl (KChar 'v')])) + + ,("insert-newline" , (ActInsertEnter , [meta KEnter])) + ,("insert-digraph" , (ActDigraph , [meta (KChar 'k')])) + + ,("next-window" , (ActAdvanceFocus , [ctrl (KChar 'n')])) + ,("prev-window" , (ActRetreatFocus , [ctrl (KChar 'p')])) + ,("next-network" , (ActAdvanceNetwork , [ctrl (KChar 'x')])) + ,("refresh" , (ActRefresh , [ctrl (KChar 'l')])) + ,("jump-to-activity" , (ActJumpToActivity , [meta (KChar 'a')])) + ,("jump-to-previous" , (ActJumpPrevious , [meta (KChar 's')])) + + ,("reset" , (ActReset , [norm KEsc])) + + ,("left-word" , (ActBackWord , [meta KLeft, meta (KChar 'b')])) + ,("right-word" , (ActForwardWord , [meta KRight, meta (KChar 'f')])) + ,("left" , (ActLeft , [norm KLeft])) + ,("right" , (ActRight , [norm KRight])) + ,("up" , (ActOlderLine , [norm KUp])) + ,("down" , (ActNewerLine , [norm KDown])) + ,("scroll-up" , (ActScrollUp , [norm KPageUp])) + ,("scroll-down" , (ActScrollDown , [norm KPageDown])) + ,("enter" , (ActEnter , [norm KEnter])) + ,("word-complete-back", (ActTabCompleteBack , [norm KBackTab])) + ,("word-complete" , (ActTabComplete , [norm (KChar '\t')])) + ] + + +actionNames :: Map Action Text +actionNames = Map.fromList + [ (action, name) | (name, (action,_)) <- HashMap.toList actionInfos ] + + +-- | Render action as human-readable text. +actionName :: Action -> Text +actionName (ActCommand txt) = "command: " <> txt +actionName a = Map.findWithDefault (Text.pack (show a)) a actionNames + + +keyMapLens :: [Modifier] -> Key -> Lens' KeyMap (Maybe Action) +keyMapLens mods key f (KeyMap m) = + KeyMap <$> (at (normalizeModifiers mods) . non' _Empty . at key) f m + + +-- | Lookup the action to perform in response to a particular key event. +keyToAction :: + KeyMap {- ^ actions -} -> + [Modifier] {- ^ jump modifier -} -> + Text {- ^ window names -} -> + [Modifier] {- ^ actual modifier -} -> + Key {- ^ key -} -> + Action {- ^ action -} +keyToAction _ jumpMods names mods (KChar c) + | normalizeModifiers jumpMods == normalizeModifiers mods + , Just i <- Text.findIndex (c==) names = ActJump i +keyToAction m _ _ modifier key = + case m ^. keyMapLens modifier key of + Just a -> a + Nothing | KChar c <- key, null modifier -> ActInsert c + | otherwise -> ActIgnored + + +-- | Bind a keypress event to a new action. +addKeyBinding :: + [Modifier] {- ^ modifiers -} -> + Key {- ^ key -} -> + Action {- ^ action -} -> + KeyMap {- ^ actions -} -> + KeyMap +addKeyBinding mods k a = keyMapLens mods k ?~ a + +-- | Unbind the action associated with a key. +removeKeyBinding :: + [Modifier] {- ^ modifiers -} -> + Key {- ^ key -} -> + KeyMap {- ^ actions -} -> + KeyMap +removeKeyBinding mods k = set (keyMapLens mods k) Nothing + + +normalizeModifiers :: [Modifier] -> [Modifier] +normalizeModifiers = nub . sort + + +-- | Default key bindings +initialKeyMap :: KeyMap +initialKeyMap = KeyMap $ + Map.fromListWith Map.union $ + + ([], Map.fromList + [ (KFun 2, ActCommand "toggle-detail") + , (KFun 3, ActCommand "toggle-activity-bar") + , (KFun 4, ActCommand "toggle-metadata") + , (KFun 5, ActCommand "toggle-layout") + ]) + : + + [ (mods, Map.singleton k act) + | (act, mks) <- HashMap.elems actionInfos + , (mods, k) <- mks + ] + + +parseKey :: String -> Maybe ([Modifier], Key) +parseKey = getCompose . go + where + modifier x = Compose (Just ([x], ())) + liftMaybe mb = Compose ((,)[] <$> mb) + go str = + case str of + "Tab" -> pure (KChar '\t') + "BackTab" -> pure KBackTab + "Enter" -> pure KEnter + "Home" -> pure KHome + "End" -> pure KEnd + "Esc" -> pure KEsc + "PageUp" -> pure KPageUp + "PageDown" -> pure KPageDown + "Backspace" -> pure KBS + "Delete" -> pure KDel + "Left" -> pure KLeft + "Right" -> pure KRight + [c] -> pure (KChar c) + 'F':xs -> KFun <$> liftMaybe (readMaybe xs) + 'C':'-':xs -> modifier MCtrl *> go xs + 'M':'-':xs -> modifier MMeta *> go xs + 'S':'-':xs -> modifier MShift *> go xs + 'A':'-':xs -> modifier MAlt *> go xs + _ -> empty + + +prettyModifierKey :: [Modifier] -> Key -> String +prettyModifierKey mods k + = foldr prettyModifier (prettyKey k) mods + +prettyModifier :: Modifier -> ShowS +prettyModifier MCtrl = showString "C-" +prettyModifier MMeta = showString "M-" +prettyModifier MShift = showString "S-" +prettyModifier MAlt = showString "A-" + +prettyKey :: Key -> String +prettyKey (KChar '\t') = "Tab" +prettyKey (KChar c) = showLitChar c "" -- escapes anything non-ascii +prettyKey (KFun n) = 'F' : show n +prettyKey KBackTab = "BackTab" +prettyKey KEnter = "Enter" +prettyKey KEsc = "Esc" +prettyKey KHome = "Home" +prettyKey KEnd = "End" +prettyKey KPageUp = "PageUp" +prettyKey KPageDown = "PageDn" +prettyKey KDel = "Delete" +prettyKey KBS = "Backspace" +prettyKey KLeft = "Left" +prettyKey KRight = "Right" +prettyKey k = show k diff --git a/src/Client/EventLoop/Errors.hs b/src/Client/EventLoop/Errors.hs --- a/src/Client/EventLoop/Errors.hs +++ b/src/Client/EventLoop/Errors.hs @@ -40,7 +40,7 @@ | Just err <- fromException ex = explainHookupError err -- HsOpenSSL errors - | Just err <- fromException ex :: Maybe ConnectionAbruptlyTerminated = + | Just _ <- fromException ex :: Maybe ConnectionAbruptlyTerminated = "Connection abruptly terminated" :| [] | Just (ProtocolError e) <- fromException ex = ("TLS protocol error: " ++ e) :| [] diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -9,18 +9,10 @@ This module provides the renderer for the client's UI. -} -module Client.Image - ( clientPicture - , scrollAmount - ) where +module Client.Image (clientPicture) where -import Client.Image.Palette -import Client.Image.StatusLine -import Client.Image.Textbox -import Client.Image.Utils +import Client.Image.Layout import Client.State -import Client.State.Focus -import Client.View import Control.Lens import Graphics.Vty (Background (..), Cursor (..), Picture (..)) @@ -45,85 +37,8 @@ (Int, Image, ClientState) {- ^ text box cursor position, image, updated state -} clientImage st = (pos, img, st') where - (mainHeight, splitHeight) = clientWindowHeights (imageHeight statusLine) st - splitFocuses = clientExtraFocuses st - focus = view clientFocus st - (pos , nextOffset, tbImg) = textboxImage st - -- update client state for scroll clamp !st' = set clientTextBoxOffset nextOffset $ over clientScroll (max 0 . subtract overscroll) st - (overscroll, msgs) = messagePane mainHeight focus (view clientSubfocus st) st - splits = renderExtra st' <$> splitFocuses - -- outgoing state is ignored here, splits don't get to truncate scrollback - - img = vertCat splits <-> - msgs <-> - statusLine <-> - tbImg - - statusLine = statusLineImage st - - renderExtra stIn focus1 = outImg - where - (_,msgImg) = messagePane splitHeight focus1 FocusMessages stIn - pal = clientPalette stIn - divider = view palWindowDivider pal - outImg = msgImg <-> minorStatusLineImage focus1 stIn - <-> charFill divider ' ' (view clientWidth stIn) 1 - --- | Generate an image corresponding to the image lines of the given --- focus and subfocus. Returns the number of lines overscrolled to --- assist in clamping scroll to the lines available in the window. -messagePane :: - Int {- ^ available rows -} -> - Focus {- ^ focused window -} -> - Subfocus {- ^ subfocus to render -} -> - ClientState {- ^ client state -} -> - (Int, Image) {- ^ overscroll, rendered messages -} -messagePane h focus subfocus st = (overscroll, img) - where - images = viewLines focus subfocus st - vimg = assemble emptyImage images - vimg1 = cropBottom h vimg - img = pad 0 (h - imageHeight vimg1) 0 0 vimg1 - - overscroll = vh - imageHeight vimg - - assemble acc _ | imageHeight acc >= vh = cropTop vh acc - assemble acc [] = acc - assemble acc (x:xs) = assemble (lineWrap w Nothing x <-> acc) xs - - scroll = view clientScroll st - vh = h + scroll - - w = view clientWidth st - - --- | Compute the number of lines in a page at the current window size -scrollAmount :: - ClientState {- ^ client state -} -> - Int {- ^ scroll amount -} -scrollAmount st = max 1 (snd (clientWindowHeights actSize st)) - -- extra will be equal to main or 1 smaller - where - actSize = imageHeight (statusLineImage st) - - --- | Number of lines to allocate for the focused window and the --- main window. This doesn't include the textbox, activity bar, --- or status line. -clientWindowHeights :: - Int {- ^ status bar height -} -> - ClientState {- ^ client state -} -> - (Int,Int) {- ^ main height, extra height -} -clientWindowHeights statusBar st = (mainH, splitH) - where - h = max 0 (view clientHeight st - overhead) - splitH = h `quot` (1+extras) - mainH = h - splitH*extras - - extras = length (clientExtraFocuses st) - textbox = 1 - overhead = textbox + statusBar + 2*extras + (overscroll, pos, nextOffset, img) = drawLayout st diff --git a/src/Client/Image/Arguments.hs b/src/Client/Image/Arguments.hs --- a/src/Client/Image/Arguments.hs +++ b/src/Client/Image/Arguments.hs @@ -18,26 +18,27 @@ import Client.Commands.Arguments import Client.Image.MircFormatting +import Client.Image.PackedImage import Client.Image.Palette import Control.Lens +import Data.Semigroup import qualified Data.Text as Text import Graphics.Vty.Attributes -import Graphics.Vty.Image -- | Parse command arguments against a given 'ArgumentSpec'. -- The given text will be rendered and then any missing arguments -- will be indicated by extra placeholder values appended onto the -- image. Parameters are rendered with 'plainText' except for -- the case of 'RemainingArg' which supports WYSIWYG. -argumentsImage :: Palette -> ArgumentSpec a -> String -> Image +argumentsImage :: Palette -> ArgumentSpec a -> String -> Image' argumentsImage pal spec xs | all (==' ') xs = placeholders - <|> string defAttr (drop (imageWidth placeholders) xs) + <> string defAttr (drop (imageWidth placeholders) xs) | otherwise = case spec of NoArg -> plainText xs - ReqTokenArg _ a -> plainText token <|> argumentsImage pal a xs' - OptTokenArg _ a -> plainText token <|> argumentsImage pal a xs' + ReqTokenArg _ a -> plainText token <> argumentsImage pal a xs' + OptTokenArg _ a -> plainText token <> argumentsImage pal a xs' RemainingArg _ -> parseIrcTextExplicit (Text.pack xs) where @@ -49,17 +50,17 @@ -- | Construct an 'Image' containing placeholders for each -- of the remaining arguments. -mkPlaceholders :: Palette -> ArgumentSpec a -> Image +mkPlaceholders :: Palette -> ArgumentSpec a -> Image' mkPlaceholders pal arg = case arg of - NoArg -> emptyImage + NoArg -> mempty ReqTokenArg n a -> leader - <|> string (view palCommandPlaceholder pal) n - <|> mkPlaceholders pal a + <> string (view palCommandPlaceholder pal) n + <> mkPlaceholders pal a OptTokenArg n a -> leader - <|> string (view palCommandPlaceholder pal) (n ++ "?") - <|> mkPlaceholders pal a + <> string (view palCommandPlaceholder pal) (n ++ "?") + <> mkPlaceholders pal a RemainingArg n -> leader - <|> string (view palCommandPlaceholder pal) (n ++ "…") + <> string (view palCommandPlaceholder pal) (n ++ "…") where leader = char defAttr ' ' diff --git a/src/Client/Image/Layout.hs b/src/Client/Image/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Client/Image/Layout.hs @@ -0,0 +1,191 @@ +{-| +Module : Client.Image.Layout +Description : Layout code for the multi-window splits +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +-} +module Client.Image.Layout (scrollAmount, drawLayout) where + +import Control.Lens +import Client.State +import Client.State.Focus +import Client.Configuration (LayoutMode(..)) +import Client.Image.StatusLine (statusLineImage, minorStatusLineImage) +import Client.Image.Textbox +import Client.Image.LineWrap (lineWrap) +import Client.Image.Palette +import Client.View +import Graphics.Vty.Image +import Graphics.Vty.Attributes (defAttr) + +-- | Compute the combined image for all the visible message windows. +drawLayout :: + ClientState {- ^ client state -} -> + (Int, Int, Int, Image) {- ^ overscroll, cursor pos, next offset, final image -} +drawLayout st = + case view clientLayout st of + TwoColumn | not (null extrafocus) -> drawLayoutTwo st extrafocus + _ -> drawLayoutOne st extrafocus + where + extrafocus = clientExtraFocuses st + +-- | Layout algorithm for all windows in a single column. +drawLayoutOne :: + ClientState {- ^ client state -} -> + [Focus] {- ^ extra window names -} -> + (Int, Int, Int, Image) {- ^ overscroll and final image -} +drawLayoutOne st extrafocus = + (overscroll, pos, nextOffset, output) + where + w = view clientWidth st + h:hs = splitHeights (rows - saveRows) (length extraLines) + scroll = view clientScroll st + + (overscroll, pos, nextOffset, main) = + drawMain w (saveRows + h) scroll st + + output = vertCat $ reverse + $ main + : [ drawExtra st w h' foc imgs + | (h', (foc, imgs)) <- zip hs extraLines] + + rows = view clientHeight st + + -- don't count textbox or the main status line against the main window's height + saveRows = 1 + imageHeight (statusLineImage w st) + + extraLines = [ (focus', viewLines focus' FocusMessages w st) + | focus' <- extrafocus ] + +-- | Layout algorithm for all windows in a single column. +drawLayoutTwo :: + ClientState {- ^ client state -} -> + [Focus] {- ^ extra window names -} -> + (Int, Int, Int, Image) {- ^ overscroll, cursor pos, offset, final image -} +drawLayoutTwo st extrafocus = + (overscroll, pos, nextOffset, output) + where + [wl,wr] = divisions (view clientWidth st - 1) 2 + hs = divisions (rows - length extraLines) (length extraLines) + scroll = view clientScroll st + + output = main <|> divider <|> extraImgs + + extraImgs = vertCat $ reverse + [ drawExtra st wr h' foc imgs + | (h', (foc, imgs)) <- zip hs extraLines] + + (overscroll, pos, nextOffset, main) = + drawMain wl rows scroll st + + pal = clientPalette st + divider = charFill (view palWindowDivider pal) ' ' 1 rows + rows = view clientHeight st + + extraLines = [ (focus', viewLines focus' FocusMessages wr st) + | focus' <- extrafocus ] + +drawMain :: + Int {- ^ draw width -} -> + Int {- ^ draw height -} -> + Int {- ^ scroll amount -} -> + ClientState {- ^ client state -} -> + (Int,Int,Int,Image) +drawMain w h scroll st = (overscroll, pos, nextOffset, msgs <-> bottomImg) + where + focus = view clientFocus st + subfocus = view clientSubfocus st + + msgLines = viewLines focus subfocus w st + + (overscroll, msgs) = messagePane w h' scroll msgLines + + h' = max 0 (h - imageHeight bottomImg) + + bottomImg = statusLineImage w st <-> tbImage + (pos, nextOffset, tbImage) = textboxImage w st + + +-- | Draw one of the extra windows from @/splits@ +drawExtra :: + ClientState {- ^ client state -} -> + Int {- ^ draw width -} -> + Int {- ^ draw height -} -> + Focus {- ^ focus -} -> + [Image] {- ^ image lines -} -> + Image {- ^ rendered window -} +drawExtra st w h focus lineImages = + msgImg <-> minorStatusLineImage focus w True st + where + (_, msgImg) = messagePane w h 0 lineImages + + +-- | Generate an image corresponding to the image lines of the given +-- focus and subfocus. Returns the number of lines overscrolled to +-- assist in clamping scroll to the lines available in the window. +messagePane :: + Int {- ^ client width -} -> + Int {- ^ available rows -} -> + Int {- ^ current scroll -} -> + [Image] {- ^ focused window -} -> + (Int, Image) {- ^ overscroll, rendered messages -} +messagePane w h scroll images = (overscroll, img) + where + vimg = assemble emptyImage images + vimg1 = cropBottom h vimg + img = charFill defAttr ' ' w (h - imageHeight vimg1) + <-> vimg1 + + overscroll = vh - imageHeight vimg + vh = h + scroll + + assemble acc _ | imageHeight acc >= vh = cropTop vh acc + assemble acc [] = acc + assemble acc (x:xs) = assemble (lineWrap w x <-> acc) xs + + +splitHeights :: + Int {- ^ screen rows to fill -} -> + Int {- ^ number of extra windows -} -> + [Int] {- ^ list of heights for each division -} +splitHeights h ex = divisions (h - ex) (1 + ex) + + +-- | Constructs a list of numbers with the length of the divisor +-- and that sums to the dividend. Each element will be within +-- one of the quotient. +divisions :: + Int {- ^ dividend -} -> + Int {- ^ divisor -} -> + [Int] +divisions x y + | y <= 0 = [] + | otherwise = replicate r (q+1) ++ replicate (y-r) q + where + (q,r) = quotRem (max 0 x) y + + + +-- | Compute the number of lines in a page at the current window size +scrollAmount :: + ClientState {- ^ client state -} -> + Int {- ^ scroll amount -} +scrollAmount st = + case view clientLayout st of + TwoColumn -> h + OneColumn -> head (splitHeights h ex) -- extra will be equal to main or 1 smaller + where + layout = view clientLayout st + + h = view clientHeight st - bottomSize + ex = length (clientExtraFocuses st) + + bottomSize = 1 -- textbox + + imageHeight (statusLineImage mainWidth st) + + mainWidth = + case layout of + TwoColumn -> head (divisions (view clientWidth st - 1) 2) + OneColumn -> view clientWidth st diff --git a/src/Client/Image/LineWrap.hs b/src/Client/Image/LineWrap.hs new file mode 100644 --- /dev/null +++ b/src/Client/Image/LineWrap.hs @@ -0,0 +1,103 @@ +{-| +Module : Client.Image.LineWrap +Description : Chat message view +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +Provides utilities for line wrapping images. +-} + +module Client.Image.LineWrap (lineWrap, lineWrapChat) where + +import Client.Image.PackedImage +import Data.Semigroup +import qualified Graphics.Vty.Image as Vty +import Graphics.Vty.Attributes +import qualified Data.Text.Lazy as L + +-- | Given an image, break the image up into chunks of at most the +-- given width and stack the resulting chunks vertically top-to-bottom. +lineWrap :: + Int {- ^ terminal width -} -> + Vty.Image {- ^ unwrapped image -} -> + Vty.Image {- ^ wrapped image -} +lineWrap w img + | Vty.imageWidth img == 0 = Vty.emptyImage + | Vty.imageWidth img <= w = terminate w img + | otherwise = + terminate w (Vty.cropRight w img) Vty.<-> + lineWrap w (Vty.cropLeft (Vty.imageWidth img - w) img) + +-- | Trailing space with default attributes deals with bug in VTY +-- where the formatting will continue past the end of chat messages. +-- This adds an extra space if a line doesn't end on the terminal edge. +terminate :: + Int {- ^ terminal width -} -> + Vty.Image {- ^ unwrapped image -} -> + Vty.Image {- ^ wrapped image -} +terminate n img + | Vty.imageWidth img == n = img + | otherwise = img Vty.<|> Vty.char defAttr ' ' + + +lineWrapChat :: + Int {- ^ terminal width -} -> + Maybe Int {- ^ optional indentation -} -> + Image' {- ^ unwrapped image -} -> + [Image'] {- ^ wrapped image -} +lineWrapChat w (Just i) + | 2*i <= w = reverse . addPadding i . wordLineWrap w (w-i) +lineWrapChat w _ = reverse . wordLineWrap w w + + +addPadding :: Int -> [Image'] -> [Image'] +addPadding _ [] = [] +addPadding i (x:xs) = x : map indent xs + where indent = (string defAttr (replicate i ' ') <>) + + +wordLineWrap :: + Int {- ^ first line length -} -> + Int {- ^ secondary line length -} -> + Image' {- ^ image -} -> + [Image'] {- ^ splits -} +wordLineWrap w wNext img + | imgW == 0 = [] + | imgW <= w = [img] + | otherwise = l : wordLineWrap wNext wNext (dropSpaces r) + where + imgW = imageWidth img + x:xs = splitOptions img + + (l,r) = splitImage width img + + width + | x <= w = go x xs + | otherwise = w + + go y [] = min y w + go y (z:zs) + | z-y > wNext = w + | z > w = y + | otherwise = go z zs + + +-- | List of image widths suitable for breaking the image on +-- that correspond to word breaks. +splitOptions :: Image' -> [Int] +splitOptions + = dropWhile (0==) + . scanl1 (\x y -> 1 + x + y) + . map (Vty.wcswidth . L.unpack) + . L.split (' '==) + . imageText + + +-- | Drop the leading spaces from an image +dropSpaces :: Image' -> Image' +dropSpaces img + | n == 0 = img + | otherwise = snd (splitImage n img) + where + n = fromIntegral $ L.length $ L.takeWhile (' '==) $ imageText 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 @@ -26,6 +26,7 @@ ) where import Client.Image.MircFormatting +import Client.Image.PackedImage import Client.Image.Palette import Client.Message import Control.Lens @@ -34,12 +35,12 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List +import Data.Semigroup import Data.Text (Text) import qualified Data.Text as Text import Data.Time import qualified Data.Vector as Vector import Graphics.Vty.Attributes -import Graphics.Vty.Image import Irc.Codes import Irc.Identifier import Irc.Message @@ -73,8 +74,8 @@ msgImage :: RenderMode -> ZonedTime {- ^ time of message -} -> - MessageRendererParams -> MessageBody -> Image -msgImage rm when params body = horizCat + MessageRendererParams -> MessageBody -> Image' +msgImage rm when params body = mconcat [ renderTime rm (rendPalette params) when , statusMsgImage (rendStatusMsg params) , bodyImage rm params body @@ -93,8 +94,8 @@ errorImage :: MessageRendererParams -> Text {- ^ error message -} -> - Image -errorImage params txt = horizCat + Image' +errorImage params txt = mconcat [ text' (view palError (rendPalette params)) "error " , text' defAttr (cleanText txt) ] @@ -102,23 +103,23 @@ normalImage :: MessageRendererParams -> Text {- ^ message -} -> - Image -normalImage params txt = horizCat + Image' +normalImage params txt = mconcat [ text' (view palLabel (rendPalette params)) "client " , text' defAttr (cleanText txt) ] -- | Render the given time according to the current mode and palette. -renderTime :: RenderMode -> Palette -> ZonedTime -> Image +renderTime :: RenderMode -> Palette -> ZonedTime -> Image' renderTime DetailedRender = datetimeImage renderTime NormalRender = timeImage -- | Render the sigils for a restricted message. -statusMsgImage :: [Char] {- ^ sigils -} -> Image +statusMsgImage :: [Char] {- ^ sigils -} -> Image' statusMsgImage modes - | null modes = emptyImage - | otherwise = string defAttr "(" <|> - string statusMsgColor modes <|> + | null modes = mempty + | otherwise = string defAttr "(" <> + string statusMsgColor modes <> string defAttr ") " where statusMsgColor = withForeColor defAttr red @@ -128,7 +129,7 @@ bodyImage :: RenderMode -> MessageRendererParams -> - MessageBody -> Image + MessageBody -> Image' bodyImage rm params body = case body of IrcBody irc -> ircLineImage rm params irc @@ -140,7 +141,7 @@ -- @ -- 23:15 -- @ -timeImage :: Palette -> ZonedTime -> Image +timeImage :: Palette -> ZonedTime -> Image' timeImage palette = string (view palTime palette) . formatTime defaultTimeLocale "%R " @@ -150,7 +151,7 @@ -- @ -- 2016-07-24 23:15:10 -- @ -datetimeImage :: Palette -> ZonedTime -> Image +datetimeImage :: Palette -> ZonedTime -> Image' datetimeImage palette = string (view palTime palette) . formatTime defaultTimeLocale "%F %T " @@ -162,10 +163,10 @@ -- | Optionally insert padding on the right of an 'Image' until it has -- the minimum width. -rightPad :: RenderMode -> Maybe Integer -> Image -> Image +rightPad :: RenderMode -> Maybe Integer -> Image' -> Image' rightPad NormalRender (Just minWidth) i = let w = max 0 (fromIntegral minWidth - imageWidth i) - in i <|> string defAttr (replicate w ' ') + in i <> string defAttr (replicate w ' ') rightPad _ _ i = i -- | Render a chat message given a rendering mode, the sigils of the user @@ -173,7 +174,7 @@ ircLineImage :: RenderMode -> MessageRendererParams -> - IrcMsg -> Image + IrcMsg -> Image' ircLineImage rm !rp body = let quietAttr = view palMeta pal pal = rendPalette rp @@ -182,132 +183,132 @@ nicks = rendNicks rp detail img = case rm of - NormalRender -> emptyImage + NormalRender -> mempty DetailedRender -> img in case body of Nick old new -> - detail (string quietAttr "nick ") <|> - string (view palSigil pal) sigils <|> - coloredUserInfo pal rm myNicks old <|> - string defAttr " is now known as " <|> + detail (string quietAttr "nick ") <> + string (view palSigil pal) sigils <> + coloredUserInfo pal rm myNicks old <> + string defAttr " is now known as " <> coloredIdentifier pal NormalIdentifier myNicks new Join nick _chan -> - string quietAttr "join " <|> + string quietAttr "join " <> coloredUserInfo pal rm myNicks nick Part nick _chan mbreason -> - string quietAttr "part " <|> - coloredUserInfo pal rm myNicks nick <|> - foldMap (\reason -> string quietAttr " (" <|> - parseIrcText reason <|> + string quietAttr "part " <> + coloredUserInfo pal rm myNicks nick <> + foldMap (\reason -> string quietAttr " (" <> + parseIrcText reason <> string quietAttr ")") mbreason Quit nick mbreason -> - string quietAttr "quit " <|> - coloredUserInfo pal rm myNicks nick <|> - foldMap (\reason -> string quietAttr " (" <|> - parseIrcText reason <|> + string quietAttr "quit " <> + coloredUserInfo pal rm myNicks nick <> + foldMap (\reason -> string quietAttr " (" <> + parseIrcText reason <> string quietAttr ")") mbreason Kick kicker _channel kickee reason -> - detail (string quietAttr "kick ") <|> - string (view palSigil pal) sigils <|> - coloredUserInfo pal rm myNicks kicker <|> - string defAttr " kicked " <|> - coloredIdentifier pal NormalIdentifier myNicks kickee <|> - string defAttr ": " <|> + detail (string quietAttr "kick ") <> + string (view palSigil pal) sigils <> + coloredUserInfo pal rm myNicks kicker <> + string defAttr " kicked " <> + coloredIdentifier pal NormalIdentifier myNicks kickee <> + string defAttr ": " <> parseIrcText reason Topic src _dst txt -> - detail (string quietAttr "tpic ") <|> - coloredUserInfo pal rm myNicks src <|> - string defAttr " changed the topic to: " <|> + detail (string quietAttr "tpic ") <> + coloredUserInfo pal rm myNicks src <> + string defAttr " changed the topic to: " <> parseIrcText txt Notice src _dst txt -> - detail (string quietAttr "note ") <|> + detail (string quietAttr "note ") <> rightPad rm (rendNickPadding rp) - (string (view palSigil pal) sigils <|> - coloredUserInfo pal rm myNicks src) <|> - string (withForeColor defAttr red) ": " <|> + (string (view palSigil pal) sigils <> + coloredUserInfo pal rm myNicks src) <> + string (withForeColor defAttr red) ": " <> parseIrcTextWithNicks pal myNicks nicks txt Privmsg src _dst txt -> - detail (string quietAttr "chat ") <|> + detail (string quietAttr "chat ") <> rightPad rm (rendNickPadding rp) - (string (view palSigil pal) sigils <|> - coloredUserInfo pal rm myNicks src) <|> - string defAttr ": " <|> + (string (view palSigil pal) sigils <> + coloredUserInfo pal rm myNicks src) <> + string defAttr ": " <> parseIrcTextWithNicks pal myNicks nicks txt Ctcp src _dst "ACTION" txt -> - detail (string quietAttr "actp ") <|> - string (withForeColor defAttr blue) "* " <|> - string (view palSigil pal) sigils <|> - coloredUserInfo pal rm myNicks src <|> - string defAttr " " <|> + detail (string quietAttr "actp ") <> + string (withForeColor defAttr blue) "* " <> + string (view palSigil pal) sigils <> + coloredUserInfo pal rm myNicks src <> + string defAttr " " <> parseIrcTextWithNicks pal myNicks nicks txt CtcpNotice src _dst "ACTION" txt -> - detail (string quietAttr "actn ") <|> - string (withForeColor defAttr red) "* " <|> - string (view palSigil pal) sigils <|> - coloredUserInfo pal rm myNicks src <|> - string defAttr " " <|> + detail (string quietAttr "actn ") <> + string (withForeColor defAttr red) "* " <> + string (view palSigil pal) sigils <> + coloredUserInfo pal rm myNicks src <> + string defAttr " " <> parseIrcTextWithNicks pal myNicks nicks txt Ctcp src _dst cmd txt -> - detail (string quietAttr "ctcp ") <|> - string (withForeColor defAttr blue) "! " <|> - string (view palSigil pal) sigils <|> - coloredUserInfo pal rm myNicks src <|> - string defAttr " " <|> - parseIrcText cmd <|> - separatorImage <|> + detail (string quietAttr "ctcp ") <> + string (withForeColor defAttr blue) "! " <> + string (view palSigil pal) sigils <> + coloredUserInfo pal rm myNicks src <> + string defAttr " " <> + parseIrcText cmd <> + separatorImage <> parseIrcText txt CtcpNotice src _dst cmd txt -> - detail (string quietAttr "ctcp ") <|> - string (withForeColor defAttr red) "! " <|> - string (view palSigil pal) sigils <|> - coloredUserInfo pal rm myNicks src <|> - string defAttr " " <|> - parseIrcText cmd <|> - separatorImage <|> + detail (string quietAttr "ctcp ") <> + string (withForeColor defAttr red) "! " <> + string (view palSigil pal) sigils <> + coloredUserInfo pal rm myNicks src <> + string defAttr " " <> + parseIrcText cmd <> + separatorImage <> parseIrcText txt Ping params -> - string defAttr "PING " <|> separatedParams params + string defAttr "PING " <> separatedParams params Pong params -> - string defAttr "PONG " <|> separatedParams params + string defAttr "PONG " <> separatedParams params Error reason -> - string (view palError pal) "ERROR " <|> + string (view palError pal) "ERROR " <> parseIrcText reason Reply code params -> renderReplyCode rm rp code params UnknownMsg irc -> - maybe emptyImage (\ui -> coloredUserInfo pal rm myNicks ui <|> char defAttr ' ') - (view msgPrefix irc) <|> - text' defAttr (view msgCommand irc) <|> - char defAttr ' ' <|> + foldMap (\ui -> coloredUserInfo pal rm myNicks ui <> char defAttr ' ') + (view msgPrefix irc) <> + text' defAttr (view msgCommand irc) <> + char defAttr ' ' <> separatedParams (view msgParams irc) Cap cmd args -> - text' (withForeColor defAttr magenta) (renderCapCmd cmd) <|> - text' defAttr ": " <|> + text' (withForeColor defAttr magenta) (renderCapCmd cmd) <> + text' defAttr ": " <> separatedParams args Mode nick _chan params -> - detail (string quietAttr "mode ") <|> - string (view palSigil pal) sigils <|> - coloredUserInfo pal rm myNicks nick <|> - string defAttr " set mode: " <|> + detail (string quietAttr "mode ") <> + string (view palSigil pal) sigils <> + coloredUserInfo pal rm myNicks nick <> + string defAttr " set mode: " <> ircWords params Authenticate{} -> string defAttr "AUTHENTICATE ***" @@ -325,34 +326,34 @@ CapEnd -> "caps finished" -- server shouldn't send this CapReq -> "caps requested" -- server shouldn't send this -separatorImage :: Image +separatorImage :: Image' separatorImage = char (withForeColor defAttr blue) '·' -- | Process list of 'Text' as individual IRC formatted words -- separated by a special separator to distinguish parameters -- from words within parameters. -separatedParams :: [Text] -> Image -separatedParams = horizCat . intersperse separatorImage . map parseIrcText +separatedParams :: [Text] -> Image' +separatedParams = mconcat . intersperse separatorImage . map parseIrcText -- | Process list of 'Text' as individual IRC formatted words -ircWords :: [Text] -> Image -ircWords = horizCat . intersperse (char defAttr ' ') . map parseIrcText +ircWords :: [Text] -> Image' +ircWords = mconcat . intersperse (char defAttr ' ') . map parseIrcText -renderReplyCode :: RenderMode -> MessageRendererParams -> ReplyCode -> [Text] -> Image +renderReplyCode :: RenderMode -> MessageRendererParams -> ReplyCode -> [Text] -> Image' renderReplyCode rm rp code@(ReplyCode w) params = case rm of - DetailedRender -> string attr (show w) <|> rawParamsImage + DetailedRender -> string attr (show w) <> rawParamsImage NormalRender -> rightPad rm (rendNickPadding rp) - (text' attr (Text.toLower (replyCodeText info))) <|> - char defAttr ':' <|> + (text' attr (replyCodeText info)) <> + char defAttr ':' <> case code of RPL_WHOISIDLE -> whoisIdleParamsImage _ -> rawParamsImage where rawParamsImage = - char defAttr ' ' <|> + char defAttr ' ' <> separatedParams params' params' = case rm of @@ -372,11 +373,11 @@ whoisIdleParamsImage = case params' of [name, idle, signon, _txt] -> - char defAttr ' ' <|> - text' defAttr name <|> - text' defAttr " idle: " <|> - string defAttr (prettySeconds (Text.unpack idle)) <|> - text' defAttr " sign-on: " <|> + char defAttr ' ' <> + text' defAttr name <> + text' defAttr " idle: " <> + string defAttr (prettySeconds (Text.unpack idle)) <> + text' defAttr " sign-on: " <> string defAttr (prettyUnixTime (Text.unpack signon)) _ -> rawParamsImage @@ -413,7 +414,7 @@ IdentifierColorMode {- ^ draw mode -} -> HashSet Identifier {- ^ my nicknames -} -> Identifier {- ^ identifier to draw -} -> - Image + Image' coloredIdentifier palette icm myNicks ident = text' color (idText ident) where @@ -436,11 +437,11 @@ RenderMode {- ^ mode -} -> HashSet Identifier {- ^ my nicks -} -> UserInfo {- ^ userinfo to draw-} -> - Image + Image' coloredUserInfo palette NormalRender myNicks ui = coloredIdentifier palette NormalIdentifier myNicks (userNick ui) coloredUserInfo palette DetailedRender myNicks !ui = - horizCat + mconcat [ coloredIdentifier palette NormalIdentifier myNicks (userNick ui) , aux '!' (userName ui) , aux '@' (userHost ui) @@ -448,11 +449,11 @@ where quietAttr = view palMeta palette aux x xs - | Text.null xs = emptyImage - | otherwise = char quietAttr x <|> text' quietAttr xs + | Text.null xs = mempty + | otherwise = char quietAttr x <> text' quietAttr xs -- | Render an identifier without using colors. This is useful for metadata. -quietIdentifier :: Palette -> Identifier -> Image +quietIdentifier :: Palette -> Identifier -> Image' quietIdentifier palette ident = text' (view palMeta palette) (idText ident) @@ -464,7 +465,7 @@ Palette -> HashSet Identifier {- ^ my nicks -} -> HashSet Identifier {- ^ other nicks -} -> - Text -> Image + Text -> Image' parseIrcTextWithNicks palette myNicks nicks txt | Text.any isControl txt = parseIrcText txt | otherwise = highlightNicks palette myNicks nicks txt @@ -475,8 +476,8 @@ Palette -> HashSet Identifier {- ^ my nicks -} -> HashSet Identifier {- ^ other nicks -} -> - Text -> Image -highlightNicks palette myNicks nicks txt = horizCat (highlight1 <$> txtParts) + Text -> Image' +highlightNicks palette myNicks nicks txt = mconcat (highlight1 <$> txtParts) where txtParts = nickSplit txt allNicks = HashSet.union myNicks nicks @@ -488,7 +489,7 @@ -- | Returns image and identifier to be used when collapsing metadata -- messages. -metadataImg :: IrcSummary -> Maybe (Image, Identifier, Maybe Identifier) +metadataImg :: IrcSummary -> Maybe (Image', Identifier, Maybe Identifier) metadataImg msg = case msg of QuitSummary who -> Just (char (withForeColor defAttr red ) 'x', who, Nothing) @@ -499,5 +500,5 @@ _ -> Nothing -- | Image used when treating ignored chat messages as metadata -ignoreImage :: Image +ignoreImage :: Image' ignoreImage = char (withForeColor defAttr yellow) 'I' diff --git a/src/Client/Image/MircFormatting.hs b/src/Client/Image/MircFormatting.hs --- a/src/Client/Image/MircFormatting.hs +++ b/src/Client/Image/MircFormatting.hs @@ -17,16 +17,16 @@ , controlImage ) where +import Client.Image.PackedImage as I import Control.Applicative ((<|>)) import Control.Lens import Data.Attoparsec.Text as Parse import Data.Bits import Data.Char import Data.Maybe +import Data.Semigroup ((<>)) import Data.Text (Text) import Graphics.Vty.Attributes -import Graphics.Vty.Image hiding ((<|>)) -import qualified Graphics.Vty as Vty data FormatState = FormatState { _fmtFore :: Maybe Color @@ -56,16 +56,16 @@ defaultFormatState = FormatState Nothing Nothing False False False False -- | Parse mIRC encoded format characters and hide the control characters. -parseIrcText :: Text -> Image +parseIrcText :: Text -> Image' parseIrcText = parseIrcText' False -- | Parse mIRC encoded format characters and render the control characters -- explicitly. This view is useful when inputting control characters to make -- it clear where they are in the text. -parseIrcTextExplicit :: Text -> Image +parseIrcTextExplicit :: Text -> Image' parseIrcTextExplicit = parseIrcText' True -parseIrcText' :: Bool -> Text -> Image +parseIrcText' :: Bool -> Text -> Image' parseIrcText' explicit = either plainText id . parseOnly (pIrcLine explicit defaultFormatState) @@ -75,27 +75,27 @@ pSegment = TextSegment <$> takeWhile1 (not . isControl) <|> ControlSegment <$> satisfy isControl -pIrcLine :: Bool -> FormatState -> Parser Image +pIrcLine :: Bool -> FormatState -> Parser Image' pIrcLine explicit fmt = do seg <- option Nothing (Just <$> pSegment) case seg of - Nothing -> return emptyImage + Nothing -> return mempty Just (TextSegment txt) -> do rest <- pIrcLine explicit fmt - return (text' (formatAttr fmt) txt Vty.<|> rest) + return (text' (formatAttr fmt) txt <> rest) Just (ControlSegment '\^C') -> do (numberText, colorNumbers) <- match pColorNumbers rest <- pIrcLine explicit (applyColors colorNumbers fmt) return $ if explicit then controlImage '\^C' - Vty.<|> text' defAttr numberText - Vty.<|> rest + <> text' defAttr numberText + <> rest else rest Just (ControlSegment c) -- always render control codes that we don't understand | isNothing mbFmt' || explicit -> do rest <- next - return (controlImage c Vty.<|> rest) + return (controlImage c <> rest) | otherwise -> next where mbFmt' = applyControlEffect c fmt @@ -152,8 +152,8 @@ applyControlEffect _ = const Nothing -- | Safely render a control character. -controlImage :: Char -> Image -controlImage = Vty.char attr . controlName +controlImage :: Char -> Image' +controlImage = I.char attr . controlName where attr = withStyle defAttr reverseVideo controlName c @@ -163,11 +163,11 @@ -- | Render a 'String' with default attributes and replacing all of the -- control characters with reverse-video letters corresponding to caret -- notation. -plainText :: String -> Image -plainText "" = emptyImage +plainText :: String -> Image' +plainText "" = mempty plainText xs = case break isControl xs of - (first, "" ) -> Vty.string defAttr first - (first, cntl:rest) -> Vty.string defAttr first Vty.<|> - controlImage cntl Vty.<|> + (first, "" ) -> I.string defAttr first + (first, cntl:rest) -> I.string defAttr first <> + controlImage cntl <> plainText rest diff --git a/src/Client/Image/PackedImage.hs b/src/Client/Image/PackedImage.hs --- a/src/Client/Image/PackedImage.hs +++ b/src/Client/Image/PackedImage.hs @@ -1,5 +1,4 @@ -{-# Language TypeOperators, MultiParamTypeClasses, DeriveGeneric #-} -{-# OPTIONS_GHC -Wno-orphans -funfolding-creation-threshold=1500 -funfolding-use-threshold=5000 #-} +{-# Language OverloadedStrings #-} {-| Module : Client.Image.PackedImage Description : Packed vty Image type @@ -12,39 +11,32 @@ -} module Client.Image.PackedImage ( Image' - , _Image' + , unpackImage + + -- * Packed image construction + , char + , text' + , string + , imageWidth + , splitImage + , imageText ) where -import Control.Lens (Iso', iso) +import Data.List (findIndex) import qualified Data.Text as S import qualified Data.Text.Lazy as L -import Data.List -import GHC.Generics +import Data.Semigroup +import Data.String import Graphics.Vty.Attributes -import Graphics.Vty.Image -import Graphics.Vty.Image.Internal - - --- | Isomorphism between packed images and normal images. -_Image' :: Iso' Image' Image -_Image' = iso mirror (mirror . compress) -{-# INLINE _Image' #-} - - --- | Attempts to locate adjacent text sections with equal attributes --- so that they can be merged. -compress :: Image -> Image -compress = horizCat . map horizCat . groupBy textsWithEqAttr . flip horizList [] - - -textsWithEqAttr :: Image -> Image -> Bool -textsWithEqAttr (HorizText a _ _ _) (HorizText b _ _ _) = a == b -textsWithEqAttr _ _ = False +import Graphics.Vty.Image ((<|>), wcswidth, wcwidth) +import Graphics.Vty.Image.Internal (Image(..)) -horizList :: Image -> [Image] -> [Image] -horizList (HorizJoin x y _ _) = horizList x . horizList y -horizList x = (x:) +unpackImage :: Image' -> Image +unpackImage i = + case i of + EmptyImage' -> EmptyImage + HorizText' a b c d e -> HorizText a (L.fromStrict b) c d <|> unpackImage e -- | Packed, strict version of 'Image' used for long-term storage of images. @@ -54,67 +46,58 @@ {-# UNPACK #-} !S.Text {-# UNPACK #-} !Int {-# UNPACK #-} !Int - | HorizJoin' !Image' - !Image' - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - | VertJoin' - !Image' - !Image' - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - | BGFill' - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - | CropRight' - !Image' - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - | CropLeft' - !Image' - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - | CropBottom' - !Image' - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - | CropTop' - !Image' - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - {-# UNPACK #-} !Int | EmptyImage' - deriving (Show, Generic) + deriving (Show) ------------------------------------------------------------------------- +instance Monoid Image' where + mempty = EmptyImage' + mappend = (<>) -class Mirror a b where mirror :: a -> b -instance Mirror Attr Attr where mirror = id -instance Mirror Int Int where mirror = id -instance Mirror L.Text S.Text where mirror = L.toStrict -instance Mirror S.Text L.Text where mirror = L.fromStrict -instance Mirror Image Image' where mirror = to . gmirror . from -instance Mirror Image' Image where mirror = to . gmirror . from +instance Semigroup Image' where + -- maintain compressed form + HorizText' a b c d EmptyImage' <> HorizText' a' b' c' d' rest + | a == a' = HorizText' a (b <> b') (c + c') (d + d') rest ------------------------------------------------------------------------- + EmptyImage' <> y = y + HorizText' a b c d e <> y = HorizText' a b c d (e <> y) -class GMirror f g where - gmirror :: f p -> g q +instance IsString Image' where fromString = string defAttr -instance GMirror f g => GMirror (M1 i c f) (M1 j d g) where - gmirror (M1 x) = M1 (gmirror x) +text' :: Attr -> S.Text -> Image' +text' a s + | S.null s = EmptyImage' + | otherwise = HorizText' a s (wcswidth (S.unpack s)) (S.length s) EmptyImage' -instance (GMirror f1 g1, GMirror f2 g2) => GMirror (f1 :*: f2) (g1 :*: g2) where - gmirror (x :*: y) = gmirror x :*: gmirror y +char :: Attr -> Char -> Image' +char a c = HorizText' a (S.singleton c) (wcwidth c) 1 EmptyImage' -instance (GMirror f1 g1, GMirror f2 g2) => GMirror (f1 :+: f2) (g1 :+: g2) where - gmirror (L1 x) = L1 (gmirror x) - gmirror (R1 x) = R1 (gmirror x) +string :: Attr -> String -> Image' +string a s + | null s = EmptyImage' + | otherwise = HorizText' a t (wcswidth s) (S.length t) EmptyImage' + where t = S.pack s -instance GMirror U1 U1 where - gmirror _ = U1 +splitImage :: Int {- ^ image width -} -> Image' -> (Image',Image') +splitImage _ EmptyImage' = (EmptyImage', EmptyImage') +splitImage w (HorizText' a t w' l rest) + | w >= w' = case splitImage (w-w') rest of + (x,y) -> (HorizText' a t w' l x, y) + | otherwise = (text' a (S.take i t), text' a (S.drop i t) <> rest) + where + ws = scanl1 (+) (map wcwidth (S.unpack t)) + i = case findIndex (> w) ws of + Nothing -> 0 + Just ix -> ix -instance Mirror a b => GMirror (K1 i a) (K1 j b) where - gmirror (K1 x) = K1 (mirror x) +imageWidth :: Image' -> Int +imageWidth = go 0 + where + go acc EmptyImage' = acc + go acc (HorizText' _ _ w _ x) = go (acc + w) x + +imageText :: Image' -> L.Text +imageText = L.fromChunks . go + where + go EmptyImage' = [] + go (HorizText' _ t _ _ xs) = t : go xs 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 @@ -16,6 +16,7 @@ , minorStatusLineImage ) where +import Client.Image.Message (cleanText) import Client.Image.Palette import Client.State import Client.State.Channel @@ -32,39 +33,63 @@ import Irc.Identifier (Identifier, idText) import Numeric +bar :: Char +bar = '━' + -- | Renders the status line between messages and the textbox. statusLineImage :: + Int {- ^ draw width -} -> ClientState {- ^ client state -} -> Image {- ^ status bar -} -statusLineImage st = content <|> charFill defAttr '─' fillSize 1 +statusLineImage w st = + makeLines w (common : activity ++ errorImgs) where - fillSize = max 0 (view clientWidth st - imageWidth content) - contentSansActivity = horizCat + common = horizCat [ myNickImage st - , focusImage st + , focusImage (view clientFocus st) st + , subfocusImage st , detailImage st - , nometaImage st + , nometaImage (view clientFocus st) st , scrollImage st , filterImage st , latencyImage st ] - content - | view clientActivityBar st = - makeLines (view clientWidth st) (contentSansActivity : activityBarImages st) - | otherwise = contentSansActivity <|> activitySummary st + activity + | view clientActivityBar st = activityBarImages st + | otherwise = [activitySummary st] + errorImgs = + transientErrorImage <$> maybeToList (view clientErrorMsg st) + +-- Generates an error message notification image. +transientErrorImage :: + Text {- ^ @error-message@ -} -> + Image {- ^ @─[error: error-message]@ -} +transientErrorImage txt = + text' defAttr "─[" <|> + text' (withForeColor defAttr red) "error: " <|> + text' defAttr (cleanText txt) <|> + text' defAttr "]" + + -- | The minor status line is used when rendering the @/splits@ and -- @/mentions@ views to show the associated window name. -minorStatusLineImage :: Focus -> ClientState -> Image -minorStatusLineImage focus st = - content <|> charFill defAttr '─' fillSize 1 +minorStatusLineImage :: + Focus {- ^ window name -} -> + Int {- ^ draw width -} -> + Bool {- ^ show hidemeta status -} -> + ClientState -> Image +minorStatusLineImage focus w showHideMeta st = + content <|> charFill defAttr bar fillSize 1 where - content = infoBubble (focusImageMajor focus st) - fillSize = max 0 (view clientWidth st - imageWidth content) + content = focusImage focus st <|> + if showHideMeta then nometaImage focus st else mempty + fillSize = max 0 (w - imageWidth content) + -- | Indicate when the client is scrolling and old messages are being shown. scrollImage :: ClientState -> Image scrollImage st @@ -118,7 +143,7 @@ -- | Wrap some text in parentheses to make it suitable for inclusion in the -- status line. infoBubble :: Image -> Image -infoBubble img = string defAttr "─(" <|> img <|> string defAttr ")" +infoBubble img = string defAttr (bar:"(") <|> img <|> string defAttr ")" -- | Indicate that the client is in the /detailed/ view. @@ -133,13 +158,14 @@ -- | Indicate that the client isn't showing the metadata lines in /normal/ -- view. -nometaImage :: ClientState -> Image -nometaImage st - | view clientShowMetadata st = emptyImage - | otherwise = infoBubble (string attr "nometa") +nometaImage :: Focus -> ClientState -> Image +nometaImage focus st + | metaHidden = infoBubble (string attr "nometa") + | otherwise = emptyImage where - pal = clientPalette st - attr = view palLabel pal + pal = clientPalette st + attr = view palLabel pal + metaHidden = orOf (clientWindows . ix focus . winHideMeta) st -- | Image for little box with active window names: -- @@ -147,7 +173,7 @@ activitySummary :: ClientState -> Image activitySummary st | null indicators = emptyImage - | otherwise = string defAttr "─[" <|> + | otherwise = string defAttr (bar:"[") <|> horizCat indicators <|> string defAttr "]" where @@ -179,7 +205,7 @@ baraux i (focus,w) | n == 0 = Nothing -- todo: make configurable | otherwise = Just - $ string defAttr "─[" <|> + $ string defAttr (bar:"[") <|> char (view palWindowName pal) i <|> char defAttr ':' <|> text' (view palLabel pal) focusText <|> @@ -218,7 +244,7 @@ = go acc' ys go acc ys = makeLines w ys - <-> acc <|> charFill defAttr '─' (max 0 (w - imageWidth acc)) 1 + <-> acc <|> charFill defAttr bar (max 0 (w - imageWidth acc)) 1 myNickImage :: ClientState -> Image @@ -243,19 +269,14 @@ Just chan -> view (csChannels . ix chan . chanUsers . ix nick) cs -focusImage :: ClientState -> Image -focusImage st = - infoBubble (focusImageMajor focus st) <|> - foldMap infoBubble (viewSubfocusLabel pal subfocus) +subfocusImage :: ClientState -> Image +subfocusImage st = foldMap infoBubble (viewSubfocusLabel pal subfocus) where - - !pal = clientPalette st - focus = view clientFocus st + pal = clientPalette st subfocus = view clientSubfocus st -focusImageMajor :: Focus -> ClientState -> Image -focusImageMajor focus st = - horizCat +focusImage :: Focus -> ClientState -> Image +focusImage focus st = infoBubble $ horizCat [ char (view palWindowName pal) windowName , char defAttr ':' , viewFocusLabel st focus @@ -306,6 +327,7 @@ FocusMentions -> Just $ string (view palLabel pal) "mentions" FocusPalette -> Just $ string (view palLabel pal) "palette" FocusDigraphs -> Just $ string (view palLabel pal) "digraphs" + FocusKeyMap -> Just $ string (view palLabel pal) "keymap" FocusHelp mb -> Just $ string (view palLabel pal) "help" <|> opt mb FocusMasks m -> Just $ horizCat 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 @@ -22,34 +22,35 @@ import Client.Commands.Recognizer import Client.Image.Arguments import Client.Image.MircFormatting +import Client.Image.PackedImage import Client.Image.Palette import Client.State import qualified Client.State.EditBox as Edit import Control.Lens import Data.Char import Data.List -import Data.Monoid +import Data.Semigroup import qualified Data.Text as Text import Graphics.Vty.Attributes -import Graphics.Vty.Image +import qualified Graphics.Vty.Image as Vty -- | Compute the UI image for the text input box. This computes -- the logical cursor position on the screen to compensate for -- VTY's cursor placement behavior. -textboxImage :: ClientState -> (Int, Int, Image) -- ^ cursor column, new offset, image -textboxImage st +textboxImage :: Int -> ClientState -> (Int, Int, Vty.Image) -- ^ cursor column, new offset, image +textboxImage width st = (newPos, newOffset, croppedImage) where - width = view clientWidth st macros = views (clientConfig . configMacros) (fmap macroSpec) st (txt, content) = views (clientTextBox . Edit.content) (renderContent macros pal) st - lineImage = beginning <|> content <|> ending + lineImage = unpackImage (beginning <> content <> ending) leftOfCurWidth = myWcswidth ('^':txt) - croppedImage = cropLeft (imageWidth lineImage - newOffset) lineImage + croppedImage = Vty.resizeWidth width + $ Vty.cropLeft (Vty.imageWidth lineImage - newOffset) lineImage cursorAnchor = width * 3 `quot` 4 @@ -76,9 +77,9 @@ -- 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 -} + Palette {- ^ palette -} -> + Edit.Content {- ^ content -} -> + (String, Image') {- ^ plain text rendering, image rendering -} renderContent macros pal c = (txt, wholeImg) where as = reverse (view Edit.above c) @@ -91,7 +92,7 @@ -- ["one","two"] "three" --> "two one three" txt = foldl (\acc x -> x ++ ' ' : acc) leftCur as - wholeImg = horizCat + wholeImg = mconcat $ intersperse (plainText "\n") $ map renderOtherLine as ++ renderLine macros pal curTxt @@ -103,7 +104,7 @@ myWcwidth :: Char -> Int myWcwidth x | isControl x = 1 - | otherwise = wcwidth x + | otherwise = Vty.wcwidth x -- | Version of 'wcswidth' that accounts for how control characters are -- rendered @@ -112,40 +113,39 @@ -- | Render an unfocused line -renderOtherLine :: String -> Image +renderOtherLine :: String -> Image' renderOtherLine = parseIrcTextExplicit . Text.pack -- | Render the active text box line using command highlighting and -- placeholders, and WYSIWYG mIRC formatting control characters. -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 :: 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 - (cmd, rest) = break isSpace xs - allCommands = (Left <$> macros) <> (Right <$> commands) - (attr, continue) - = case recognize (Text.pack cmd) allCommands of - Exact (Right Command{cmdArgumentSpec = 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 - ) + (cmd, rest) = break isSpace xs + allCommands = (Left <$> macros) <> (Right <$> commands) + (attr, continue) + = case recognize (Text.pack cmd) allCommands of + Exact (Right Command{cmdArgumentSpec = 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) - diff --git a/src/Client/Image/Utils.hs b/src/Client/Image/Utils.hs deleted file mode 100644 --- a/src/Client/Image/Utils.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-| -Module : Client.Image.Utils -Description : Chat message view -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -Provides utilities for formatting Vty Images. --} - -module Client.Image.Utils (lineWrap) where - -import Graphics.Vty.Image -import Graphics.Vty.Attributes - --- | Given an image, break the image up into chunks of at most the --- given width and stack the resulting chunks vertically top-to-bottom. -lineWrap :: - Int {- ^ terminal width -} -> - Maybe Int {- ^ optional indentation -} -> - Image {- ^ unwrapped image -} -> - Image {- ^ wrapped image -} -lineWrap w mi img - | imageWidth img == 0 = emptyImage - | imageWidth img <= w = terminate w img - | otherwise = - terminate w (cropRight w img) <-> - maybe (lineWrapNoIndent w) (lineWrapIndent w) mi - (cropLeft (imageWidth img - w) img) - --- | Trailing space with default attributes deals with bug in VTY --- where the formatting will continue past the end of chat messages. --- This adds an extra space if a line doesn't end on the terminal edge. -terminate :: - Int {- ^ terminal width -} -> - Image {- ^ unwrapped image -} -> - Image {- ^ wrapped image -} -terminate n img - | imageWidth img == n = img - | otherwise = img <|> char defAttr ' ' - -lineWrapNoIndent :: - Int {- ^ terminal width -} -> - Image {- ^ unwrapped image -} -> - Image {- ^ wrapped image -} -lineWrapNoIndent w img - | iw <= w = terminate w img - | otherwise = cropRight w img <-> - lineWrapNoIndent w (cropLeft (iw - w) img) - where - iw = imageWidth img - -lineWrapIndent :: - Int {- ^ terminal width -} -> - Int {- ^ indentation -} -> - Image {- ^ unwrapped image -} -> - Image {- ^ wrapped image -} -lineWrapIndent w i img - | 20 + i > w = lineWrapNoIndent w img -- ensure we stop wrapping when it doesn't make sense - | iw + i <= w = terminate w (leftPad i img) - | otherwise = leftPad i (cropRight (w-i) img) <-> - lineWrapIndent w i (cropLeft (iw - w + i) img) - where - iw = imageWidth img - -leftPad :: Int -> Image -> Image -leftPad i = pad i 0 0 0 diff --git a/src/Client/Options.hs b/src/Client/Options.hs --- a/src/Client/Options.hs +++ b/src/Client/Options.hs @@ -38,7 +38,6 @@ import Data.List import Data.Text (Text) import qualified Data.Text as Text -import qualified Data.Text.IO as Text import Data.Version import Development.GitRev (gitHash, gitDirty) import System.Console.GetOpt @@ -111,12 +110,20 @@ traverse_ (hPutStr stderr) (map bullet errors) hPutStrLn stderr tryHelpTxt - if | view optShowHelp opts -> putStr helpTxt >> exitSuccess - | view optShowFullVersion opts -> putStr fullVersionTxt >> exitSuccess - | view optShowVersion opts -> putStr versionTxt >> exitSuccess - | view optShowConfigFormat opts -> Text.putStr (generateDocs configurationSpec) >> exitSuccess - | null errors -> return opts - | otherwise -> reportErrors >> exitFailure + if | view optShowHelp opts -> putStr helpTxt >> exitSuccess + | view optShowFullVersion opts -> putStr fullVersionTxt >> exitSuccess + | view optShowVersion opts -> putStr versionTxt >> exitSuccess + | view optShowConfigFormat opts -> printConfigFormat >> exitSuccess + | null errors -> return opts + | otherwise -> reportErrors >> exitFailure + +printConfigFormat :: IO () +printConfigFormat = + do path <- getNewConfigPath + putStrLn "" + putStrLn ("Default configuration file path: " ++ path) + putStrLn "" + print (generateDocs configurationSpec) helpTxt :: String helpTxt = usageInfo "glirc2 [FLAGS] INITIAL_NETWORKS..." options diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -30,7 +30,6 @@ , clientScroll , clientDetailView , clientActivityBar - , clientShowMetadata , clientSubfocus , clientNextConnectionId , clientNetworkMap @@ -41,6 +40,8 @@ , clientRegex , clientLogQueue , clientActivityReturn + , clientErrorMsg + , clientLayout -- * Client operations , withClientState @@ -49,6 +50,7 @@ , clientPark , clientMatcher , clientActiveRegex + , clientToggleHideMeta , consumeInput , currentCompletionList @@ -103,7 +105,6 @@ import Client.Configuration import Client.Configuration.ServerSettings import Client.Image.Message -import Client.Image.PackedImage import Client.Image.Palette import Client.Log import Client.Message @@ -168,8 +169,8 @@ , _clientScroll :: !Int -- ^ buffer scroll lines , _clientDetailView :: !Bool -- ^ use detailed rendering mode , _clientActivityBar :: !Bool -- ^ visible activity bar - , _clientShowMetadata :: !Bool -- ^ visible activity bar , _clientRegex :: Maybe Regex -- ^ optional persistent filter + , _clientLayout :: !LayoutMode -- ^ layout mode for split screen , _clientBell :: !Bool -- ^ sound a bell next draw @@ -177,6 +178,7 @@ , _clientExtensions :: !ExtensionState -- ^ state of loaded extensions , _clientLogQueue :: ![LogLine] -- ^ log lines ready to write + , _clientErrorMsg :: Maybe Text -- ^ transient error box text } @@ -249,13 +251,14 @@ , _clientConfig = cfg , _clientScroll = 0 , _clientDetailView = False - , _clientShowMetadata = True , _clientRegex = Nothing + , _clientLayout = view configLayout cfg , _clientActivityBar = view configActivityBar cfg , _clientNextConnectionId = 0 , _clientBell = False , _clientExtensions = exts , _clientLogQueue = [] + , _clientErrorMsg = Nothing } withExtensionState :: (ExtensionState -> IO a) -> IO a @@ -410,6 +413,7 @@ ClientMessage -> ClientState -> ClientState recordIrcMessage network target msg st = + updateTransientError msg $ case target of TargetHidden -> st TargetNetwork -> recordNetworkMessage msg st @@ -452,9 +456,28 @@ . csChannels . ix channel . chanUsers . ix user + +-- | Detect /error/ messages and add the message text to the transient +-- error display. +updateTransientError :: ClientMessage -> ClientState -> ClientState +updateTransientError msg = + + let err = set clientErrorMsg . Just in + + case view msgBody msg of + ErrorBody txt -> err txt + IrcBody (Error txt) -> err txt + IrcBody (Reply code args) + | let info = replyCodeInfo code + , ErrorReply <- replyCodeType info -> + err (Text.intercalate " " (replyCodeText info : drop 1 args)) + _ -> id + + -- | Record a message on a network window recordNetworkMessage :: ClientMessage -> ClientState -> ClientState -recordNetworkMessage msg st = recordWindowLine focus wl st +recordNetworkMessage msg st = updateTransientError msg + $ recordWindowLine focus wl st where network = view msgNetwork msg focus | Text.null network = Unfocused @@ -464,6 +487,7 @@ cfg = view clientConfig st + -- | Record window line at the given focus creating the window if necessary recordWindowLine :: Focus -> @@ -472,8 +496,9 @@ ClientState recordWindowLine focus wl st = st2 where + freshWindow = emptyWindow { _winHideMeta = view (clientConfig . configHideMeta) st } st1 = over (clientWindows . at focus) - (\w -> Just $! addToWindow wl (fromMaybe emptyWindow w)) + (\w -> Just $! addToWindow wl (fromMaybe freshWindow w)) st st2 @@ -490,8 +515,8 @@ toWindowLine params importance msg = WindowLine { _wlSummary = msgSummary (view msgBody msg) , _wlText = msgText (view msgBody msg) - , _wlImage' = _Image' # mkImage NormalRender - , _wlFullImage' = _Image' # mkImage DetailedRender + , _wlImage = mkImage NormalRender + , _wlFullImage = mkImage DetailedRender , _wlImportance = importance , _wlTimestamp = zonedTimeToUTC (view msgTime msg) } @@ -859,7 +884,8 @@ ClientState {- ^ client state -} -> ClientState changeSubfocus focus - = set clientScroll 0 + = set clientErrorMsg Nothing + . set clientScroll 0 . set clientSubfocus focus -- | Return to previously focused window. @@ -946,3 +972,8 @@ [ network | (network, cfg) <- views (clientConfig . configServers) HashMap.toList st , view ssAutoconnect cfg ] + +-- | Toggle the /hide metadata/ setting for the focused window. +clientToggleHideMeta :: ClientState -> ClientState +clientToggleHideMeta st = + overStrict (clientWindows . ix (view clientFocus st) . winHideMeta) not st 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 @@ -51,6 +51,7 @@ | FocusPalette -- ^ Show current palette | FocusMentions -- ^ Show all mentions | FocusDigraphs -- ^ Show all digraphs + | FocusKeyMap -- ^ Show key bindings | FocusHelp (Maybe Text) -- ^ Show help window with optional command deriving (Eq,Show) 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 @@ -20,6 +20,7 @@ , winTotal , winMention , winMarker + , winHideMeta -- * Window lines , WindowLine(..) @@ -46,14 +47,13 @@ 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 { _wlSummary :: !IrcSummary -- ^ Summary value , _wlText :: {-# UNPACK #-} !Text -- ^ Searchable text form - , _wlImage' :: !Image' -- ^ Normal rendered image - , _wlFullImage' :: !Image' -- ^ Detailed rendered image + , _wlImage :: !Image' -- ^ Normal rendered image + , _wlFullImage :: !Image' -- ^ Detailed rendered image , _wlImportance :: !WindowLineImportance -- ^ Importance of message , _wlTimestamp :: {-# UNPACK #-} !UTCTime } @@ -70,6 +70,7 @@ , _winUnread :: !Int -- ^ Messages added since buffer was visible , _winTotal :: !Int -- ^ Messages in buffer , _winMention :: !WindowLineImportance -- ^ Indicates an important event is unread + , _winHideMeta :: !Bool -- ^ Hide metadata messages } data ActivityLevel = NoActivity | NormalActivity | HighActivity @@ -86,17 +87,6 @@ makeLenses ''WindowLine --- | Lens for the '_wlImage' field viewed in unpacked form. -wlImage :: Lens' WindowLine Image -wlImage = wlImage' . _Image' -{-# INLINE wlImage #-} - --- | Lens for the '_wlFullImage' field viewed in unpacked form. -wlFullImage :: Lens' WindowLine Image -wlFullImage = wlFullImage' . _Image' -{-# INLINE wlFullImage #-} - - -- | A window with no messages emptyWindow :: Window emptyWindow = Window @@ -105,6 +95,7 @@ , _winUnread = 0 , _winTotal = 0 , _winMention = WLBoring + , _winHideMeta = False } -- | Adds a given line to a window as the newest message. Window's @@ -118,6 +109,7 @@ then view winUnread win else view winUnread win + 1 , _winMention = max (view winMention win) (view wlImportance msg) + , _winHideMeta = view winHideMeta win } -- | Update the window clearing the unread count and important flag. diff --git a/src/Client/View.hs b/src/Client/View.hs --- a/src/Client/View.hs +++ b/src/Client/View.hs @@ -18,6 +18,7 @@ import Client.View.ChannelInfo import Client.View.Digraphs import Client.View.Help +import Client.View.KeyMap import Client.View.MaskList import Client.View.Mentions import Client.View.Messages @@ -28,8 +29,8 @@ import Control.Lens import Graphics.Vty.Image -viewLines :: Focus -> Subfocus -> ClientState -> [Image] -viewLines focus subfocus !st = +viewLines :: Focus -> Subfocus -> Int -> ClientState -> [Image] +viewLines focus subfocus w !st = case (focus, subfocus) of _ | Just ("url",arg) <- clientActiveCommand st -> urlSelectionView focus arg st @@ -39,12 +40,13 @@ | view clientDetailView st -> userInfoImages network channel st | otherwise -> userListImages network channel st (ChannelFocus network channel, FocusMasks mode) -> - maskListImages mode network channel st + maskListImages mode network channel w st (_, FocusWindows filt) -> windowsImages filt st - (_, FocusMentions) -> mentionsViewLines st + (_, FocusMentions) -> mentionsViewLines w st (_, FocusPalette) -> paletteViewLines pal - (_, FocusDigraphs) -> digraphLines st + (_, FocusDigraphs) -> digraphLines w st + (_, FocusKeyMap) -> keyMapLines st (_, FocusHelp mb) -> helpImageLines mb pal - _ -> chatMessageImages focus st + _ -> chatMessageImages focus w st where pal = clientPalette st diff --git a/src/Client/View/ChannelInfo.hs b/src/Client/View/ChannelInfo.hs --- a/src/Client/View/ChannelInfo.hs +++ b/src/Client/View/ChannelInfo.hs @@ -18,6 +18,7 @@ import Client.Image.Message import Client.Image.MircFormatting +import Client.Image.PackedImage (unpackImage) import Client.Image.Palette import Client.State import Client.State.Channel @@ -55,7 +56,8 @@ where label = text' (view palLabel pal) - topicLine = label "Topic: " <|> parseIrcText (view chanTopic channel) + topicLine = label "Topic: " <|> + unpackImage (parseIrcText (view chanTopic channel)) utcTimeImage = string defAttr . formatTime defaultTimeLocale "%F %T" @@ -65,7 +67,9 @@ Nothing -> [] Just !prov -> [ label "Topic set by: " <|> - coloredUserInfo pal DetailedRender myNicks (view topicAuthor prov) + unpackImage + (coloredUserInfo + pal DetailedRender myNicks (view topicAuthor prov)) , label "Topic set on: " <|> utcTimeImage (view topicTime prov) ] @@ -77,5 +81,5 @@ urlLines = case view chanUrl channel of Nothing -> [] - Just url -> [ label "Channel URL: " <|> parseIrcText url ] + Just url -> [ label "Channel URL: " <|> unpackImage (parseIrcText url) ] diff --git a/src/Client/View/Digraphs.hs b/src/Client/View/Digraphs.hs --- a/src/Client/View/Digraphs.hs +++ b/src/Client/View/Digraphs.hs @@ -6,14 +6,13 @@ License : ISC Maintainer : emertens@gmail.com -This module provides an view of the built-in digraph list. +This module provides a view of the built-in digraph list. -} module Client.View.Digraphs (digraphLines) where import Client.Image.Message (cleanChar) import Client.State -import Control.Lens import Data.List import Data.List.Split import qualified Data.Text as Text @@ -23,9 +22,10 @@ -- | Render the lines of a table showing all of the available digraph entries digraphLines :: + Int {- ^ draw width -} -> ClientState {- ^ client state -} -> [Image] {- ^ output lines -} -digraphLines st +digraphLines w st = map (horizCat . intersperse sep) $ chunksOf entriesPerLine $ map (text' defAttr) @@ -33,7 +33,6 @@ $ map (Text.pack . drawEntry) $ digraphListToList digraphs where - w = view clientWidth st matcher = maybe id filter (clientMatcher st) entriesPerLine = max 1 -- just in case? $ (w + sepWidth) `quot` (entryWidth + sepWidth) diff --git a/src/Client/View/Help.hs b/src/Client/View/Help.hs --- a/src/Client/View/Help.hs +++ b/src/Client/View/Help.hs @@ -18,6 +18,7 @@ import Client.Commands.Arguments import Client.Image.Arguments import Client.Image.MircFormatting +import Client.Image.PackedImage import Client.Image.Palette import Client.Commands.Recognizer import Control.Lens @@ -28,7 +29,7 @@ import Data.Text (Text) import qualified Data.Text as Text import Graphics.Vty.Attributes -import Graphics.Vty.Image +import Graphics.Vty.Image (Image) -- | Generate either the list of all commands and their arguments, -- or when given a command name generate the detailed help text @@ -37,16 +38,16 @@ Maybe Text {- ^ optional command name -} -> Palette {- ^ palette -} -> [Image] {- ^ help lines -} -helpImageLines mbCmd pal = +helpImageLines mbCmd pal = map unpackImage $ 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 -} + Text {- ^ command name -} -> + Palette {- ^ palette -} -> + [Image'] {- ^ lines -} commandHelpLines cmdName pal = case recognize cmdName commands of Invalid -> [string (view palError pal) "Unknown command, try /help"] @@ -73,7 +74,7 @@ -- implementation will be valid. explainContext :: CommandImpl a {- ^ command implementation -} -> - Image {- ^ help line -} + Image' {- ^ help line -} explainContext impl = case impl of ClientCommand {} -> go "client command" "works everywhere" @@ -81,13 +82,13 @@ 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 <|> + 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 -} + Palette {- ^ palette -} -> + [Image'] {- ^ help lines -} listAllCommands pal = intercalate [emptyLine] $ map reverse @@ -96,7 +97,7 @@ listCommandSection :: Palette {- ^ palette -} -> CommandSection {- ^ command section -} -> - [Image] {- ^ help lines -} + [Image'] {- ^ help lines -} listCommandSection pal sec = text' (withStyle defAttr bold) (cmdSectionName sec) : [ commandSummary pal names spec @@ -112,15 +113,15 @@ Palette {- ^ palette -} -> NonEmpty Text {- ^ command name and aliases -} -> ArgumentSpec a {- ^ argument specification -} -> - Image {- ^ summary help line -} + Image' {- ^ summary help line -} commandSummary pal (cmd :| _) args = - char defAttr '/' <|> - text' (view palCommand pal) cmd <|> + char defAttr '/' <> + text' (view palCommand pal) cmd <> argumentsImage pal' args "" where pal' = set palCommandPlaceholder defAttr pal -- Empty line used as a separator -emptyLine :: Image -emptyLine = text' defAttr " " +emptyLine :: Image' +emptyLine = char defAttr ' ' diff --git a/src/Client/View/KeyMap.hs b/src/Client/View/KeyMap.hs new file mode 100644 --- /dev/null +++ b/src/Client/View/KeyMap.hs @@ -0,0 +1,47 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.View.KeyMap +Description : List of the current key map +Copyright : (c) Eric Mertens, 2017 +License : ISC +Maintainer : emertens@gmail.com + +This module provides a view of the key bindings map + +-} +module Client.View.KeyMap (keyMapLines) where + +import Client.Configuration +import Client.EventLoop.Actions +import Client.State +import Control.Lens +import Data.List +import Data.Ord +import Graphics.Vty.Attributes +import Graphics.Vty.Image +import Graphics.Vty.Input + +-- | Render the lines of a table showing all of the available digraph entries +keyMapLines :: + ClientState {- ^ client state -} -> + [Image] {- ^ output lines -} +keyMapLines + = renderEntries + . keyMapEntries + . view (clientConfig . configKeyMap) + +renderEntries :: [([Modifier], Key, Action)] -> [Image] +renderEntries entries = + [ resizeWidth keyColWidth key <|> act | (key,act) <- images ] + + where + third (_,_,x) = x + + images = + [ ( string defAttr (prettyModifierKey mods key) + , text' defAttr (actionName act ) + ) + | (mods,key,act) <- sortBy (comparing third) entries + ] + + keyColWidth = 1 + maximum (0 : map (imageWidth . fst) images) diff --git a/src/Client/View/MaskList.hs b/src/Client/View/MaskList.hs --- a/src/Client/View/MaskList.hs +++ b/src/Client/View/MaskList.hs @@ -31,14 +31,15 @@ -- | Render the lines used in a channel mask list maskListImages :: - Char {- ^ Mask mode -} -> - Text {- ^ network -} -> - Identifier {- ^ channel -} -> + Char {- ^ Mask mode -} -> + Text {- ^ network -} -> + Identifier {- ^ channel -} -> + Int {- ^ draw width -} -> ClientState -> [Image] -maskListImages mode network channel st = +maskListImages mode network channel w st = case mbEntries of Nothing -> [text' (view palError pal) "Mask list not loaded"] - Just entries -> maskListImages' entries st + Just entries -> maskListImages' entries w st where pal = clientPalette st @@ -48,8 +49,8 @@ . chanLists . ix mode ) st -maskListImages' :: HashMap Text MaskListEntry -> ClientState -> [Image] -maskListImages' entries st = countImage : images +maskListImages' :: HashMap Text MaskListEntry -> Int -> ClientState -> [Image] +maskListImages' entries w st = countImage : images where pal = clientPalette st @@ -72,7 +73,7 @@ maskImages = text' defAttr <$> masks maskColumnWidth = maximum (imageWidth <$> maskImages) + 1 paddedMaskImages = resizeWidth maskColumnWidth <$> maskImages - width = max 1 (view clientWidth st) + width = max 1 w images = [ cropLine $ mask <|> text' defAttr who <|> diff --git a/src/Client/View/Mentions.hs b/src/Client/View/Mentions.hs --- a/src/Client/View/Mentions.hs +++ b/src/Client/View/Mentions.hs @@ -14,6 +14,7 @@ ( mentionsViewLines ) where +import Client.Image.PackedImage (Image', unpackImage) import Client.Image.StatusLine import Client.State import Client.State.Focus @@ -26,8 +27,8 @@ -- | 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 st entries +mentionsViewLines :: Int -> ClientState -> [Image] +mentionsViewLines w st = addMarkers w st entries where names = clientWindowNames st ++ repeat '?' @@ -43,18 +44,19 @@ { mlTimestamp :: UTCTime , mlWindowName :: Char , mlFocus :: Focus - , mlImage :: Image + , mlImage :: Image' } addMarkers :: + Int {- ^ draw width -} -> ClientState {- ^ client state -} -> [MentionLine] {- ^ list of mentions in time order -} -> [Image] {- ^ mention images and channel labels -} -addMarkers _ [] = [] -addMarkers !st (!ml : xs) - = map mlImage (ml:same) - ++ minorStatusLineImage (mlFocus ml) st - : addMarkers st rest +addMarkers _ _ [] = [] +addMarkers w !st (!ml : xs) + = map (unpackImage . mlImage) (ml:same) + ++ minorStatusLineImage (mlFocus ml) w False st + : addMarkers w st rest where isSame ml' = mlFocus ml == mlFocus ml' diff --git a/src/Client/View/Messages.hs b/src/Client/View/Messages.hs --- a/src/Client/View/Messages.hs +++ b/src/Client/View/Messages.hs @@ -15,9 +15,10 @@ ) where import Client.Configuration +import Client.Image.LineWrap import Client.Image.Message +import Client.Image.PackedImage import Client.Image.Palette -import Client.Image.Utils import Client.Message import Client.State import Client.State.Focus @@ -25,111 +26,135 @@ import Client.State.Window import Control.Lens import Control.Monad +import Data.Semigroup import Graphics.Vty.Attributes -import Graphics.Vty.Image +import qualified Graphics.Vty.Image as Vty import Irc.Identifier import Irc.Message -chatMessageImages :: Focus -> ClientState -> [Image] -chatMessageImages focus st = +chatMessageImages :: Focus -> Int -> ClientState -> [Vty.Image] +chatMessageImages focus w st = case preview (clientWindows . ix focus) st of Nothing -> [] Just win -> - let msgs = toListOf each (view winMessages win) in + let msgs = toListOf each (view winMessages win) + hideMeta = view winHideMeta win in case clientMatcher st of - Just matcher -> windowLineProcessor (filter (views wlText matcher) msgs) + Just matcher -> windowLineProcessor hideMeta (filter (views wlText matcher) msgs) Nothing -> case view winMarker win of - Nothing -> windowLineProcessor msgs + Nothing -> windowLineProcessor hideMeta msgs Just n -> - windowLineProcessor l ++ + windowLineProcessor hideMeta l ++ [marker] ++ - windowLineProcessor r + windowLineProcessor hideMeta r where (l,r) = splitAt n msgs where palette = clientPalette st - marker = string (view palLineMarker palette) (replicate (view clientWidth st) '-') - windowLineProcessor + marker = Vty.string (view palLineMarker palette) (replicate w '-') + windowLineProcessor hideMeta | view clientDetailView st = - if view clientShowMetadata st - then map (view wlFullImage) - else detailedImagesWithoutMetadata st + if hideMeta + then detailedImagesWithoutMetadata st + else map (views wlFullImage unpackImage) - | otherwise = windowLinesToImages st . filter (not . isNoisy) + | otherwise = windowLinesToImages st w hideMeta . filter (not . isNoisy) isNoisy msg = case view wlSummary msg of ReplySummary code -> squelchIrcMsg (Reply code []) _ -> False -detailedImagesWithoutMetadata :: ClientState -> [WindowLine] -> [Image] +detailedImagesWithoutMetadata :: ClientState -> [WindowLine] -> [Vty.Image] detailedImagesWithoutMetadata st wwls = case gatherMetadataLines st wwls of ([], []) -> [] - ([], w:ws) -> view wlFullImage w : detailedImagesWithoutMetadata st ws + ([], w:ws) -> views wlFullImage unpackImage w + : detailedImagesWithoutMetadata st ws (_:_, wls) -> detailedImagesWithoutMetadata st wls -windowLinesToImages :: ClientState -> [WindowLine] -> [Image] -windowLinesToImages st wwls = + +windowLinesToImages :: + ClientState {- ^ client state -} -> + Int {- ^ draw width -} -> + Bool {- ^ hide metadata -} -> + [WindowLine] {- ^ window lines -} -> + [Vty.Image] {- ^ image lines -} +windowLinesToImages st w hideMeta wwls = case gatherMetadataLines st wwls of ([], []) -> [] - ([], w:ws) -> lineWrap (view clientWidth st) + ([], wl:wls) -> + map unpackImage + (lineWrapChat w (view (clientConfig . configIndentWrapped) st) - (view wlImage w) - : windowLinesToImages st ws + (view wlImage wl)) + ++ windowLinesToImages st w hideMeta wls ((img,who,mbnext):mds, wls) - | view clientShowMetadata st -> - startMetadata img mbnext who mds palette - : windowLinesToImages st wls + | hideMeta -> windowLinesToImages st w hideMeta wls - | otherwise -> windowLinesToImages st wls + | otherwise -> + mkLines w (startMetadata img mbnext who mds palette) + ++ windowLinesToImages st w hideMeta wls + where palette = clientPalette st +mkLines :: Int -> [Vty.Image] -> [Vty.Image] +mkLines _ [] = [] +mkLines w (x:xs) = reverse (mkLines1 w x xs) + +mkLines1 :: Int -> Vty.Image -> [Vty.Image] -> [Vty.Image] +mkLines1 _ x [] = [x] +mkLines1 w x (y:ys) + | Vty.imageWidth x' <= w = mkLines1 w x' ys + | otherwise = x : mkLines1 w y ys + where + x' = x Vty.<|> Vty.char defAttr ' ' Vty.<|> y + ------------------------------------------------------------------------ type MetadataState = - Identifier {- ^ current nick -} -> - [(Image,Identifier,Maybe Identifier)] {- ^ metadata -} -> - Palette {- ^ palette -} -> - Image + Identifier {- ^ current nick -} -> + [(Image',Identifier,Maybe Identifier)] {- ^ metadata -} -> + Palette {- ^ palette -} -> + [Vty.Image] startMetadata :: - Image {- ^ metadata image -} -> + Image' {- ^ metadata image -} -> Maybe Identifier {- ^ possible nick transition -} -> MetadataState startMetadata img mbnext who mds palette = - quietIdentifier palette who - <|> img - <|> transitionMetadata mbnext who mds palette + let acc = unpackImage (quietIdentifier palette who <> img) + in transitionMetadata acc mbnext who mds palette transitionMetadata :: + Vty.Image -> Maybe Identifier {- ^ possible nick transition -} -> MetadataState -transitionMetadata mbwho who mds palette = +transitionMetadata acc mbwho who mds palette = case mbwho of - Nothing -> continueMetadata who mds palette - Just who' -> quietIdentifier palette who' - <|> continueMetadata who' mds palette + Nothing -> continueMetadata acc who mds palette + Just who' -> + let acc' = acc Vty.<|> unpackImage (quietIdentifier palette who') + in continueMetadata acc' 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 +continueMetadata :: Vty.Image -> MetadataState +continueMetadata acc _ [] _ = [acc] +continueMetadata acc who1 ((img, who2, mbwho3):mds) palette + | who1 == who2 = let acc' = acc Vty.<|> unpackImage img + in transitionMetadata acc' mbwho3 who2 mds palette + | otherwise = acc : startMetadata img mbwho3 who2 mds palette ------------------------------------------------------------------------ gatherMetadataLines :: ClientState -> [WindowLine] -> - ( [(Image, Identifier, Maybe Identifier)] , [ WindowLine ] ) + ( [(Image', Identifier, Maybe Identifier)] , [ WindowLine ] ) -- ^ metadata entries are reversed gatherMetadataLines st = go [] where @@ -144,7 +169,7 @@ metadataWindowLine :: ClientState -> WindowLine -> - Maybe (Image, Identifier, Maybe Identifier) + Maybe (Image', Identifier, Maybe Identifier) {- ^ Image, incoming identifier, outgoing identifier if changed -} metadataWindowLine st wl = case view wlSummary wl of diff --git a/src/Client/View/UrlSelection.hs b/src/Client/View/UrlSelection.hs --- a/src/Client/View/UrlSelection.hs +++ b/src/Client/View/UrlSelection.hs @@ -15,6 +15,7 @@ import Client.Configuration import Client.Image.Message +import Client.Image.PackedImage (unpackImage) import Client.Image.Palette import Client.Message import Client.State @@ -84,8 +85,9 @@ (Maybe Identifier, Text) {- ^ sender and url text -} -> Image {- ^ rendered line -} draw me pal padding selected i (who,url) = - rightPad NormalRender padding - (foldMap (coloredIdentifier pal NormalIdentifier me) who) <|> + unpackImage + (rightPad NormalRender padding + (foldMap (coloredIdentifier pal NormalIdentifier me) who)) <|> string defAttr ": " <|> string attr (shows i ". ") <|> text' attr (cleanText url) diff --git a/src/Client/View/UserList.hs b/src/Client/View/UserList.hs --- a/src/Client/View/UserList.hs +++ b/src/Client/View/UserList.hs @@ -14,6 +14,7 @@ ) where import Client.Image.Message +import Client.Image.PackedImage (unpackImage) import Client.Image.Palette import Client.State import Client.State.Channel @@ -59,7 +60,7 @@ renderUser (ident, sigils) = string (view palSigil pal) sigils <|> - coloredIdentifier pal NormalIdentifier myNicks ident + unpackImage (coloredIdentifier pal NormalIdentifier myNicks ident) gap = char defAttr ' ' @@ -109,7 +110,7 @@ renderEntry (info, sigils) = string (view palSigil pal) sigils <|> - coloredUserInfo pal DetailedRender myNicks info + unpackImage (coloredUserInfo pal DetailedRender myNicks info) matcher' (info,sigils) = matcher (Text.pack sigils `Text.append` renderUserInfo info)