module System.Taffybar.Widgets.VerticalBar (
VerticalBarHandle,
BarConfig(..),
verticalBarNew,
verticalBarSetPercent,
defaultBarConfig
) where
import Control.Concurrent
import Graphics.Rendering.Cairo
import Graphics.UI.Gtk
newtype VerticalBarHandle = VBH (MVar VerticalBarState)
data VerticalBarState =
VerticalBarState { barIsBootstrapped :: Bool
, barPercent :: Double
, barCanvas :: DrawingArea
, barConfig :: BarConfig
}
data BarConfig =
BarConfig { barBorderColor :: (Double, Double, Double)
, barBackgroundColor :: (Double, Double, Double)
, barColor :: Double -> (Double, Double, Double)
, barPadding :: Int
, barWidth :: Int
}
defaultBarConfig :: (Double -> (Double, Double, Double)) -> BarConfig
defaultBarConfig c = BarConfig { barBorderColor = (0.5, 0.5, 0.5)
, barBackgroundColor = (0, 0, 0)
, barColor = c
, barPadding = 2
, barWidth = 15
}
verticalBarSetPercent :: VerticalBarHandle -> Double -> IO ()
verticalBarSetPercent (VBH mv) pct = do
s <- readMVar mv
let drawArea = barCanvas s
case barIsBootstrapped s of
False -> return ()
True -> do
modifyMVar_ mv (\s' -> return s' { barPercent = clamp 0 1 pct })
postGUIAsync $ widgetQueueDraw drawArea
clamp :: Double -> Double -> Double -> Double
clamp lo hi d = max lo $ min hi d
renderFrame :: BarConfig -> Int -> Int -> Render ()
renderFrame cfg width height = do
let fwidth = fromIntegral width
fheight = fromIntegral height
let (bgR, bgG, bgB) = barBackgroundColor cfg
pad = barPadding cfg
fpad = fromIntegral pad
setSourceRGB bgR bgG bgB
rectangle fpad fpad (fwidth 2 * fpad) (fheight 2 * fpad)
fill
let (frameR, frameG, frameB) = barBorderColor cfg
setSourceRGB frameR frameG frameB
setLineWidth 1.0
rectangle fpad fpad (fwidth 2 * fpad) (fheight 2 * fpad)
stroke
renderBar :: Double -> BarConfig -> Int -> Int -> Render ()
renderBar pct cfg width height = do
let activeHeight = pct * (fromIntegral height)
activeWidth = fromIntegral width
newOrigin = fromIntegral height activeHeight
pad = barPadding cfg
renderFrame cfg width height
translate (fromIntegral pad + 1) (fromIntegral pad + 1)
let xS = fromIntegral (width 2 * pad 2) / fromIntegral width
yS = fromIntegral (height 2 * pad 2) / fromIntegral height
scale xS yS
let (r, g, b) = (barColor cfg) pct
setSourceRGB r g b
translate 0 newOrigin
rectangle 0 0 activeWidth activeHeight
fill
drawBar :: MVar VerticalBarState -> DrawingArea -> IO ()
drawBar mv drawArea = do
(w, h) <- widgetGetSize drawArea
drawWin <- widgetGetDrawWindow drawArea
s <- readMVar mv
let pct = barPercent s
modifyMVar_ mv (\s' -> return s' { barIsBootstrapped = True })
renderWithDrawable drawWin (renderBar pct (barConfig s) w h)
verticalBarNew :: BarConfig -> IO (Widget, VerticalBarHandle)
verticalBarNew cfg = do
drawArea <- drawingAreaNew
mv <- newMVar VerticalBarState { barIsBootstrapped = False
, barPercent = 0
, barCanvas = drawArea
, barConfig = cfg
}
widgetSetSizeRequest drawArea (barWidth cfg) (1)
_ <- on drawArea exposeEvent $ tryEvent $ liftIO (drawBar mv drawArea)
box <- hBoxNew False 1
boxPackStart box drawArea PackGrow 0
widgetShowAll box
return (toWidget box, VBH mv)