{-# 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.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, userSigil, editMarking )
import Matterhorn.Draw.RichText.Flatten
import Matterhorn.Draw.RichText.Wrap
import Matterhorn.Themes
import Matterhorn.Types ( HighlightSet(..), emptyHSet )
import Matterhorn.Types.RichText
cursorSentinel :: Char
cursorSentinel :: Char
cursorSentinel = Char
'‸'
renderRichText :: Text -> HighlightSet -> Maybe Int -> Bool -> Blocks -> Widget a
renderRichText :: Text -> HighlightSet -> Maybe Int -> Bool -> Blocks -> Widget a
renderRichText Text
curUser HighlightSet
hSet Maybe Int
w Bool
doWrap (Blocks Seq Block
bs) =
Reader DrawCfg (Widget a) -> DrawCfg -> Widget a
forall r a. Reader r a -> r -> a
runReader (do
Seq (Widget a)
blocks <- (Block -> Reader DrawCfg (Widget a))
-> Seq Block -> ReaderT DrawCfg Identity (Seq (Widget a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Block -> Reader DrawCfg (Widget a)
forall a. Block -> M (Widget a)
renderBlock (Seq Block -> Seq Block
addBlankLines Seq Block
bs)
Widget a -> Reader DrawCfg (Widget a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget a -> Reader DrawCfg (Widget a))
-> Widget a -> Reader DrawCfg (Widget a)
forall a b. (a -> b) -> a -> b
$ [Widget a] -> Widget a
forall n. [Widget n] -> Widget n
B.vBox ([Widget a] -> Widget a) -> [Widget a] -> Widget a
forall a b. (a -> b) -> a -> b
$ Seq (Widget a) -> [Widget a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Widget a)
blocks)
(DrawCfg :: Text -> HighlightSet -> Maybe Int -> Bool -> DrawCfg
DrawCfg { drawCurUser :: Text
drawCurUser = Text
curUser
, drawHighlightSet :: HighlightSet
drawHighlightSet = HighlightSet
hSet
, drawLineWidth :: Maybe Int
drawLineWidth = Maybe Int
w
, drawDoLineWrapping :: Bool
drawDoLineWrapping = Bool
doWrap
})
addBlankLines :: Seq Block -> Seq Block
addBlankLines :: Seq Block -> Seq Block
addBlankLines = ViewL Block -> Seq Block
go' (ViewL Block -> Seq Block)
-> (Seq Block -> ViewL Block) -> Seq Block -> Seq Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Block -> ViewL Block
forall a. Seq a -> ViewL a
viewl
where go' :: ViewL Block -> Seq Block
go' ViewL Block
EmptyL = Seq Block
forall a. Seq a
S.empty
go' (Block
x :< Seq Block
xs) = Block -> ViewL Block -> Seq Block
go Block
x (Seq Block -> ViewL Block
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 Block -> Seq Block -> Seq Block
forall a. a -> Seq a -> Seq a
<| Block
blank Block -> Seq Block -> Seq Block
forall a. a -> Seq a -> Seq a
<| Block -> ViewL Block -> Seq Block
go Block
b (Seq Block -> ViewL Block
forall a. Seq a -> ViewL a
viewl Seq Block
rs)
| Bool
otherwise = Block
a Block -> Seq Block -> Seq Block
forall a. a -> Seq a -> Seq a
<| Block -> ViewL Block -> Seq Block
go Block
b (Seq Block -> ViewL Block
forall a. Seq a -> ViewL a
viewl Seq Block
rs)
go Block
x ViewL Block
EmptyL = Block -> Seq Block
forall a. a -> Seq a
S.singleton Block
x
blank :: Block
blank = Inlines -> Block
Para (Seq Inline -> Inlines
Inlines (Seq Inline -> Inlines) -> Seq Inline -> Inlines
forall a b. (a -> b) -> a -> b
$ Inline -> Seq Inline
forall a. a -> Seq a
S.singleton Inline
ESpace)
renderText :: Text -> Widget a
renderText :: Text -> Widget a
renderText Text
txt = Maybe TeamBaseURL -> Text -> HighlightSet -> Text -> Widget a
forall a.
Maybe TeamBaseURL -> Text -> HighlightSet -> Text -> Widget a
renderText' Maybe TeamBaseURL
forall a. Maybe a
Nothing Text
"" HighlightSet
emptyHSet Text
txt
renderText' :: Maybe TeamBaseURL -> Text -> HighlightSet -> Text -> Widget a
renderText' :: Maybe TeamBaseURL -> Text -> HighlightSet -> Text -> Widget a
renderText' Maybe TeamBaseURL
baseUrl Text
curUser HighlightSet
hSet Text
t =
Text -> HighlightSet -> Maybe Int -> Bool -> Blocks -> Widget a
forall a.
Text -> HighlightSet -> Maybe Int -> Bool -> Blocks -> Widget a
renderRichText Text
curUser HighlightSet
hSet Maybe Int
forall a. Maybe a
Nothing Bool
True (Blocks -> Widget a) -> Blocks -> Widget a
forall a b. (a -> b) -> a -> b
$
Maybe TeamBaseURL -> Text -> Blocks
parseMarkdown Maybe TeamBaseURL
baseUrl Text
t
vBox :: F.Foldable f => f (Widget a) -> Widget a
vBox :: f (Widget a) -> Widget a
vBox = [Widget a] -> Widget a
forall n. [Widget n] -> Widget n
B.vBox ([Widget a] -> Widget a)
-> (f (Widget a) -> [Widget a]) -> f (Widget a) -> Widget a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Widget a) -> [Widget a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
hBox :: F.Foldable f => f (Widget a) -> Widget a
hBox :: f (Widget a) -> Widget a
hBox = [Widget a] -> Widget a
forall n. [Widget n] -> Widget n
B.hBox ([Widget a] -> Widget a)
-> (f (Widget a) -> [Widget a]) -> f (Widget a) -> Widget a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Widget a) -> [Widget a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
header :: Int -> Widget a
Int
n = Text -> Widget a
forall n. Text -> Widget n
B.txt (Int -> Text -> Text
T.replicate Int
n Text
"#")
maybeHLimit :: Maybe Int -> Widget a -> Widget a
maybeHLimit :: Maybe Int -> Widget a -> Widget a
maybeHLimit Maybe Int
Nothing Widget a
w = Widget a
w
maybeHLimit (Just Int
i) Widget a
w = Int -> Widget a -> Widget a
forall n. Int -> Widget n -> Widget n
hLimit Int
i Widget a
w
type M a = Reader DrawCfg a
data DrawCfg =
DrawCfg { DrawCfg -> Text
drawCurUser :: Text
, DrawCfg -> HighlightSet
drawHighlightSet :: HighlightSet
, DrawCfg -> Maybe Int
drawLineWidth :: Maybe Int
, DrawCfg -> Bool
drawDoLineWrapping :: Bool
}
renderBlock :: Block -> M (Widget a)
renderBlock :: Block -> M (Widget a)
renderBlock (Para Inlines
is) =
Inlines -> M (Widget a)
forall a. Inlines -> M (Widget a)
renderInlines Inlines
is
renderBlock (Header Int
n Inlines
is) = do
Widget a
headerTxt <- (DrawCfg -> DrawCfg) -> M (Widget a) -> M (Widget a)
forall r' r a. (r' -> r) -> Reader r a -> Reader r' a
withReader (\DrawCfg
c -> DrawCfg
c { drawLineWidth :: Maybe Int
drawLineWidth = Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawCfg -> Maybe Int
drawLineWidth DrawCfg
c }) (M (Widget a) -> M (Widget a)) -> M (Widget a) -> M (Widget a)
forall a b. (a -> b) -> a -> b
$
Inlines -> M (Widget a)
forall a. Inlines -> M (Widget a)
renderInlines Inlines
is
Widget a -> M (Widget a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget a -> M (Widget a)) -> Widget a -> M (Widget a)
forall a b. (a -> b) -> a -> b
$ AttrName -> Widget a -> Widget a
forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
clientHeaderAttr (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$
[Widget a] -> Widget a
forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
hBox [ Padding -> Widget a -> Widget a
forall n. Padding -> Widget n -> Widget n
B.padRight (Int -> Padding
B.Pad Int
1) (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$ Int -> Widget a
forall a. Int -> Widget a
header Int
n
, Widget a
headerTxt
]
renderBlock (Blockquote Blocks
bs) = do
Maybe Int
w <- (DrawCfg -> Maybe Int) -> ReaderT DrawCfg Identity (Maybe Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DrawCfg -> Maybe Int
drawLineWidth
Seq (Widget a)
bws <- (Block -> M (Widget a))
-> Seq Block -> ReaderT DrawCfg Identity (Seq (Widget a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Block -> M (Widget a)
forall a. Block -> M (Widget a)
renderBlock (Blocks -> Seq Block
unBlocks Blocks
bs)
Widget a -> M (Widget a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget a -> M (Widget a)) -> Widget a -> M (Widget a)
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Widget a -> Widget a
forall a. Maybe Int -> Widget a -> Widget a
maybeHLimit Maybe Int
w (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$ Widget a -> Widget a
forall n. Widget n -> Widget n
addQuoting (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$ Seq (Widget a) -> Widget a
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 <- (DrawCfg -> Maybe Int) -> ReaderT DrawCfg Identity (Maybe Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DrawCfg -> Maybe Int
drawLineWidth
Widget a
lst <- ListType -> ListSpacing -> Seq Blocks -> M (Widget a)
forall a. ListType -> ListSpacing -> Seq Blocks -> M (Widget a)
renderList ListType
ty ListSpacing
spacing Seq Blocks
bs
Widget a -> M (Widget a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget a -> M (Widget a)) -> Widget a -> M (Widget a)
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Widget a -> Widget a
forall a. Maybe Int -> Widget a -> Widget a
maybeHLimit Maybe Int
w Widget a
lst
renderBlock (CodeBlock CodeBlockInfo
ci Text
tx) = do
HighlightSet
hSet <- (DrawCfg -> HighlightSet) -> ReaderT DrawCfg Identity HighlightSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DrawCfg -> HighlightSet
drawHighlightSet
let f :: Text -> M (Widget a)
f = (Text -> M (Widget a))
-> (Syntax -> Text -> M (Widget a))
-> Maybe Syntax
-> Text
-> M (Widget a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text -> M (Widget a)
forall a. Text -> M (Widget a)
renderRawCodeBlock
(SyntaxMap -> Syntax -> Text -> M (Widget a)
forall a. SyntaxMap -> Syntax -> Text -> M (Widget a)
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)
Text -> M (Widget a)
forall a. Text -> M (Widget a)
f Text
tx
renderBlock (HTMLBlock Text
t) = do
Maybe Int
w <- (DrawCfg -> Maybe Int) -> ReaderT DrawCfg Identity (Maybe Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DrawCfg -> Maybe Int
drawLineWidth
Widget a -> M (Widget a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget a -> M (Widget a)) -> Widget a -> M (Widget a)
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Widget a -> Widget a
forall a. Maybe Int -> Widget a -> Widget a
maybeHLimit Maybe Int
w (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$ Text -> Widget a
forall n. Text -> Widget n
textWithCursor Text
t
renderBlock (Block
HRule) = do
Maybe Int
w <- (DrawCfg -> Maybe Int) -> ReaderT DrawCfg Identity (Maybe Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DrawCfg -> Maybe Int
drawLineWidth
Widget a -> M (Widget a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget a -> M (Widget a)) -> Widget a -> M (Widget a)
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Widget a -> Widget a
forall a. Maybe Int -> Widget a -> Widget a
maybeHLimit Maybe Int
w (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$ Int -> Widget a -> Widget a
forall n. Int -> Widget n -> Widget n
B.vLimit Int
1 (Char -> Widget a
forall n. Char -> Widget n
B.fill Char
'*')
quoteChar :: Char
quoteChar :: Char
quoteChar = Char
'>'
addQuoting :: B.Widget n -> B.Widget n
addQuoting :: Widget n -> Widget n
addQuoting Widget n
w =
Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
B.Widget Size
B.Fixed (Widget n -> Size
forall n. Widget n -> Size
B.vSize Widget n
w) (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n) -> Widget n
forall a b. (a -> b) -> a -> b
$ do
Context
ctx <- RenderM n Context
forall n. RenderM n Context
B.getContext
Result n
childResult <- Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
B.render (Widget n -> RenderM n (Result n))
-> Widget n -> RenderM n (Result n)
forall a b. (a -> b) -> a -> b
$ Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
B.hLimit (Context
ctxContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
B.availWidthL Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Widget n
w
let quoteBorder :: Widget n
quoteBorder = Image -> Widget n
forall n. Image -> Widget n
B.raw (Image -> Widget n) -> Image -> Widget n
forall a b. (a -> b) -> a -> b
$ Attr -> Char -> Int -> Int -> Image
forall d. Integral d => Attr -> Char -> d -> d -> Image
V.charFill (Context
ctxContext -> Getting Attr Context Attr -> Attr
forall s a. s -> Getting a s a -> a
^.Getting Attr Context Attr
forall r. Getting r Context Attr
B.attrL) Char
quoteChar Int
1 Int
height
height :: Int
height = Image -> Int
V.imageHeight (Image -> Int) -> Image -> Int
forall a b. (a -> b) -> a -> b
$ Result n
childResultResult n -> Getting Image (Result n) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result n) Image
forall n. Lens' (Result n) Image
B.imageL
Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
B.render (Widget n -> RenderM n (Result n))
-> Widget n -> RenderM n (Result n)
forall a b. (a -> b) -> a -> b
$ [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
B.hBox [ Padding -> Widget n -> Widget n
forall n. Padding -> Widget n -> Widget n
B.padRight (Int -> Padding
B.Pad Int
1) Widget n
forall n. Widget n
quoteBorder
, Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
B.Widget Size
B.Fixed Size
B.Fixed (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n) -> Widget n
forall a b. (a -> b) -> a -> b
$ Result n -> RenderM n (Result n)
forall (m :: * -> *) a. Monad m => a -> m a
return Result n
childResult
]
renderCodeBlock :: Sky.SyntaxMap -> Sky.Syntax -> Text -> M (Widget a)
renderCodeBlock :: SyntaxMap -> Syntax -> Text -> M (Widget a)
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
_ -> Text -> M (Widget a)
forall a. Text -> M (Widget a)
renderRawCodeBlock Text
tx
Right [SourceLine]
tokLines -> do
let padding :: Widget n
padding = Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
B.padLeftRight Int
1 (Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
B.vLimit ([SourceLine] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SourceLine]
tokLines) Widget n
forall n. Widget n
B.vBorder)
Widget a -> M (Widget a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget a -> M (Widget a)) -> Widget a -> M (Widget a)
forall a b. (a -> b) -> a -> b
$ (Text -> Widget a
forall n. Text -> Widget n
B.txt (Text -> Widget a) -> Text -> Widget a
forall a b. (a -> b) -> a -> b
$ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Syntax -> Text
Sky.sName Syntax
syntax Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]") Widget a -> Widget a -> Widget a
forall n. Widget n -> Widget n -> Widget n
B.<=>
(Widget a
forall n. Widget n
padding Widget a -> Widget a -> Widget a
forall n. Widget n -> Widget n -> Widget n
<+> (Text -> Widget a) -> [SourceLine] -> Widget a
forall n. (Text -> Widget n) -> [SourceLine] -> Widget n
BS.renderRawSource Text -> Widget a
forall n. Text -> Widget n
textWithCursor [SourceLine]
tokLines)
renderRawCodeBlock :: Text -> M (Widget a)
renderRawCodeBlock :: Text -> M (Widget a)
renderRawCodeBlock Text
tx = do
Bool
doWrap <- (DrawCfg -> Bool) -> ReaderT DrawCfg Identity Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DrawCfg -> Bool
drawDoLineWrapping
let hPolicy :: Size
hPolicy = if Bool
doWrap then Size
Greedy else Size
Fixed
Widget a -> M (Widget a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget a -> M (Widget a)) -> Widget a -> M (Widget a)
forall a b. (a -> b) -> a -> b
$ AttrName -> Widget a -> Widget a
forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
codeAttr (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$
Size -> Size -> RenderM a (Result a) -> Widget a
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
hPolicy Size
Fixed (RenderM a (Result a) -> Widget a)
-> RenderM a (Result a) -> Widget a
forall a b. (a -> b) -> a -> b
$ do
Context
c <- RenderM a Context
forall n. RenderM n Context
B.getContext
let theLines :: [Text]
theLines = Text -> Text
forall p. (Eq p, IsString p) => p -> p
expandEmpty (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [Text]
T.lines Text
tx
expandEmpty :: p -> p
expandEmpty p
"" = p
" "
expandEmpty p
s = p
s
wrapFunc :: Text -> Widget a
wrapFunc = if Bool
doWrap then Text -> Widget a
forall n. Text -> Widget n
wrappedTextWithCursor
else Text -> Widget a
forall n. Text -> Widget n
textWithCursor
Result a
renderedText <- Widget a -> RenderM a (Result a)
forall n. Widget n -> RenderM n (Result n)
render (Int -> Widget a -> Widget a
forall n. Int -> Widget n -> Widget n
B.hLimit (Context
cContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
B.availWidthL Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$ [Widget a] -> Widget a
forall n. [Widget n] -> Widget n
B.vBox ([Widget a] -> Widget a) -> [Widget a] -> Widget a
forall a b. (a -> b) -> a -> b
$
Text -> Widget a
forall n. Text -> Widget n
wrapFunc (Text -> Widget a) -> [Text] -> [Widget a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
theLines)
let textHeight :: Int
textHeight = Image -> Int
V.imageHeight (Image -> Int) -> Image -> Int
forall a b. (a -> b) -> a -> b
$ Result a
renderedTextResult a -> Getting Image (Result a) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result a) Image
forall n. Lens' (Result n) Image
imageL
padding :: Widget n
padding = Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
B.padLeftRight Int
1 (Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
B.vLimit Int
textHeight Widget n
forall n. Widget n
B.vBorder)
Widget a -> RenderM a (Result a)
forall n. Widget n -> RenderM n (Result n)
render (Widget a -> RenderM a (Result a))
-> Widget a -> RenderM a (Result a)
forall a b. (a -> b) -> a -> b
$ Widget a
forall n. Widget n
padding Widget a -> Widget a -> Widget a
forall n. Widget n -> Widget n -> Widget n
<+> (Size -> Size -> RenderM a (Result a) -> Widget a
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (RenderM a (Result a) -> Widget a)
-> RenderM a (Result a) -> Widget a
forall a b. (a -> b) -> a -> b
$ Result a -> RenderM a (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return Result a
renderedText)
renderInlines :: Inlines -> M (Widget a)
renderInlines :: Inlines -> M (Widget a)
renderInlines Inlines
es = do
Maybe Int
w <- (DrawCfg -> Maybe Int) -> ReaderT DrawCfg Identity (Maybe Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DrawCfg -> Maybe Int
drawLineWidth
HighlightSet
hSet <- (DrawCfg -> HighlightSet) -> ReaderT DrawCfg Identity HighlightSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DrawCfg -> HighlightSet
drawHighlightSet
Text
curUser <- (DrawCfg -> Text) -> ReaderT DrawCfg Identity Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DrawCfg -> Text
drawCurUser
Widget a -> M (Widget a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget a -> M (Widget a)) -> Widget a -> M (Widget a)
forall a b. (a -> b) -> a -> b
$ Size -> Size -> RenderM a (Result a) -> Widget a
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
B.Widget Size
B.Fixed Size
B.Fixed (RenderM a (Result a) -> Widget a)
-> RenderM a (Result a) -> Widget a
forall a b. (a -> b) -> a -> b
$ do
Context
ctx <- RenderM a Context
forall n. RenderM n Context
B.getContext
let width :: Int
width = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Context
ctxContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
B.availWidthL) Maybe Int
w
ws :: Seq (Widget a)
ws = (WrappedLine -> Widget a) -> Seq WrappedLine -> Seq (Widget a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> WrappedLine -> Widget a
forall a. Text -> WrappedLine -> Widget a
renderWrappedLine Text
curUser) (Seq WrappedLine -> Seq (Widget a))
-> Seq WrappedLine -> Seq (Widget a)
forall a b. (a -> b) -> a -> b
$
[Seq WrappedLine] -> Seq WrappedLine
forall a. Monoid a => [a] -> a
mconcat ([Seq WrappedLine] -> Seq WrappedLine)
-> [Seq WrappedLine] -> Seq WrappedLine
forall a b. (a -> b) -> a -> b
$
(Int -> WrappedLine -> Seq WrappedLine
doLineWrapping Int
width (WrappedLine -> Seq WrappedLine)
-> [WrappedLine] -> [Seq WrappedLine]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Seq WrappedLine -> [WrappedLine]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq WrappedLine -> [WrappedLine])
-> Seq WrappedLine -> [WrappedLine]
forall a b. (a -> b) -> a -> b
$ HighlightSet -> Inlines -> Seq WrappedLine
flattenInlineSeq HighlightSet
hSet Inlines
es))
Widget a -> RenderM a (Result a)
forall n. Widget n -> RenderM n (Result n)
B.render (Seq (Widget a) -> Widget a
forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
vBox Seq (Widget a)
forall a. Seq (Widget a)
ws)
renderList :: ListType -> ListSpacing -> Seq Blocks -> M (Widget a)
renderList :: ListType -> ListSpacing -> Seq Blocks -> M (Widget a)
renderList ListType
ty ListSpacing
_spacing Seq Blocks
bs = do
let is :: [Text]
is = case ListType
ty of
BulletList Char
_ -> Text -> [Text]
forall a. a -> [a]
repeat (Text
"• ")
OrderedList Int
s EnumeratorType
_ DelimiterType
Period ->
[ String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int
n :: Int)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". " | Int
n <- [Int
s..] ]
OrderedList Int
s EnumeratorType
_ DelimiterType
OneParen ->
[ String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int
n :: Int)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") " | Int
n <- [Int
s..] ]
OrderedList Int
s EnumeratorType
_ DelimiterType
TwoParens ->
[ String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int
n :: Int)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")) " | Int
n <- [Int
s..] ]
[Widget a]
results <- [(Text, Seq Block)]
-> ((Text, Seq Block) -> M (Widget a))
-> ReaderT DrawCfg Identity [Widget a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Text] -> [Seq Block] -> [(Text, Seq Block)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
is ([Seq Block] -> [(Text, Seq Block)])
-> [Seq Block] -> [(Text, Seq Block)]
forall a b. (a -> b) -> a -> b
$ Blocks -> Seq Block
unBlocks (Blocks -> Seq Block) -> [Blocks] -> [Seq Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Seq Blocks -> [Blocks]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq Blocks
bs)) (((Text, Seq Block) -> M (Widget a))
-> ReaderT DrawCfg Identity [Widget a])
-> ((Text, Seq Block) -> M (Widget a))
-> ReaderT DrawCfg Identity [Widget a]
forall a b. (a -> b) -> a -> b
$ \(Text
i, Seq Block
b) -> do
Seq (Widget a)
blocks <- (Block -> M (Widget a))
-> Seq Block -> ReaderT DrawCfg Identity (Seq (Widget a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Block -> M (Widget a)
forall a. Block -> M (Widget a)
renderBlock Seq Block
b
Widget a -> M (Widget a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget a -> M (Widget a)) -> Widget a -> M (Widget a)
forall a b. (a -> b) -> a -> b
$ Text -> Widget a
forall n. Text -> Widget n
B.txt Text
i Widget a -> Widget a -> Widget a
forall n. Widget n -> Widget n -> Widget n
<+> Seq (Widget a) -> Widget a
forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
vBox Seq (Widget a)
blocks
Widget a -> M (Widget a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget a -> M (Widget a)) -> Widget a -> M (Widget a)
forall a b. (a -> b) -> a -> b
$ [Widget a] -> Widget a
forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
vBox [Widget a]
results
renderWrappedLine :: Text -> WrappedLine -> Widget a
renderWrappedLine :: Text -> WrappedLine -> Widget a
renderWrappedLine Text
curUser WrappedLine
l = [Widget a] -> Widget a
forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
hBox ([Widget a] -> Widget a) -> [Widget a] -> Widget a
forall a b. (a -> b) -> a -> b
$ Seq (Widget a) -> [Widget a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (Widget a) -> [Widget a]) -> Seq (Widget a) -> [Widget a]
forall a b. (a -> b) -> a -> b
$ Text -> FlattenedValue -> Widget a
forall a. Text -> FlattenedValue -> Widget a
renderFlattenedValue Text
curUser (FlattenedValue -> Widget a) -> WrappedLine -> Seq (Widget a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WrappedLine
l
renderFlattenedValue :: Text -> FlattenedValue -> Widget a
renderFlattenedValue :: Text -> FlattenedValue -> Widget a
renderFlattenedValue Text
curUser (NonBreaking Seq WrappedLine
rs) =
let renderLine :: WrappedLine -> Widget a
renderLine = [Widget a] -> Widget a
forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
hBox ([Widget a] -> Widget a)
-> (WrappedLine -> [Widget a]) -> WrappedLine -> Widget a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (Widget a) -> [Widget a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (Seq (Widget a) -> [Widget a])
-> (WrappedLine -> Seq (Widget a)) -> WrappedLine -> [Widget a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FlattenedValue -> Widget a) -> WrappedLine -> Seq (Widget a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> FlattenedValue -> Widget a
forall a. Text -> FlattenedValue -> Widget a
renderFlattenedValue Text
curUser)
in [Widget a] -> Widget a
forall (f :: * -> *) a. Foldable f => f (Widget a) -> Widget a
vBox ([Widget a] -> [Widget a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList ([Widget a] -> [Widget a]) -> [Widget a] -> [Widget a]
forall a b. (a -> b) -> a -> b
$ WrappedLine -> Widget a
forall a. WrappedLine -> Widget a
renderLine (WrappedLine -> Widget a) -> [WrappedLine] -> [Widget a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq WrappedLine -> [WrappedLine]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq WrappedLine
rs)
renderFlattenedValue Text
curUser (SingleInline FlattenedInline
fi) = Widget a -> Widget a
forall n. Widget n -> Widget n
addHyperlink (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$ Widget a -> Widget a
forall n. Widget n -> Widget n
addStyles Widget a
forall n. Widget n
widget
where
val :: FlattenedContent
val = FlattenedInline -> FlattenedContent
fiValue FlattenedInline
fi
mUrl :: Maybe URL
mUrl = FlattenedInline -> Maybe URL
fiURL FlattenedInline
fi
styles :: [InlineStyle]
styles = FlattenedInline -> [InlineStyle]
fiStyles FlattenedInline
fi
addStyles :: Widget n -> Widget n
addStyles Widget n
w = (InlineStyle -> Widget n -> Widget n)
-> Widget n -> [InlineStyle] -> Widget n
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr InlineStyle -> Widget n -> Widget n
forall n. InlineStyle -> Widget n -> Widget n
addStyle Widget n
w [InlineStyle]
styles
addStyle :: InlineStyle -> Widget n -> Widget n
addStyle InlineStyle
s =
AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
B.withDefAttr (AttrName -> Widget n -> Widget n)
-> AttrName -> Widget n -> Widget n
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 -> Widget n -> Widget n
forall a. a -> a
id
Just URL
u -> AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
urlAttr (Widget n -> Widget n)
-> (Widget n -> Widget n) -> Widget n -> Widget n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Widget n -> Widget n
forall n. Text -> Widget n -> Widget n
B.hyperlink (URL -> Text
unURL URL
u)
widget :: Widget n
widget = case FlattenedContent
val of
FlattenedContent
FSpace -> Text -> Widget n
forall n. Text -> Widget n
B.txt Text
" "
FUser Text
u -> Text -> Text -> Text -> Widget n
forall a. Text -> Text -> Text -> Widget a
colorUsername Text
curUser Text
u (Text -> Widget n) -> Text -> Widget n
forall a b. (a -> b) -> a -> b
$ Text
userSigil Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
u
FChannel Text
c -> AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
channelNameAttr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
Text -> Widget n
forall n. Text -> Widget n
B.txt (Text -> Widget n) -> Text -> Widget n
forall a b. (a -> b) -> a -> b
$ Text
normalChannelSigil Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c
FEmoji Text
em -> AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
emojiAttr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
Text -> Widget n
forall n. Text -> Widget n
B.txt (Text -> Widget n) -> Text -> Widget n
forall a b. (a -> b) -> a -> b
$ Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
em Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"
FText Text
t -> if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Text
T.singleton (Char
cursorSentinel)
then Widget n -> Widget n
forall n. Widget n -> Widget n
B.visible (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
B.txt Text
" "
else Text -> Widget n
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 AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
B.withDefAttr AttrName
attr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
B.txt Text
editMarking
textWithCursor :: Text -> Widget a
textWithCursor :: Text -> Widget a
textWithCursor Text
t
| (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
cursorSentinel) Text
t = Widget a -> Widget a
forall n. Widget n -> Widget n
B.visible (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$ Text -> Widget a
forall n. Text -> Widget n
B.txt (Text -> Widget a) -> Text -> Widget a
forall a b. (a -> b) -> a -> b
$ Text -> Text
removeCursor Text
t
| Bool
otherwise = Text -> Widget a
forall n. Text -> Widget n
B.txt Text
t
wrappedTextWithCursor :: Text -> Widget a
wrappedTextWithCursor :: Text -> Widget a
wrappedTextWithCursor Text
t
| (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
cursorSentinel) Text
t = Widget a -> Widget a
forall n. Widget n -> Widget n
B.visible (Widget a -> Widget a) -> Widget a -> Widget a
forall a b. (a -> b) -> a -> b
$ Text -> Widget a
forall n. Text -> Widget n
B.txtWrap (Text -> Widget a) -> Text -> Widget a
forall a b. (a -> b) -> a -> b
$ Text -> Text
removeCursor Text
t
| Bool
otherwise = Text -> Widget a
forall n. Text -> Widget n
B.txtWrap Text
t
removeCursor :: Text -> Text
removeCursor :: Text -> Text
removeCursor = (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
cursorSentinel)