glirc 2.20.6 → 2.21

raw patch · 36 files changed

+1698/−892 lines, 36 filesdep ~config-schemadep ~config-valuedep ~semigroupoidsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: config-schema, config-value, semigroupoids

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−0
• exec/Main.hs +4/−4
• glirc.cabal +10/−5
• src/Client/Commands.hs +165/−64
• src/Client/Commands/Recognizer.hs +4/−1
• src/Client/Configuration.hs +136/−161
• src/Client/Configuration/Colors.hs +3/−4
• src/Client/Configuration/Macros.hs +38/−0
• src/Client/Configuration/ServerSettings.hs +129/−5
• src/Client/EventLoop.hs +63/−68
• src/Client/EventLoop/Actions.hs +293/−0
• src/Client/EventLoop/Errors.hs +1/−1
• src/Client/Image.hs +3/−88
• src/Client/Image/Arguments.hs +13/−12
• src/Client/Image/Layout.hs +191/−0
• src/Client/Image/LineWrap.hs +103/−0
• src/Client/Image/Message.hs +113/−112
• src/Client/Image/MircFormatting.hs +18/−18
• src/Client/Image/PackedImage.hs +64/−81
• src/Client/Image/StatusLine.hs +56/−34
• src/Client/Image/Textbox.hs +42/−42
• src/Client/Image/Utils.hs +0/−67
• src/Client/Options.hs +14/−7
• src/Client/State.hs +40/−9
• src/Client/State/Focus.hs +1/−0
• src/Client/State/Window.hs +6/−14
• src/Client/View.hs +8/−6
• src/Client/View/ChannelInfo.hs +7/−3
• src/Client/View/Digraphs.hs +3/−4
• src/Client/View/Help.hs +16/−15
• src/Client/View/KeyMap.hs +47/−0
• src/Client/View/MaskList.hs +9/−8
• src/Client/View/Mentions.hs +10/−8
• src/Client/View/Messages.hs +72/−47
• src/Client/View/UrlSelection.hs +4/−2
• src/Client/View/UserList.hs +3/−2

@@ -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.

@@ -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

@@ -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,

@@ -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 =

@@ -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

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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) :| []

@@ -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

@@ -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 ' '

@@ -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

@@ -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

@@ -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'

@@ -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

@@ -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

@@ -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

@@ -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)-

@@ -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

@@ -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

@@ -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

@@ -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) 

@@ -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.

@@ -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

@@ -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) ] 

@@ -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)

@@ -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 ' '

@@ -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)

@@ -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 <|>

@@ -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' 

@@ -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

@@ -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)

@@ -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)