{-# Language TemplateHaskell, BangPatterns, OverloadedStrings #-}
module Client.State
(
ClientState(..)
, clientWindows
, clientTextBox
, clientTextBoxOffset
, clientConnections
, clientWidth
, clientHeight
, clientEvents
, clientFocus
, clientPrevFocus
, clientExtraFocus
, clientConfig
, clientScroll
, clientDetailView
, clientActivityBar
, clientShowMetadata
, clientSubfocus
, clientNextConnectionId
, clientNetworkMap
, clientIgnores
, clientConnection
, clientBell
, clientExtensions
, clientRegex
, clientLogQueue
, clientActivityReturn
, withClientState
, clientStartExtensions
, clientShutdown
, clientPark
, clientMatcher
, clientActiveRegex
, consumeInput
, currentCompletionList
, identIgnored
, clientFirstLine
, clientLine
, abortNetwork
, addConnection
, removeNetwork
, clientTick
, applyMessageToClientState
, clientHighlights
, clientWindowNames
, clientPalette
, clientAutoconnects
, clientActiveCommand
, clientExtraFocuses
, currentNickCompletionMode
, recordChannelMessage
, recordNetworkMessage
, recordIrcMessage
, changeFocus
, changeSubfocus
, returnFocus
, advanceFocus
, advanceNetworkFocus
, retreatFocus
, jumpToActivity
, jumpFocus
, setExtraFocus
, scrollClient
, ExtensionState
, esActive
, urlPattern
, urlMatches
) where
import Client.CApi
import Client.Commands.WordCompletion
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
import Client.Network.Async
import Client.State.Channel
import qualified Client.State.EditBox as Edit
import Client.State.Focus
import Client.State.Network
import Client.State.Window
import Control.Applicative
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Exception
import Control.Lens
import Control.Monad
import Data.Foldable
import Data.Either
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.IntMap (IntMap)
import Data.List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time
import Foreign.Ptr
import Foreign.StablePtr
import Irc.Codes
import Irc.Identifier
import Irc.Message
import Irc.RawIrcMsg
import Irc.UserInfo
import LensUtils
import Text.Regex.TDFA
import Text.Regex.TDFA.String (compile)
data ClientState = ClientState
{ _clientWindows :: !(Map Focus Window)
, _clientPrevFocus :: !Focus
, _clientActivityReturn :: !Focus
, _clientFocus :: !Focus
, _clientSubfocus :: !Subfocus
, _clientExtraFocus :: ![Focus]
, _clientConnections :: !(IntMap NetworkState)
, _clientNextConnectionId :: !NetworkId
, _clientEvents :: !(TQueue NetworkEvent)
, _clientNetworkMap :: !(HashMap Text NetworkId)
, _clientConfig :: !Configuration
, _clientTextBox :: !Edit.EditBox
, _clientTextBoxOffset :: !Int
, _clientWidth :: !Int
, _clientHeight :: !Int
, _clientScroll :: !Int
, _clientDetailView :: !Bool
, _clientActivityBar :: !Bool
, _clientShowMetadata :: !Bool
, _clientRegex :: Maybe Regex
, _clientBell :: !Bool
, _clientIgnores :: !(HashSet Identifier)
, _clientExtensions :: !ExtensionState
, _clientLogQueue :: ![LogLine]
}
data ExtensionState = ExtensionState
{ _esActive :: [ActiveExtension]
, _esMVar :: MVar ClientState
, _esStablePtr :: StablePtr (MVar ClientState)
}
makeLenses ''ClientState
makeLenses ''ExtensionState
-- | Prepare the client to support reentry from the extension API.
clientPark ::
ClientState {- ^ client state -} ->
(Ptr () -> IO a) {- ^ continuation using the stable pointer to the client -} ->
IO (ClientState, a)
clientPark st k =
do let mvar = view (clientExtensions . esMVar) st
putMVar mvar st
let token = views (clientExtensions . esStablePtr) castStablePtrToPtr st
res <- k token
st' <- takeMVar mvar
return (st', res)
-- | 'Traversal' for finding the 'NetworkState' associated with a given network
-- if that connection is currently active.
clientConnection ::
Applicative f =>
Text {- ^ network -} ->
LensLike' f ClientState NetworkState
clientConnection network f st =
case view (clientNetworkMap . at network) st of
Nothing -> pure st
Just i -> clientConnections (ix i f) st
-- | The full top-most line that would be executed
clientFirstLine :: ClientState -> String
clientFirstLine = fst . Edit.shift . view (clientTextBox . Edit.content)
-- | The line under the cursor in the edit box.
clientLine :: ClientState -> (Int, String) {- ^ line number, line content -}
clientLine = views (clientTextBox . Edit.line) (\(Edit.Line n t) -> (n, t))
-- | Construct an initial 'ClientState' using default values.
withClientState :: Configuration -> (ClientState -> IO a) -> IO a
withClientState cfg k =
withExtensionState $ \exts ->
do events <- atomically newTQueue
k ClientState
{ _clientWindows = _Empty # ()
, _clientNetworkMap = _Empty # ()
, _clientIgnores = view configIgnores cfg
, _clientConnections = _Empty # ()
, _clientTextBox = Edit.defaultEditBox
, _clientTextBoxOffset = 0
, _clientWidth = 80
, _clientHeight = 25
, _clientEvents = events
, _clientPrevFocus = Unfocused
, _clientActivityReturn = Unfocused
, _clientFocus = Unfocused
, _clientSubfocus = FocusMessages
, _clientExtraFocus = []
, _clientConfig = cfg
, _clientScroll = 0
, _clientDetailView = False
, _clientShowMetadata = True
, _clientRegex = Nothing
, _clientActivityBar = view configActivityBar cfg
, _clientNextConnectionId = 0
, _clientBell = False
, _clientExtensions = exts
, _clientLogQueue = []
}
withExtensionState :: (ExtensionState -> IO a) -> IO a
withExtensionState k =
do mvar <- newEmptyMVar
bracket (newStablePtr mvar) freeStablePtr $ \stab ->
k ExtensionState
{ _esActive = []
, _esMVar = mvar
, _esStablePtr = stab
}
-- | Forcefully terminate the connection currently associated
-- with a given network name.
abortNetwork ::
Text {- ^ network -} ->
ClientState -> IO ClientState
abortNetwork network st =
case preview (clientConnection network) st of
Nothing -> return st
Just cs -> do abortConnection ForcedDisconnect (view csSocket cs)
return $! over clientNetworkMap (sans network) st
-- | Add a message to the window associated with a given channel
recordChannelMessage ::
Text {- ^ network -} ->
Identifier {- ^ channel -} ->
ClientMessage ->
ClientState ->
ClientState
recordChannelMessage network channel msg st
= recordLogLine msg channel
$ recordWindowLine focus wl st
where
focus = ChannelFocus network channel'
wl = toWindowLine rendParams importance msg
rendParams = MessageRendererParams
{ rendStatusMsg = statusModes
, rendUserSigils = computeMsgLineSigils network channel' msg st
, rendNicks = HashSet.fromList (channelUserList network channel' st)
, rendMyNicks = highlights
, rendPalette = clientPalette st
, rendNickPadding = view (clientConfig . configNickPadding) st
}
-- on failure returns mempty/""
possibleStatusModes = view (clientConnection network . csStatusMsg) st
(statusModes, channel') = splitStatusMsgModes possibleStatusModes channel
importance = msgImportance msg st
highlights = clientHighlightsNetwork network st
recordLogLine ::
ClientMessage {- ^ message -} ->
Identifier {- ^ target -} ->
ClientState {- ^ client state -} ->
ClientState
recordLogLine msg target st =
case view (clientConnection (view msgNetwork msg) . csSettings . ssLogDir) st of
Nothing -> st
Just dir ->
case renderLogLine msg dir target of
Nothing -> st
Just ll -> over clientLogQueue (cons ll) st
-- | Extract the status mode sigils from a message target.
splitStatusMsgModes ::
[Char] {- ^ possible modes -} ->
Identifier {- ^ target -} ->
([Char], Identifier) {- ^ actual modes, actual target -}
splitStatusMsgModes possible ident = (Text.unpack modes, mkId ident')
where
(modes, ident') = Text.span (`elem` possible) (idText ident)
-- | Compute the importance of a message to be used when computing
-- change notifications in the client.
msgImportance :: ClientMessage -> ClientState -> WindowLineImportance
msgImportance msg st =
let network = view msgNetwork msg
me = preview (clientConnection network . csNick) st
highlights = clientHighlightsNetwork network st
isMe x = Just x == me
checkTxt txt
| any (\x -> HashSet.member (mkId x) highlights)
(nickSplit txt) = WLImportant
| otherwise = WLNormal
in
case view msgBody msg of
NormalBody{} -> WLImportant
ErrorBody{} -> WLImportant
IrcBody irc
| squelchIrcMsg irc -> WLBoring
| isJust (ircIgnorable irc st) -> WLBoring
| otherwise ->
case irc of
Privmsg _ tgt txt
| isMe tgt -> WLImportant
| otherwise -> checkTxt txt
Notice _ tgt txt
| isMe tgt -> WLImportant
| otherwise -> checkTxt txt
Ctcp _ tgt "ACTION" txt
| isMe tgt -> WLImportant
| otherwise -> checkTxt txt
Ctcp{} -> WLNormal
Part who _ _ | isMe (userNick who) -> WLImportant
| otherwise -> WLBoring
Kick _ _ kicked _ | isMe kicked -> WLImportant
| otherwise -> WLNormal
Error{} -> WLImportant
Reply cmd _ ->
case replyCodeType (replyCodeInfo cmd) of
ErrorReply -> WLImportant
_ -> WLNormal
_ -> WLBoring
-- | Predicate for messages that should be ignored based on the
-- configurable ignore list
ircIgnorable :: IrcMsg -> ClientState -> Maybe Identifier
ircIgnorable msg !st =
case msg of
Privmsg who _ _ -> checkUser who
Notice who _ _ -> checkUser who
-- privmsg ctcp commands are already metadata
Ctcp who _ "ACTION" _ -> checkUser who
-- notice ctcp responses are not already metadata
CtcpNotice who _ _ _ -> checkUser who
_ -> Nothing
where
checkUser !who
| identIgnored (userNick who) st = Just (userNick who)
| otherwise = Nothing
-- | Predicate for nicknames to determine if messages should be ignored.
identIgnored ::
Identifier {- ^ nickname -} ->
ClientState {- ^ client state -} ->
Bool {- ^ is ignored -}
identIgnored who st = HashSet.member who (view clientIgnores st)
-- | Record a message in the windows corresponding to the given target
recordIrcMessage ::
Text {- ^ network -} ->
MessageTarget ->
ClientMessage ->
ClientState -> ClientState
recordIrcMessage network target msg st =
case target of
TargetHidden -> st
TargetNetwork -> recordNetworkMessage msg st
TargetWindow chan -> recordChannelMessage network chan msg st
TargetUser user ->
foldl' (\st' chan -> overStrict
(clientWindows . ix (ChannelFocus network chan))
(addToWindow wl) st')
st chans
where
cfg = view clientConfig st
wl = toWindowLine' cfg WLBoring msg
chans = user
: case preview (clientConnection network . csChannels) st of
Nothing -> []
Just m -> [chan | (chan, cs) <- HashMap.toList m
, HashMap.member user (view chanUsers cs) ]
-- | Compute the sigils of the user who sent a message.
computeMsgLineSigils ::
Text {- ^ network -} ->
Identifier {- ^ channel -} ->
ClientMessage ->
ClientState ->
[Char] {- ^ sigils -}
computeMsgLineSigils network channel msg st =
case msgActor =<< preview (msgBody . _IrcBody) msg of
Just user -> computeUserSigils network channel (userNick user) st
Nothing -> []
-- | Compute sigils for a user on a channel
computeUserSigils ::
Text {- ^ network -} ->
Identifier {- ^ channel -} ->
Identifier {- ^ user -} ->
ClientState ->
[Char] {- ^ sigils -}
computeUserSigils network channel user =
view $ clientConnection network
. csChannels . ix channel
. chanUsers . ix user
-- | Record a message on a network window
recordNetworkMessage :: ClientMessage -> ClientState -> ClientState
recordNetworkMessage msg st = recordWindowLine focus wl st
where
network = view msgNetwork msg
focus | Text.null network = Unfocused
| otherwise = NetworkFocus (view msgNetwork msg)
importance = msgImportance msg st
wl = toWindowLine' cfg importance msg
cfg = view clientConfig st
-- | Record window line at the given focus creating the window if necessary
recordWindowLine ::
Focus ->
WindowLine ->
ClientState ->
ClientState
recordWindowLine focus wl st = st2
where
st1 = over (clientWindows . at focus)
(\w -> Just $! addToWindow wl (fromMaybe emptyWindow w))
st
st2
| not (view clientBell st)
, view (clientConfig . configBellOnMention) st
, view wlImportance wl == WLImportant
, not (hasMention st) = set clientBell True st1
| otherwise = st1
hasMention = elemOf (clientWindows . folded . winMention) WLImportant
toWindowLine :: MessageRendererParams -> WindowLineImportance -> ClientMessage -> WindowLine
toWindowLine params importance msg = WindowLine
{ _wlSummary = msgSummary (view msgBody msg)
, _wlText = msgText (view msgBody msg)
, _wlImage' = _Image' # mkImage NormalRender
, _wlFullImage' = _Image' # mkImage DetailedRender
, _wlImportance = importance
, _wlTimestamp = zonedTimeToUTC (view msgTime msg)
}
where
mkImage mode =
msgImage mode (view msgTime msg) params (view msgBody msg)
-- | 'toWindowLine' but with mostly defaulted parameters.
toWindowLine' :: Configuration -> WindowLineImportance -> ClientMessage -> WindowLine
toWindowLine' config =
toWindowLine defaultRenderParams
{ rendPalette = view configPalette config
, rendNickPadding = view configNickPadding config
, rendMyNicks = view configExtraHighlights config
}
-- | Function applied to the client state every redraw.
clientTick :: ClientState -> ClientState
clientTick = set clientBell False
. markSeen
. set clientLogQueue []
-- | Mark the messages on the current window (and any splits) as seen.
markSeen :: ClientState -> ClientState
markSeen st =
case view clientSubfocus st of
FocusMessages -> foldl' aux st focuses
_ -> st
where
aux acc focus = overStrict (clientWindows . ix focus) windowSeen acc
focuses = view clientFocus st
: view clientExtraFocus st
-- | Add the textbox input to the edit history and clear the textbox.
consumeInput :: ClientState -> ClientState
consumeInput = over clientTextBox Edit.success
-- | Returns the current network's channels and current channel's users.
currentCompletionList :: ClientState -> [Identifier]
currentCompletionList st =
case view clientFocus st of
NetworkFocus network -> networkChannelList network st
ChannelFocus network chan ->
chan -- might be a disconnected channel or a private chat
: networkChannelList network st
++ channelUserList network chan st
_ -> []
-- | Returns the 'WordCompletionMode' associated with the current network.
currentNickCompletionMode :: ClientState -> WordCompletionMode
currentNickCompletionMode st =
fromMaybe defaultNickWordCompleteMode $
do network <- views clientFocus focusNetwork st
preview (clientConnection network . csSettings . ssNickCompletion) st
networkChannelList ::
Text {- ^ network -} ->
ClientState ->
[Identifier] {- ^ channels -}
networkChannelList network =
views (clientConnection network . csChannels) HashMap.keys
channelUserList ::
Text {- ^ network -} ->
Identifier {- ^ channel -} ->
ClientState ->
[Identifier] {- ^ nicks -}
channelUserList network channel =
views (clientConnection network . csChannels . ix channel . chanUsers) HashMap.keys
-- | Returns the current filtering predicate if one is active.
clientMatcher ::
ClientState {- ^ client state -} ->
Maybe (Text -> Bool) {- ^ optional predicate -}
clientMatcher st =
do r <- clientActiveRegex st
return (matchTest r . Text.unpack)
-- | Construct a text matching predicate used to filter the message window.
clientActiveRegex :: ClientState -> Maybe Regex
clientActiveRegex st =
case clientActiveCommand st of
Just ("grep" ,reStr) -> go True reStr
Just ("grepi",reStr) -> go False reStr
_ -> case view clientRegex st of
Nothing -> Nothing
Just r -> Just r
where
go sensitive reStr =
case compile defaultCompOpt{caseSensitive=sensitive}
defaultExecOpt{captureGroups=False}
reStr of
Left{} -> Nothing
Right r -> Just r
-- | Compute the command and arguments currently in the textbox.
clientActiveCommand ::
ClientState {- ^ client state -} ->
Maybe (String,String) {- ^ command name and argument string -}
clientActiveCommand st =
case break (==' ') (clientFirstLine st) of
('/':cmd,_:args) -> Just (cmd,args)
_ -> Nothing
-- | Regular expression for matching HTTP/HTTPS URLs in chat text.
urlPattern :: Regex
Right urlPattern =
compile
defaultCompOpt
defaultExecOpt{captureGroups=False}
"https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[^[:cntrl:][:space:]]*)|\
\<https?://[^>]*>"
-- | Find all the URL matches using 'urlPattern' in a given 'Text' suitable
-- for being opened. Surrounding @<@ and @>@ are removed.
urlMatches :: Text -> [Text]
urlMatches txt = removeBrackets . extractText . (^?! ix 0)
<$> matchAll urlPattern (Text.unpack txt)
where
extractText (off,len) = Text.take len (Text.drop off txt)
removeBrackets t =
case Text.uncons t of
Just ('<',t') | not (Text.null t') -> Text.init t'
_ -> t
-- | Remove a network connection and unlink it from the network map.
-- This operation assumes that the network connection exists and should
-- only be applied once per connection.
removeNetwork :: NetworkId -> ClientState -> (NetworkState, ClientState)
removeNetwork networkId st =
case (clientConnections . at networkId <<.~ Nothing) st of
(Nothing, _ ) -> error "removeNetwork: network not found"
(Just cs, st1) ->
-- Only remove the network mapping if it hasn't already been replaced
-- with a new one. This can happen during reconnect in particular.
let network = view csNetwork cs in
forOf (clientNetworkMap . at network) st1 $ \mb ->
case mb of
Just i | i == networkId -> (cs,Nothing)
_ -> (cs,mb)
-- | Start a new connection. The delay is used for reconnections.
addConnection ::
Int {- ^ attempts -} ->
Maybe UTCTime {- ^ optional disconnect time -} ->
Text {- ^ network name -} ->
ClientState ->
IO ClientState
addConnection attempts lastTime network st =
do let defSettings = (view (clientConfig . configDefaults) st)
{ _ssName = Just network
, _ssHostName = Text.unpack network
}
settings = fromMaybe defSettings
$ preview (clientConfig . configServers . ix network) st
let (i,st') = st & clientNextConnectionId <+~ 1
-- don't bother delaying on the first reconnect
delay = 15 * max 0 (attempts - 1)
c <- createConnection
delay
i
settings
(view clientEvents st')
let cs = newNetworkState i network settings c (PingConnecting attempts lastTime)
traverse_ (sendMsg cs) (initialMessages cs)
return $ set (clientNetworkMap . at network) (Just i)
$ set (clientConnections . at i) (Just cs) st'
applyMessageToClientState ::
ZonedTime {- ^ timestamp -} ->
IrcMsg {- ^ message received -} ->
NetworkId {- ^ message network -} ->
NetworkState {- ^ network connection state -} ->
ClientState {- ^ client state -} ->
([RawIrcMsg], ClientState) {- ^ response , updated state -}
applyMessageToClientState time irc networkId cs st =
cs' `seq` (reply, st')
where
(reply, cs') = applyMessage time irc cs
network = view csNetwork cs
st' = applyWindowRenames network irc
$ set (clientConnections . ix networkId) cs' st
-- | When a nick change happens and there is an open query window for that nick
-- and there isn't an open query window for the new nick, rename the window.
applyWindowRenames ::
Text {- ^ network -} ->
IrcMsg ->
ClientState -> ClientState
applyWindowRenames network (Nick old new) st
| hasWindow old'
, not (hasWindow new) = over clientFocus moveFocus
$ over clientWindows moveWindow st
| otherwise = st
where
old' = userNick old
mkFocus = ChannelFocus network
hasWindow who = has (clientWindows . ix (mkFocus who)) st
moveWindow :: Map Focus Window -> Map Focus Window
moveWindow wins =
let (win,wins') = (at (mkFocus old') <<.~ Nothing) wins
in set (at (mkFocus new)) win wins'
moveFocus x
| x == mkFocus old' = mkFocus new
| otherwise = x
applyWindowRenames _ _ st = st
-- | Actions to be run when exiting the client.
clientShutdown :: ClientState -> IO ()
clientShutdown st = () <$ clientStopExtensions st
-- other shutdown stuff might be added here later
-- | Unload all active extensions.
clientStopExtensions :: ClientState -> IO ClientState
clientStopExtensions st =
do let (aes,st1) = (clientExtensions . esActive <<.~ []) st
(st2,_) <- clientPark st1 $ \ptr ->
traverse_ (deactivateExtension ptr) aes
return st2
-- | Start extensions after ensuring existing ones are stopped
clientStartExtensions :: ClientState -> IO ClientState
clientStartExtensions st =
do let cfg = view clientConfig st
st1 <- clientStopExtensions st
(st2, res) <- clientPark st1 $ \ptr ->
traverse (try . activateExtension ptr <=< resolveConfigurationPath)
(view configExtensions cfg)
let (errors, exts) = partitionEithers res
st3 <- recordErrors errors st2
return $! set (clientExtensions . esActive) exts st3
where
recordErrors [] ste = return ste
recordErrors es ste =
do now <- getZonedTime
return $! foldl' (recordError now) ste es
recordError now ste e =
recordNetworkMessage ClientMessage
{ _msgTime = now
, _msgBody = ErrorBody (Text.pack (show (e :: IOError)))
, _msgNetwork = ""
} ste
------------------------------------------------------------------------
-- Scrolling
------------------------------------------------------------------------
-- | Scroll the current buffer to show newer messages
scrollClient :: Int -> ClientState -> ClientState
scrollClient amt = over clientScroll $ \n -> max 0 (n + amt)
-- | List of extra focuses to display as split windows
clientExtraFocuses :: ClientState -> [Focus]
clientExtraFocuses st =
case view clientSubfocus st of
FocusMessages -> view clientFocus st `delete` view clientExtraFocus st
_ -> []
------------------------------------------------------------------------
-- Focus Management
------------------------------------------------------------------------
-- | Jump the focus of the client to a buffer that has unread activity.
-- Some events like errors or chat messages mentioning keywords are
-- considered important and will be jumped to first.
jumpToActivity :: ClientState -> ClientState
jumpToActivity st = changeFocus newFocus st
where
windowList = views clientWindows Map.toAscList st
highPriority = find (\x -> WLImportant == view winMention (snd x)) windowList
lowPriority = find (\x -> view winUnread (snd x) > 0) windowList
newFocus =
case mplus highPriority lowPriority of
Just (focus,_) -> focus
Nothing -> view clientActivityReturn st
-- | Jump the focus directly to a window based on its zero-based index.
jumpFocus ::
Int {- ^ zero-based window index -} ->
ClientState -> ClientState
jumpFocus i st
| 0 <= i, i < Map.size windows = changeFocus focus st
| otherwise = st
where
windows = view clientWindows st
(focus,_) = Map.elemAt i windows
-- | Change the window focus to the given value, reset the subfocus
-- to message view, reset the scroll, remember the previous focus
-- if it changed.
changeFocus ::
Focus {- ^ new focus -} ->
ClientState {- ^ client state -} ->
ClientState
changeFocus focus st
= set clientScroll 0
. activateCurrent
. deactivatePrevious
. updatePrevious
. set clientFocus focus
. set clientSubfocus FocusMessages
$ st
where
oldFocus = view clientFocus st
updatePrevious
| focus == oldFocus = id
| otherwise = set clientPrevFocus oldFocus
-- always activate the new window. If it was already active this
-- will clear the marker.
activateCurrent = over (clientWindows . ix focus) windowActivate
-- Don't deactivate a window if it's going to stay active
deactivatePrevious
| oldFocus `elem` focus : view clientExtraFocus st = id
| otherwise = over (clientWindows . ix oldFocus) windowDeactivate
-- | Unified logic for assigning to the extra focuses field that activates
-- and deactivates windows as needed.
setExtraFocus :: [Focus] -> ClientState -> ClientState
setExtraFocus newFocuses st
= aux windowDeactivate newlyInactive
$ aux windowActivate newlyActive
$ set clientExtraFocus newFocuses st
where
newlyActive = newFocuses \\ (view clientFocus st : view clientExtraFocus st)
newlyInactive = view clientExtraFocus st \\ (view clientFocus st : newFocuses)
aux f xs st1 =
foldl' (\acc w -> overStrict (clientWindows . ix w) f acc) st1 xs
-- | Change the subfocus to the given value, preserve the focus, reset
-- the scroll.
changeSubfocus ::
Subfocus {- ^ new subfocus -} ->
ClientState {- ^ client state -} ->
ClientState
changeSubfocus focus
= set clientScroll 0
. set clientSubfocus focus
-- | Return to previously focused window.
returnFocus :: ClientState -> ClientState
returnFocus st = changeFocus (view clientPrevFocus st) st
-- | Step focus to the next window when on message view. Otherwise
-- switch to message view.
advanceFocus :: ClientState -> ClientState
advanceFocus = stepFocus $ \l r ->
fst . fst <$> Map.minViewWithKey r <|>
fst . fst <$> Map.minViewWithKey l
-- | Step focus to the previous window when on message view. Otherwise
-- switch to message view.
retreatFocus :: ClientState -> ClientState
retreatFocus = stepFocus $ \l r ->
fst . fst <$> Map.maxViewWithKey l <|>
fst . fst <$> Map.maxViewWithKey r
-- | Step focus to the next window when on message view. Otherwise
-- switch to message view.
advanceNetworkFocus :: ClientState -> ClientState
advanceNetworkFocus = stepFocus $ \l r ->
fst . fst <$> Map.minViewWithKey (Map.filterWithKey isNetwork r) <|>
fst . fst <$> Map.minViewWithKey (Map.filterWithKey isNetwork l)
where
isNetwork k _ = has _NetworkFocus k
-- | Selection function used in 'stepFocus'
type FocusSelector =
Map Focus Window {- ^ windows before current window -} ->
Map Focus Window {- ^ windows after current window -} ->
Maybe Focus {- ^ window to focus -}
-- | Step focus to the next window when on message view. Otherwise
-- switch to message view. Reverse the step order when argument is 'True'.
stepFocus ::
FocusSelector {- ^ selection function -} ->
ClientState {- ^ client state -} ->
ClientState
stepFocus selector st =
case selector l r of
Just k -> changeFocus k st
Nothing -> st
where
(l,r) = Map.split (view clientFocus st) (view clientWindows st)
-- | Compute the set of extra identifiers that should be highlighted given
-- a particular network state.
clientHighlights ::
NetworkState {- ^ network state -} ->
ClientState {- ^ client state -} ->
HashSet Identifier {- ^ extra highlight identifiers -}
clientHighlights cs st =
HashSet.insert
(view csNick cs)
(view (clientConfig . configExtraHighlights) st)
-- | Compute the set of extra identifiers that should be highlighted given
-- a particular network.
clientHighlightsNetwork ::
Text {- ^ network -} ->
ClientState {- ^ client state -} ->
HashSet Identifier {- ^ extra highlight identifiers -}
clientHighlightsNetwork network st =
case preview (clientConnection network) st of
Just cs -> clientHighlights cs st
Nothing -> view (clientConfig . configExtraHighlights) st
-- | Produce the list of window names configured for the client.
clientWindowNames ::
ClientState ->
[Char]
clientWindowNames = views (clientConfig . configWindowNames) Text.unpack
-- | Produce the list of window names configured for the client.
clientPalette :: ClientState -> Palette
clientPalette = view (clientConfig . configPalette)
-- | Returns the list of network names that requested autoconnection.
clientAutoconnects :: ClientState -> [Text]
clientAutoconnects st =
[ network | (network, cfg) <- views (clientConfig . configServers) HashMap.toList st
, view ssAutoconnect cfg
]