-- | 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
  VerticalBarState
s <- MVar VerticalBarState -> IO VerticalBarState
forall a. MVar a -> IO a
readMVar MVar VerticalBarState
mv
  let drawArea :: DrawingArea
drawArea = VerticalBarState -> DrawingArea
barCanvas VerticalBarState
s
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VerticalBarState -> Bool
barIsBootstrapped VerticalBarState
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MVar VerticalBarState
-> (VerticalBarState -> IO VerticalBarState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar VerticalBarState
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 })
    IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DrawingArea -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetQueueDraw DrawingArea
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
  (Double
bgR, Double
bgG, Double
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 :: Int
pad = BarConfig -> Int
barPadding BarConfig
cfg
      fpad :: Double
fpad = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pad
  Double -> Double -> Double -> Render ()
C.setSourceRGB Double
bgR Double
bgG Double
bgB
  Double -> Double -> Double -> Double -> Render ()
C.rectangle Double
fpad Double
fpad (Double
fwidth Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fpad) (Double
fheight Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fpad)
  Render ()
C.fill

  -- Now draw a nice frame
  (Double
frameR, Double
frameG, Double
frameB) <- 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 -> IO (Double, Double, Double)
liftedBorderColor BarConfig
cfg
  Double -> Double -> Double -> Render ()
C.setSourceRGB Double
frameR Double
frameG Double
frameB
  Double -> Render ()
C.setLineWidth Double
1.0
  Double -> Double -> Double -> Double -> Render ()
C.rectangle (Double
fpad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.5) (Double
fpad Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.5) (Double
fwidth Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fpad Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1) (Double
fheight Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fpad Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1)
  Render ()
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

  (Double
r, Double
g, Double
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
  Double -> Double -> Double -> Render ()
C.setSourceRGB Double
r Double
g Double
b
  Double -> Double -> Render ()
C.translate Double
0 Double
newOrigin
  Double -> Double -> Double -> Double -> Render ()
C.rectangle Double
0 Double
0 Double
activeWidth Double
activeHeight
  Render ()
C.fill

drawBar :: MVar VerticalBarState -> DrawingArea -> C.Render ()
drawBar :: MVar VerticalBarState -> DrawingArea -> Render ()
drawBar MVar VerticalBarState
mv DrawingArea
drawArea = do
  (Int
w, Int
h) <- DrawingArea -> Render (Int, Int)
forall self (m :: * -> *).
(IsWidget self, MonadIO m) =>
self -> m (Int, Int)
widgetGetAllocatedSize DrawingArea
drawArea
  VerticalBarState
s <- IO VerticalBarState -> Render VerticalBarState
forall a. IO a -> Render a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO VerticalBarState -> Render VerticalBarState)
-> IO VerticalBarState -> Render VerticalBarState
forall a b. (a -> b) -> a -> b
$ do
         VerticalBarState
s <- MVar VerticalBarState -> IO VerticalBarState
forall a. MVar a -> IO a
readMVar MVar VerticalBarState
mv
         MVar VerticalBarState
-> (VerticalBarState -> IO VerticalBarState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar VerticalBarState
mv (\VerticalBarState
s' -> VerticalBarState -> IO VerticalBarState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return VerticalBarState
s' { barIsBootstrapped = True })
         VerticalBarState -> IO VerticalBarState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return VerticalBarState
s
  Double -> BarConfig -> Int -> Int -> Render ()
renderBar (VerticalBarState -> Double
barPercent VerticalBarState
s) (VerticalBarState -> BarConfig
barConfig VerticalBarState
s) Int
w Int
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
  DrawingArea
drawArea <- IO DrawingArea
forall (m :: * -> *). (HasCallStack, MonadIO m) => m DrawingArea
drawingAreaNew
  MVar VerticalBarState
mv <-
    VerticalBarState -> IO (MVar VerticalBarState)
forall a. a -> IO (MVar a)
newMVar
      VerticalBarState
      { barIsBootstrapped :: Bool
barIsBootstrapped = Bool
False
      , barPercent :: Double
barPercent = Double
0
      , barCanvas :: DrawingArea
barCanvas = DrawingArea
drawArea
      , barConfig :: BarConfig
barConfig = BarConfig
cfg
      }
  DrawingArea -> Int32 -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Int32 -> Int32 -> m ()
widgetSetSizeRequest DrawingArea
drawArea (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ BarConfig -> Int
barWidth BarConfig
cfg) (-Int32
1)
  SignalHandlerId
_ <- DrawingArea
-> ((?self::DrawingArea) => WidgetDrawCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => WidgetDrawCallback) -> m SignalHandlerId
onWidgetDraw DrawingArea
drawArea (((?self::DrawingArea) => WidgetDrawCallback)
 -> IO SignalHandlerId)
-> ((?self::DrawingArea) => WidgetDrawCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \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
box <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
boxNew Orientation
OrientationHorizontal Int32
1
  Box -> DrawingArea -> Bool -> Bool -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
boxPackStart Box
box DrawingArea
drawArea Bool
True Bool
True Word32
0
  Box -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShowAll Box
box
  Widget
giBox <- Box -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget Box
box
  (Widget, VerticalBarHandle) -> IO (Widget, VerticalBarHandle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Widget
giBox, MVar VerticalBarState -> VerticalBarHandle
VBH MVar VerticalBarState
mv)