Main.hs

{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
module Matterhorn.Draw.Main
  ( drawMain
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Brick
import           Brick.Widgets.Border
import           Data.List ( intersperse )
import           Data.Maybe ( fromJust )
import qualified Data.Text as T
import           Lens.Micro.Platform ( Lens' )

import           Network.Mattermost.Types ( Type(Direct, Private, Group)
                                          , TeamId, teamDisplayName, teamId
                                          )


import           Matterhorn.Draw.ChannelList ( renderChannelList )
import           Matterhorn.Draw.Messages
import           Matterhorn.Draw.MessageInterface
import           Matterhorn.Draw.Autocomplete
import           Matterhorn.Draw.Util
import           Matterhorn.Draw.RichText
import           Matterhorn.Themes
import           Matterhorn.Types
import           Matterhorn.Types.Common ( sanitizeUserText )
import qualified Matterhorn.Zipper as Z


drawMain :: ChatState -> Mode -> [Widget Name]
drawMain st mode =
    (connectionLayer st : drawAutocompleteLayers st) <>
    [joinBorders $ mainInterface st mode (st^.csCurrentTeamId)]

connectionLayer :: ChatState -> Widget Name
connectionLayer st =
    case st^.csConnectionStatus of
        Connected -> emptyWidget
        Disconnected ->
            Widget Fixed Fixed $ do
                ctx <- getContext
                let aw = ctx^.availWidthL
                    w = length msg + 2
                    msg = "NOT CONNECTED"
                render $ translateBy (Location (max 0 (aw - w), 0)) $
                         withDefAttr errorMessageAttr $
                         border $ str msg

mainInterface :: ChatState -> Mode -> Maybe TeamId -> Widget Name
mainInterface st mode mtId =
    vBox [ teamList st
         , body
         ]
    where
    config = st^.csResources.crConfiguration

    showChannelList =
        config^.configShowChannelListL ||
        case mtId of
            Nothing -> True
            Just {} -> mode == ChannelSelect

    body = if showChannelList
           then case st^.csChannelListOrientation of
               ChannelListLeft ->
                   hBox [channelList, vBorder, mainDisplay]
               ChannelListRight ->
                   hBox [mainDisplay, vBorder, channelList]
           else mainDisplay

    mainDisplay = maybeSubdue messageInterface

    channelList = channelListMaybeVlimit mode $
                  hLimit channelListWidth $ case mtId of
                      Nothing -> fill ' '
                      Just tId -> renderChannelList st tId
    channelListWidth = configChannelListWidth $ st^.csResources.crConfiguration
    channelListMaybeVlimit ChannelSelect w =
        Widget (hSize w) (vSize w) $ do
            ctx <- getContext
            render $ vLimit (ctx^.availHeightL - 1) w
    channelListMaybeVlimit _ w = w

    noMessageInterface = fill ' '

    messageInterface = fromMaybe noMessageInterface $ do
        tId <- mtId
        let hs = getHighlightSet st tId

            channelHeader chan =
                withDefAttr channelHeaderAttr $
                padRight Max $
                renderChannelHeader st tId hs chan

            focused = st^.csTeam(tId).tsMessageInterfaceFocus == FocusCurrentChannel &&
                      threadShowing
            threadShowing = isJust $ st^.csTeam(tId).tsThreadInterface
            channelMessageIface cId =
                drawMessageInterface st hs tId True
                                     (csChannelMessageInterface(cId))
                                     True
                                     focused

            maybeThreadIface = do
                _ <- st^.csTeam(tId).tsThreadInterface
                return $ drawThreadWindow st tId

        cId <- st^.csCurrentChannelId(tId)
        ch <- st^?csChannel(cId)

        let channelUI = channelHeader ch <=> hBorder <=> channelMessageIface cId

        return $ fromMaybe channelUI $ do
            tui <- maybeThreadIface
            return $ case config^.configThreadOrientationL of
                ThreadAbove -> tui <=> hBorder <=> channelUI
                ThreadBelow -> channelUI <=> hBorder <=> tui
                ThreadLeft  -> tui <+> vBorder <+> channelUI
                ThreadRight -> channelUI <+> vBorder <+> tui

    maybeSubdue = if mode == ChannelSelect
                  then forceAttr $ attrName ""
                  else id

teamList :: ChatState -> Widget Name
teamList st =
    let curTid = st^.csCurrentTeamId
        z = st^.csTeamZipper
        pos = fromJust $ Z.position z
        teams = (\tId -> st^.csTeam(tId)) <$> (concat $ snd <$> Z.toList z)
        numTeams = length teams
        entries = mkEntry <$> teams
        mkEntry ts =
            let tId = teamId $ _tsTeam ts
                unread = uCount > 0
                uCount = teamUnreadCount tId st
                tName  = ClickableTeamListEntry tId
            in (if Just tId == curTid
                   then visible . withDefAttr currentTeamAttr
                   else if unread
                        then withDefAttr unreadChannelAttr
                        else id) $
               clickable tName $ txt $
               (T.strip $ sanitizeUserText $ teamDisplayName $ _tsTeam ts)
    in if numTeams == 1
       then emptyWidget
       else vBox [ hBox [ padRight (Pad 1) $ txt $ T.pack $ "Teams (" <> show (pos + 1) <> "/" <> show numTeams <> "):"
                        , vLimit 1 $ viewport TeamList Horizontal $
                          hBox $
                          intersperse (txt " ") entries
                        ]
                 , hBorder
                 ]

renderChannelHeader :: ChatState -> TeamId -> HighlightSet -> ClientChannel -> Widget Name
renderChannelHeader st tId hs chan =
    let chnType = chan^.ccInfo.cdType
        topicStr = chan^.ccInfo.cdHeader
        userHeader u = let s = T.intercalate " " $ filter (not . T.null) parts
                           parts = [ chanName
                                   , if (all T.null names)
                                     then mempty
                                     else "is"
                                   ] <> names <> [
                                     if T.null (u^.uiEmail)
                                     then mempty
                                     else "(" <> u^.uiEmail <> ")"
                                   ]
                           names = [ u^.uiFirstName
                                   , nick
                                   , u^.uiLastName
                                   ]
                           quote n = "\"" <> n <> "\""
                           nick = maybe "" quote $ u^.uiNickName
                       in s
        firstTopicLine = case T.lines topicStr of
            [h] -> h
            (h:_:_) -> h
            _ -> ""
        maybeTopic = if T.null topicStr
                     then ""
                     else " - " <> if st^.csResources.crConfiguration.configShowExpandedChannelTopicsL
                                   then topicStr
                                   else firstTopicLine
        channelNameString = case chnType of
            Direct ->
                case chan^.ccInfo.cdDMUserId >>= flip userById st of
                    Nothing -> chanName
                    Just u -> userHeader u
            Private ->
                channelNamePair <> " (Private)"
            Group ->
                channelNamePair <> " (Private group)"
            _ ->
                channelNamePair
        channelNamePair = chanName <> " - " <> (chan^.ccInfo.cdDisplayName)
        chanName = mkChannelName st (chan^.ccInfo)
        baseUrl = serverBaseUrl st tId

    in renderText' (Just baseUrl) (myUsername st)
         hs (Just (mkClickableInline Nothing (ChannelTopic $ chan^.ccInfo.cdChannelId)))
         (channelNameString <> maybeTopic)

drawThreadWindow :: ChatState -> TeamId -> Widget Name
drawThreadWindow st tId = withDefAttr threadAttr body
    where
        ti :: Lens' ChatState ThreadInterface
        ti = unsafeThreadInterface(tId)

        hs = getHighlightSet st tId
        cId = st^.ti.miChannelId

        titleText = case st^?csChannel(cId) of
            Nothing -> "Thread"
            Just chan ->
                let prefix = case chan^.ccInfo.cdType of
                        Group -> "Thread with "
                        Direct -> "Thread with "
                        _ -> "Thread in "
                in prefix <> mkChannelName st (chan^.ccInfo)

        title = renderText' Nothing "" hs Nothing titleText
        focused = st^.csTeam(tId).tsMessageInterfaceFocus == FocusThread
        body = title <=> hBorder <=> messageUI
        messageUI = drawMessageInterface st hs tId False ti False focused