module Graphics.Vty.Widgets.Borders
( HasBorderAttr(..)
, Bordered
, HBorder
, VBorder
, vBorder
, hBorder
, bordered
, withBorderAttribute
, withHBorderLabel
, withBorderedLabel
, setHBorderLabel
, setBorderedLabel
)
where
import qualified Data.Text as T
import Graphics.Vty
import Graphics.Vty.Widgets.Core
import Graphics.Vty.Widgets.Box
import Graphics.Vty.Widgets.Text
import Graphics.Vty.Widgets.Util
import Graphics.Vty.Widgets.Skins
class HasBorderAttr a where
setBorderAttribute :: a -> Attr -> IO ()
data HBorder = HBorder Attr T.Text
deriving (Show)
instance HasBorderAttr (Widget HBorder) where
setBorderAttribute t a =
updateWidgetState t $ \(HBorder a' s) -> HBorder (mergeAttr a a') s
withBorderAttribute :: (HasBorderAttr a) => Attr -> a -> IO a
withBorderAttribute att w = setBorderAttribute w att >> return w
withHBorderLabel :: T.Text -> Widget HBorder -> IO (Widget HBorder)
withHBorderLabel label w = setHBorderLabel w label >> return w
setHBorderLabel :: Widget HBorder -> T.Text -> IO ()
setHBorderLabel w label =
updateWidgetState w $ \(HBorder a _) -> HBorder a label
withBorderedLabel :: T.Text -> Widget (Bordered a) -> IO (Widget (Bordered a))
withBorderedLabel label w = setBorderedLabel w label >> return w
setBorderedLabel :: Widget (Bordered a) -> T.Text -> IO ()
setBorderedLabel w label =
updateWidgetState w $ \(Bordered a ch _) -> Bordered a ch label
hBorder :: IO (Widget HBorder)
hBorder = do
let initSt = HBorder defAttr T.empty
wRef <- newWidget initSt $ \w ->
w { growHorizontal_ = const $ return True
, render_ = renderHBorder
, getCursorPosition_ = const $ return Nothing
}
return wRef
renderHBorder :: Widget HBorder -> DisplayRegion -> RenderContext -> IO Image
renderHBorder _ (0, _) _ = return emptyImage
renderHBorder _ (_, 0) _ = return emptyImage
renderHBorder this s ctx = do
HBorder attr str <- getState this
let attr' = mergeAttrs [ overrideAttr ctx
, attr
, normalAttr ctx
]
ch = skinHorizontal $ skin ctx
noTitle = T.pack $ replicate (fromEnum $ regionWidth s) ch
wStr <- case T.null str of
True -> return noTitle
False -> do
let title = T.concat [ T.pack " "
, str
, T.pack " "
]
case (textWidth title) > (Phys $ fromEnum $ regionWidth s) of
True -> return noTitle
False -> do
let remaining = (Phys $ fromEnum $ regionWidth s) (textWidth title)
Phys side1 = remaining `div` Phys 2
side2 = if remaining `mod` Phys 2 == Phys 0 then side1 else side1 + 1
return $ T.concat [ T.pack $ replicate side1 ch
, title
, T.pack $ replicate side2 ch
]
w <- plainTextWithAttrs [(wStr, attr')]
render w s ctx
data VBorder = VBorder Attr
deriving (Show)
instance HasBorderAttr (Widget VBorder) where
setBorderAttribute t a =
updateWidgetState t $ \(VBorder a') -> VBorder (mergeAttr a a')
vBorder :: IO (Widget VBorder)
vBorder = do
let initSt = VBorder defAttr
wRef <- newWidget initSt $ \w ->
w { growVertical_ = const $ return True
, getCursorPosition_ = const $ return Nothing
, render_ = \this s ctx -> do
VBorder attr <- getState this
let attr' = mergeAttrs [ overrideAttr ctx
, attr
, normalAttr ctx
]
return $ charFill attr' (skinVertical $ skin ctx) 1 (regionHeight s)
}
return wRef
data Bordered a = (Show a) => Bordered Attr (Widget a) T.Text
instance Show (Bordered a) where
show (Bordered attr _ l) = concat [ "Bordered { attr = "
, show attr
, ", label = "
, show l
, ", ... }"
]
instance HasBorderAttr (Widget (Bordered a)) where
setBorderAttribute t a =
updateWidgetState t $ \(Bordered a' ch s) -> Bordered (mergeAttr a a') ch s
bordered :: (Show a) => Widget a -> IO (Widget (Bordered a))
bordered child = do
let initSt = Bordered defAttr child T.empty
wRef <- newWidget initSt $ \w ->
w { growVertical_ = const $ growVertical child
, growHorizontal_ = const $ growHorizontal child
, keyEventHandler =
\this key mods -> do
Bordered _ ch _ <- getState this
handleKeyEvent ch key mods
, render_ =
\this s ctx -> do
st <- getState this
drawBordered st s ctx
, setCurrentPosition_ =
\this pos -> do
Bordered _ ch _ <- getState this
let chPos = pos `plusWidth` 1 `plusHeight` 1
setCurrentPosition ch chPos
}
wRef `relayFocusEvents` child
wRef `relayKeyEvents` child
return wRef
drawBordered :: (Show a) =>
Bordered a -> DisplayRegion -> RenderContext -> IO Image
drawBordered this s ctx
| regionWidth s < 2 || regionHeight s < 2 = return emptyImage
| otherwise = do
let Bordered attr child label = this
attr' = mergeAttrs [ overrideAttr ctx
, attr
, normalAttr ctx
]
sk = skin ctx
let constrained = (regionWidth s 2, regionHeight s 2)
childImage <- render child constrained ctx
let adjusted = ( imageWidth childImage + 2
, imageHeight childImage
)
tlCorner <- plainText (T.singleton $ skinCornerTL sk)
>>= withNormalAttribute attr'
trCorner <- plainText (T.singleton $ skinCornerTR sk)
>>= withNormalAttribute attr'
blCorner <- plainText (T.singleton $ skinCornerBL sk)
>>= withNormalAttribute attr'
brCorner <- plainText (T.singleton $ skinCornerBR sk)
>>= withNormalAttribute attr'
hb <- hBorder >>= withHBorderLabel label
setBorderAttribute hb attr'
topWidget <- hBox tlCorner =<< hBox hb trCorner
top <- render topWidget adjusted ctx
hb2 <- hBorder
bottomWidget <- hBox blCorner =<< hBox hb2 brCorner
bottom <- render bottomWidget adjusted ctx
vb <- vBorder
setBorderAttribute vb attr'
leftRight <- render vb adjusted ctx
let middle = horizCat [leftRight, childImage, leftRight]
return $ vertCat [top, middle, bottom]