module Graphics.Vty.Widgets.Text
( FormattedText
, plainText
, plainTextWithAttrs
, textWidget
, setText
, appendText
, prependText
, setTextWithAttrs
, appendTextWithAttrs
, prependTextWithAttrs
, setTextFormatter
, setTextAppearFocused
, Formatter(Formatter)
, applyFormatter
, getTextFormatter
, nullFormatter
, wrap
)
where
import Control.Applicative
import Data.Monoid
import qualified Data.Text as T
import Graphics.Vty
import Graphics.Vty.Widgets.Core
import Text.Trans.Tokenize
import Graphics.Vty.Widgets.Util
newtype Formatter = Formatter (DisplayRegion -> TextStream Attr -> IO (TextStream Attr))
instance Monoid Formatter where
mempty = nullFormatter
mappend (Formatter f1) (Formatter f2) =
Formatter (\sz t -> f1 sz t >>= f2 sz)
applyFormatter :: Formatter -> DisplayRegion -> TextStream Attr -> IO (TextStream Attr)
applyFormatter (Formatter f) sz t = f sz t
nullFormatter :: Formatter
nullFormatter = Formatter (\_ t -> return t)
data FormattedText =
FormattedText { textContent :: TextStream Attr
, formatter :: !Formatter
, useFocusAttribute :: !Bool
}
instance Show FormattedText where
show (FormattedText t _ f) = concat [ "FormattedText { "
, "text = ", show t
, ", formatter = ..."
, ", useFocusAttribute = " ++ show f
, " }"
]
plainText :: T.Text -> IO (Widget FormattedText)
plainText = textWidget nullFormatter
plainTextWithAttrs :: [(T.Text, Attr)] -> IO (Widget FormattedText)
plainTextWithAttrs pairs = do
w <- textWidget nullFormatter T.empty
setTextWithAttrs w pairs
return w
wrap :: Formatter
wrap =
Formatter $ \sz ts -> do
let width = Phys $ fromEnum $ fst sz
return $ wrapStream width ts
textWidget :: Formatter -> T.Text -> IO (Widget FormattedText)
textWidget format s = do
let initSt = FormattedText { textContent = TS []
, formatter = format
, useFocusAttribute = False
}
wRef <- newWidget initSt $ \w ->
w { getCursorPosition_ = const $ return Nothing
, render_ =
\this size ctx -> do
ft <- getState this
f <- focused <~ this
appearFocused <- useFocusAttribute <~~ this
renderText (textContent ft) (f && appearFocused) (formatter ft) size ctx
}
setText wRef s
return wRef
setTextFormatter :: Widget FormattedText -> Formatter -> IO ()
setTextFormatter wRef f = updateWidgetState wRef $ \st ->
st { formatter = f }
getTextFormatter :: Widget FormattedText -> IO Formatter
getTextFormatter = (formatter <~~)
setTextAppearFocused :: Widget FormattedText -> Bool -> IO ()
setTextAppearFocused wRef val = updateWidgetState wRef $ \st ->
st { useFocusAttribute = val }
setText :: Widget FormattedText -> T.Text -> IO ()
setText wRef s = setTextWithAttrs wRef [(s, defAttr)]
appendText :: Widget FormattedText -> T.Text -> IO ()
appendText wRef s = appendTextWithAttrs wRef [(s, defAttr)]
prependText :: Widget FormattedText -> T.Text -> IO ()
prependText wRef s = prependTextWithAttrs wRef [(s, defAttr)]
prependTextWithAttrs :: Widget FormattedText -> [(T.Text, Attr)] -> IO ()
prependTextWithAttrs wRef pairs = _setTextWithAttrs wRef pairs f
where
f st new = let TS old = textContent st
in new ++ old
appendTextWithAttrs :: Widget FormattedText -> [(T.Text, Attr)] -> IO ()
appendTextWithAttrs wRef pairs = _setTextWithAttrs wRef pairs f
where
f st new = let TS old = textContent st
in old ++ new
setTextWithAttrs :: Widget FormattedText -> [(T.Text, Attr)] -> IO ()
setTextWithAttrs wRef pairs = _setTextWithAttrs wRef pairs (\_ new -> new)
_setTextWithAttrs :: Widget FormattedText
-> [(T.Text, Attr)]
-> (FormattedText -> [TextStreamEntity Attr] -> [TextStreamEntity Attr])
-> IO ()
_setTextWithAttrs wRef pairs f = do
let streams = map (\(s, a) -> tokenize s a) pairs
ts = concat $ map streamEntities streams
updateWidgetState wRef $ \st ->
st { textContent = TS $ f st ts }
renderText :: TextStream Attr
-> Bool
-> Formatter
-> DisplayRegion
-> RenderContext
-> IO Image
renderText t foc (Formatter format) sz ctx = do
TS newText <- format sz t
let attr' = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx
, normalAttr ctx
]
finalAttr tok = mergeAttrs [ if foc then focusAttr ctx else overrideAttr ctx
, tokenAttr tok
, normalAttr ctx
]
lineImgs = map mkLineImg ls
lineLength l = length $ tokenStr <$> l
maxLineLength = maximum $ lineLength <$> ls
emptyLineLength = min (fromEnum $ fst sz) maxLineLength
ls = map truncLine $ map (map entityToken) $ findLines newText
truncLine = truncateLine (Phys $ fromEnum $ fst sz)
mkLineImg line = if null line
then charFill attr' ' ' emptyLineLength 1
else horizCat $ map mkTokenImg line
nullImg = string defAttr ""
mkTokenImg :: Token Attr -> Image
mkTokenImg tok = string (finalAttr tok) (T.unpack $ tokenStr tok)
return $ if snd sz == 0
then nullImg
else if null ls || all null ls
then nullImg
else vertCat $ take (fromEnum $ snd sz) lineImgs