    {-# 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 = Just "/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