module Graphics.Vty.Widgets.Box
( Box
, ChildSizePolicy(..)
, IndividualPolicy(..)
, BoxError(..)
, hBox
, vBox
, (<++>)
, (<-->)
, setBoxSpacing
, withBoxSpacing
, defaultChildSizePolicy
, setBoxChildSizePolicy
, getBoxChildSizePolicy
, getFirstChild
, getSecondChild
)
where
import GHC.Word ( Word )
import Data.Typeable
import Control.Exception
import Control.Monad
import Graphics.Vty.Widgets.Core
import Graphics.Vty
import Graphics.Vty.Widgets.Util
data BoxError = BadPercentage
deriving (Eq, Show, Typeable)
instance Exception BoxError
data Orientation = Horizontal | Vertical
deriving (Eq, Show)
data IndividualPolicy = BoxAuto
| BoxFixed Int
deriving (Show, Eq)
data ChildSizePolicy = PerChild IndividualPolicy IndividualPolicy
| Percentage Int
deriving (Show, Eq)
data Box a b = Box { boxChildSizePolicy :: ChildSizePolicy
, boxOrientation :: Orientation
, boxSpacing :: Int
, boxFirst :: Widget a
, boxSecond :: Widget b
, firstGrows :: IO Bool
, secondGrows :: IO Bool
, regDimension :: DisplayRegion -> Word
, imgDimension :: Image -> Word
, withDimension :: DisplayRegion -> Word -> DisplayRegion
, img_cat :: [Image] -> Image
}
instance Show (Box a b) where
show b = concat [ "Box { spacing = ", show $ boxSpacing b
, ", childSizePolicy = ", show $ boxChildSizePolicy b
, ", orientation = ", show $ boxOrientation b
, " }"
]
hBox :: (Show a, Show b) => Widget a -> Widget b -> IO (Widget (Box a b))
hBox = box Horizontal 0
vBox :: (Show a, Show b) => Widget a -> Widget b -> IO (Widget (Box a b))
vBox = box Vertical 0
(<-->) :: (Show a, Show b) => IO (Widget a) -> IO (Widget b) -> IO (Widget (Box a b))
(<-->) act1 act2 = do
ch1 <- act1
ch2 <- act2
vBox ch1 ch2
(<++>) :: (Show a, Show b) => IO (Widget a) -> IO (Widget b) -> IO (Widget (Box a b))
(<++>) act1 act2 = do
ch1 <- act1
ch2 <- act2
hBox ch1 ch2
infixl 3 <-->
infixl 3 <++>
defaultChildSizePolicy :: ChildSizePolicy
defaultChildSizePolicy = PerChild BoxAuto BoxAuto
box :: (Show a, Show b) =>
Orientation -> Int -> Widget a -> Widget b -> IO (Widget (Box a b))
box o spacing wa wb = do
wRef <- newWidget $ \w ->
w { state = Box { boxChildSizePolicy = defaultChildSizePolicy
, boxOrientation = o
, boxSpacing = spacing
, boxFirst = wa
, boxSecond = wb
, firstGrows =
(if o == Vertical then growVertical else growHorizontal) wa
, secondGrows =
(if o == Vertical then growVertical else growHorizontal) wb
, regDimension =
if o == Vertical then region_height else region_width
, imgDimension =
if o == Vertical then image_height else image_width
, withDimension =
if o == Vertical then withHeight else withWidth
, img_cat =
if o == Vertical then vert_cat else horiz_cat
}
, growHorizontal_ = \b -> do
case boxOrientation b of
Vertical -> do
h1 <- growHorizontal $ boxFirst b
h2 <- growHorizontal $ boxSecond b
return $ h1 || h2
Horizontal -> do
case boxChildSizePolicy b of
Percentage _ -> return True
PerChild s1 s2 -> do
h1 <- growHorizontal $ boxFirst b
h2 <- growHorizontal $ boxSecond b
return $ (h1 && s1 == BoxAuto) || (h2 && s2 == BoxAuto)
, growVertical_ = \b -> do
case boxOrientation b of
Horizontal -> do
h1 <- growVertical $ boxFirst b
h2 <- growVertical $ boxSecond b
return $ h1 || h2
Vertical -> do
case boxChildSizePolicy b of
Percentage _ -> return True
PerChild s1 s2 -> do
h1 <- growVertical $ boxFirst b
h2 <- growVertical $ boxSecond b
return $ (h1 && s1 == BoxAuto) || (h2 && s2 == BoxAuto)
, keyEventHandler =
\this key mods -> do
b <- getState this
handled <- handleKeyEvent (boxFirst b) key mods
if handled then return True else
handleKeyEvent (boxSecond b) key mods
, render_ = \this s ctx -> do
b <- getState this
renderBox s ctx b
, getCursorPosition_ =
\this -> do
b <- getState this
ch1_pos <- getCursorPosition $ boxFirst b
case ch1_pos of
Just v -> return $ Just v
Nothing -> getCursorPosition $ boxSecond b
, setCurrentPosition_ =
\this pos -> do
b <- getState this
ch1_size <- getCurrentSize $ boxFirst b
setCurrentPosition (boxFirst b) pos
case boxOrientation b of
Horizontal -> setCurrentPosition (boxSecond b) $
pos `plusWidth` ((region_width ch1_size) + (toEnum $ boxSpacing b))
Vertical -> setCurrentPosition (boxSecond b) $
pos `plusHeight` ((region_height ch1_size) + (toEnum $ boxSpacing b))
}
wRef `relayFocusEvents` wa
wRef `relayFocusEvents` wb
return wRef
getFirstChild :: Widget (Box a b) -> IO (Widget a)
getFirstChild = (boxFirst <~~)
getSecondChild :: Widget (Box a b) -> IO (Widget b)
getSecondChild = (boxSecond <~~)
setBoxSpacing :: Widget (Box a b) -> Int -> IO ()
setBoxSpacing wRef spacing =
updateWidgetState wRef $ \b -> b { boxSpacing = spacing }
withBoxSpacing :: Int -> Widget (Box a b) -> IO (Widget (Box a b))
withBoxSpacing spacing wRef = do
setBoxSpacing wRef spacing
return wRef
getBoxChildSizePolicy :: Widget (Box a b) -> IO ChildSizePolicy
getBoxChildSizePolicy = (boxChildSizePolicy <~~)
setBoxChildSizePolicy :: Widget (Box a b) -> ChildSizePolicy -> IO ()
setBoxChildSizePolicy b spol = do
case spol of
Percentage v -> when (v < 0 || v > 100) $ throw BadPercentage
_ -> return ()
updateWidgetState b $ \s -> s { boxChildSizePolicy = spol }
renderBox :: (Show a, Show b) =>
DisplayRegion
-> RenderContext
-> Box a b
-> IO Image
renderBox s ctx this = do
let actualSpace = regDimension this s (toEnum (boxSpacing this))
(img1, img2) <-
case boxChildSizePolicy this of
PerChild BoxAuto BoxAuto -> renderBoxAuto s ctx this
Percentage v -> do
let firstDim = round (fromRational
(fromRational ((toRational v) / (100.0)) *
(toRational actualSpace)) ::Rational)
secondDim = fromEnum (actualSpace firstDim)
renderBoxFixed s ctx this (fromEnum firstDim) secondDim
PerChild BoxAuto (BoxFixed v) -> do
let remaining = fromEnum (actualSpace toEnum v)
renderBoxFixed s ctx this remaining v
PerChild (BoxFixed v) BoxAuto -> do
let remaining = fromEnum (actualSpace toEnum v)
renderBoxFixed s ctx this v remaining
PerChild (BoxFixed v1) (BoxFixed v2) -> renderBoxFixed s ctx this v1 v2
let spAttr = getNormalAttr ctx
spacing = boxSpacing this
spacer = case spacing of
0 -> empty_image
_ -> case boxOrientation this of
Horizontal -> let h = max (image_height img1) (image_height img2)
in char_fill spAttr ' ' (toEnum spacing) h
Vertical -> let w = max (image_width img1) (image_width img2)
in char_fill spAttr ' ' w (toEnum spacing)
common_opposite_dim = case boxOrientation this of
Horizontal -> max (image_height img1) (image_height img2)
Vertical -> max (image_width img1) (image_width img2)
padded_img1 = case boxOrientation this of
Horizontal -> img1 <->
(char_fill spAttr ' ' (image_width img1)
(common_opposite_dim image_height img1))
Vertical -> img1 <|>
(char_fill spAttr ' ' (common_opposite_dim image_width img1)
(image_height img1))
padded_img2 = case boxOrientation this of
Horizontal -> img2 <->
(char_fill spAttr ' ' (image_width img2)
(common_opposite_dim image_height img2))
Vertical -> img2 <|>
(char_fill spAttr ' ' (common_opposite_dim image_width img2)
(image_height img2))
return $ (img_cat this) [padded_img1, spacer, padded_img2]
renderBoxFixed :: (Show a, Show b) =>
DisplayRegion
-> RenderContext
-> Box a b
-> Int
-> Int
-> IO (Image, Image)
renderBoxFixed s ctx this firstDim secondDim
| toEnum firstDim + toEnum secondDim > regDimension this s = return (empty_image, empty_image)
| otherwise = do
let withDim = withDimension this
img1 <- render (boxFirst this) (s `withDim` (toEnum firstDim)) ctx
img2 <- render (boxSecond this) (s `withDim` (toEnum secondDim)) ctx
let fill img amt = case boxOrientation this of
Vertical -> char_fill (getNormalAttr ctx) ' ' (image_width img) amt
Horizontal -> char_fill (getNormalAttr ctx) ' ' amt (image_height img)
firstDimW = toEnum firstDim
secondDimW = toEnum secondDim
img1_size = (imgDimension this) img1
img2_size = (imgDimension this) img2
img1_padded = if img1_size < firstDimW
then (img_cat this) [img1, fill img1 (firstDimW img1_size)]
else img1
img2_padded = if img2_size < secondDimW
then (img_cat this) [img2, fill img2 (secondDimW img2_size)]
else img2
return (img1_padded, img2_padded)
renderBoxAuto :: (Show a, Show b) =>
DisplayRegion
-> RenderContext
-> Box a b
-> IO (Image, Image)
renderBoxAuto s ctx this = do
let spacing = boxSpacing this
first = boxFirst this
second = boxSecond this
withDim = withDimension this
renderDimension = imgDimension this
regDim = regDimension this
actualSpace = s `withDim` (max (regDim s toEnum spacing) 0)
renderOrdered a b = do
a_img <- render a actualSpace ctx
let remaining = regDim actualSpace renderDimension a_img
s' = actualSpace `withDim` remaining
b_img <- render b s' ctx
return $ if renderDimension a_img >= regDim actualSpace
then [a_img, empty_image]
else [a_img, b_img]
renderHalves = do
let half = actualSpace `withDim` div (regDim actualSpace) 2
half' = if regDim actualSpace `mod` 2 == 0
then half
else half `withDim` (regDim half + 1)
first_img <- render first half ctx
second_img <- render second half' ctx
return [first_img, second_img]
gf <- firstGrows this
gs <- secondGrows this
[img1, img2] <- case (gf, gs) of
(True, True) -> renderHalves
(False, _) -> renderOrdered first second
(_, False) -> do
images <- renderOrdered second first
return $ reverse images
return (img1, img2)