{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Widget.Battery
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- This module provides battery widgets that are queried using the UPower dbus
-- service. To avoid duplicating all information requests for each battery
-- widget displayed (if using a multi-head configuration or multiple battery
-- widgets), these widgets use the "BroadcastChan" based system for receiving
-- updates defined in "System.Taffybar.Information.Battery".
-----------------------------------------------------------------------------
module System.Taffybar.Widget.Battery
  ( batteryIconNew
  , textBatteryNew
  , textBatteryNewWithLabelAction
  ) where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Reader
import           Data.Default (Default(..))
import           Data.Int (Int64)
import qualified Data.Text as T
import           GI.Gtk as Gtk
import           Prelude
import           StatusNotifier.Tray (scalePixbufToSize)
import           System.Taffybar.Context
import           System.Taffybar.Information.Battery
import           System.Taffybar.Util
import           System.Taffybar.Widget.Generic.AutoSizeImage
import           System.Taffybar.Widget.Generic.ChannelWidget
import           System.Taffybar.Widget.Util hiding (themeLoadFlags)
import           Text.Printf
import           Text.StringTemplate

-- | Just the battery info that will be used for display (this makes combining
-- several easier).
data BatteryWidgetInfo = BWI
  { BatteryWidgetInfo -> Maybe Int64
seconds :: Maybe Int64
  , BatteryWidgetInfo -> Int
percent :: Int
  , BatteryWidgetInfo -> String
status :: String
  } deriving (BatteryWidgetInfo -> BatteryWidgetInfo -> Bool
(BatteryWidgetInfo -> BatteryWidgetInfo -> Bool)
-> (BatteryWidgetInfo -> BatteryWidgetInfo -> Bool)
-> Eq BatteryWidgetInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BatteryWidgetInfo -> BatteryWidgetInfo -> Bool
== :: BatteryWidgetInfo -> BatteryWidgetInfo -> Bool
$c/= :: BatteryWidgetInfo -> BatteryWidgetInfo -> Bool
/= :: BatteryWidgetInfo -> BatteryWidgetInfo -> Bool
Eq, Int -> BatteryWidgetInfo -> ShowS
[BatteryWidgetInfo] -> ShowS
BatteryWidgetInfo -> String
(Int -> BatteryWidgetInfo -> ShowS)
-> (BatteryWidgetInfo -> String)
-> ([BatteryWidgetInfo] -> ShowS)
-> Show BatteryWidgetInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BatteryWidgetInfo -> ShowS
showsPrec :: Int -> BatteryWidgetInfo -> ShowS
$cshow :: BatteryWidgetInfo -> String
show :: BatteryWidgetInfo -> String
$cshowList :: [BatteryWidgetInfo] -> ShowS
showList :: [BatteryWidgetInfo] -> ShowS
Show)

-- | Format a duration expressed as seconds to hours and minutes
formatDuration :: Maybe Int64 -> String
formatDuration :: Maybe Int64 -> String
formatDuration Maybe Int64
Nothing = String
""
formatDuration (Just Int64
secs) = let minutes :: Int64
minutes = Int64
secs Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
60
                                 hours :: Int64
hours = Int64
minutes Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
60
                                 minutes' :: Int64
minutes' = Int64
minutes Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`mod` Int64
60
                             in String -> Int64 -> Int64 -> String
forall r. PrintfType r => String -> r
printf String
"%02d:%02d" Int64
hours Int64
minutes'

getBatteryWidgetInfo :: BatteryInfo -> BatteryWidgetInfo
getBatteryWidgetInfo :: BatteryInfo -> BatteryWidgetInfo
getBatteryWidgetInfo BatteryInfo
info =
  let battPctNum :: Int
      battPctNum :: Int
battPctNum = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (BatteryInfo -> Double
batteryPercentage BatteryInfo
info)
      battTime :: Maybe Int64
      battTime :: Maybe Int64
battTime =
        case BatteryInfo -> BatteryState
batteryState BatteryInfo
info of
          BatteryState
BatteryStateCharging -> Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64) -> Int64 -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ BatteryInfo -> Int64
batteryTimeToFull BatteryInfo
info
          BatteryState
BatteryStateDischarging -> Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64) -> Int64 -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ BatteryInfo -> Int64
batteryTimeToEmpty BatteryInfo
info
          BatteryState
_ -> Maybe Int64
forall a. Maybe a
Nothing
      battStatus :: String
      battStatus :: String
battStatus =
        case BatteryInfo -> BatteryState
batteryState BatteryInfo
info of
          BatteryState
BatteryStateCharging -> String
"Charging"
          BatteryState
BatteryStateDischarging -> String
"Discharging"
          BatteryState
_ -> String
"✔"
  in BWI {seconds :: Maybe Int64
seconds = Maybe Int64
battTime, percent :: Int
percent = Int
battPctNum, status :: String
status = String
battStatus}

-- | Given (maybe summarized) battery info and format: provides the string to display
formatBattInfo :: BatteryWidgetInfo -> String -> T.Text
formatBattInfo :: BatteryWidgetInfo -> String -> Text
formatBattInfo BatteryWidgetInfo
info String
fmt =
  let tpl :: StringTemplate Text
tpl = String -> StringTemplate Text
forall a. Stringable a => String -> StringTemplate a
newSTMP String
fmt
      tpl' :: StringTemplate Text
tpl' = [(String, String)] -> StringTemplate Text -> StringTemplate Text
forall a b.
(ToSElem a, Stringable b) =>
[(String, a)] -> StringTemplate b -> StringTemplate b
setManyAttrib [ (String
"percentage", (Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> (BatteryWidgetInfo -> Int) -> BatteryWidgetInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatteryWidgetInfo -> Int
percent) BatteryWidgetInfo
info)
                           , (String
"time", Maybe Int64 -> String
formatDuration (BatteryWidgetInfo -> Maybe Int64
seconds BatteryWidgetInfo
info))
                           , (String
"status", BatteryWidgetInfo -> String
status BatteryWidgetInfo
info)
                           ] StringTemplate Text
tpl
  in StringTemplate Text -> Text
forall a. Stringable a => StringTemplate a -> a
render StringTemplate Text
tpl'

-- | A simple textual battery widget. The displayed format is specified format
-- string where $percentage$ is replaced with the percentage of battery
-- remaining and $time$ is replaced with the time until the battery is fully
-- charged/discharged.
textBatteryNew :: String -> TaffyIO Widget
textBatteryNew :: String -> TaffyIO Widget
textBatteryNew String
format = (Label -> BatteryInfo -> TaffyIO ()) -> TaffyIO Widget
textBatteryNewWithLabelAction Label -> BatteryInfo -> TaffyIO ()
labelSetter
  where labelSetter :: Label -> BatteryInfo -> TaffyIO ()
labelSetter Label
label BatteryInfo
info = do
          BatteryClassesConfig -> Label -> BatteryInfo -> TaffyIO ()
forall (m :: * -> *).
MonadIO m =>
BatteryClassesConfig -> Label -> BatteryInfo -> m ()
setBatteryStateClasses BatteryClassesConfig
forall a. Default a => a
def Label
label BatteryInfo
info
          Label -> Text -> TaffyIO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
labelSetMarkup Label
label (Text -> TaffyIO ()) -> Text -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$
                         BatteryWidgetInfo -> String -> Text
formatBattInfo (BatteryInfo -> BatteryWidgetInfo
getBatteryWidgetInfo BatteryInfo
info) String
format

data BatteryClassesConfig = BatteryClassesConfig
  { BatteryClassesConfig -> Double
batteryHighThreshold :: Double
  , BatteryClassesConfig -> Double
batteryLowThreshold :: Double
  , BatteryClassesConfig -> Double
batteryCriticalThreshold :: Double
  }

defaultBatteryClassesConfig :: BatteryClassesConfig
defaultBatteryClassesConfig :: BatteryClassesConfig
defaultBatteryClassesConfig =
  BatteryClassesConfig
  { batteryHighThreshold :: Double
batteryHighThreshold = Double
80
  , batteryLowThreshold :: Double
batteryLowThreshold = Double
20
  , batteryCriticalThreshold :: Double
batteryCriticalThreshold = Double
5
  }

instance Default BatteryClassesConfig where
  def :: BatteryClassesConfig
def = BatteryClassesConfig
defaultBatteryClassesConfig

setBatteryStateClasses ::
  MonadIO m => BatteryClassesConfig -> Gtk.Label -> BatteryInfo -> m ()
setBatteryStateClasses :: forall (m :: * -> *).
MonadIO m =>
BatteryClassesConfig -> Label -> BatteryInfo -> m ()
setBatteryStateClasses BatteryClassesConfig
config Label
label BatteryInfo
info = do
  case BatteryInfo -> BatteryState
batteryState BatteryInfo
info of
    BatteryState
BatteryStateCharging -> Text -> Label -> m ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
addClassIfMissing Text
"charging" Label
label m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                            Text -> Label -> m ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
removeClassIfPresent Text
"discharging" Label
label
    BatteryState
BatteryStateDischarging -> Text -> Label -> m ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
addClassIfMissing Text
"discharging" Label
label m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                               Text -> Label -> m ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
removeClassIfPresent Text
"charging" Label
label
    BatteryState
_ -> Text -> Label -> m ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
removeClassIfPresent Text
"charging" Label
label m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
         Text -> Label -> m ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
removeClassIfPresent Text
"discharging" Label
label

  Text -> Bool -> m ()
classIf Text
"high" (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Double
percentage Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= BatteryClassesConfig -> Double
batteryHighThreshold BatteryClassesConfig
config
  Text -> Bool -> m ()
classIf Text
"low" (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Double
percentage Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= BatteryClassesConfig -> Double
batteryLowThreshold BatteryClassesConfig
config
  Text -> Bool -> m ()
classIf Text
"critical" (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Double
percentage Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= BatteryClassesConfig -> Double
batteryCriticalThreshold BatteryClassesConfig
config
  where percentage :: Double
percentage = BatteryInfo -> Double
batteryPercentage BatteryInfo
info
        classIf :: Text -> Bool -> m ()
classIf Text
klass Bool
condition =
          if Bool
condition
          then Text -> Label -> m ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
addClassIfMissing Text
klass Label
label
          else Text -> Label -> m ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
removeClassIfPresent Text
klass Label
label

-- | Like `textBatteryNew` but provides a more general way to update the label
-- widget. The argument provided is an action that is used to update the text
-- label given a 'BatteryInfo' object describing the state of the battery.
textBatteryNewWithLabelAction ::
  (Gtk.Label -> BatteryInfo -> TaffyIO ()) -> TaffyIO Widget
textBatteryNewWithLabelAction :: (Label -> BatteryInfo -> TaffyIO ()) -> TaffyIO Widget
textBatteryNewWithLabelAction Label -> BatteryInfo -> TaffyIO ()
labelSetter = do
  BroadcastChan In BatteryInfo
chan <- TaffyIO (BroadcastChan In BatteryInfo)
getDisplayBatteryChan
  Context
ctx <- ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO Widget -> TaffyIO Widget
forall a. IO a -> ReaderT Context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Widget -> TaffyIO Widget) -> IO Widget -> TaffyIO Widget
forall a b. (a -> b) -> a -> b
$ do
    Label
label <- Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
labelNew Maybe Text
forall a. Maybe a
Nothing
    let updateWidget :: BatteryInfo -> IO ()
updateWidget =
          IO () -> IO ()
postGUIASync (IO () -> IO ()) -> (BatteryInfo -> IO ()) -> BatteryInfo -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TaffyIO () -> Context -> IO ()) -> Context -> TaffyIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip TaffyIO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
ctx (TaffyIO () -> IO ())
-> (BatteryInfo -> TaffyIO ()) -> BatteryInfo -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> BatteryInfo -> TaffyIO ()
labelSetter Label
label
    IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Label -> ((?self::Label) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
onWidgetRealize Label
label (((?self::Label) => IO ()) -> IO SignalHandlerId)
-> ((?self::Label) => IO ()) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$
         ReaderT Context IO BatteryInfo -> Context -> IO BatteryInfo
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Context IO BatteryInfo
getDisplayBatteryInfo Context
ctx IO BatteryInfo -> (BatteryInfo -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BatteryInfo -> IO ()
updateWidget
    Label -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget (Label -> IO Widget) -> IO Label -> IO Widget
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Label
-> BroadcastChan In BatteryInfo
-> (BatteryInfo -> IO ())
-> IO Label
forall (m :: * -> *) w a.
(MonadIO m, IsWidget w) =>
w -> BroadcastChan In a -> (a -> IO ()) -> m w
channelWidgetNew Label
label BroadcastChan In BatteryInfo
chan BatteryInfo -> IO ()
updateWidget

themeLoadFlags :: [IconLookupFlags]
themeLoadFlags :: [IconLookupFlags]
themeLoadFlags = [IconLookupFlags
IconLookupFlagsGenericFallback, IconLookupFlags
IconLookupFlagsUseBuiltin]

batteryIconNew :: TaffyIO Widget
batteryIconNew :: TaffyIO Widget
batteryIconNew = do
  BroadcastChan In BatteryInfo
chan <- TaffyIO (BroadcastChan In BatteryInfo)
getDisplayBatteryChan
  Context
ctx <- ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO Widget -> TaffyIO Widget
forall a. IO a -> ReaderT Context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Widget -> TaffyIO Widget) -> IO Widget -> TaffyIO Widget
forall a b. (a -> b) -> a -> b
$ do
    Image
image <- IO Image
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Image
imageNew
    StyleContext
styleCtx <- Widget -> IO StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
widgetGetStyleContext (Widget -> IO StyleContext) -> IO Widget -> IO StyleContext
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Image -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget Image
image
    IconTheme
defaultTheme <- IO IconTheme
forall (m :: * -> *). (HasCallStack, MonadIO m) => m IconTheme
iconThemeGetDefault
    let getCurrentBatteryIconNameString :: IO Text
getCurrentBatteryIconNameString =
          String -> Text
T.pack (String -> Text) -> (BatteryInfo -> String) -> BatteryInfo -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatteryInfo -> String
batteryIconName (BatteryInfo -> Text) -> IO BatteryInfo -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Context IO BatteryInfo -> Context -> IO BatteryInfo
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Context IO BatteryInfo
getDisplayBatteryInfo Context
ctx
        extractPixbuf :: IconInfo -> IO Pixbuf
extractPixbuf IconInfo
info =
          (Pixbuf, Bool) -> Pixbuf
forall a b. (a, b) -> a
fst ((Pixbuf, Bool) -> Pixbuf) -> IO (Pixbuf, Bool) -> IO Pixbuf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IconInfo -> StyleContext -> IO (Pixbuf, Bool)
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsIconInfo a, IsStyleContext b) =>
a -> b -> m (Pixbuf, Bool)
iconInfoLoadSymbolicForContext IconInfo
info StyleContext
styleCtx
        setIconForSize :: Int32 -> IO (Maybe Pixbuf)
setIconForSize Int32
size = do
          Text
name <- IO Text
getCurrentBatteryIconNameString
          IconTheme
-> Text -> Int32 -> [IconLookupFlags] -> IO (Maybe IconInfo)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsIconTheme a) =>
a -> Text -> Int32 -> [IconLookupFlags] -> m (Maybe IconInfo)
iconThemeLookupIcon IconTheme
defaultTheme Text
name Int32
size [IconLookupFlags]
themeLoadFlags IO (Maybe IconInfo)
-> (Maybe IconInfo -> IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            (IconInfo -> IO Pixbuf) -> Maybe IconInfo -> IO (Maybe Pixbuf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse IconInfo -> IO Pixbuf
extractPixbuf IO (Maybe Pixbuf)
-> (Maybe Pixbuf -> IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
              (Pixbuf -> IO Pixbuf) -> Maybe Pixbuf -> IO (Maybe Pixbuf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Int32 -> Orientation -> Pixbuf -> IO Pixbuf
scalePixbufToSize Int32
size Orientation
OrientationHorizontal)
    IO ()
updateImage <- Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> IO (IO ())
forall (m :: * -> *).
MonadIO m =>
Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> m (IO ())
autoSizeImage Image
image Int32 -> IO (Maybe Pixbuf)
setIconForSize Orientation
OrientationHorizontal
    Image -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget (Image -> IO Widget) -> IO Image -> IO Widget
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Image
-> BroadcastChan In BatteryInfo
-> (BatteryInfo -> IO ())
-> IO Image
forall (m :: * -> *) w a.
(MonadIO m, IsWidget w) =>
w -> BroadcastChan In a -> (a -> IO ()) -> m w
channelWidgetNew Image
image BroadcastChan In BatteryInfo
chan (IO () -> BatteryInfo -> IO ()
forall a b. a -> b -> a
const (IO () -> BatteryInfo -> IO ()) -> IO () -> BatteryInfo -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
postGUIASync IO ()
updateImage)