glirc-2.38: src/Client/Commands/Window.hs
{-# Language OverloadedStrings #-}
{-|
Module : Client.Commands.Window
Description : Window command implementations
Copyright : (c) Eric Mertens, 2016-2020
License : ISC
Maintainer : emertens@gmail.com
-}
module Client.Commands.Window (windowCommands, parseFocus) where
import Client.Commands.Arguments.Spec
import Client.Commands.TabCompletion
import Client.Commands.Types
import Client.Commands.WordCompletion
import Client.Mask (buildMask)
import Client.State
import Client.State.Focus
import Client.State.Network
import Client.State.Window (windowClear, wlText, winMessages, winHidden, winSilent, winName)
import Control.Applicative
import Control.Exception
import Control.Lens
import Data.Foldable
import Data.List ((\\), nub)
import qualified Client.State.EditBox as Edit
import Data.HashSet (HashSet)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.IO as LText
import Irc.Identifier
windowCommands :: CommandSection
windowCommands = CommandSection "Window management"
------------------------------------------------------------------------
[ Command
(pure "focus")
(liftA2 (,) (simpleToken "network") (optionalArg (simpleToken "[target]")))
"Change the focused window.\n\
\\n\
\When only \^Bnetwork\^B is specified this switches to the network status window.\n\
\When \^Bnetwork\^B and \^Btarget\^B are specified this switches to that chat window.\n\
\\n\
\Nickname and channels can be specified in the \^Btarget\^B parameter.\n\
\See also: /query (aliased /c /channel) to switch to a target on the current network.\n"
$ ClientCommand cmdFocus tabFocus
, Command
("c" :| ["channel"])
(simpleToken "focus")
"\^BParameters:\^B\n\
\\n\
\ focuses: Focus name\n\
\\n\
\\^BDescription:\^B\n\
\\n\
\ This command sets the current window focus. When\n\
\ no network is specified, the current network will\n\
\ be used.\n\
\\n\
\ Client: *\n\
\ Network: \^_network\^_:\n\
\ Channel: \^_#channel\^_\n\
\ Channel: \^_network\^_:\^_#channel\^_\n\
\ User: \^_nick\^_\n\
\ User: \^_network\^_:\^_nick\^_\n\
\\n\
\\^BExamples:\^B\n\
\\n\
\ /c fn:#haskell\n\
\ /c #haskell\n\
\ /c fn:\n\
\ /c *:\n\
\\n\
\\^BSee also:\^B focus\n"
$ ClientCommand cmdChannel tabChannel
, Command
(pure "clear")
(optionalArg (liftA2 (,) (simpleToken "[network]") (optionalArg (simpleToken "[channel]"))))
"Clear a window.\n\
\\n\
\If no arguments are provided the current window is cleared.\n\
\If \^Bnetwork\^B is provided the that network window is cleared.\n\
\If \^Bnetwork\^B and \^Bchannel\^B are provided that chat window is cleared.\n\
\If \^Bnetwork\^B is provided and \^Bchannel\^B is \^B*\^O all windows for that network are cleared.\n\
\\n\
\If a window is cleared and no longer active that window will be removed from the client.\n"
$ ClientCommand cmdClear tabFocus
, Command
(pure "windows")
(optionalArg (simpleToken "[kind]"))
"Show a list of all windows with an optional argument to limit the kinds of windows listed.\n\
\\n\
\\^Bkind\^O: one of \^Bnetworks\^O, \^Bchannels\^O, \^Busers\^O\n\
\\n"
$ ClientCommand cmdWindows tabWindows
, Command
(pure "splits")
(remainingArg "focuses")
"\^BParameters:\^B\n\
\\n\
\ focuses: List of focus names\n\
\\n\
\\^BDescription:\^B\n\
\\n\
\ This command sents the set of focuses that will always\n\
\ be visible, even when unfocused. When the client is focused\n\
\ to an active network, the network can be omitted when\n\
\ specifying a focus. If no focuses are listed, they will\n\
\ all be cleared.\n\
\\n\
\ Client: *\n\
\ Network: \^_network\^_:\n\
\ Channel: \^_#channel\^_\n\
\ Channel: \^_network\^_:\^_#channel\^_\n\
\ User: \^_nick\^_\n\
\ User: \^_network\^_:\^_nick\^_\n\
\\n\
\\^BExamples:\^B\n\
\\n\
\ /splits * fn:#haskell fn:chanserv\n\
\ /splits #haskell #haskell-lens nickserv\n\
\ /splits\n\
\\n\
\\^BSee also:\^B splits+, splits-\n"
$ ClientCommand cmdSplits tabSplits
, Command
(pure "splits+")
(remainingArg "focuses")
"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\
\\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. 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\
\\n\
\If the network part is omitted, the current network will be used.\n"
$ ClientCommand cmdSplitsDel tabActiveSplits
, Command
(pure "ignore")
(remainingArg "masks")
"\^BParameters:\^B\n\
\\n\
\ masks: List of masks\n\
\\n\
\\^BDescription:\^B\n\
\\n\
\ Toggle the soft-ignore on each of the space-delimited given\n\
\ nicknames. Ignores can use \^B*\^B (many) and \^B?\^B (one) wildcards.\n\
\ Masks can be of the form: nick[[!user]@host]\n\
\ Masks use a case-insensitive comparison.\n\
\\n\
\ If no masks are specified the current ignore list is displayed.\n\
\\n\
\\^BExamples:\^B\n\
\\n\
\ /ignore\n\
\ /ignore nick1 nick2 nick3\n\
\ /ignore nick@host\n\
\ /ignore nick!user@host\n\
\ /ignore *@host\n\
\ /ignore *!baduser@*\n"
$ ClientCommand cmdIgnore tabIgnore
, Command
(pure "grep")
(remainingArg "regular-expression")
"Set the persistent regular expression.\n\
\\n\
\\^BFlags:\^B\n\
\ -A n Show n messages after match\n\
\ -B n Show n messages before match\n\
\ -C n Show n messages before and after match\n\
\ -F Use plain-text match instead of regular expression\n\
\ -i Case insensitive match\n\
\ -v Invert pattern match\n\
\ -m n Limit results to n matches\n\
\ -- Stop processing flags\n\
\\n\
\Clear the regular expression by calling this without an argument.\n\
\\n\
\\^B/grep\^O is case-sensitive.\n"
$ ClientCommand cmdGrep simpleClientTab
, Command
(pure "dump")
(simpleToken "filename")
"Dump current buffer to file.\n"
$ ClientCommand cmdDump simpleClientTab
, Command
(pure "mentions")
(pure ())
"Show a list of all message that were highlighted as important.\n\
\\n\
\When using \^B/grep\^B the important messages are those matching\n\
\the regular expression instead.\n"
$ ClientCommand cmdMentions noClientTab
, Command
(pure "setwindow")
(simpleToken "hide|show|loud|silent")
"Set window property.\n\
\\n\
\\^Bloud\^B / \^Bsilent\^B\n\
\ Toggles if window activity appears in the status bar.\n\
\n\
\\^Bshow\^B / \^Bhide\^B\n\
\ Toggles if window appears in window command shortcuts.\n"
$ ClientCommand cmdSetWindow tabSetWindow
, Command
(pure "setname")
(optionalArg (simpleToken "[letter]"))
"Set window shortcut letter. If no letter is provided the next available\n\
\letter will automatically be assigned.\n\
\\n\
\Available letters are configured in the 'window-names' configuration setting.\n"
$ ClientCommand cmdSetWindowName noClientTab
]
cmdSetWindowName :: ClientCommand (Maybe String)
cmdSetWindowName st arg =
-- unset current name so that it becomes available
let mbSt1 = failover (clientWindows . ix (view clientFocus st) . winName) (\_ -> Nothing) st in
case mbSt1 of
Nothing -> commandFailureMsg "no current window" st
Just st1 ->
let next = clientNextWindowName st
mbName =
case arg of
Just [n] | n `elem` clientWindowNames st -> Right n
Just _ -> Left "invalid name"
Nothing
| next /= '\0' -> Right next
| otherwise -> Left "no free names" in
case mbName of
Left e -> commandFailureMsg e st
Right name ->
let unset n = if n == Just name then Nothing else n in
commandSuccess
$ set (clientWindows . ix (view clientFocus st) . winName) (Just name)
$ over (clientWindows . each . winName) unset
$ st1
cmdSetWindow :: ClientCommand String
cmdSetWindow st cmd =
case mbFun of
Nothing -> commandFailureMsg "bad window setting" st
Just f ->
case failover (clientWindows . ix (view clientFocus st)) f st of
Nothing -> commandFailureMsg "no such window" st
Just st' -> commandSuccess st'
where
mbFun =
case cmd of
"show" -> Just (set winHidden False)
"hide" -> Just (set winName Nothing . set winHidden True)
"loud" -> Just (set winSilent False)
"silent" -> Just (set winSilent True)
_ -> Nothing
tabSetWindow :: Bool {- ^ reversed -} -> ClientCommand String
tabSetWindow isReversed st _ =
simpleTabCompletion plainWordCompleteMode [] completions isReversed st
where
completions = ["hide", "show", "loud", "silent"] :: [Text]
-- | Implementation of @/grep@
cmdGrep :: ClientCommand String
cmdGrep st str
| null str = commandSuccess (set clientRegex Nothing st)
| otherwise =
case buildMatcher str of
Nothing -> commandFailureMsg "bad grep" st
Just r -> commandSuccess (set clientRegex (Just r) st)
-- | Implementation of @/windows@ command. Set subfocus to Windows.
cmdWindows :: ClientCommand (Maybe String)
cmdWindows st arg =
case arg of
Nothing -> success AllWindows
Just "networks" -> success NetworkWindows
Just "channels" -> success ChannelWindows
Just "users" -> success UserWindows
_ -> commandFailureMsg errmsg st
where
errmsg = "/windows expected networks, channels, or users"
success x =
commandSuccess (changeSubfocus (FocusWindows x) st)
-- | Implementation of @/mentions@ command. Set subfocus to Mentions.
cmdMentions :: ClientCommand ()
cmdMentions st _ = commandSuccess (changeSubfocus FocusMentions st)
cmdIgnore :: ClientCommand String
cmdIgnore st rest =
case mkId <$> Text.words (Text.pack rest) of
[] -> commandSuccess (changeSubfocus FocusIgnoreList st)
xs -> commandSuccess st2
where
(newIgnores, st1) = (clientIgnores <%~ updateIgnores) st
st2 = set clientIgnoreMask (buildMask (toList newIgnores)) st1
updateIgnores :: HashSet Identifier -> HashSet Identifier
updateIgnores s = foldl' updateIgnore s xs
updateIgnore s x = over (contains x) not s
-- | Complete the nickname at the current cursor position using the
-- userlist for the currently focused channel (if any)
tabIgnore :: Bool {- ^ reversed -} -> ClientCommand String
tabIgnore isReversed st _ =
simpleTabCompletion mode hint completions isReversed st
where
hint = activeNicks st
completions = currentCompletionList st ++ views clientIgnores toList st
mode = currentNickCompletionMode st
-- | Implementation of @/splits@
cmdSplits :: ClientCommand String
cmdSplits st str =
withSplitFocuses st str $ \args ->
commandSuccess (setExtraFocus (nub args) st)
-- | Implementation of @/splits+@. When no focuses are provided
-- the current focus is used instead.
cmdSplitsAdd :: ClientCommand String
cmdSplitsAdd st str =
withSplitFocuses st str $ \args ->
let args'
| null args = [(view clientFocus st, view clientSubfocus st)]
| otherwise = args
extras = nub (args' ++ view clientExtraFocus st)
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 =
withSplitFocuses st str $ \args ->
let args'
| null args = [(view clientFocus st, view clientSubfocus st)]
| otherwise = args
extras = view clientExtraFocus st \\ args'
in commandSuccess (setExtraFocus extras st)
withSplitFocuses ::
ClientState ->
String ->
([(Focus, Subfocus)] -> IO CommandResult) ->
IO CommandResult
withSplitFocuses st str k =
case mb of
Nothing -> commandFailureMsg "unable to parse arguments" st
Just args -> k [(x, FocusMessages) | x <- args]
where
mb = traverse
(parseFocus (views clientFocus focusNetwork st))
(words str)
-- | Parses a single focus name given a default network.
parseFocus ::
Maybe Text {- ^ default network -} ->
String {- ^ @[network:]target@ -} ->
Maybe Focus
parseFocus mbNet x =
case break (==':') x of
("*","") -> pure Unfocused
(net,_:"") -> pure (NetworkFocus (Text.pack net))
(net,_:chan) -> pure (ChannelFocus (Text.pack net) (mkId (Text.pack chan)))
(chan,"") -> mbNet <&> \net ->
ChannelFocus net (mkId (Text.pack chan))
cmdFocus :: ClientCommand (String, Maybe String)
cmdFocus st (network, mbChannel)
| network == "*" = commandSuccess (changeFocus Unfocused st)
| otherwise =
case mbChannel of
Nothing ->
let focus = NetworkFocus (Text.pack network) in
commandSuccess (changeFocus focus st)
Just channel ->
let focus = ChannelFocus (Text.pack network) (mkId (Text.pack channel)) in
commandSuccess
$ changeFocus focus st
tabWindows :: Bool -> ClientCommand String
tabWindows isReversed st _ =
simpleTabCompletion plainWordCompleteMode [] completions isReversed st
where
completions = ["networks","channels","users"] :: [Text]
-- | Tab completion for @/splits-@. This completes only from the list of active
-- entries in the splits list.
tabActiveSplits :: Bool -> ClientCommand String
tabActiveSplits isReversed st _ =
simpleTabCompletion plainWordCompleteMode [] completions isReversed st
where
completions = currentNetSplits <> currentSplits
currentSplits = [renderSplitFocus x | (x, FocusMessages) <- view clientExtraFocus st]
currentNetSplits =
[ idText chan
| (ChannelFocus net chan, FocusMessages) <- view clientExtraFocus st
, views clientFocus focusNetwork st == Just net
]
-- | 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
-- user is not joined to this command will delete the window.
cmdClear :: ClientCommand (Maybe (String, Maybe String))
cmdClear st args =
case args of
Nothing -> clearFocus (view clientFocus st)
Just ("*", Nothing ) -> clearFocus Unfocused
Just (network, Nothing ) -> clearFocus (NetworkFocus (Text.pack network))
Just (network, Just "*" ) -> clearNetworkWindows network
Just (network, Just channel) -> clearFocus (ChannelFocus (Text.pack network) (mkId (Text.pack channel)))
where
clearNetworkWindows network
= commandSuccess
$ foldl' (flip clearFocus1) st
$ filter (\x -> focusNetwork x == Just (Text.pack network))
$ views clientWindows Map.keys st
clearFocus focus = commandSuccess (clearFocus1 focus st)
clearFocus1 focus st' = focusEffect (windowEffect st')
where
windowEffect = over (clientWindows . at focus)
(if isActive then fmap windowClear else const Nothing)
focusEffect
| noChangeNeeded = id
| prevExists = changeFocus prev
| otherwise = advanceFocus
where
noChangeNeeded = isActive || view clientFocus st' /= focus
prevExists = has (clientWindows . ix prev) st'
prev = view clientPrevFocus st
isActive =
case focus of
Unfocused -> False
NetworkFocus network -> has (clientConnection network) st'
ChannelFocus network channel -> has (clientConnection network
.csChannels . ix channel) st'
-- | Tab completion for @/splits[+]@. When given no arguments this
-- populates the current list of splits, otherwise it tab completes
-- all of the currently available windows.
tabSplits :: Bool -> ClientCommand String
tabSplits isReversed st rest
-- If no arguments, populate the current splits
| all (' '==) rest =
let cmd = unwords $ "/splits"
: [Text.unpack (renderSplitFocus x) | (x, FocusMessages) <- 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 =
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
-- | Render a entry from splits back to the textual format.
renderSplitFocus :: Focus -> Text
renderSplitFocus Unfocused = "*"
renderSplitFocus (NetworkFocus x) = x <> ":"
renderSplitFocus (ChannelFocus x y) = x <> ":" <> idText y
-- | When tab completing the first parameter of the focus command
-- the current networks are used.
tabFocus :: Bool -> ClientCommand String
tabFocus isReversed st _ =
simpleTabCompletion plainWordCompleteMode [] completions isReversed st
where
networks = map mkId $ HashMap.keys $ view clientConnections st
params = words $ uncurry take $ clientLine st
completions =
case params of
[_cmd,_net] -> networks
[_cmd,net,_chan] -> channelWindowsOnNetwork (Text.pack net) st
_ -> []
-- | @/channel@ command. Takes a channel or nickname and switches
-- focus to that target on the current network.
cmdChannel :: ClientCommand String
cmdChannel st channel =
case parseFocus (views clientFocus focusNetwork st) channel of
Just focus -> commandSuccess (changeFocus focus st)
Nothing -> commandFailureMsg "No current network" st
-- | Tab completion for @/channel@. Tab completion uses pre-existing
-- windows.
tabChannel ::
Bool {- ^ reversed order -} ->
ClientCommand String
tabChannel isReversed st _ =
simpleTabCompletion plainWordCompleteMode [] completions isReversed st
where
completions = currentNet <> allWindows
allWindows = renderSplitFocus <$> views clientWindows Map.keys st
currentNet = case views clientFocus focusNetwork st of
Just net -> idText <$> channelWindowsOnNetwork net st
Nothing -> []
-- | Return the list of identifiers for open channel windows on
-- the given network name.
channelWindowsOnNetwork ::
Text {- ^ network -} ->
ClientState {- ^ client state -} ->
[Identifier] {- ^ open channel windows -}
channelWindowsOnNetwork network st =
[ chan | ChannelFocus net chan <- Map.keys (view clientWindows st)
, net == network ]
-- | Implementation of @/dump@. Writes detailed contents of focused buffer
-- to the given filename.
cmdDump :: ClientCommand String
cmdDump st fp =
do res <- try (LText.writeFile fp (LText.unlines outputLines))
case res of
Left e -> commandFailureMsg (Text.pack (displayException (e :: SomeException))) st
Right{} -> commandSuccess st
where
focus = view clientFocus st
outputLines
= reverse
$ clientFilter st id
$ toListOf (clientWindows . ix focus . winMessages . each . wlText) st