{-# LANGUAGE RankNTypes #-}
module Matterhorn.Draw.InputPreview
  ( inputPreview
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Brick
import           Brick.Widgets.Border
import           Brick.Widgets.Edit
import           Control.Arrow ( (>>>) )
import qualified Data.Text as T
import           Data.Text.Zipper ( insertChar, getText, gotoEOL )
import           Data.Time.Calendar ( fromGregorian )
import           Data.Time.Clock ( UTCTime(..) )
import qualified Graphics.Vty as Vty
import           Lens.Micro.Platform ( SimpleGetter, to )

import           Network.Mattermost.Types ( ServerTime(..), UserId, TeamId
                                          )

import           Matterhorn.Constants
import           Matterhorn.Draw.Messages
import           Matterhorn.Draw.RichText
import           Matterhorn.Themes
import           Matterhorn.Types
import           Matterhorn.Types.RichText ( parseMarkdown, TeamBaseURL )


inputPreview :: ChatState
             -> SimpleGetter ChatState (EditState Name)
             -> TeamId
             -> Name
             -> HighlightSet
             -> Widget Name
inputPreview :: ChatState
-> SimpleGetter ChatState (EditState Name)
-> TeamId
-> Name
-> HighlightSet
-> Widget Name
inputPreview ChatState
st SimpleGetter ChatState (EditState Name)
editWhich TeamId
tId Name
vpName HighlightSet
hs
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ChatState
stChatState -> Getting Bool ChatState Bool -> Bool
forall s a. s -> Getting a s a -> a
^.(ChatResources -> Const Bool ChatResources)
-> ChatState -> Const Bool ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const Bool ChatResources)
 -> ChatState -> Const Bool ChatState)
-> ((Bool -> Const Bool Bool)
    -> ChatResources -> Const Bool ChatResources)
-> Getting Bool ChatState Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Const Bool Config)
-> ChatResources -> Const Bool ChatResources
Lens' ChatResources Config
crConfiguration((Config -> Const Bool Config)
 -> ChatResources -> Const Bool ChatResources)
-> ((Bool -> Const Bool Bool) -> Config -> Const Bool Config)
-> (Bool -> Const Bool Bool)
-> ChatResources
-> Const Bool ChatResources
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Bool -> Const Bool Bool) -> Config -> Const Bool Config
Lens' Config Bool
configShowMessagePreviewL = Widget Name
forall n. Widget n
emptyWidget
    | Bool
otherwise = Widget Name
thePreview
    where
    uId :: UserId
uId = ChatState -> UserId
myUserId ChatState
st
    -- Insert a cursor sentinel into the input text just before
    -- rendering the preview. We use the inserted sentinel (which is
    -- not rendered) to get brick to ensure that the line the cursor is
    -- on is visible in the preview viewport. We put the sentinel at
    -- the *end* of the line because it will still influence markdown
    -- parsing and can create undesirable/confusing churn in the
    -- rendering while the cursor moves around. If the cursor is at the
    -- end of whatever line the user is editing, that is very unlikely
    -- to be a problem.
    curContents :: [Text]
curContents = TextZipper Text -> [Text]
forall a. Monoid a => TextZipper a -> [a]
getText (TextZipper Text -> [Text]) -> TextZipper Text -> [Text]
forall a b. (a -> b) -> a -> b
$ (TextZipper Text -> TextZipper Text
forall a. Monoid a => TextZipper a -> TextZipper a
gotoEOL (TextZipper Text -> TextZipper Text)
-> (TextZipper Text -> TextZipper Text)
-> TextZipper Text
-> TextZipper Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Char -> TextZipper Text -> TextZipper Text
forall a. Monoid a => Char -> TextZipper a -> TextZipper a
insertChar Char
cursorSentinel) (TextZipper Text -> TextZipper Text)
-> TextZipper Text -> TextZipper Text
forall a b. (a -> b) -> a -> b
$
                  ChatState
stChatState
-> Getting (TextZipper Text) ChatState (TextZipper Text)
-> TextZipper Text
forall s a. s -> Getting a s a -> a
^.Getting (TextZipper Text) ChatState (EditState Name)
SimpleGetter ChatState (EditState Name)
editWhichGetting (TextZipper Text) ChatState (EditState Name)
-> ((TextZipper Text -> Const (TextZipper Text) (TextZipper Text))
    -> EditState Name -> Const (TextZipper Text) (EditState Name))
-> Getting (TextZipper Text) ChatState (TextZipper Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Editor Text Name -> Const (TextZipper Text) (Editor Text Name))
-> EditState Name -> Const (TextZipper Text) (EditState Name)
forall n. Lens' (EditState n) (Editor Text n)
esEditor((Editor Text Name -> Const (TextZipper Text) (Editor Text Name))
 -> EditState Name -> Const (TextZipper Text) (EditState Name))
-> ((TextZipper Text -> Const (TextZipper Text) (TextZipper Text))
    -> Editor Text Name -> Const (TextZipper Text) (Editor Text Name))
-> (TextZipper Text -> Const (TextZipper Text) (TextZipper Text))
-> EditState Name
-> Const (TextZipper Text) (EditState Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(TextZipper Text -> Const (TextZipper Text) (TextZipper Text))
-> Editor Text Name -> Const (TextZipper Text) (Editor Text Name)
forall t1 n t2.
Lens (Editor t1 n) (Editor t2 n) (TextZipper t1) (TextZipper t2)
editContentsL
    eName :: Name
eName = Editor Text Name -> Name
forall a n. Named a n => a -> n
getName (Editor Text Name -> Name) -> Editor Text Name -> Name
forall a b. (a -> b) -> a -> b
$ ChatState
stChatState
-> Getting (Editor Text Name) ChatState (Editor Text Name)
-> Editor Text Name
forall s a. s -> Getting a s a -> a
^.Getting (Editor Text Name) ChatState (EditState Name)
SimpleGetter ChatState (EditState Name)
editWhichGetting (Editor Text Name) ChatState (EditState Name)
-> ((Editor Text Name
     -> Const (Editor Text Name) (Editor Text Name))
    -> EditState Name -> Const (Editor Text Name) (EditState Name))
-> Getting (Editor Text Name) ChatState (Editor Text Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Editor Text Name -> Const (Editor Text Name) (Editor Text Name))
-> EditState Name -> Const (Editor Text Name) (EditState Name)
forall n. Lens' (EditState n) (Editor Text n)
esEditor
    curStr :: Text
curStr = Text -> [Text] -> Text
T.intercalate Text
"\n" [Text]
curContents
    overrideTy :: Maybe MessageType
overrideTy = case ChatState
stChatState -> Getting EditMode ChatState EditMode -> EditMode
forall s a. s -> Getting a s a -> a
^.Getting EditMode ChatState (EditState Name)
SimpleGetter ChatState (EditState Name)
editWhichGetting EditMode ChatState (EditState Name)
-> ((EditMode -> Const EditMode EditMode)
    -> EditState Name -> Const EditMode (EditState Name))
-> Getting EditMode ChatState EditMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EditMode -> Const EditMode EditMode)
-> EditState Name -> Const EditMode (EditState Name)
forall n. Lens' (EditState n) EditMode
esEditMode of
        Editing Post
_ MessageType
ty -> MessageType -> Maybe MessageType
forall a. a -> Maybe a
Just MessageType
ty
        EditMode
_ -> Maybe MessageType
forall a. Maybe a
Nothing
    baseUrl :: TeamBaseURL
baseUrl = ChatState -> TeamId -> TeamBaseURL
serverBaseUrl ChatState
st TeamId
tId
    previewMsg :: Maybe Message
previewMsg = TeamBaseURL -> Maybe MessageType -> UserId -> Text -> Maybe Message
previewFromInput TeamBaseURL
baseUrl Maybe MessageType
overrideTy UserId
uId Text
curStr
    thePreview :: Widget Name
thePreview = let noPreview :: Widget n
noPreview = String -> Widget n
forall n. String -> Widget n
str String
"(No preview)"
                     msgPreview :: Widget Name
msgPreview = case Maybe Message
previewMsg of
                       Maybe Message
Nothing -> Widget Name
forall n. Widget n
noPreview
                       Just Message
pm -> if Text -> Bool
T.null Text
curStr
                                  then Widget Name
forall n. Widget n
noPreview
                                  else Message -> Maybe Message -> Widget Name
prview Message
pm (Maybe Message -> Widget Name) -> Maybe Message -> Widget Name
forall a b. (a -> b) -> a -> b
$ ChatState -> Message -> Maybe Message
getParentMessage ChatState
st Message
pm
                     tag :: Name
tag = Name -> Name
MessagePreviewViewport Name
eName
                     prview :: Message -> Maybe Message -> Widget Name
prview Message
m Maybe Message
p = Widget Name -> Widget Name
forall n. Widget n -> Widget n
freezeBorders (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$
                                  MessageData -> Widget Name
renderMessage MessageData :: Maybe ServerTime
-> Bool
-> Bool
-> Message
-> Maybe Text
-> Maybe Message
-> Maybe Text
-> ThreadState
-> Bool
-> Bool
-> HighlightSet
-> Bool
-> Maybe Int
-> Maybe Int
-> Text
-> UserId
-> Bool
-> Name
-> MessageData
MessageData
                                  { mdMessage :: Message
mdMessage           = Message
m
                                  , mdUserName :: Maybe Text
mdUserName          = Message
mMessage -> Getting (Maybe Text) Message (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^.(UserRef -> Const (Maybe Text) UserRef)
-> Message -> Const (Maybe Text) Message
Lens' Message UserRef
mUser((UserRef -> Const (Maybe Text) UserRef)
 -> Message -> Const (Maybe Text) Message)
-> ((Maybe Text -> Const (Maybe Text) (Maybe Text))
    -> UserRef -> Const (Maybe Text) UserRef)
-> Getting (Maybe Text) Message (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(UserRef -> Maybe Text) -> SimpleGetter UserRef (Maybe Text)
forall s a. (s -> a) -> SimpleGetter s a
to (ChatState -> UserRef -> Maybe Text
printableNameForUserRef ChatState
st)
                                  , mdParentMessage :: Maybe Message
mdParentMessage     = Maybe Message
p
                                  , mdParentUserName :: Maybe Text
mdParentUserName    = Maybe Message
p Maybe Message -> (Message -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Message -> Getting (Maybe Text) Message (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^.(UserRef -> Const (Maybe Text) UserRef)
-> Message -> Const (Maybe Text) Message
Lens' Message UserRef
mUser((UserRef -> Const (Maybe Text) UserRef)
 -> Message -> Const (Maybe Text) Message)
-> ((Maybe Text -> Const (Maybe Text) (Maybe Text))
    -> UserRef -> Const (Maybe Text) UserRef)
-> Getting (Maybe Text) Message (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(UserRef -> Maybe Text) -> SimpleGetter UserRef (Maybe Text)
forall s a. (s -> a) -> SimpleGetter s a
to (ChatState -> UserRef -> Maybe Text
printableNameForUserRef ChatState
st))
                                  , mdHighlightSet :: HighlightSet
mdHighlightSet      = HighlightSet
hs
                                  , mdEditThreshold :: Maybe ServerTime
mdEditThreshold     = Maybe ServerTime
forall a. Maybe a
Nothing
                                  , mdShowOlderEdits :: Bool
mdShowOlderEdits    = Bool
False
                                  , mdRenderReplyParent :: Bool
mdRenderReplyParent = Bool
True
                                  , mdRenderReplyIndent :: Bool
mdRenderReplyIndent = Bool
True
                                  , mdIndentBlocks :: Bool
mdIndentBlocks      = Bool
True
                                  , mdThreadState :: ThreadState
mdThreadState       = ThreadState
NoThread
                                  , mdShowReactions :: Bool
mdShowReactions     = Bool
True
                                  , mdMessageWidthLimit :: Maybe Int
mdMessageWidthLimit = Maybe Int
forall a. Maybe a
Nothing
                                  , mdMyUsername :: Text
mdMyUsername        = ChatState -> Text
myUsername ChatState
st
                                  , mdMyUserId :: UserId
mdMyUserId          = ChatState -> UserId
myUserId ChatState
st
                                  , mdWrapNonhighlightedCodeBlocks :: Bool
mdWrapNonhighlightedCodeBlocks = Bool
True
                                  , mdTruncateVerbatimBlocks :: Maybe Int
mdTruncateVerbatimBlocks = Maybe Int
forall a. Maybe a
Nothing
                                  , mdClickableNameTag :: Name
mdClickableNameTag  = Name
tag
                                  }
                 in (Name -> Widget Name -> Widget Name
maybePreviewViewport Name
vpName Widget Name
msgPreview) Widget Name -> Widget Name -> Widget Name
forall n. Widget n -> Widget n -> Widget n
<=>
                    Widget Name -> Widget Name
forall n. Widget n -> Widget n
hBorderWithLabel (AttrName -> Widget Name -> Widget Name
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientEmphAttr (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ String -> Widget Name
forall n. String -> Widget n
str String
"[Preview ↑]")

previewFromInput :: TeamBaseURL -> Maybe MessageType -> UserId -> Text -> Maybe Message
previewFromInput :: TeamBaseURL -> Maybe MessageType -> UserId -> Text -> Maybe Message
previewFromInput TeamBaseURL
_ Maybe MessageType
_ UserId
_ Text
s | Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Text
T.singleton Char
cursorSentinel = Maybe Message
forall a. Maybe a
Nothing
previewFromInput TeamBaseURL
baseUrl Maybe MessageType
overrideTy UserId
uId Text
s =
    -- If it starts with a slash but not /me, this has no preview
    -- representation
    let isCommand :: Bool
isCommand = Text
"/" Text -> Text -> Bool
`T.isPrefixOf` Text
s
        isEmoteCmd :: Bool
isEmoteCmd = Text
"/me " Text -> Text -> Bool
`T.isPrefixOf` Text
s
        content :: Text
content = if Bool
isEmoteCmd
                  then Text -> Text
T.stripStart (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
3 Text
s
                  else Text
s
        msgTy :: MessageType
msgTy = MessageType -> Maybe MessageType -> MessageType
forall a. a -> Maybe a -> a
fromMaybe (if Bool
isEmoteCmd then ClientPostType -> MessageType
CP ClientPostType
Emote else ClientPostType -> MessageType
CP ClientPostType
NormalPost) Maybe MessageType
overrideTy
    in if Bool
isCommand Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isEmoteCmd
       then Maybe Message
forall a. Maybe a
Nothing
       else Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> Maybe Message) -> Message -> Maybe Message
forall a b. (a -> b) -> a -> b
$ Message :: Blocks
-> Text
-> UserRef
-> ServerTime
-> MessageType
-> Bool
-> Bool
-> Seq Attachment
-> ReplyState
-> Maybe MessageId
-> Map Text (Set UserId)
-> Maybe Post
-> Bool
-> Bool
-> Maybe ChannelId
-> Message
Message { _mText :: Blocks
_mText          = Maybe TeamBaseURL -> Text -> Blocks
parseMarkdown (TeamBaseURL -> Maybe TeamBaseURL
forall a. a -> Maybe a
Just TeamBaseURL
baseUrl) Text
content
                           , _mMarkdownSource :: Text
_mMarkdownSource = Text
content
                           , _mUser :: UserRef
_mUser          = Bool -> UserId -> UserRef
UserI Bool
False UserId
uId
                           , _mDate :: ServerTime
_mDate          = UTCTime -> ServerTime
ServerTime (UTCTime -> ServerTime) -> UTCTime -> ServerTime
forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
1970 Int
1 Int
1) DiffTime
0
                           -- The date is not used for preview
                           -- rendering, but we need to provide one.
                           -- Ideally we'd just use today's date, but
                           -- the rendering function is pure so we
                           -- can't.
                           , _mType :: MessageType
_mType          = MessageType
msgTy
                           , _mPending :: Bool
_mPending       = Bool
False
                           , _mDeleted :: Bool
_mDeleted       = Bool
False
                           , _mAttachments :: Seq Attachment
_mAttachments   = Seq Attachment
forall a. Monoid a => a
mempty
                           , _mInReplyToMsg :: ReplyState
_mInReplyToMsg  = ReplyState
NotAReply
                           , _mMessageId :: Maybe MessageId
_mMessageId     = Maybe MessageId
forall a. Maybe a
Nothing
                           , _mReactions :: Map Text (Set UserId)
_mReactions     = Map Text (Set UserId)
forall a. Monoid a => a
mempty
                           , _mOriginalPost :: Maybe Post
_mOriginalPost  = Maybe Post
forall a. Maybe a
Nothing
                           , _mFlagged :: Bool
_mFlagged       = Bool
False
                           , _mPinned :: Bool
_mPinned        = Bool
False
                           , _mChannelId :: Maybe ChannelId
_mChannelId     = Maybe ChannelId
forall a. Maybe a
Nothing
                           }

maybePreviewViewport :: Name -> Widget Name -> Widget Name
maybePreviewViewport :: Name -> Widget Name -> Widget Name
maybePreviewViewport Name
n Widget Name
w =
    Size -> Size -> RenderM Name (Result Name) -> Widget Name
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Fixed (RenderM Name (Result Name) -> Widget Name)
-> RenderM Name (Result Name) -> Widget Name
forall a b. (a -> b) -> a -> b
$ do
        Result Name
result <- Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render Widget Name
w
        case (Image -> Int
Vty.imageHeight (Image -> Int) -> Image -> Int
forall a b. (a -> b) -> a -> b
$ Result Name
resultResult Name -> Getting Image (Result Name) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result Name) Image
forall n. Lens' (Result n) Image
imageL) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
previewMaxHeight of
            Bool
False -> Result Name -> RenderM Name (Result Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Result Name
result
            Bool
True ->
                Widget Name -> RenderM Name (Result Name)
forall n. Widget n -> RenderM n (Result n)
render (Widget Name -> RenderM Name (Result Name))
-> Widget Name -> RenderM Name (Result Name)
forall a b. (a -> b) -> a -> b
$ Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
vLimit Int
previewMaxHeight (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Name -> ViewportType -> Widget Name -> Widget Name
forall n.
(Ord n, Show n) =>
n -> ViewportType -> Widget n -> Widget n
viewport Name
n ViewportType
Vertical (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$
                         (Result Name -> Widget Name
forall n. Result n -> Widget n
resultToWidget Result Name
result)