-- | 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
  { VerticalBarState -> Bool
barIsBootstrapped :: Bool
  , VerticalBarState -> Double
barPercent :: Double
  , VerticalBarState -> DrawingArea
barCanvas :: DrawingArea
  , VerticalBarState -> BarConfig
barConfig :: BarConfig
  }

data BarDirection = HORIZONTAL | VERTICAL

data BarConfig
  = BarConfig {
     -- | Color of the border drawn around the widget
      BarConfig -> (Double, Double, Double)
barBorderColor :: (Double, Double, Double)
     -- | The background color of the widget
    , BarConfig -> Double -> (Double, Double, Double)
barBackgroundColor :: Double -> (Double, Double, Double)
     -- | A function to determine the color of the widget for the current data point
    , BarConfig -> Double -> (Double, Double, Double)
barColor :: Double -> (Double, Double, Double)
     -- | Number of pixels of padding around the widget
    , BarConfig -> Int
barPadding :: Int
    , BarConfig -> Int
barWidth :: Int
    , BarConfig -> BarDirection
barDirection :: BarDirection}
  | BarConfigIO { BarConfig -> IO (Double, Double, Double)
barBorderColorIO :: IO (Double, Double, Double)
                , BarConfig -> Double -> IO (Double, Double, Double)
barBackgroundColorIO :: Double -> IO (Double, Double, Double)
                , BarConfig -> 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 :: (Double -> (Double, Double, Double)) -> BarConfig
defaultBarConfig Double -> (Double, Double, Double)
c =
  BarConfig
  { barBorderColor :: (Double, Double, Double)
barBorderColor = (Double
0.5, Double
0.5, Double
0.5)
  , barBackgroundColor :: Double -> (Double, Double, Double)
barBackgroundColor = (Double, Double, Double) -> Double -> (Double, Double, Double)
forall a b. a -> b -> a
const (Double
0, Double
0, Double
0)
  , barColor :: Double -> (Double, Double, Double)
barColor = Double -> (Double, Double, Double)
c
  , barPadding :: Int
barPadding = Int
2
  , barWidth :: Int
barWidth = Int
15
  , barDirection :: BarDirection
barDirection = BarDirection
VERTICAL
  }

defaultBarConfigIO :: (Double -> IO (Double, Double, Double)) -> BarConfig
defaultBarConfigIO :: (Double -> IO (Double, Double, Double)) -> BarConfig
defaultBarConfigIO Double -> IO (Double, Double, Double)
c =
  BarConfigIO
  { barBorderColorIO :: IO (Double, Double, Double)
barBorderColorIO = (Double, Double, Double) -> IO (Double, Double, Double)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
0.5, Double
0.5, Double
0.5)
  , barBackgroundColorIO :: Double -> IO (Double, Double, Double)
barBackgroundColorIO = \Double
_ -> (Double, Double, Double) -> IO (Double, Double, Double)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
0, Double
0, Double
0)
  , barColorIO :: Double -> IO (Double, Double, Double)
barColorIO = Double -> IO (Double, Double, Double)
c
  , barPadding :: Int
barPadding = Int
2
  , barWidth :: Int
barWidth = Int
15
  , barDirection :: BarDirection
barDirection = BarDirection
VERTICAL
  }

verticalBarSetPercent :: VerticalBarHandle -> Double -> IO ()
verticalBarSetPercent :: VerticalBarHandle -> Double -> IO ()
verticalBarSetPercent (VBH MVar VerticalBarState
mv) Double
pct = do
  s <- MVar VerticalBarState -> IO VerticalBarState
forall a. MVar a -> IO a
readMVar MVar VerticalBarState
mv
  let drawArea = VerticalBarState -> DrawingArea
barCanvas VerticalBarState
s
  when (barIsBootstrapped s) $ do
    modifyMVar_ mv (\VerticalBarState
s' -> VerticalBarState -> IO VerticalBarState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return VerticalBarState
s' { barPercent = clamp 0 1 pct })
    postGUIASync $ widgetQueueDraw drawArea

clamp :: Double -> Double -> Double -> Double
clamp :: Double -> Double -> Double -> Double
clamp Double
lo Double
hi Double
d = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
lo (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
hi Double
d

liftedBackgroundColor :: BarConfig -> Double -> IO (Double, Double, Double)
liftedBackgroundColor :: BarConfig -> Double -> IO (Double, Double, Double)
liftedBackgroundColor BarConfig
bc Double
pct =
  case BarConfig
bc of
    BarConfig { barBackgroundColor :: BarConfig -> Double -> (Double, Double, Double)
barBackgroundColor = Double -> (Double, Double, Double)
bcolor } -> (Double, Double, Double) -> IO (Double, Double, Double)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> (Double, Double, Double)
bcolor Double
pct)
    BarConfigIO { barBackgroundColorIO :: BarConfig -> Double -> IO (Double, Double, Double)
barBackgroundColorIO = Double -> IO (Double, Double, Double)
bcolor } -> Double -> IO (Double, Double, Double)
bcolor Double
pct

liftedBorderColor :: BarConfig -> IO (Double, Double, Double)
liftedBorderColor :: BarConfig -> IO (Double, Double, Double)
liftedBorderColor BarConfig
bc =
  case BarConfig
bc of
    BarConfig { barBorderColor :: BarConfig -> (Double, Double, Double)
barBorderColor = (Double, Double, Double)
border } -> (Double, Double, Double) -> IO (Double, Double, Double)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double, Double, Double)
border
    BarConfigIO { barBorderColorIO :: BarConfig -> IO (Double, Double, Double)
barBorderColorIO = IO (Double, Double, Double)
border } -> IO (Double, Double, Double)
border

liftedBarColor :: BarConfig -> Double -> IO (Double, Double, Double)
liftedBarColor :: BarConfig -> Double -> IO (Double, Double, Double)
liftedBarColor BarConfig
bc Double
pct =
  case BarConfig
bc of
    BarConfig { barColor :: BarConfig -> Double -> (Double, Double, Double)
barColor = Double -> (Double, Double, Double)
c } -> (Double, Double, Double) -> IO (Double, Double, Double)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> (Double, Double, Double)
c Double
pct)
    BarConfigIO { barColorIO :: BarConfig -> Double -> IO (Double, Double, Double)
barColorIO = Double -> IO (Double, Double, Double)
c } -> Double -> IO (Double, Double, Double)
c Double
pct

renderFrame_ :: Double -> BarConfig -> Int -> Int -> C.Render ()
renderFrame_ :: Double -> BarConfig -> Int -> Int -> Render ()
renderFrame_ Double
pct BarConfig
cfg Int
width Int
height = do
  let fwidth :: Double
fwidth = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width
      fheight :: Double
fheight = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height

  -- Now draw the user's requested background, respecting padding
  (bgR, bgG, bgB) <- IO (Double, Double, Double) -> Render (Double, Double, Double)
forall a. IO a -> Render a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
C.liftIO (IO (Double, Double, Double) -> Render (Double, Double, Double))
-> IO (Double, Double, Double) -> Render (Double, Double, Double)
forall a b. (a -> b) -> a -> b
$ BarConfig -> Double -> IO (Double, Double, Double)
liftedBackgroundColor BarConfig
cfg Double
pct
  let pad = BarConfig -> Int
barPadding BarConfig
cfg
      fpad = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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 :: Double -> BarConfig -> Int -> Int -> Render ()
renderBar Double
pct BarConfig
cfg Int
width Int
height = do
  let direction :: BarDirection
direction = BarConfig -> BarDirection
barDirection BarConfig
cfg
      activeHeight :: Double
activeHeight = case BarDirection
direction of
                       BarDirection
VERTICAL   -> Double
pct Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height
                       BarDirection
HORIZONTAL -> Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height
      activeWidth :: Double
activeWidth  = case BarDirection
direction of
                       BarDirection
VERTICAL   -> Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width
                       BarDirection
HORIZONTAL -> Double
pct Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width
      newOrigin :: Double
newOrigin    = case BarDirection
direction of
                       BarDirection
VERTICAL -> Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
activeHeight
                       BarDirection
HORIZONTAL -> Double
0
      pad :: Int
pad = BarConfig -> Int
barPadding BarConfig
cfg

  Double -> BarConfig -> Int -> Int -> Render ()
renderFrame_ Double
pct BarConfig
cfg Int
width Int
height

  -- After we draw the frame, transform the coordinate space so that
  -- we only draw within the frame.
  Double -> Double -> Render ()
C.translate (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1)
  let xS :: Double
xS = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pad Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width
      yS :: Double
yS = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
pad Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height
  Double -> Double -> Render ()
C.scale Double
xS Double
yS

  (r, g, b) <- IO (Double, Double, Double) -> Render (Double, Double, Double)
forall a. IO a -> Render a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
C.liftIO (IO (Double, Double, Double) -> Render (Double, Double, Double))
-> IO (Double, Double, Double) -> Render (Double, Double, Double)
forall a b. (a -> b) -> a -> b
$ BarConfig -> Double -> IO (Double, Double, Double)
liftedBarColor BarConfig
cfg Double
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 :: MVar VerticalBarState -> DrawingArea -> Render ()
drawBar MVar VerticalBarState
mv DrawingArea
drawArea = do
  (w, h) <- DrawingArea -> Render (Int, Int)
forall self (m :: * -> *).
(IsWidget self, MonadIO m) =>
self -> m (Int, Int)
widgetGetAllocatedSize DrawingArea
drawArea
  s <- liftIO $ do
         s <- readMVar mv
         modifyMVar_ mv (\VerticalBarState
s' -> VerticalBarState -> IO VerticalBarState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return VerticalBarState
s' { barIsBootstrapped = True })
         return s
  renderBar (barPercent s) (barConfig s) w h

verticalBarNew :: MonadIO m => BarConfig -> m (GI.Gtk.Widget, VerticalBarHandle)
verticalBarNew :: forall (m :: * -> *).
MonadIO m =>
BarConfig -> m (Widget, VerticalBarHandle)
verticalBarNew BarConfig
cfg = IO (Widget, VerticalBarHandle) -> m (Widget, VerticalBarHandle)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Widget, VerticalBarHandle) -> m (Widget, VerticalBarHandle))
-> IO (Widget, VerticalBarHandle) -> m (Widget, VerticalBarHandle)
forall a b. (a -> b) -> a -> b
$ do
  drawArea <- IO DrawingArea
forall (m :: * -> *). (HasCallStack, MonadIO m) => m DrawingArea
drawingAreaNew
  mv <-
    newMVar
      VerticalBarState
      { barIsBootstrapped = False
      , barPercent = 0
      , barCanvas = drawArea
      , barConfig = cfg
      }
  widgetSetSizeRequest drawArea (fromIntegral $ barWidth cfg) (-1)
  _ <- onWidgetDraw drawArea $ \Context
ctx -> Render () -> Context -> IO ()
forall (m :: * -> *) a. MonadIO m => Render a -> Context -> m a
renderWithContext (MVar VerticalBarState -> DrawingArea -> Render ()
drawBar MVar VerticalBarState
mv DrawingArea
drawArea) Context
ctx IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  box <- boxNew OrientationHorizontal 1
  boxPackStart box drawArea True True 0
  widgetShowAll box
  giBox <- toWidget box
  return (giBox, VBH mv)