{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Widget.MPRIS2
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- This is a "Now Playing" widget that listens for MPRIS2 events on DBus. You
-- can find the MPRIS2 specification here at
-- (<https://specifications.freedesktop.org/mpris-spec/latest/>).
-----------------------------------------------------------------------------
module System.Taffybar.Widget.MPRIS2 where

import           Control.Arrow
import qualified Control.Concurrent.MVar as MV
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Reader
import           DBus
import           DBus.Client
import qualified DBus.TH as DBus
import           Data.Default (Default(..))
import           Data.GI.Base.Overloading (IsDescendantOf)
import           Data.Int
import           Data.List
import qualified Data.Map as M
import qualified Data.Text as T
import qualified GI.GLib as G
import           GI.GdkPixbuf.Objects.Pixbuf as Gdk
import qualified GI.Gtk as Gtk
import           System.Environment.XDG.DesktopEntry
import           System.Log.Logger
import           System.Taffybar.Context
import qualified System.Taffybar.DBus.Client.MPRIS2 as MPRIS2DBus
import           System.Taffybar.Information.MPRIS2
import           System.Taffybar.Util
import           System.Taffybar.Widget.Generic.AutoSizeImage
import           System.Taffybar.Widget.Util
import           System.Taffybar.WindowIcon
import           Text.Printf

mprisLog :: (MonadIO m, Show t) => Priority -> String -> t -> m ()
mprisLog :: forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
mprisLog = String -> Priority -> String -> t -> m ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
String -> Priority -> String -> t -> m ()
logPrintF String
"System.Taffybar.Widget.MPRIS2"

-- | A type representing a function that produces an IO action that adds the
-- provided widget to some container.
type WidgetAdder a m =
  (IsDescendantOf Gtk.Widget a
  , MonadIO m
  , Gtk.GObject a
  ) => a -> m ()

-- | The type of a customization function that is used to update a widget with
-- the provided now playing info. The type a should be the internal state used
-- for the widget (typically just references to the child widgets that may need
-- to be updated ). When the provided value is nothing, it means that the widget
-- does not exist yet and it should be instantiated. When the provided
-- NowPlaying value is Nothing, the dbus client is no longer, and typically the
-- widget should be hidden.
type UpdateMPRIS2PlayerWidget a =
  (forall w. WidgetAdder w IO) -> Maybe a -> Maybe NowPlaying -> TaffyIO a

-- | Configuration for an MPRIS2 Widget
data MPRIS2Config a =
  MPRIS2Config
  {
  -- | A function that will be used to wrap the outer MPRIS2 grid widget
    forall a. MPRIS2Config a -> Widget -> IO Widget
mprisWidgetWrapper :: Gtk.Widget -> IO Gtk.Widget
  -- | This function will be called to instantiate and update the player widgets
  -- of each dbus player client. See the docstring for `UpdateMPRIS2PlayerWidget`
  -- for more details.
  , forall a. MPRIS2Config a -> UpdateMPRIS2PlayerWidget a
updatePlayerWidget :: UpdateMPRIS2PlayerWidget a
  }

defaultMPRIS2Config :: MPRIS2Config MPRIS2PlayerWidget
defaultMPRIS2Config :: MPRIS2Config MPRIS2PlayerWidget
defaultMPRIS2Config =
  MPRIS2Config
  { mprisWidgetWrapper :: Widget -> IO Widget
mprisWidgetWrapper = Widget -> IO Widget
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
  , updatePlayerWidget :: UpdateMPRIS2PlayerWidget MPRIS2PlayerWidget
updatePlayerWidget = SimpleMPRIS2PlayerConfig
-> UpdateMPRIS2PlayerWidget MPRIS2PlayerWidget
simplePlayerWidget SimpleMPRIS2PlayerConfig
forall a. Default a => a
def
  }

data MPRIS2PlayerWidget = MPRIS2PlayerWidget
  { MPRIS2PlayerWidget -> Label
playerLabel :: Gtk.Label
  , MPRIS2PlayerWidget -> Widget
playerWidget :: Gtk.Widget
  }

data SimpleMPRIS2PlayerConfig = SimpleMPRIS2PlayerConfig
  { SimpleMPRIS2PlayerConfig -> NowPlaying -> IO Text
setNowPlayingLabel :: NowPlaying -> IO T.Text
  , SimpleMPRIS2PlayerConfig -> NowPlaying -> IO Bool
showPlayerWidgetFn :: NowPlaying -> IO Bool
  }

defaultPlayerConfig :: SimpleMPRIS2PlayerConfig
defaultPlayerConfig :: SimpleMPRIS2PlayerConfig
defaultPlayerConfig = SimpleMPRIS2PlayerConfig
  { setNowPlayingLabel :: NowPlaying -> IO Text
setNowPlayingLabel = Int -> Int -> NowPlaying -> IO Text
forall (m :: * -> *).
MonadIO m =>
Int -> Int -> NowPlaying -> m Text
playingText Int
20 Int
30
  , showPlayerWidgetFn :: NowPlaying -> IO Bool
showPlayerWidgetFn =
    \NowPlaying { npStatus :: NowPlaying -> String
npStatus = String
status } -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ String
status String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"Stopped"
  }

instance Default SimpleMPRIS2PlayerConfig where
  def :: SimpleMPRIS2PlayerConfig
def = SimpleMPRIS2PlayerConfig
defaultPlayerConfig

makeExcept :: String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b
makeExcept :: forall a b.
String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b
makeExcept String
errorString a -> IO (Maybe b)
actionBuilder =
  IO (Either String b) -> ExceptT String IO b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String b) -> ExceptT String IO b)
-> (a -> IO (Either String b)) -> a -> ExceptT String IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe b -> Either String b)
-> IO (Maybe b) -> IO (Either String b)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Maybe b -> Either String b
forall b a. b -> Maybe a -> Either b a
maybeToEither String
errorString) (IO (Maybe b) -> IO (Either String b))
-> (a -> IO (Maybe b)) -> a -> IO (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO (Maybe b)
actionBuilder

loadIconAtSize ::
  Client -> BusName -> Int32 -> IO Gdk.Pixbuf
loadIconAtSize :: Client -> BusName -> Int32 -> IO Pixbuf
loadIconAtSize Client
client BusName
busName Int32
size =
  let
    failure :: String -> IO Pixbuf
failure String
err =
      Priority -> String -> String -> IO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
mprisLog Priority
WARNING String
"Failed to load default image: %s" String
err IO () -> IO Pixbuf -> IO Pixbuf
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
               Int32 -> Word32 -> IO Pixbuf
forall (m :: * -> *). MonadIO m => Int32 -> Word32 -> m Pixbuf
pixBufFromColor Int32
size Word32
0
    loadDefault :: IO Pixbuf
loadDefault =
      Int32 -> String -> IO (Either String Pixbuf)
loadIcon Int32
size String
"play.svg" IO (Either String Pixbuf)
-> (Either String Pixbuf -> IO Pixbuf) -> IO Pixbuf
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO Pixbuf)
-> (Pixbuf -> IO Pixbuf) -> Either String Pixbuf -> IO Pixbuf
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO Pixbuf
failure Pixbuf -> IO Pixbuf
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    logErrorAndLoadDefault :: String -> IO Pixbuf
logErrorAndLoadDefault String
err =
      Priority -> String -> String -> IO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
mprisLog Priority
WARNING String
"Failed to get MPRIS icon: %s" String
err IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
      Priority -> String -> BusName -> IO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
mprisLog Priority
WARNING String
"MPRIS failure for: %s" BusName
busName IO () -> IO Pixbuf -> IO Pixbuf
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
      IO Pixbuf
loadDefault
    chromeSpecialCase :: Either MethodError String -> Either MethodError String
chromeSpecialCase l :: Either MethodError String
l@(Left MethodError
_) =
      if String
"chrom" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` BusName -> String
formatBusName BusName
busName
      then String -> Either MethodError String
forall a b. b -> Either a b
Right String
"google-chrome" else Either MethodError String
l
    chromeSpecialCase Either MethodError String
x = Either MethodError String
x
  in
    (String -> IO Pixbuf)
-> (Pixbuf -> IO Pixbuf) -> Either String Pixbuf -> IO Pixbuf
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO Pixbuf
logErrorAndLoadDefault Pixbuf -> IO Pixbuf
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Pixbuf -> IO Pixbuf)
-> IO (Either String Pixbuf) -> IO Pixbuf
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    ExceptT String IO Pixbuf -> IO (Either String Pixbuf)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (IO (Either String String) -> ExceptT String IO String
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT ((MethodError -> String)
-> Either MethodError String -> Either String String
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left MethodError -> String
forall a. Show a => a -> String
show (Either MethodError String -> Either String String)
-> (Either MethodError String -> Either MethodError String)
-> Either MethodError String
-> Either String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either MethodError String -> Either MethodError String
chromeSpecialCase (Either MethodError String -> Either String String)
-> IO (Either MethodError String) -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client -> BusName -> IO (Either MethodError String)
MPRIS2DBus.getDesktopEntry Client
client BusName
busName)
                          ExceptT String IO String
-> (String -> ExceptT String IO DesktopEntry)
-> ExceptT String IO DesktopEntry
forall a b.
ExceptT String IO a
-> (a -> ExceptT String IO b) -> ExceptT String IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String
-> (String -> IO (Maybe DesktopEntry))
-> String
-> ExceptT String IO DesktopEntry
forall a b.
String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b
makeExcept String
"Failed to get desktop entry"
                              String -> IO (Maybe DesktopEntry)
getDirectoryEntryDefault
                          ExceptT String IO DesktopEntry
-> (DesktopEntry -> ExceptT String IO Pixbuf)
-> ExceptT String IO Pixbuf
forall a b.
ExceptT String IO a
-> (a -> ExceptT String IO b) -> ExceptT String IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String
-> (DesktopEntry -> IO (Maybe Pixbuf))
-> DesktopEntry
-> ExceptT String IO Pixbuf
forall a b.
String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b
makeExcept String
"Failed to get image"
                                (Int32 -> DesktopEntry -> IO (Maybe Pixbuf)
getImageForDesktopEntry Int32
size))

-- | This is the default player widget constructor that is used to build mpris
-- widgets. It provides only an icon and NowPlaying text.
simplePlayerWidget ::
  SimpleMPRIS2PlayerConfig -> UpdateMPRIS2PlayerWidget MPRIS2PlayerWidget

simplePlayerWidget :: SimpleMPRIS2PlayerConfig
-> UpdateMPRIS2PlayerWidget MPRIS2PlayerWidget
simplePlayerWidget SimpleMPRIS2PlayerConfig
_ forall w. WidgetAdder w IO
_
                     (Just p :: MPRIS2PlayerWidget
p@MPRIS2PlayerWidget { playerWidget :: MPRIS2PlayerWidget -> Widget
playerWidget = Widget
widget })
                     Maybe NowPlaying
Nothing =
                       IO MPRIS2PlayerWidget -> ReaderT Context IO MPRIS2PlayerWidget
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO MPRIS2PlayerWidget -> ReaderT Context IO MPRIS2PlayerWidget)
-> IO MPRIS2PlayerWidget -> ReaderT Context IO MPRIS2PlayerWidget
forall a b. (a -> b) -> a -> b
$ Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetHide Widget
widget IO () -> IO MPRIS2PlayerWidget -> IO MPRIS2PlayerWidget
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MPRIS2PlayerWidget -> IO MPRIS2PlayerWidget
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MPRIS2PlayerWidget
p

simplePlayerWidget SimpleMPRIS2PlayerConfig
c forall w. WidgetAdder w IO
addToParent Maybe MPRIS2PlayerWidget
Nothing
                     np :: Maybe NowPlaying
np@(Just NowPlaying { npBusName :: NowPlaying -> BusName
npBusName = BusName
busName }) = do
  Context
ctx <- ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Client
client <- (Context -> Client) -> ReaderT Context IO Client
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> Client
sessionDBusClient
  IO MPRIS2PlayerWidget -> ReaderT Context IO MPRIS2PlayerWidget
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO MPRIS2PlayerWidget -> ReaderT Context IO MPRIS2PlayerWidget)
-> IO MPRIS2PlayerWidget -> ReaderT Context IO MPRIS2PlayerWidget
forall a b. (a -> b) -> a -> b
$ do
    Priority -> String -> BusName -> IO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
mprisLog Priority
DEBUG String
"Building widget for %s" BusName
busName
    Image
image <- (Int32 -> IO Pixbuf) -> Orientation -> IO Image
forall (m :: * -> *).
MonadIO m =>
(Int32 -> IO Pixbuf) -> Orientation -> m Image
autoSizeImageNew (Client -> BusName -> Int32 -> IO Pixbuf
loadIconAtSize Client
client BusName
busName) Orientation
Gtk.OrientationHorizontal
    Grid
playerBox <- IO Grid
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Grid
Gtk.gridNew
    Label
label <- Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
Gtk.labelNew Maybe Text
forall a. Maybe a
Nothing
    EventBox
ebox <- IO EventBox
forall (m :: * -> *). (HasCallStack, MonadIO m) => m EventBox
Gtk.eventBoxNew
    SignalHandlerId
_ <- EventBox
-> ((?self::EventBox) => WidgetButtonPressEventCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a
-> ((?self::a) => WidgetButtonPressEventCallback)
-> m SignalHandlerId
Gtk.onWidgetButtonPressEvent EventBox
ebox (((?self::EventBox) => WidgetButtonPressEventCallback)
 -> IO SignalHandlerId)
-> ((?self::EventBox) => WidgetButtonPressEventCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$
         IO Bool -> WidgetButtonPressEventCallback
forall a b. a -> b -> a
const (IO Bool -> WidgetButtonPressEventCallback)
-> IO Bool -> WidgetButtonPressEventCallback
forall a b. (a -> b) -> a -> b
$ Client -> BusName -> IO (Either MethodError ())
MPRIS2DBus.playPause Client
client BusName
busName IO (Either MethodError ()) -> 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
    Grid -> Image -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Grid
playerBox Image
image
    Grid -> Label -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Grid
playerBox Label
label
    EventBox -> Grid -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd EventBox
ebox Grid
playerBox
    Grid -> IO ()
forall o (m :: * -> *). (IsWidget o, MonadIO m) => o -> m ()
vFillCenter Grid
playerBox
    EventBox -> IO ()
forall w. WidgetAdder w IO
addToParent EventBox
ebox
    Grid -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
Gtk.widgetSetVexpand Grid
playerBox Bool
True
    Grid -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Text -> m ()
Gtk.widgetSetName Grid
playerBox (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ BusName -> String
formatBusName BusName
busName
    EventBox -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShowAll EventBox
ebox
    EventBox -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetHide EventBox
ebox
    Widget
widget <- EventBox -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget EventBox
ebox
    let widgetData :: MPRIS2PlayerWidget
widgetData =
          MPRIS2PlayerWidget { playerLabel :: Label
playerLabel = Label
label, playerWidget :: Widget
playerWidget = Widget
widget }
    (ReaderT Context IO MPRIS2PlayerWidget
 -> Context -> IO MPRIS2PlayerWidget)
-> Context
-> ReaderT Context IO MPRIS2PlayerWidget
-> IO MPRIS2PlayerWidget
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Context IO MPRIS2PlayerWidget
-> Context -> IO MPRIS2PlayerWidget
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
ctx (ReaderT Context IO MPRIS2PlayerWidget -> IO MPRIS2PlayerWidget)
-> ReaderT Context IO MPRIS2PlayerWidget -> IO MPRIS2PlayerWidget
forall a b. (a -> b) -> a -> b
$
         SimpleMPRIS2PlayerConfig
-> UpdateMPRIS2PlayerWidget MPRIS2PlayerWidget
simplePlayerWidget SimpleMPRIS2PlayerConfig
c w -> IO ()
forall w. WidgetAdder w IO
addToParent (MPRIS2PlayerWidget -> Maybe MPRIS2PlayerWidget
forall a. a -> Maybe a
Just MPRIS2PlayerWidget
widgetData) Maybe NowPlaying
np

simplePlayerWidget SimpleMPRIS2PlayerConfig
config forall w. WidgetAdder w IO
_
                     (Just w :: MPRIS2PlayerWidget
w@MPRIS2PlayerWidget
                             { playerLabel :: MPRIS2PlayerWidget -> Label
playerLabel = Label
label
                             , playerWidget :: MPRIS2PlayerWidget -> Widget
playerWidget = Widget
widget
                             }) (Just NowPlaying
nowPlaying) = IO MPRIS2PlayerWidget -> ReaderT Context IO MPRIS2PlayerWidget
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO MPRIS2PlayerWidget -> ReaderT Context IO MPRIS2PlayerWidget)
-> IO MPRIS2PlayerWidget -> ReaderT Context IO MPRIS2PlayerWidget
forall a b. (a -> b) -> a -> b
$ do
  Priority -> String -> NowPlaying -> IO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
mprisLog Priority
DEBUG String
"Setting state %s" NowPlaying
nowPlaying
  Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
Gtk.labelSetMarkup Label
label (Text -> IO ()) -> IO Text -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SimpleMPRIS2PlayerConfig -> NowPlaying -> IO Text
setNowPlayingLabel SimpleMPRIS2PlayerConfig
config NowPlaying
nowPlaying
  Bool
shouldShow <- SimpleMPRIS2PlayerConfig -> NowPlaying -> IO Bool
showPlayerWidgetFn SimpleMPRIS2PlayerConfig
config NowPlaying
nowPlaying
  if Bool
shouldShow
  then Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShowAll Widget
widget
  else Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetHide Widget
widget
  MPRIS2PlayerWidget -> IO MPRIS2PlayerWidget
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MPRIS2PlayerWidget
w

simplePlayerWidget SimpleMPRIS2PlayerConfig
_ forall w. WidgetAdder w IO
_ Maybe MPRIS2PlayerWidget
_ Maybe NowPlaying
_ =
  Priority -> String -> String -> ReaderT Context IO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
mprisLog Priority
WARNING String
"widget update called with no widget or %s"
             (String
"nowplaying" :: String) ReaderT Context IO ()
-> ReaderT Context IO MPRIS2PlayerWidget
-> ReaderT Context IO MPRIS2PlayerWidget
forall a b.
ReaderT Context IO a
-> ReaderT Context IO b -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MPRIS2PlayerWidget -> ReaderT Context IO MPRIS2PlayerWidget
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MPRIS2PlayerWidget
forall a. HasCallStack => a
undefined

-- | Construct a new MPRIS2 widget using the `simplePlayerWidget` constructor.
mpris2New :: TaffyIO Gtk.Widget
mpris2New :: TaffyIO Widget
mpris2New = MPRIS2Config MPRIS2PlayerWidget -> TaffyIO Widget
forall a. MPRIS2Config a -> TaffyIO Widget
mpris2NewWithConfig MPRIS2Config MPRIS2PlayerWidget
defaultMPRIS2Config

-- | Construct a new MPRIS2 widget with the provided configuration.
mpris2NewWithConfig :: MPRIS2Config a -> TaffyIO Gtk.Widget
mpris2NewWithConfig :: forall a. MPRIS2Config a -> TaffyIO Widget
mpris2NewWithConfig MPRIS2Config a
config = ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT Context IO Context
-> (Context -> TaffyIO Widget) -> TaffyIO Widget
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context
ctx -> (Context -> Client) -> ReaderT Context IO Client
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> Client
sessionDBusClient ReaderT Context IO Client
-> (Client -> TaffyIO Widget) -> TaffyIO Widget
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Client
client -> IO Widget -> TaffyIO Widget
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Widget -> TaffyIO Widget) -> IO Widget -> TaffyIO Widget
forall a b. (a -> b) -> a -> b
$ do
  Grid
grid <- IO Grid
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Grid
Gtk.gridNew
  Widget
outerWidget <- Grid -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget Grid
grid IO Widget -> (Widget -> IO Widget) -> IO Widget
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MPRIS2Config a -> Widget -> IO Widget
forall a. MPRIS2Config a -> Widget -> IO Widget
mprisWidgetWrapper MPRIS2Config a
config
  Grid -> IO ()
forall o (m :: * -> *). (IsWidget o, MonadIO m) => o -> m ()
vFillCenter Grid
grid
  MVar (Map BusName a)
playerWidgetsVar <- Map BusName a -> IO (MVar (Map BusName a))
forall a. a -> IO (MVar a)
MV.newMVar Map BusName a
forall k a. Map k a
M.empty
  let
    updateWidget :: UpdateMPRIS2PlayerWidget a
updateWidget = MPRIS2Config a -> UpdateMPRIS2PlayerWidget a
forall a. MPRIS2Config a -> UpdateMPRIS2PlayerWidget a
updatePlayerWidget MPRIS2Config a
config
    updatePlayerWidgets :: [NowPlaying] -> Map BusName a -> ReaderT Context IO (Map BusName a)
updatePlayerWidgets [NowPlaying]
nowPlayings Map BusName a
playerWidgets = do
      let
        updateWidgetFromNP :: NowPlaying -> ReaderT Context IO (BusName, a)
updateWidgetFromNP np :: NowPlaying
np@NowPlaying { npBusName :: NowPlaying -> BusName
npBusName = BusName
busName } =
          (BusName
busName,) (a -> (BusName, a))
-> ReaderT Context IO a -> ReaderT Context IO (BusName, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UpdateMPRIS2PlayerWidget a
updateWidget (Grid -> w -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Grid
grid)
                       (BusName -> Map BusName a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup BusName
busName Map BusName a
playerWidgets) (NowPlaying -> Maybe NowPlaying
forall a. a -> Maybe a
Just NowPlaying
np)
        activeBusNames :: [BusName]
activeBusNames = (NowPlaying -> BusName) -> [NowPlaying] -> [BusName]
forall a b. (a -> b) -> [a] -> [b]
map NowPlaying -> BusName
npBusName [NowPlaying]
nowPlayings
        existingBusNames :: [BusName]
existingBusNames = Map BusName a -> [BusName]
forall k a. Map k a -> [k]
M.keys Map BusName a
playerWidgets
        inactiveBusNames :: [BusName]
inactiveBusNames = [BusName]
existingBusNames [BusName] -> [BusName] -> [BusName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [BusName]
activeBusNames
        callForNoPlayingAvailable :: BusName -> ReaderT Context IO a
callForNoPlayingAvailable BusName
busName =
          UpdateMPRIS2PlayerWidget a
updateWidget (Grid -> w -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Grid
grid)
                         (BusName -> Map BusName a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup BusName
busName Map BusName a
playerWidgets) Maybe NowPlaying
forall a. Maybe a
Nothing

      -- Invoke the widgets with no NowPlaying so they can hide etc.
      (BusName -> ReaderT Context IO a)
-> [BusName] -> ReaderT Context IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BusName -> ReaderT Context IO a
callForNoPlayingAvailable [BusName]
inactiveBusNames
      -- Update all the other widgets
      Map BusName a
updatedWidgets <- [(BusName, a)] -> Map BusName a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(BusName, a)] -> Map BusName a)
-> ReaderT Context IO [(BusName, a)]
-> ReaderT Context IO (Map BusName a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NowPlaying -> ReaderT Context IO (BusName, a))
-> [NowPlaying] -> ReaderT Context IO [(BusName, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM NowPlaying -> ReaderT Context IO (BusName, a)
updateWidgetFromNP [NowPlaying]
nowPlayings
      Map BusName a -> ReaderT Context IO (Map BusName a)
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map BusName a -> ReaderT Context IO (Map BusName a))
-> Map BusName a -> ReaderT Context IO (Map BusName a)
forall a b. (a -> b) -> a -> b
$ Map BusName a -> Map BusName a -> Map BusName a
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map BusName a
updatedWidgets Map BusName a
playerWidgets

    updatePlayerWidgetsVar :: [NowPlaying] -> IO ()
updatePlayerWidgetsVar [NowPlaying]
nowPlayings = IO () -> IO ()
postGUISync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      MVar (Map BusName a)
-> (Map BusName a -> IO (Map BusName a)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar (Map BusName a)
playerWidgetsVar ((Map BusName a -> IO (Map BusName a)) -> IO ())
-> (Map BusName a -> IO (Map BusName a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ (ReaderT Context IO (Map BusName a)
 -> Context -> IO (Map BusName a))
-> Context
-> ReaderT Context IO (Map BusName a)
-> IO (Map BusName a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Context IO (Map BusName a) -> Context -> IO (Map BusName a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
ctx (ReaderT Context IO (Map BusName a) -> IO (Map BusName a))
-> (Map BusName a -> ReaderT Context IO (Map BusName a))
-> Map BusName a
-> IO (Map BusName a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        [NowPlaying] -> Map BusName a -> ReaderT Context IO (Map BusName a)
updatePlayerWidgets [NowPlaying]
nowPlayings

    setPlayingClass :: IO ()
setPlayingClass = do
      Bool
anyVisible <- (Widget -> IO Bool) -> [Widget] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
anyM Widget -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m Bool
Gtk.widgetIsVisible ([Widget] -> IO Bool) -> IO [Widget] -> IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Grid -> IO [Widget]
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsContainer a) =>
a -> m [Widget]
Gtk.containerGetChildren Grid
grid
      if Bool
anyVisible
      then do
        Text -> Widget -> IO ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
addClassIfMissing Text
"visible-children" Widget
outerWidget
        Text -> Widget -> IO ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
removeClassIfPresent Text
"no-visible-children" Widget
outerWidget
      else do
        Text -> Widget -> IO ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
addClassIfMissing Text
"no-visible-children" Widget
outerWidget
        Text -> Widget -> IO ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
removeClassIfPresent Text
"visible-children" Widget
outerWidget

    doUpdate :: IO ()
doUpdate = do
      [NowPlaying]
nowPlayings <- Client -> IO [NowPlaying]
forall (m :: * -> *). MonadIO m => Client -> m [NowPlaying]
getNowPlayingInfo Client
client
      [NowPlaying] -> IO ()
updatePlayerWidgetsVar [NowPlaying]
nowPlayings
      IO ()
setPlayingClass

    signalCallback :: Signal -> String -> Map String Variant -> [String] -> IO ()
signalCallback Signal
_ String
_ Map String Variant
_ [String]
_ = IO ()
doUpdate

    propMatcher :: MatchRule
propMatcher = MatchRule
matchAny { matchPath :: Maybe ObjectPath
matchPath = ObjectPath -> Maybe ObjectPath
forall a. a -> Maybe a
Just ObjectPath
"/org/mpris/MediaPlayer2" }

    handleNameOwnerChanged :: Signal -> String -> String -> String -> IO ()
handleNameOwnerChanged Signal
_ String
name String
_ String
_ = do
      Map BusName a
playerWidgets <- MVar (Map BusName a) -> IO (Map BusName a)
forall a. MVar a -> IO a
MV.readMVar MVar (Map BusName a)
playerWidgetsVar
      BusName
busName <- String -> IO BusName
forall (m :: * -> *). MonadThrow m => String -> m BusName
parseBusName String
name
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BusName
busName BusName -> Map BusName a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map BusName a
playerWidgets) IO ()
doUpdate

  SignalHandlerId
_ <- Grid -> ((?self::Grid) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
Gtk.onWidgetRealize Grid
grid (((?self::Grid) => IO ()) -> IO SignalHandlerId)
-> ((?self::Grid) => IO ()) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ do
    SignalHandler
updateHandler <-
      Client
-> MatchRule
-> (Signal -> String -> Map String Variant -> [String] -> IO ())
-> IO SignalHandler
DBus.registerForPropertiesChanged Client
client MatchRule
propMatcher Signal -> String -> Map String Variant -> [String] -> IO ()
signalCallback
    SignalHandler
nameHandler <-
      Client
-> MatchRule
-> (Signal -> String -> String -> String -> IO ())
-> IO SignalHandler
DBus.registerForNameOwnerChanged Client
client MatchRule
matchAny Signal -> String -> String -> String -> IO ()
handleNameOwnerChanged
    IO ()
doUpdate
    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
$ Grid -> ((?self::Grid) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
Gtk.onWidgetUnrealize Grid
grid (((?self::Grid) => IO ()) -> IO SignalHandlerId)
-> ((?self::Grid) => IO ()) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$
         Client -> SignalHandler -> IO ()
removeMatch Client
client SignalHandler
updateHandler IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Client -> SignalHandler -> IO ()
removeMatch Client
client SignalHandler
nameHandler

  Grid -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow Grid
grid
  IO ()
setPlayingClass
  Widget -> IO Widget
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Widget
outerWidget

-- | Generate now playing text with the artist truncated to a maximum given by
-- the first provided int, and the song title truncated to a maximum given by
-- the second provided int.
playingText :: MonadIO m => Int -> Int -> NowPlaying -> m T.Text
playingText :: forall (m :: * -> *).
MonadIO m =>
Int -> Int -> NowPlaying -> m Text
playingText Int
artistMax Int
songMax NowPlaying {npArtists :: NowPlaying -> [String]
npArtists = [String]
artists, npTitle :: NowPlaying -> String
npTitle = String
title} =
  Text -> Int64 -> m Text
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> m Text
G.markupEscapeText Text
formattedText (-Int64
1)
  where truncatedTitle :: String
truncatedTitle = Int -> String -> String
truncateString Int
songMax String
title
        formattedText :: Text
formattedText = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
artists
          then String
truncatedTitle
          else String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
           String
"%s - %s"
           (Int -> String -> String
truncateString Int
artistMax (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
artists)
           String
truncatedTitle