content: -- | 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
  
  newtype VerticalBarHandle = VBH (MVar VerticalBarState)
  data VerticalBarState = VerticalBarState
    { barIsBootstrapped :: Bool
    , barPercent :: Double
    , barCanvas :: DrawingArea
    , barConfig :: BarConfig
    }
  
  data BarDirection = HORIZONTAL | VERTICAL
  
  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
    }
  
  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
    }
  
  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
  
  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)
  