{-# 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
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 (f :: * -> *).
Functor f =>
(Editor Text n -> f (Editor Text n))
-> EditState n -> f (EditState 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 (f :: * -> *).
Functor f =>
(TextZipper t1 -> f (TextZipper t2))
-> Editor t1 n -> f (Editor t2 n)
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 (f :: * -> *).
Functor f =>
(Editor Text n -> f (Editor Text n))
-> EditState n -> f (EditState 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 (f :: * -> *).
Functor f =>
(EditMode -> f EditMode) -> EditState n -> f (EditState n)
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
{ 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 a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 =
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 { _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 (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 = 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 (f :: * -> *).
Functor f =>
(Image -> f Image) -> Result n -> f (Result n)
imageL) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
previewMaxHeight of
Bool
False -> Result Name -> RenderM Name (Result Name)
forall a. a -> ReaderT (Context Name) (State (RenderState Name)) a
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)