-- | 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 c :: Double -> (Double, Double, Double)
c =
  BarConfig :: (Double, Double, Double)
-> (Double -> (Double, Double, Double))
-> (Double -> (Double, Double, Double))
-> Int
-> Int
-> BarDirection
-> BarConfig
BarConfig
  { barBorderColor :: (Double, Double, Double)
barBorderColor = (0.5, 0.5, 0.5)
  , barBackgroundColor :: Double -> (Double, Double, Double)
barBackgroundColor = (Double, Double, Double) -> Double -> (Double, Double, Double)
forall a b. a -> b -> a
const (0, 0, 0)
  , barColor :: Double -> (Double, Double, Double)
barColor = Double -> (Double, Double, Double)
c
  , barPadding :: Int
barPadding = 2
  , barWidth :: Int
barWidth = 15
  , barDirection :: BarDirection
barDirection = BarDirection
VERTICAL
  }

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

verticalBarSetPercent :: VerticalBarHandle -> Double -> IO ()
verticalBarSetPercent :: VerticalBarHandle -> Double -> IO ()
verticalBarSetPercent (VBH mv :: MVar VerticalBarState
mv) pct :: 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 (\s' :: VerticalBarState
s' -> VerticalBarState -> IO VerticalBarState
forall (m :: * -> *) a. Monad m => a -> m a
return VerticalBarState
s' { barPercent :: Double
barPercent = Double -> Double -> Double -> Double
clamp 0 1 Double
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 lo :: Double
lo hi :: Double
hi d :: 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 bc :: BarConfig
bc pct :: 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 (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 bc :: 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 (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 bc :: BarConfig
bc pct :: 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 (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_ pct :: Double
pct cfg :: BarConfig
cfg width :: Int
width height :: 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 :: Double
bgR, bgG :: Double
bgG, bgB :: Double
bgB) <- IO (Double, Double, Double) -> Render (Double, Double, Double)
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
- 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
- 2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fpad)
  Render ()
C.fill

  -- Now draw a nice frame
  (frameR :: Double
frameR, frameG :: Double
frameG, frameB :: Double
frameB) <- IO (Double, Double, Double) -> Render (Double, Double, Double)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
C.liftIO