{-# 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
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 =
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
, _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)