{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ParallelListComp #-}
module Matterhorn.Draw.RichText
( renderRichText
, renderText
, renderText'
, cursorSentinel
, findVerbatimChunk
)
where
import Prelude ()
import Matterhorn.Prelude
import Brick ( (<+>), Widget, hLimit, imageL
, render, Size(..), Widget(..)
)
import qualified Brick as B
import qualified Brick.Widgets.Border as B
import qualified Brick.Widgets.Table as B
import qualified Brick.Widgets.Skylighting as BS
import Control.Monad.Reader
import qualified Data.Foldable as F
import qualified Data.Sequence as S
import Data.Sequence ( ViewL(..)
, (<|)
, viewl
)
import qualified Data.Text as T
import qualified Graphics.Vty as V
import qualified Skylighting.Core as Sky
import Matterhorn.Constants ( normalChannelSigil, editMarking )
import Matterhorn.Draw.RichText.Flatten
import Matterhorn.Draw.RichText.Wrap
import Matterhorn.Themes
import Matterhorn.Types ( HighlightSet(..), emptyHSet, SemEq(..)
, addUserSigil, resultToWidget )
import Matterhorn.Types.RichText
renderRichText :: SemEq a
=> Text
-> HighlightSet
-> Maybe Int
-> Bool
-> Maybe Int
-> Maybe (Int -> Inline -> Maybe a)
-> Blocks
-> Widget a
renderRichText :: forall a.
SemEq a =>
Text
-> HighlightSet
-> Maybe Int
-> Bool
-> Maybe Int
-> Maybe (Int -> Inline -> Maybe a)
-> Blocks
-> Widget a
renderRichText Text
curUser HighlightSet
hSet Maybe Int
w Bool
doWrap Maybe Int
doVerbTrunc Maybe (Int -> Inline -> Maybe a)
nameGen (Blocks Seq Block
bs) =
forall r a. Reader r a -> r -> a
runReader (do
Seq (Widget a)
blocks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Ord a, SemEq a) => Block -> M (Widget a) a
renderBlock (Seq Block -> Seq Block
addBlankLines Seq Block
bs)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
B.vBox forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Widget a)
blocks)
(DrawCfg { drawCurUser :: Text
drawCurUser = Text
curUser
, drawHighlightSet :: HighlightSet
drawHighlightSet = HighlightSet
hSet
, drawLineWidth :: Maybe Int
drawLineWidth = Maybe Int
w
, drawDoLineWrapping :: Bool
drawDoLineWrapping = Bool
doWrap
, drawTruncateVerbatimBlocks :: Maybe Int
drawTruncateVerbatimBlocks = Maybe Int
doVerbTrunc
, drawNameGen :: Maybe (Int -> Inline -> Maybe a)
drawNameGen = Maybe (Int -> Inline -> Maybe a)
nameGen
})
renderText :: SemEq a => Text -> Widget a
renderText :: forall a. SemEq a => Text -> Widget a
renderText Text
txt = forall a.
SemEq a =>
Maybe TeamBaseURL
-> Text
-> HighlightSet
-> Maybe (Int -> Inline -> Maybe a)
-> Text
-> Widget a
renderText' forall a. Maybe a
Nothing Text
"" HighlightSet
emptyHSet forall a. Maybe a
Nothing Text
txt
renderText' :: SemEq a
=> Maybe TeamBaseURL
-> Text
-> HighlightSet
-> Maybe (Int -> Inline -> Maybe a)
-> Text
-> Widget a
renderText' :: forall a.
SemEq a =>
Maybe TeamBaseURL
-> Text
-> HighlightSet
-> Maybe (Int -> Inline -> Maybe a)
-> Text
-> Widget a
renderText' Maybe TeamBaseURL
baseUrl Text
curUser HighlightSet
hSet Maybe (Int -> Inline -> Maybe a)
nameGen Text
t =
forall a.
SemEq a =>
Text
-> HighlightSet
-> Maybe Int
-> Bool
-> Maybe Int
-> Maybe (Int -> Inline -> Maybe a)
-> Blocks
-> Widget a
renderRichText Text
curUser HighlightSet
hSet forall a. Maybe a
Nothing Bool
True forall a. Maybe a
Nothing Maybe (Int -> Inline -> Maybe a)
nameGen forall a b. (a -> b) -> a -> b
$
Maybe TeamBaseURL -> Text -> Blocks
parseMarkdown Maybe TeamBaseURL
baseUrl Text
t
addBlankLines :: Seq Block -> Seq Block
addBlankLines :: Seq Block -> Seq Block
addBlankLines = ViewL Block -> Seq Block
go' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Seq a -> ViewL a
viewl
where go' :: ViewL Block -> Seq Block
go' ViewL Block
EmptyL = forall a. Seq a
S.empty
go' (Block
x :< Seq Block
xs) = Block -> ViewL Block -> Seq Block
go Block
x (forall a. Seq a -> ViewL a
viewl Seq Block
xs)
go :: Block -> ViewL Block -> Seq Block
go Block
a (Block
b :< Seq Block
rs)
| Block -> Block -> Bool
sameBlockType Block
a Block
b = Block
a forall a. a -> Seq a -> Seq a
<| Block
blank forall a. a -> Seq a -> Seq a
<| Block -> ViewL Block -> Seq Block
go Block
b (forall a. Seq a -> ViewL a
viewl Seq Block
rs)
| Bool
otherwise = Block
a forall a. a -> Seq a -> Seq a
<| Block -> ViewL Block -> Seq Block
go Block
b (forall a. Seq a -> ViewL a
viewl Seq Block
rs)
go Block
x ViewL Block
EmptyL = forall a. a -> Seq a
S.singleton Block
x
blank :: Block
blank = Inlines -> Block
Para (Seq Inline -> Inlines
Inlines forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
S.singleton Inline
ESpace)
vBox :: F.Foldable f => f (Widget a) -> Widget a
vBox :: forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
vBox = forall n. [Widget n] -> Widget n
B.vBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
hBox :: F.Foldable f => f (Widget a) -> Widget a
hBox :: forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
hBox = forall n. [Widget n] -> Widget n
B.hBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
header :: Int -> Widget a
Int
n = forall n. Text -> Widget n
B.txt (Int -> Text -> Text
T.replicate Int
n Text
"#")
maybeHLimit :: Maybe Int -> Widget a -> Widget a
maybeHLimit :: forall a. Maybe Int -> Widget a -> Widget a
maybeHLimit Maybe Int
Nothing Widget a
w = Widget a
w
maybeHLimit (Just Int
i) Widget a
w = forall n. Int -> Widget n -> Widget n
hLimit Int
i Widget a
w
type M a b = Reader (DrawCfg b) a
data DrawCfg a =
DrawCfg { forall a. DrawCfg a -> Text
drawCurUser :: Text
, forall a. DrawCfg a -> HighlightSet
drawHighlightSet :: HighlightSet
, forall a. DrawCfg a -> Maybe Int
drawLineWidth :: Maybe Int
, forall a. DrawCfg a -> Bool
drawDoLineWrapping :: Bool
, forall a. DrawCfg a -> Maybe Int
drawTruncateVerbatimBlocks :: Maybe Int
, forall a. DrawCfg a -> Maybe (Int -> Inline -> Maybe a)
drawNameGen :: Maybe (Int -> Inline -> Maybe a)
}
renderBlock :: (Ord a, SemEq a) => Block -> M (Widget a) a
renderBlock :: forall a. (Ord a, SemEq a) => Block -> M (Widget a) a
renderBlock (Table [ColAlignment]
aligns [Inlines]
headings [[Inlines]]
body) = do
[Widget a]
headingWs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Ord a, SemEq a) => Inlines -> M (Widget a) a
renderInlines [Inlines]
headings
[[Widget a]]
bodyWs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Inlines]]
body forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Ord a, SemEq a) => Inlines -> M (Widget a) a
renderInlines
let t :: Table a
t = forall n. [[Widget n]] -> Table n
B.table ([Widget a]
headingWs forall a. a -> [a] -> [a]
: [[Widget a]]
bodyWs)
alignPairs :: [(Int, ColAlignment)]
alignPairs = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [ColAlignment]
aligns
align :: (Int, ColAlignment) -> Table n -> Table n
align (Int
_, ColAlignment
LeftAlignedCol) = forall a. a -> a
id
align (Int
_, ColAlignment
DefaultAlignedCol) = forall a. a -> a
id
align (Int
i, ColAlignment
RightAlignedCol) = forall n. Int -> Table n -> Table n
B.alignRight Int
i
align (Int
i, ColAlignment
CenterAlignedCol) = forall n. Int -> Table n -> Table n
B.alignCenter Int
i
applyAlignment :: Table n -> Table n
applyAlignment = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall {n}. (Int, ColAlignment) -> Table n -> Table n
align forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, ColAlignment)]
alignPairs)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. Table n -> Widget n
B.renderTable forall a b. (a -> b) -> a -> b
$ forall {n}. Table n -> Table n
applyAlignment Table a
t
renderBlock (Para Inlines
is) =
forall a. (Ord a, SemEq a) => Inlines -> M (Widget a) a
renderInlines Inlines
is
renderBlock (Header Int
n Inlines
is) = do
Widget a
headerTxt <- forall r' r a. (r' -> r) -> Reader r a -> Reader r' a
withReader (\DrawCfg a
c -> DrawCfg a
c { drawLineWidth :: Maybe Int
drawLineWidth = forall a. Num a => a -> a -> a
subtract Int
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. DrawCfg a -> Maybe Int
drawLineWidth DrawCfg a
c }) forall a b. (a -> b) -> a -> b
$
forall a. (Ord a, SemEq a) => Inlines -> M (Widget a) a
renderInlines Inlines
is
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
clientHeaderAttr forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
hBox [ forall n. Padding -> Widget n -> Widget n
B.padRight (Int -> Padding
B.Pad Int
1) forall a b. (a -> b) -> a -> b
$ forall a. Int -> Widget a
header Int
n
, Widget a
headerTxt
]
renderBlock (Blockquote Blocks
bs) = do
Maybe Int
w <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. DrawCfg a -> Maybe Int
drawLineWidth
Seq (Widget a)
bws <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Ord a, SemEq a) => Block -> M (Widget a) a
renderBlock (Blocks -> Seq Block
unBlocks Blocks
bs)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe Int -> Widget a -> Widget a
maybeHLimit Maybe Int
w forall a b. (a -> b) -> a -> b
$ forall n. Widget n -> Widget n
addQuoting forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
vBox Seq (Widget a)
bws
renderBlock (List ListType
ty ListSpacing
spacing Seq Blocks
bs) = do
Maybe Int
w <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. DrawCfg a -> Maybe Int
drawLineWidth
Widget a
lst <- forall a.
(Ord a, SemEq a) =>
ListType -> ListSpacing -> Seq Blocks -> M (Widget a) a
renderList ListType
ty ListSpacing
spacing Seq Blocks
bs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe Int -> Widget a -> Widget a
maybeHLimit Maybe Int
w Widget a
lst
renderBlock (CodeBlock CodeBlockInfo
ci Text
tx) = do
HighlightSet
hSet <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. DrawCfg a -> HighlightSet
drawHighlightSet
let f :: Text -> M (Widget a) b
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a b. Text -> M (Widget a) b
renderRawCodeBlock
(forall a b. SyntaxMap -> Syntax -> Text -> M (Widget a) b
renderCodeBlock (HighlightSet -> SyntaxMap
hSyntaxMap HighlightSet
hSet))
Maybe Syntax
mSyntax
mSyntax :: Maybe Syntax
mSyntax = do
Text
lang <- CodeBlockInfo -> Maybe Text
codeBlockLanguage CodeBlockInfo
ci
Text -> SyntaxMap -> Maybe Syntax
Sky.lookupSyntax Text
lang (HighlightSet -> SyntaxMap
hSyntaxMap HighlightSet
hSet)
Widget a
w <- forall a b. Text -> M (Widget a) b
f Text
tx
Maybe Int
trunc <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. DrawCfg a -> Maybe Int
drawTruncateVerbatimBlocks
case Maybe Int
trunc of
Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Widget a
w
Just Int
maxHeight -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
maybeTruncVerbatim Int
maxHeight Widget a
w
renderBlock (HTMLBlock Text
t) = do
Maybe Int
w <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. DrawCfg a -> Maybe Int
drawLineWidth
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe Int -> Widget a -> Widget a
maybeHLimit Maybe Int
w forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
textWithCursor Text
t
renderBlock (Block
HRule) = do
Maybe Int
w <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. DrawCfg a -> Maybe Int
drawLineWidth
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe Int -> Widget a -> Widget a
maybeHLimit Maybe Int
w forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
B.vLimit Int
1 (forall n. Char -> Widget n
B.fill Char
'*')
maybeTruncVerbatim :: Int -> B.Widget n -> B.Widget n
maybeTruncVerbatim :: forall n. Int -> Widget n -> Widget n
maybeTruncVerbatim Int
maxHeight Widget n
w =
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget (forall n. Widget n -> Size
B.hSize Widget n
w) (forall n. Widget n -> Size
B.vSize Widget n
w) forall a b. (a -> b) -> a -> b
$ do
Result n
result <- forall n. Widget n -> RenderM n (Result n)
render Widget n
w
let h :: Int
h = Image -> Int
V.imageHeight (Result n
resultforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
B.imageL)
if Int
h forall a. Ord a => a -> a -> Bool
> Int
maxHeight
then forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
B.vBox [ forall n. Int -> Widget n -> Widget n
B.vLimit Int
maxHeight forall a b. (a -> b) -> a -> b
$ forall n. Size -> Size -> RenderM n (Result n) -> Widget n
B.Widget Size
B.Fixed Size
B.Fixed forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Result n
result
, forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
verbatimTruncateMessageAttr forall a b. (a -> b) -> a -> b
$
forall n. String -> Widget n
B.str forall a b. (a -> b) -> a -> b
$ String
"(Showing " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
maxHeight forall a. Semigroup a => a -> a -> a
<> String
" of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
h forall a. Semigroup a => a -> a -> a
<> String
" lines)"
]
else forall (m :: * -> *) a. Monad m => a -> m a
return Result n
result
quoteChar :: Char
quoteChar :: Char
quoteChar = Char
'>'
addQuoting :: B.Widget n -> B.Widget n
addQuoting :: forall n. Widget n -> Widget n
addQuoting Widget n
w =
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
B.Widget Size
B.Fixed (forall n. Widget n -> Size
B.vSize Widget n
w) forall a b. (a -> b) -> a -> b
$ do
Context n
ctx <- forall n. RenderM n (Context n)
B.getContext
Result n
childResult <- forall n. Widget n -> RenderM n (Result n)
B.render forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
B.hLimit (Context n
ctxforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
B.availWidthL forall a. Num a => a -> a -> a
- Int
2) Widget n
w
let quoteBorder :: Widget n
quoteBorder = forall n. Image -> Widget n
B.raw forall a b. (a -> b) -> a -> b
$ forall d. Integral d => Attr -> Char -> d -> d -> Image
V.charFill (Context n
ctxforall s a. s -> Getting a s a -> a
^.forall r n. Getting r (Context n) Attr
B.attrL) Char
quoteChar Int
1 Int
height
height :: Int
height = Image -> Int
V.imageHeight forall a b. (a -> b) -> a -> b
$ Result n
childResultforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
B.imageL
forall n. Widget n -> RenderM n (Result n)
B.render forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
B.hBox [ forall n. Padding -> Widget n -> Widget n
B.padRight (Int -> Padding
B.Pad Int
1) forall {n}. Widget n
quoteBorder
, forall n. Size -> Size -> RenderM n (Result n) -> Widget n
B.Widget Size
B.Fixed Size
B.Fixed forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Result n
childResult
]
renderCodeBlock :: Sky.SyntaxMap -> Sky.Syntax -> Text -> M (Widget a) b
renderCodeBlock :: forall a b. SyntaxMap -> Syntax -> Text -> M (Widget a) b
renderCodeBlock SyntaxMap
syntaxMap Syntax
syntax Text
tx = do
let result :: Either String [SourceLine]
result = TokenizerConfig -> Syntax -> Text -> Either String [SourceLine]
Sky.tokenize TokenizerConfig
cfg Syntax
syntax Text
tx
cfg :: TokenizerConfig
cfg = SyntaxMap -> Bool -> TokenizerConfig
Sky.TokenizerConfig SyntaxMap
syntaxMap Bool
False
case Either String [SourceLine]
result of
Left String
_ -> forall a b. Text -> M (Widget a) b
renderRawCodeBlock Text
tx
Right [SourceLine]
tokLines -> do
let padding :: Widget n
padding = forall n. Int -> Widget n -> Widget n
B.padLeftRight Int
1 (forall n. Int -> Widget n -> Widget n
B.vLimit (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceLine]
tokLines) forall {n}. Widget n
B.vBorder)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall n. Text -> Widget n
B.txt forall a b. (a -> b) -> a -> b
$ Text
"[" forall a. Semigroup a => a -> a -> a
<> Syntax -> Text
Sky.sName Syntax
syntax forall a. Semigroup a => a -> a -> a
<> Text
"]") forall n. Widget n -> Widget n -> Widget n
B.<=>
(forall {n}. Widget n
padding forall n. Widget n -> Widget n -> Widget n
<+> forall n. (Text -> Widget n) -> [SourceLine] -> Widget n
BS.renderRawSource forall n. Text -> Widget n
textWithCursor [SourceLine]
tokLines)
renderRawCodeBlock :: Text -> M (Widget a) b
renderRawCodeBlock :: forall a b. Text -> M (Widget a) b
renderRawCodeBlock Text
tx = do
Bool
doWrap <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. DrawCfg a -> Bool
drawDoLineWrapping
let hPolicy :: Size
hPolicy = if Bool
doWrap then Size
Greedy else Size
Fixed
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
codeAttr forall a b. (a -> b) -> a -> b
$
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
hPolicy Size
Fixed forall a b. (a -> b) -> a -> b
$ do
Context a
c <- forall n. RenderM n (Context n)
B.getContext
let theLines :: [Text]
theLines = forall {a}. (Eq a, IsString a) => a -> a
expandEmpty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [Text]
T.lines Text
tx
expandEmpty :: a -> a
expandEmpty a
"" = a
" "
expandEmpty a
s = a
s
wrapFunc :: Text -> Widget a
wrapFunc = if Bool
doWrap then forall n. Text -> Widget n
wrappedTextWithCursor
else forall n. Text -> Widget n
textWithCursor
Result a
renderedText <- forall n. Widget n -> RenderM n (Result n)
render (forall n. Int -> Widget n -> Widget n
B.hLimit (Context a
cforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
B.availWidthL forall a. Num a => a -> a -> a
- Int
3) forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
B.vBox forall a b. (a -> b) -> a -> b
$
forall n. Text -> Widget n
wrapFunc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
theLines)
let textHeight :: Int
textHeight = Image -> Int
V.imageHeight forall a b. (a -> b) -> a -> b
$ Result a
renderedTextforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageL
padding :: Widget n
padding = forall n. Int -> Widget n -> Widget n
B.padLeftRight Int
1 (forall n. Int -> Widget n -> Widget n
B.vLimit Int
textHeight forall {n}. Widget n
B.vBorder)
forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall {n}. Widget n
padding forall n. Widget n -> Widget n -> Widget n
<+> (forall n. Result n -> Widget n
resultToWidget Result a
renderedText)
renderInlines :: (Ord a, SemEq a) => Inlines -> M (Widget a) a
renderInlines :: forall a. (Ord a, SemEq a) => Inlines -> M (Widget a) a
renderInlines Inlines
es = do
Maybe Int
w <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. DrawCfg a -> Maybe Int
drawLineWidth
HighlightSet
hSet <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. DrawCfg a -> HighlightSet
drawHighlightSet
Text
curUser <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. DrawCfg a -> Text
drawCurUser
Maybe (Int -> Inline -> Maybe a)
nameGen <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. DrawCfg a -> Maybe (Int -> Inline -> Maybe a)
drawNameGen
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. Size -> Size -> RenderM n (Result n) -> Widget n
B.Widget Size
B.Fixed Size
B.Fixed forall a b. (a -> b) -> a -> b
$ do
Context a
ctx <- forall n. RenderM n (Context n)
B.getContext
let width :: Int
width = forall a. a -> Maybe a -> a
fromMaybe (Context a
ctxforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
B.availWidthL) Maybe Int
w
ws :: Seq (Widget a)
ws = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (Ord a, Show a) => Text -> WrappedLine a -> Widget a
renderWrappedLine Text
curUser) forall a b. (a -> b) -> a -> b
$
forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
(forall a.
Int -> Seq (FlattenedValue a) -> Seq (Seq (FlattenedValue a))
doLineWrapping Int
width forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall a b. (a -> b) -> a -> b
$ forall a.
SemEq a =>
HighlightSet
-> Maybe (Int -> Inline -> Maybe a)
-> Inlines
-> Seq (Seq (FlattenedValue a))
flattenInlineSeq HighlightSet
hSet Maybe (Int -> Inline -> Maybe a)
nameGen Inlines
es))
forall n. Widget n -> RenderM n (Result n)
B.render (forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
vBox Seq (Widget a)
ws)
renderList :: (Ord a, SemEq a) => ListType -> ListSpacing -> Seq Blocks -> M (Widget a) a
renderList :: forall a.
(Ord a, SemEq a) =>
ListType -> ListSpacing -> Seq Blocks -> M (Widget a) a
renderList ListType
ty ListSpacing
_spacing Seq Blocks
bs = do
let is :: [Text]
is = case ListType
ty of
BulletList Char
_ -> forall a. a -> [a]
repeat (Text
"• ")
OrderedList Int
s EnumeratorType
_ DelimiterType
Period ->
[ String -> Text
T.pack (forall a. Show a => a -> String
show (Int
n :: Int)) forall a. Semigroup a => a -> a -> a
<> Text
". " | Int
n <- [Int
s..] ]
OrderedList Int
s EnumeratorType
_ DelimiterType
OneParen ->
[ String -> Text
T.pack (forall a. Show a => a -> String
show (Int
n :: Int)) forall a. Semigroup a => a -> a -> a
<> Text
") " | Int
n <- [Int
s..] ]
OrderedList Int
s EnumeratorType
_ DelimiterType
TwoParens ->
[ String -> Text
T.pack (forall a. Show a => a -> String
show (Int
n :: Int)) forall a. Semigroup a => a -> a -> a
<> Text
")) " | Int
n <- [Int
s..] ]
[Widget a]
results <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
is forall a b. (a -> b) -> a -> b
$ Blocks -> Seq Block
unBlocks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq Blocks
bs)) forall a b. (a -> b) -> a -> b
$ \(Text
i, Seq Block
b) -> do
Seq (Widget a)
blocks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. (Ord a, SemEq a) => Block -> M (Widget a) a
renderBlock Seq Block
b
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
B.txt Text
i forall n. Widget n -> Widget n -> Widget n
<+> forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
vBox Seq (Widget a)
blocks
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
vBox [Widget a]
results
renderWrappedLine :: (Ord a, Show a) => Text -> WrappedLine a -> Widget a
renderWrappedLine :: forall a. (Ord a, Show a) => Text -> WrappedLine a -> Widget a
renderWrappedLine Text
curUser WrappedLine a
l = forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
hBox forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall a b. (a -> b) -> a -> b
$ forall a. (Ord a, Show a) => Text -> FlattenedValue a -> Widget a
renderFlattenedValue Text
curUser forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WrappedLine a
l
renderFlattenedValue :: (Ord a, Show a) => Text -> FlattenedValue a -> Widget a
renderFlattenedValue :: forall a. (Ord a, Show a) => Text -> FlattenedValue a -> Widget a
renderFlattenedValue Text
curUser (NonBreaking Seq (Seq (FlattenedValue a))
rs) =
let renderLine :: Seq (FlattenedValue a) -> Widget a
renderLine = forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
hBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (Ord a, Show a) => Text -> FlattenedValue a -> Widget a
renderFlattenedValue Text
curUser)
in forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
vBox (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall a b. (a -> b) -> a -> b
$ Seq (FlattenedValue a) -> Widget a
renderLine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq (Seq (FlattenedValue a))
rs)
renderFlattenedValue Text
curUser (SingleInline FlattenedInline a
fi) = Widget a -> Widget a
addClickable forall a b. (a -> b) -> a -> b
$ forall n. Widget n -> Widget n
addHyperlink forall a b. (a -> b) -> a -> b
$ forall n. Widget n -> Widget n
addStyles forall {n}. Widget n
widget
where
val :: FlattenedContent
val = forall a. FlattenedInline a -> FlattenedContent
fiValue FlattenedInline a
fi
mUrl :: Maybe URL
mUrl = forall a. FlattenedInline a -> Maybe URL
fiURL FlattenedInline a
fi
mName :: Maybe a
mName = forall a. FlattenedInline a -> Maybe a
fiName FlattenedInline a
fi
styles :: [InlineStyle]
styles = forall a. FlattenedInline a -> [InlineStyle]
fiStyles FlattenedInline a
fi
addStyles :: Widget n -> Widget n
addStyles Widget n
w = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {n}. InlineStyle -> Widget n -> Widget n
addStyle Widget n
w [InlineStyle]
styles
addStyle :: InlineStyle -> Widget n -> Widget n
addStyle InlineStyle
s =
forall n. AttrName -> Widget n -> Widget n
B.withDefAttr forall a b. (a -> b) -> a -> b
$ case InlineStyle
s of
InlineStyle
Strong -> AttrName
clientStrongAttr
InlineStyle
Code -> AttrName
codeAttr
InlineStyle
Permalink -> AttrName
permalinkAttr
InlineStyle
Strikethrough -> AttrName
strikeThroughAttr
InlineStyle
Emph -> AttrName
clientEmphAttr
addHyperlink :: Widget n -> Widget n
addHyperlink = case Maybe URL
mUrl of
Maybe URL
Nothing -> forall a. a -> a
id
Just URL
u -> forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
urlAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Text -> Widget n -> Widget n
B.hyperlink (URL -> Text
unURL URL
u)
addClickable :: Widget a -> Widget a
addClickable Widget a
w = case Maybe a
mName of
Maybe a
Nothing -> forall a. a -> a
id Widget a
w
Just a
nm -> forall n. Ord n => n -> Widget n -> Widget n
B.clickable a
nm Widget a
w
widget :: Widget n
widget = case FlattenedContent
val of
FlattenedContent
FSpace -> forall n. Text -> Widget n
B.txt Text
" "
FUser Text
u -> forall a. Text -> Text -> Text -> Widget a
colorUsername Text
curUser Text
u forall a b. (a -> b) -> a -> b
$ Text -> Text
addUserSigil Text
u
FChannel Text
c -> forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
channelNameAttr forall a b. (a -> b) -> a -> b
$
forall n. Text -> Widget n
B.txt forall a b. (a -> b) -> a -> b
$ Text
normalChannelSigil forall a. Semigroup a => a -> a -> a
<> Text
c
FEmoji Text
em -> forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
emojiAttr forall a b. (a -> b) -> a -> b
$
forall n. Text -> Widget n
B.txt forall a b. (a -> b) -> a -> b
$ Text
":" forall a. Semigroup a => a -> a -> a
<> Text
em forall a. Semigroup a => a -> a -> a
<> Text
":"
FText Text
t -> if Text
t forall a. Eq a => a -> a -> Bool
== Char -> Text
T.singleton (Char
cursorSentinel)
then forall n. Widget n -> Widget n
B.visible forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
B.txt Text
" "
else forall n. Text -> Widget n
textWithCursor Text
t
FEditSentinel Bool
recent -> let attr :: AttrName
attr = if Bool
recent
then AttrName
editedRecentlyMarkingAttr
else AttrName
editedMarkingAttr
in forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
attr forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
B.txt Text
editMarking
textWithCursor :: Text -> Widget a
textWithCursor :: forall n. Text -> Widget n
textWithCursor Text
t
| (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
cursorSentinel) Text
t = forall n. Widget n -> Widget n
B.visible forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
B.txt forall a b. (a -> b) -> a -> b
$ Text -> Text
removeCursor Text
t
| Bool
otherwise = forall n. Text -> Widget n
B.txt Text
t
wrappedTextWithCursor :: Text -> Widget a
wrappedTextWithCursor :: forall n. Text -> Widget n
wrappedTextWithCursor Text
t
| (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
cursorSentinel) Text
t = forall n. Widget n -> Widget n
B.visible forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
B.txtWrap forall a b. (a -> b) -> a -> b
$ Text -> Text
removeCursor Text
t
| Bool
otherwise = forall n. Text -> Widget n
B.txtWrap Text
t
removeCursor :: Text -> Text
removeCursor :: Text -> Text
removeCursor = (Char -> Bool) -> Text -> Text
T.filter (forall a. Eq a => a -> a -> Bool
/= Char
cursorSentinel)
cursorSentinel :: Char
cursorSentinel :: Char
cursorSentinel = Char
'‸'