{-# LANGUAGE TemplateHaskell #-}
module Simple.UI.Widgets.TextView (
TextView,
TextViewClass,
castToTextView,
textViewNew
) where
import Control.Lens (makeLensesFor, (.=))
import Control.Monad
import qualified Graphics.Vty as Vty
import Simple.UI.Core.Internal.UIApp
import Simple.UI.Core.Attribute
import Simple.UI.Core.Draw
import Simple.UI.Core.ListenerList
import Simple.UI.Widgets.Text
import Simple.UI.Widgets.Widget
data TextView = TextView
{ _textViewParent :: Text
, _textViewYOffset :: Attribute Int
, _textViewHeight :: Attribute Int
}
makeLensesFor [("_textViewParent", "textViewParent")] ''TextView
class TextClass w => TextViewClass w where
castToTextView :: w -> TextView
instance TextViewClass TextView where
castToTextView = id
instance TextClass TextView where
castToText = _textViewParent
instance WidgetClass TextView where
castToWidget = castToWidget . _textViewParent
overrideWidget = overrideWidgetHelper textViewParent
textViewNew :: Maybe String -> UIApp u TextView
textViewNew s = do
textView <- textViewNewOverride s
on_ textView draw $ textViewDraw textView
on_ textView keyPressed $ textViewKeyPressed textView
return textView
textViewNewOverride :: Maybe String -> UIApp u TextView
textViewNewOverride s = override <$> textViewNewDefault s
where
textViewComputeSize textView = do
maybeText <- get textView text
case maybeText of
Nothing -> return (1, 1)
Just _text -> do
let ls = lines _text
let ws = map length ls
let w = maximum ws
let l = length ls
return ( if w == 0 then 1 else w
, if l == 0 then 1 else l
)
override textView = overrideWidget textView $ do
virtualWidgetName .= "textview"
virtualWidgetComputeSize .= textViewComputeSize textView
textViewNewDefault :: Maybe String -> UIApp u TextView
textViewNewDefault s = do
parent <- textNew s
yOffset <- attributeNew 0
height <- attributeNew 0
return TextView
{ _textViewParent = parent
, _textViewYOffset = yOffset
, _textViewHeight = height
}
textViewDraw :: TextView -> Drawing -> Int -> Int -> UIApp u ()
textViewDraw textView drawing _ height = do
set textView _textViewHeight height
maybeText <- get textView text
forM_ maybeText $ \_text -> do
fg <- get textView colorForeground
bg <- get textView colorBackground
style <- get textView colorStyle
let ls = lines _text
let l = length ls
yOffset' <- get textView _textViewYOffset
let yOffset = if height + yOffset' > l
then nat $ l - height
else yOffset'
drawingRun drawing $ do
let minH = min height l
let h = height - l
let dy = if h <= 0 then 0 else h `div` 2
drawingSetAttrs fg bg style
drawingClear
forM_ (zip [dy..] [0 .. minH - 1]) $ \(y, i) ->
drawingPutString 0 y (ls !! (i + yOffset))
textViewKeyPressed :: TextView -> Vty.Key -> [Vty.Modifier]-> UIApp u ()
textViewKeyPressed textView key _ = do
height <- get textView _textViewHeight
yOffset <- get textView _textViewYOffset
case key of
Vty.KUp ->
when (yOffset > 0) $
set textView _textViewYOffset (yOffset - 1)
Vty.KDown -> do
maybeText <- get textView text
forM_ maybeText $ \_text -> do
let l = length . lines $ _text
when (l - height > yOffset) $
set textView _textViewYOffset (yOffset + 1)
Vty.KPageUp ->
if yOffset > 5
then set textView _textViewYOffset (yOffset - 5)
else set textView _textViewYOffset 0
Vty.KPageDown -> do
maybeText <- get textView text
forM_ maybeText $ \_text -> do
let l = length . lines $ _text
if l - height > yOffset + 5
then set textView _textViewYOffset (yOffset + 5)
else set textView _textViewYOffset (nat $ l - height)
_ ->
return ()
nat :: Int -> Int
nat x = if x < 0 then 0 else x