    {-# LANGUAGE OverloadedStrings #-}
    -----------------------------------------------------------------------------
    -- |
    -- 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 ( mpris2New ) 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           DBus.Internal.Types
    import qualified DBus.TH as DBus
    import           Data.Coerce
    import           Data.List
    import qualified Data.Text as T
    import qualified GI.Gtk as Gtk
    import qualified GI.GLib as G
    import           System.Log.Logger
    import           System.Taffybar.Context
    import           System.Taffybar.DBus.Client.MPRIS2
    import           System.Taffybar.Information.MPRIS2
    import           System.Taffybar.Information.XDG.DesktopEntry
    import           System.Taffybar.Util
    import           System.Taffybar.Widget.Generic.AutoSizeImage
    import           System.Taffybar.Widget.Util
    import           Text.Printf

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

    data MPRIS2PlayerWidget = MPRIS2PlayerWidget
      { playerLabel :: Gtk.Label
      , playerGrid :: Gtk.Grid
      }

    mpris2New :: TaffyIO Gtk.Widget
    mpris2New = asks sessionDBusClient >>= \client -> lift $ do
      grid <- Gtk.gridNew
      vFillCenter grid
      playerWidgetsVar <- MV.newMVar []
      let
        newPlayerWidget :: BusName -> IO MPRIS2PlayerWidget
        newPlayerWidget busName =
          do
            let logErrorAndLoadDefault size err =
                  mprisLog WARNING "Failed to get MPRIS icon: %s" err >>
                  mprisLog WARNING "MPRIS failure for: %s" busName >>
                           loadIcon size "play.svg"
                makeExcept ::
                  String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b
                makeExcept errorString actionBuilder =
                  ExceptT . fmap (maybeToEither errorString) . actionBuilder
                loadIconAtSize size =
                  either (logErrorAndLoadDefault size) return =<< runExceptT
                  (   ExceptT (left show <$> getDesktopEntry client busName)
                  >>= makeExcept "Failed to get desktop entry"
                      getDirectoryEntryDefault
                  >>= makeExcept "Failed to get image"
                        (getImageForDesktopEntry size)
                  )

            image <- autoSizeImageNew loadIconAtSize Gtk.OrientationHorizontal
            playerBox <- Gtk.gridNew
            label <- Gtk.labelNew Nothing

            Gtk.containerAdd playerBox image
            Gtk.containerAdd playerBox label
            vFillCenter playerBox

            Gtk.containerAdd grid playerBox
            Gtk.widgetSetVexpand playerBox True
            Gtk.widgetHide playerBox
            return MPRIS2PlayerWidget {playerLabel = label, playerGrid = playerBox}

        updatePlayerWidget
          children
          nowPlaying@NowPlaying
                      { npBusName = busName
                      , npStatus = status
                      } =
          case lookup busName children of
            Nothing -> do
              playerWidget <- newPlayerWidget busName
              setNowPlaying playerWidget
              return $ (busName, playerWidget):children
            Just playerWidget -> setNowPlaying playerWidget >> return children
          where setNowPlaying
                  MPRIS2PlayerWidget
                  { playerLabel = label
                  , playerGrid = playerBox
                  } = do
                    logPrintF "System.Taffybar.Widget.MPRIS2"
                              DEBUG "Setting state %s" nowPlaying
                    Gtk.labelSetMarkup label =<< playingText 20 30 nowPlaying
                    if status == "Playing"
                    then Gtk.widgetShowAll playerBox
                    else Gtk.widgetHide playerBox

        updatePlayerWidgets nowPlayings playerWidgets = do
          newWidgets <- foldM updatePlayerWidget playerWidgets nowPlayings
          let existingBusNames = map npBusName nowPlayings
              noInfoPlayerWidgets =
                filter ((`notElem` existingBusNames) . fst) newWidgets
          mapM_ (Gtk.widgetHide . playerGrid . snd) noInfoPlayerWidgets
          return newWidgets

        updatePlayerWidgetsVar nowPlayings = postGUIASync $
          MV.modifyMVar_ playerWidgetsVar $ updatePlayerWidgets nowPlayings

        doUpdate = getNowPlayingInfo client >>= updatePlayerWidgetsVar
        signalCallback _ _ _ _ = doUpdate
        propMatcher = matchAny { matchPath = Just "/org/mpris/MediaPlayer2" }

        handleNameOwnerChanged _ name _ _ = do
          busNames <- map (coerce . fst) <$> MV.readMVar playerWidgetsVar
          when (name `elem` busNames) 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
      Gtk.toWidget grid

    playingText :: MonadIO m => Int -> Int -> NowPlaying -> m T.Text
    playingText artistMax songMax NowPlaying {npArtists = artists, npTitle = title} =
      G.markupEscapeText formattedText (fromIntegral $ T.length formattedText)
      where formattedText = T.pack $ printf
               "%s - %s"
               (truncateString artistMax $ intercalate "," artists)
               (truncateString songMax title)