{-# 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
  ctx <- ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  client <- asks sessionDBusClient
  lift $ do
    mprisLog DEBUG "Building widget for %s" busName
    image <- autoSizeImageNew (loadIconAtSize client busName) Gtk.OrientationHorizontal
    playerBox <- Gtk.gridNew
    label <- Gtk.labelNew Nothing
    ebox <- Gtk.eventBoxNew
    _ <- Gtk.onWidgetButtonPressEvent ebox $
         const $ MPRIS2DBus.playPause client busName >> return True
    Gtk.containerAdd playerBox image
    Gtk.containerAdd playerBox label
    Gtk.containerAdd ebox playerBox
    vFillCenter playerBox
    addToParent ebox
    Gtk.widgetSetVexpand playerBox True
    Gtk.widgetSetName playerBox $ T.pack $ formatBusName busName
    Gtk.widgetShowAll ebox
    Gtk.widgetHide ebox
    widget <- Gtk.toWidget ebox
    let widgetData =
          MPRIS2PlayerWidget { playerLabel :: Label
playerLabel = Label
label, playerWidget :: Widget
playerWidget = Widget
widget }
    flip runReaderT ctx $
         simplePlayerWidget c addToParent (Just widgetData) 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
  shouldShow <- SimpleMPRIS2PlayerConfig -> NowPlaying -> IO Bool
showPlayerWidgetFn SimpleMPRIS2PlayerConfig
config NowPlaying
nowPlaying
  if shouldShow
  then Gtk.widgetShowAll widget
  else Gtk.widgetHide widget
  return 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 <- IO Grid
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Grid
Gtk.gridNew
  outerWidget <- Gtk.toWidget grid >>= mprisWidgetWrapper config
  vFillCenter grid
  playerWidgetsVar <- MV.newMVar M.empty
  let
    updateWidget = MPRIS2Config a -> UpdateMPRIS2PlayerWidget a
forall a. MPRIS2Config a -> UpdateMPRIS2PlayerWidget a
updatePlayerWidget MPRIS2Config a
config
    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
      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
      return $ M.union updatedWidgets playerWidgets

    updatePlayerWidgetsVar [NowPlaying]
nowPlayings = IO () -> IO ()
forall a. IO a -> IO a
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 = do
      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 anyVisible
      then do
        addClassIfMissing "visible-children" outerWidget
        removeClassIfPresent "no-visible-children" outerWidget
      else do
        addClassIfMissing "no-visible-children" outerWidget
        removeClassIfPresent "visible-children" outerWidget

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

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

    propMatcher = MatchRule
matchAny { matchPath = Just "/org/mpris/MediaPlayer2" }

    handleNameOwnerChanged Signal
_ String
name String
_ String
_ = do
      playerWidgets <- MVar (Map BusName a) -> IO (Map BusName a)
forall a. MVar a -> IO a
MV.readMVar MVar (Map BusName a)
playerWidgetsVar
      busName <- parseBusName name
      when (busName `M.member` playerWidgets) doUpdate

  _ <- Gtk.onWidgetRealize grid $ do
    updateHandler <-
      DBus.registerForPropertiesChanged client propMatcher signalCallback
    nameHandler <-
      DBus.registerForNameOwnerChanged client matchAny handleNameOwnerChanged
    doUpdate
    void $ Gtk.onWidgetUnrealize grid $
         removeMatch client updateHandler >> removeMatch client nameHandler

  Gtk.widgetShow grid
  setPlayingClass
  return 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