ChannelSelect.hs

{-# LANGUAGE MultiWayIf #-}
module Matterhorn.State.ChannelSelect
  ( beginChannelSelect
  , updateChannelSelectMatches
  , channelSelectNext
  , channelSelectPrevious
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Brick.Widgets.Edit ( getEditContents )
import           Data.Char ( isUpper )
import qualified Data.Text as T
import           Lens.Micro.Platform

import qualified Network.Mattermost.Types as MM

import           Matterhorn.Constants ( userSigil, normalChannelSigil )
import           Matterhorn.Types
import qualified Matterhorn.Zipper as Z

beginChannelSelect :: MM.TeamId -> MH ()
beginChannelSelect tId = do
    pushMode tId ChannelSelect
    csTeam(tId).tsChannelSelectState .= emptyChannelSelectState tId
    updateChannelSelectMatches tId

    -- Preserve the current channel selection when initializing channel
    -- selection mode
    zipper <- use (csTeam(tId).tsFocus)
    let isCurrentFocus m = Just (matchEntry m) == Z.focus zipper
    csTeam(tId).tsChannelSelectState.channelSelectMatches %= Z.findRight isCurrentFocus

-- Select the next match in channel selection mode.
channelSelectNext :: MM.TeamId -> MH ()
channelSelectNext tId = updateSelectedMatch tId Z.right

-- Select the previous match in channel selection mode.
channelSelectPrevious :: MM.TeamId -> MH ()
channelSelectPrevious tId = updateSelectedMatch tId Z.left

updateChannelSelectMatches :: MM.TeamId -> MH ()
updateChannelSelectMatches tId = do
    st <- use id

    input <- use (csTeam(tId).tsChannelSelectState.channelSelectInput)
    cconfig <- use csClientConfig
    appConfig <- use (csResources.crConfiguration)
    prefs <- use (csResources.crUserPreferences)

    let pat = parseChannelSelectPattern appConfig $ T.concat $ getEditContents input
        chanNameMatches e = case pat of
            Nothing -> const Nothing
            Just p -> applySelectPattern appConfig p e
        patTy = case pat of
            Nothing -> Nothing
            Just CSPAny -> Nothing
            Just (CSP ty _) -> Just ty

    let chanMatches e chan =
            if patTy == Just PrefixDMOnly
            then Nothing
            else if chan^.ccInfo.cdType /= MM.Group
                 then chanNameMatches e $ chan^.ccInfo.cdDisplayName
                 else Nothing
        groupChanMatches e chan =
            if patTy == Just PrefixNonDMOnly
            then Nothing
            else if chan^.ccInfo.cdType == MM.Group
                 then chanNameMatches e $ chan^.ccInfo.cdDisplayName
                 else Nothing
        displayName uInfo = displayNameForUser uInfo cconfig prefs
        userMatches e uInfo =
            if patTy == Just PrefixNonDMOnly
            then Nothing
            else (chanNameMatches e . displayName) uInfo
        matches e =
            let cId = channelListEntryChannelId e
            in case channelListEntryType e of
                CLChannel    -> findChannelById cId (st^.csChannels) >>= chanMatches e
                CLUserDM uId -> userById uId st >>= userMatches e
                CLGroupDM    -> findChannelById cId (st^.csChannels) >>= groupChanMatches e

        preserveFocus Nothing _ = False
        preserveFocus (Just m) m2 = matchEntry m == matchEntry m2

    csTeam(tId).tsChannelSelectState.channelSelectMatches %=
        (Z.updateListBy preserveFocus $ Z.toList $ Z.maybeMapZipper matches (st^.csTeam(tId).tsFocus))

applySelectPattern :: Config -> ChannelSelectPattern -> ChannelListEntry -> Text -> Maybe ChannelSelectMatch
applySelectPattern _ CSPAny entry chanName = do
    return $ ChannelSelectMatch "" "" chanName chanName entry
applySelectPattern config (CSP ty pat) entry chanName = do
    let applyType Infix | pat `T.isInfixOf` normalizedChanName =
            case T.breakOn pat normalizedChanName of
                (pre, _) ->
                    return ( T.take (T.length pre) chanName
                           , T.take (T.length pat) $ T.drop (T.length pre) chanName
                           , T.drop (T.length pat + T.length pre) chanName
                           )

        applyType Prefix | pat `T.isPrefixOf` normalizedChanName = do
            let (b, a) = T.splitAt (T.length pat) chanName
            return ("", b, a)

        applyType PrefixDMOnly | pat `T.isPrefixOf` normalizedChanName = do
            let (b, a) = T.splitAt (T.length pat) chanName
            return ("", b, a)

        applyType PrefixNonDMOnly | pat `T.isPrefixOf` normalizedChanName = do
            let (b, a) = T.splitAt (T.length pat) chanName
            return ("", b, a)

        applyType Suffix | pat `T.isSuffixOf` normalizedChanName = do
            let (b, a) = T.splitAt (T.length chanName - T.length pat) chanName
            return (b, a, "")

        applyType Equal  | pat == normalizedChanName =
            return ("", chanName, "")

        applyType _ = Nothing

        caseSensitive = T.any isUpper pat && not (configChannelSelectCaseInsensitive config)
        normalizedChanName = if caseSensitive
                             then chanName
                             else T.toLower chanName

    (pre, m, post) <- applyType ty
    return $ ChannelSelectMatch pre m post chanName entry

parseChannelSelectPattern :: Config -> Text -> Maybe ChannelSelectPattern
parseChannelSelectPattern _ "" = return CSPAny
parseChannelSelectPattern config patRaw = do
    let pat = if configChannelSelectCaseInsensitive config
              then T.toLower patRaw
              else patRaw

        only = if | userSigil `T.isPrefixOf` pat -> Just $ CSP PrefixDMOnly $ T.tail pat
                  | normalChannelSigil `T.isPrefixOf` pat -> Just $ CSP PrefixNonDMOnly $ T.tail pat
                  | otherwise -> Nothing

    (pat1, pfx) <- case "^" `T.isPrefixOf` pat of
        True  -> return (T.tail pat, Just Prefix)
        False -> return (pat, Nothing)

    (pat2, sfx) <- case "$" `T.isSuffixOf` pat1 of
        True  -> return (T.init pat1, Just Suffix)
        False -> return (pat1, Nothing)

    only <|> case (pfx, sfx) of
        (Nothing, Nothing)         -> return $ CSP Infix  pat2
        (Just Prefix, Nothing)     -> return $ CSP Prefix pat2
        (Nothing, Just Suffix)     -> return $ CSP Suffix pat2
        (Just Prefix, Just Suffix) -> return $ CSP Equal  pat2
        tys                        -> error $ "BUG: invalid channel select case: " <> show tys

-- Update the channel selection mode match cursor. The argument function
-- determines how to navigate to the next item.
updateSelectedMatch :: MM.TeamId
                    -> (Z.Zipper ChannelListGroup ChannelSelectMatch -> Z.Zipper ChannelListGroup ChannelSelectMatch)
                    -> MH ()
updateSelectedMatch tId nextItem =
    csTeam(tId).tsChannelSelectState.channelSelectMatches %= nextItem