1{-# LANGUAGE MultiWayIf #-}
2{-# LANGUAGE ViewPatterns #-}
3{-# LANGUAGE ParallelListComp #-}
4module Matterhorn.Draw.RichText
5  ( renderRichText
6  , renderText
7  , renderText'
8  , cursorSentinel
9  , findVerbatimChunk
10  )
11where
12
13import           Prelude ()
14import           Matterhorn.Prelude
15
16import           Brick ( (<+>), Widget, hLimit, imageL
17                       , render, Size(..), Widget(..)
18                       )
19import qualified Brick as B
20import qualified Brick.Widgets.Border as B
21import qualified Brick.Widgets.Table as B
22import qualified Brick.Widgets.Skylighting as BS
23import           Control.Monad.Reader
24import qualified Data.Foldable as F
25import qualified Data.Sequence as S
26import           Data.Sequence ( ViewL(..)
27                               , (<|)
28                               , viewl
29                               )
30import qualified Data.Text as T
31import qualified Graphics.Vty as V
32import qualified Skylighting.Core as Sky
33
34import           Matterhorn.Constants ( normalChannelSigil, userSigil, editMarking )
35import           Matterhorn.Draw.RichText.Flatten
36import           Matterhorn.Draw.RichText.Wrap
37import           Matterhorn.Themes
38import           Matterhorn.Types ( HighlightSet(..), emptyHSet, SemEq(..) )
39import           Matterhorn.Types.RichText
40
41
42-- Render markdown with username highlighting
43renderRichText :: SemEq a
44               => Text
45               -- ^ The username of the currently-authenticated user.
46               -> HighlightSet
47               -- ^ A highlight set for highlighting channel and
48               -- usernames.
49               -> Maybe Int
50               -- ^ An optional maximum width.
51               -> Bool
52               -- ^ Whether to do line wrapping.
53               -> Maybe (Int -> Inline -> Maybe a)
54               -- ^ An optional function to build resource names for
55               -- clickable regions.
56               -> Blocks
57               -- ^ The content to render.
58               -> Widget a
59renderRichText curUser hSet w doWrap nameGen (Blocks bs) =
60    runReader (do
61              blocks <- mapM renderBlock (addBlankLines bs)
62              return $ B.vBox $ toList blocks)
63              (DrawCfg { drawCurUser = curUser
64                       , drawHighlightSet = hSet
65                       , drawLineWidth = w
66                       , drawDoLineWrapping = doWrap
67                       , drawNameGen = nameGen
68                       })
69
70-- Render text to markdown without username highlighting, permalink
71-- detection, or clickable links
72renderText :: SemEq a => Text -> Widget a
73renderText txt = renderText' Nothing "" emptyHSet Nothing txt
74
75renderText' :: SemEq a
76            => Maybe TeamBaseURL
77            -- ^ An optional base URL against which to match post links.
78            -> Text
79            -- ^ The username of the currently-authenticated user.
80            -> HighlightSet
81            -- ^ A highlight set for highlighting channel and usernames.
82            -> Maybe (Int -> Inline -> Maybe a)
83            -- ^ An optional function to build resource names for
84            -- clickable regions.
85            -> Text
86            -- ^ The text to parse and then render as rich text.
87            -> Widget a
88renderText' baseUrl curUser hSet nameGen t =
89    renderRichText curUser hSet Nothing True nameGen $
90        parseMarkdown baseUrl t
91
92-- Add blank lines only between adjacent elements of the same type, to
93-- save space
94addBlankLines :: Seq Block -> Seq Block
95addBlankLines = go' . viewl
96  where go' EmptyL = S.empty
97        go' (x :< xs) = go x (viewl xs)
98        go a (b :< rs)
99            | sameBlockType a b = a <| blank <| go b (viewl rs)
100            | otherwise         = a <| go b (viewl rs)
101        go x EmptyL = S.singleton x
102        blank = Para (Inlines $ S.singleton ESpace)
103
104vBox :: F.Foldable f => f (Widget a) -> Widget a
105vBox = B.vBox . toList
106
107hBox :: F.Foldable f => f (Widget a) -> Widget a
108hBox = B.hBox . toList
109
110header :: Int -> Widget a
111header n = B.txt (T.replicate n "#")
112
113maybeHLimit :: Maybe Int -> Widget a -> Widget a
114maybeHLimit Nothing w = w
115maybeHLimit (Just i) w = hLimit i w
116
117type M a b = Reader (DrawCfg b) a
118
119data DrawCfg a =
120    DrawCfg { drawCurUser :: Text
121            , drawHighlightSet :: HighlightSet
122            , drawLineWidth :: Maybe Int
123            , drawDoLineWrapping :: Bool
124            , drawNameGen :: Maybe (Int -> Inline -> Maybe a)
125            }
126
127renderBlock :: SemEq a => Block -> M (Widget a) a
128renderBlock (Table aligns headings body) = do
129    headingWs <- mapM renderInlines headings
130    bodyWs <- forM body $ mapM renderInlines
131    let t = B.table (headingWs : bodyWs)
132        alignPairs = zip [0..] aligns
133        align (_, LeftAlignedCol) = id
134        align (_, DefaultAlignedCol) = id
135        align (i, RightAlignedCol) = B.alignRight i
136        align (i, CenterAlignedCol) = B.alignCenter i
137        applyAlignment = foldr (.) id (align <$> alignPairs)
138    return $ B.renderTable $ applyAlignment t
139renderBlock (Para is) =
140    renderInlines is
141renderBlock (Header n is) = do
142    headerTxt <- withReader (\c -> c { drawLineWidth = subtract 1 <$> drawLineWidth c }) $
143                 renderInlines is
144    return $ B.withDefAttr clientHeaderAttr $
145        hBox [ B.padRight (B.Pad 1) $ header n
146             , headerTxt
147             ]
148renderBlock (Blockquote bs) = do
149    w <- asks drawLineWidth
150    bws <- mapM renderBlock (unBlocks bs)
151    return $ maybeHLimit w $ addQuoting $ vBox bws
152renderBlock (List ty spacing bs) = do
153    w <- asks drawLineWidth
154    lst <- renderList ty spacing bs
155    return $ maybeHLimit w lst
156renderBlock (CodeBlock ci tx) = do
157    hSet <- asks drawHighlightSet
158
159    let f = maybe renderRawCodeBlock
160                  (renderCodeBlock (hSyntaxMap hSet))
161                  mSyntax
162        mSyntax = do
163            lang <- codeBlockLanguage ci
164            Sky.lookupSyntax lang (hSyntaxMap hSet)
165    f tx
166renderBlock (HTMLBlock t) = do
167    w <- asks drawLineWidth
168    return $ maybeHLimit w $ textWithCursor t
169renderBlock (HRule) = do
170    w <- asks drawLineWidth
171    return $ maybeHLimit w $ B.vLimit 1 (B.fill '*')
172
173quoteChar :: Char
174quoteChar = '>'
175
176addQuoting :: B.Widget n -> B.Widget n
177addQuoting w =
178    B.Widget B.Fixed (B.vSize w) $ do
179        ctx <- B.getContext
180        childResult <- B.render $ B.hLimit (ctx^.B.availWidthL - 2) w
181
182        let quoteBorder = B.raw $ V.charFill (ctx^.B.attrL) quoteChar 1 height
183            height = V.imageHeight $ childResult^.B.imageL
184
185        B.render $ B.hBox [ B.padRight (B.Pad 1) quoteBorder
186                          , B.Widget B.Fixed B.Fixed $ return childResult
187                          ]
188
189renderCodeBlock :: Sky.SyntaxMap -> Sky.Syntax -> Text -> M (Widget a) b
190renderCodeBlock syntaxMap syntax tx = do
191    let result = Sky.tokenize cfg syntax tx
192        cfg = Sky.TokenizerConfig syntaxMap False
193    case result of
194        Left _ -> renderRawCodeBlock tx
195        Right tokLines -> do
196            let padding = B.padLeftRight 1 (B.vLimit (length tokLines) B.vBorder)
197            return $ (B.txt $ "[" <> Sky.sName syntax <> "]") B.<=>
198                     (padding <+> BS.renderRawSource textWithCursor tokLines)
199
200renderRawCodeBlock :: Text -> M (Widget a) b
201renderRawCodeBlock tx = do
202    doWrap <- asks drawDoLineWrapping
203
204    let hPolicy = if doWrap then Greedy else Fixed
205    return $ B.withDefAttr codeAttr $
206        Widget hPolicy Fixed $ do
207            c <- B.getContext
208            let theLines = expandEmpty <$> T.lines tx
209                expandEmpty "" = " "
210                expandEmpty s  = s
211                wrapFunc = if doWrap then wrappedTextWithCursor
212                                     else textWithCursor
213            renderedText <- render (B.hLimit (c^.B.availWidthL - 3) $ B.vBox $
214                                    wrapFunc <$> theLines)
215
216            let textHeight = V.imageHeight $ renderedText^.imageL
217                padding = B.padLeftRight 1 (B.vLimit textHeight B.vBorder)
218
219            render $ padding <+> (Widget Fixed Fixed $ return renderedText)
220
221renderInlines :: SemEq a => Inlines -> M (Widget a) a
222renderInlines es = do
223    w <- asks drawLineWidth
224    hSet <- asks drawHighlightSet
225    curUser <- asks drawCurUser
226    nameGen <- asks drawNameGen
227
228    return $ B.Widget B.Fixed B.Fixed $ do
229        ctx <- B.getContext
230        let width = fromMaybe (ctx^.B.availWidthL) w
231            ws    = fmap (renderWrappedLine curUser) $
232                    mconcat $
233                    (doLineWrapping width <$> (F.toList $ flattenInlineSeq hSet nameGen es))
234        B.render (vBox ws)
235
236renderList :: SemEq a => ListType -> ListSpacing -> Seq Blocks -> M (Widget a) a
237renderList ty _spacing bs = do
238    let is = case ty of
239          BulletList _ -> repeat ("• ")
240          OrderedList s _ Period ->
241            [ T.pack (show (n :: Int)) <> ". " | n <- [s..] ]
242          OrderedList s _ OneParen ->
243            [ T.pack (show (n :: Int)) <> ") " | n <- [s..] ]
244          OrderedList s _ TwoParens ->
245            [ T.pack (show (n :: Int)) <> ")) " | n <- [s..] ]
246
247    results <- forM (zip is $ unBlocks <$> (F.toList bs)) $ \(i, b) -> do
248        blocks <- mapM renderBlock b
249        return $ B.txt i <+> vBox blocks
250
251    return $ vBox results
252
253renderWrappedLine :: Show a => Text -> WrappedLine a -> Widget a
254renderWrappedLine curUser l = hBox $ F.toList $ renderFlattenedValue curUser <$> l
255
256renderFlattenedValue :: Show a => Text -> FlattenedValue a -> Widget a
257renderFlattenedValue curUser (NonBreaking rs) =
258    let renderLine = hBox . F.toList . fmap (renderFlattenedValue curUser)
259    in vBox (F.toList $ renderLine <$> F.toList rs)
260renderFlattenedValue curUser (SingleInline fi) = addClickable $ addHyperlink $ addStyles widget
261    where
262        val = fiValue fi
263        mUrl = fiURL fi
264        mName = fiName fi
265        styles = fiStyles fi
266
267        addStyles w = foldr addStyle w styles
268        addStyle s =
269            B.withDefAttr $ case s of
270                Strong        -> clientStrongAttr
271                Code          -> codeAttr
272                Permalink     -> permalinkAttr
273                Strikethrough -> strikeThroughAttr
274                Emph          -> clientEmphAttr
275
276        addHyperlink = case mUrl of
277            Nothing -> id
278            Just u -> B.withDefAttr urlAttr . B.hyperlink (unURL u)
279
280        addClickable w = case mName of
281            Nothing -> id w
282            Just nm -> B.clickable nm w
283
284        widget = case val of
285            FSpace               -> B.txt " "
286            FUser u              -> colorUsername curUser u $ userSigil <> u
287            FChannel c           -> B.withDefAttr channelNameAttr $
288                                    B.txt $ normalChannelSigil <> c
289            FEmoji em            -> B.withDefAttr emojiAttr $
290                                    B.txt $ ":" <> em <> ":"
291            FText t              -> if t == T.singleton (cursorSentinel)
292                                    then B.visible $ B.txt " "
293                                    else textWithCursor t
294            FEditSentinel recent -> let attr = if recent
295                                               then editedRecentlyMarkingAttr
296                                               else editedMarkingAttr
297                                    in B.withDefAttr attr $ B.txt editMarking
298
299textWithCursor :: Text -> Widget a
300textWithCursor t
301    | T.any (== cursorSentinel) t = B.visible $ B.txt $ removeCursor t
302    | otherwise = B.txt t
303
304wrappedTextWithCursor :: Text -> Widget a
305wrappedTextWithCursor t
306    | T.any (== cursorSentinel) t = B.visible $ B.txtWrap $ removeCursor t
307    | otherwise = B.txtWrap t
308
309removeCursor :: Text -> Text
310removeCursor = T.filter (/= cursorSentinel)
311
312-- Cursor sentinel for tracking the user's cursor position in previews.
313cursorSentinel :: Char
314cursorSentinel = '‸'
315