{-# 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 forall a b. (a -> b) -> a -> b
$ ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config Bool
configShowMessagePreviewL = 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 = forall a. Monoid a => TextZipper a -> [a]
getText forall a b. (a -> b) -> a -> b
$ (forall a. Monoid a => TextZipper a -> TextZipper a
gotoEOL forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. Monoid a => Char -> TextZipper a -> TextZipper a
insertChar Char
cursorSentinel) forall a b. (a -> b) -> a -> b
$
                  ChatState
stforall s a. s -> Getting a s a -> a
^.SimpleGetter ChatState (EditState Name)
editWhichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) (Editor Text n)
esEditorforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall t1 n t2.
Lens (Editor t1 n) (Editor t2 n) (TextZipper t1) (TextZipper t2)
editContentsL
    eName :: Name
eName = forall a n. Named a n => a -> n
getName forall a b. (a -> b) -> a -> b
$ ChatState
stforall s a. s -> Getting a s a -> a
^.SimpleGetter ChatState (EditState Name)
editWhichforall b c a. (b -> c) -> (a -> b) -> a -> c
.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
stforall s a. s -> Getting a s a -> a
^.SimpleGetter ChatState (EditState Name)
editWhichforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) EditMode
esEditMode of
        Editing Post
_ MessageType
ty -> forall a. a -> Maybe a
Just MessageType
ty
        EditMode
_ -> 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 = forall n. String -> Widget n
str String
"(No preview)"
                     msgPreview :: Widget Name
msgPreview = case Maybe Message
previewMsg of
                       Maybe Message
Nothing -> forall n. Widget n
noPreview
                       Just Message
pm -> if Text -> Bool
T.null Text
curStr
                                  then forall n. Widget n
noPreview
                                  else Message -> Maybe Message -> Widget Name
prview Message
pm 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 = forall n. Widget n -> Widget n
freezeBorders forall a b. (a -> b) -> a -> b
$
                                  MessageData -> Widget Name
renderMessage MessageData
                                  { mdMessage :: Message
mdMessage           = Message
m
                                  , mdUserName :: Maybe Text
mdUserName          = Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message UserRef
mUserforall b c a. (b -> c) -> (a -> b) -> a -> c
.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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall s a. s -> Getting a s a -> a
^.Lens' Message UserRef
mUserforall b c a. (b -> c) -> (a -> b) -> a -> c
.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     = 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 = 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 = forall a. Maybe a
Nothing
                                  , mdClickableNameTag :: Name
mdClickableNameTag  = Name
tag
                                  }
                 in (Name -> Widget Name -> Widget Name
maybePreviewViewport Name
vpName Widget Name
msgPreview) forall n. Widget n -> Widget n -> Widget n
<=>
                    forall n. Widget n -> Widget n
hBorderWithLabel (forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientEmphAttr forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== Char -> Text
T.singleton Char
cursorSentinel = 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 forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
3 Text
s
                  else Text
s
        msgTy :: MessageType
msgTy = 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 forall a. Maybe a
Nothing
       else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Message { _mText :: Blocks
_mText          = Maybe TeamBaseURL -> Text -> Blocks
parseMarkdown (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 forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime (Year -> Int -> Int -> Day
fromGregorian Year
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   = forall a. Monoid a => a
mempty
                           , _mInReplyToMsg :: ReplyState
_mInReplyToMsg  = ReplyState
NotAReply
                           , _mMessageId :: Maybe MessageId
_mMessageId     = forall a. Maybe a
Nothing
                           , _mReactions :: Map Text (Set UserId)
_mReactions     = forall a. Monoid a => a
mempty
                           , _mOriginalPost :: Maybe Post
_mOriginalPost  = forall a. Maybe a
Nothing
                           , _mFlagged :: Bool
_mFlagged       = Bool
False
                           , _mPinned :: Bool
_mPinned        = Bool
False
                           , _mChannelId :: Maybe ChannelId
_mChannelId     = forall a. Maybe a
Nothing
                           }

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