VerticalBar.hs

-- | A vertical bar that can plot data in the range [0, 1].  The
-- colors are configurable.
module System.Taffybar.Widget.Generic.VerticalBar
  ( -- * Types
    VerticalBarHandle,
    BarConfig (..),
    BarDirection (..),

    -- * Accessors/Constructors
    verticalBarNew,
    verticalBarSetPercent,
    defaultBarConfig,
    defaultBarConfigIO,
  )
where

import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import qualified GI.Cairo.Render as C
import GI.Cairo.Render.Connector
import GI.Gtk hiding (widgetGetAllocatedSize)
import System.Taffybar.Util
import System.Taffybar.Widget.Util

-- | Handle used to update an existing vertical bar widget.
newtype VerticalBarHandle = VBH (MVar VerticalBarState)

data VerticalBarState = VerticalBarState
  { barIsBootstrapped :: Bool,
    barPercent :: Double,
    barCanvas :: DrawingArea,
    barConfig :: BarConfig
  }

-- | Direction in which the filled portion grows.
data BarDirection = HORIZONTAL | VERTICAL

-- | Static or IO-driven configuration for the vertical bar.
data BarConfig
  = BarConfig
      { -- | Color of the border drawn around the widget
        barBorderColor :: (Double, Double, Double),
        -- | The background color of the widget
        barBackgroundColor :: Double -> (Double, Double, Double),
        -- | A function to determine the color of the widget for the current data point
        barColor :: Double -> (Double, Double, Double),
        -- | Number of pixels of padding around the widget
        barPadding :: Int,
        barWidth :: Int,
        barDirection :: BarDirection
      }
  | BarConfigIO
      { barBorderColorIO :: IO (Double, Double, Double),
        barBackgroundColorIO :: Double -> IO (Double, Double, Double),
        barColorIO :: Double -> IO (Double, Double, Double),
        barPadding :: Int,
        barWidth :: Int,
        barDirection :: BarDirection
      }

-- | A default bar configuration.  The color of the active portion of
-- the bar must be specified.
defaultBarConfig :: (Double -> (Double, Double, Double)) -> BarConfig
defaultBarConfig c =
  BarConfig
    { barBorderColor = (0.5, 0.5, 0.5),
      barBackgroundColor = const (0, 0, 0),
      barColor = c,
      barPadding = 2,
      barWidth = 15,
      barDirection = VERTICAL
    }

-- | IO-driven variant of 'defaultBarConfig'.
defaultBarConfigIO :: (Double -> IO (Double, Double, Double)) -> BarConfig
defaultBarConfigIO c =
  BarConfigIO
    { barBorderColorIO = return (0.5, 0.5, 0.5),
      barBackgroundColorIO = \_ -> return (0, 0, 0),
      barColorIO = c,
      barPadding = 2,
      barWidth = 15,
      barDirection = VERTICAL
    }

-- | Update the bar value (clamped to @[0, 1]@) and queue a redraw.
verticalBarSetPercent :: VerticalBarHandle -> Double -> IO ()
verticalBarSetPercent (VBH mv) pct = do
  s <- readMVar mv
  let drawArea = barCanvas s
  when (barIsBootstrapped s) $ 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

liftedBackgroundColor :: BarConfig -> Double -> IO (Double, Double, Double)
liftedBackgroundColor bc pct =
  case bc of
    BarConfig {barBackgroundColor = bcolor} -> return (bcolor pct)
    BarConfigIO {barBackgroundColorIO = bcolor} -> bcolor pct

liftedBorderColor :: BarConfig -> IO (Double, Double, Double)
liftedBorderColor bc =
  case bc of
    BarConfig {barBorderColor = border} -> return border
    BarConfigIO {barBorderColorIO = border} -> border

liftedBarColor :: BarConfig -> Double -> IO (Double, Double, Double)
liftedBarColor bc pct =
  case bc of
    BarConfig {barColor = c} -> return (c pct)
    BarConfigIO {barColorIO = c} -> c pct

renderFrame_ :: Double -> BarConfig -> Int -> Int -> C.Render ()
renderFrame_ pct cfg width height = do
  let fwidth = fromIntegral width
      fheight = fromIntegral height

  -- Now draw the user's requested background, respecting padding
  (bgR, bgG, bgB) <- C.liftIO $ liftedBackgroundColor cfg pct
  let pad = barPadding cfg
      fpad = fromIntegral pad
  C.setSourceRGB bgR bgG bgB
  C.rectangle fpad fpad (fwidth - 2 * fpad) (fheight - 2 * fpad)
  C.fill

  -- Now draw a nice frame
  (frameR, frameG, frameB) <- C.liftIO $ liftedBorderColor cfg
  C.setSourceRGB frameR frameG frameB
  C.setLineWidth 1.0
  C.rectangle (fpad + 0.5) (fpad + 0.5) (fwidth - 2 * fpad - 1) (fheight - 2 * fpad - 1)
  C.stroke

renderBar :: Double -> BarConfig -> Int -> Int -> C.Render ()
renderBar pct cfg width height = do
  let direction = barDirection cfg
      activeHeight = case direction of
        VERTICAL -> pct * fromIntegral height
        HORIZONTAL -> fromIntegral height
      activeWidth = case direction of
        VERTICAL -> fromIntegral width
        HORIZONTAL -> pct * fromIntegral width
      newOrigin = case direction of
        VERTICAL -> fromIntegral height - activeHeight
        HORIZONTAL -> 0
      pad = barPadding cfg

  renderFrame_ pct cfg width height

  -- After we draw the frame, transform the coordinate space so that
  -- we only draw within the frame.
  C.translate (fromIntegral pad + 1) (fromIntegral pad + 1)
  let xS = fromIntegral (width - 2 * pad - 2) / fromIntegral width
      yS = fromIntegral (height - 2 * pad - 2) / fromIntegral height
  C.scale xS yS

  (r, g, b) <- C.liftIO $ liftedBarColor cfg pct
  C.setSourceRGB r g b
  C.translate 0 newOrigin
  C.rectangle 0 0 activeWidth activeHeight
  C.fill

drawBar :: MVar VerticalBarState -> DrawingArea -> C.Render ()
drawBar mv drawArea = do
  (w, h) <- widgetGetAllocatedSize drawArea
  s <- liftIO $ do
    s <- readMVar mv
    modifyMVar_ mv (\s' -> return s' {barIsBootstrapped = True})
    return s
  renderBar (barPercent s) (barConfig s) w h

-- | Construct a bar widget and its mutable update handle.
verticalBarNew :: (MonadIO m) => BarConfig -> m (GI.Gtk.Widget, VerticalBarHandle)
verticalBarNew cfg = liftIO $ do
  drawArea <- drawingAreaNew
  mv <-
    newMVar
      VerticalBarState
        { barIsBootstrapped = False,
          barPercent = 0,
          barCanvas = drawArea,
          barConfig = cfg
        }
  widgetSetSizeRequest drawArea (fromIntegral $ barWidth cfg) (-1)
  _ <- onWidgetDraw drawArea $ \ctx -> renderWithContext (drawBar mv drawArea) ctx >> return True
  box <- boxNew OrientationHorizontal 1
  boxPackStart box drawArea True True 0
  widgetShowAll box
  giBox <- toWidget box
  return (giBox, VBH mv)