{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Widget.Windows
-- Copyright   : (c) Ivan Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan Malison <IvanMalison@gmail.com>
-- Stability   : unstable
-- Portability : unportable
--
-- Menu widget that shows the title of the currently focused window and that,
-- when clicked, displays a menu from which the user may select a window to
-- which to switch the focus.
-----------------------------------------------------------------------------

module System.Taffybar.Widget.Windows where

import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Reader
import           Control.Monad.Trans.Maybe
import           Data.Default (Default(..))
import           Data.Maybe
import qualified Data.Text as T
import           GI.GLib (markupEscapeText)
import qualified GI.Gtk as Gtk
import           System.Taffybar.Context
import           System.Taffybar.Information.EWMHDesktopInfo
import           System.Taffybar.Widget.Generic.AutoSizeImage
import           System.Taffybar.Widget.Generic.DynamicMenu
import           System.Taffybar.Widget.Util
import           System.Taffybar.Widget.Workspaces (WindowIconPixbufGetter, getWindowData, defaultGetWindowIconPixbuf)
import           System.Taffybar.Util

data WindowsConfig = WindowsConfig
  { WindowsConfig -> X11Window -> TaffyIO Text
getMenuLabel :: X11Window -> TaffyIO T.Text
  -- ^ A monadic function that will be used to make a label for the window in
  -- the window menu.
  , WindowsConfig -> TaffyIO Text
getActiveLabel :: TaffyIO T.Text
  -- ^ Action to build the label text for the active window.
  , WindowsConfig -> Maybe WindowIconPixbufGetter
getActiveWindowIconPixbuf :: Maybe WindowIconPixbufGetter
  -- ^ Optional function to retrieve a pixbuf to show next to the
  -- window label.
  }

defaultGetMenuLabel :: X11Window -> TaffyIO T.Text
defaultGetMenuLabel :: X11Window -> TaffyIO Text
defaultGetMenuLabel X11Window
window = do
  windowString <- String -> X11Property String -> TaffyIO String
forall a. a -> X11Property a -> TaffyIO a
runX11Def String
"(nameless window)" (X11Window -> X11Property String
getWindowTitle X11Window
window)
  return $ T.pack windowString

defaultGetActiveLabel :: TaffyIO T.Text
defaultGetActiveLabel :: TaffyIO Text
defaultGetActiveLabel = do
  label <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text)
-> ReaderT Context IO (Maybe Text) -> TaffyIO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe X11Window
-> X11Property (Maybe X11Window) -> TaffyIO (Maybe X11Window)
forall a. a -> X11Property a -> TaffyIO a
runX11Def Maybe X11Window
forall a. Maybe a
Nothing X11Property (Maybe X11Window)
getActiveWindow TaffyIO (Maybe X11Window)
-> (Maybe X11Window -> ReaderT Context IO (Maybe Text))
-> ReaderT Context IO (Maybe Text)
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
>>=
                                       (X11Window -> TaffyIO Text)
-> Maybe X11Window -> ReaderT Context IO (Maybe Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse X11Window -> TaffyIO Text
defaultGetMenuLabel)
  markupEscapeText label (-1)

truncatedGetActiveLabel :: Int -> TaffyIO T.Text
truncatedGetActiveLabel :: Int -> TaffyIO Text
truncatedGetActiveLabel Int
maxLength =
  Int -> Text -> Text
truncateText Int
maxLength (Text -> Text) -> TaffyIO Text -> TaffyIO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TaffyIO Text
defaultGetActiveLabel

truncatedGetMenuLabel :: Int -> X11Window -> TaffyIO T.Text
truncatedGetMenuLabel :: Int -> X11Window -> TaffyIO Text
truncatedGetMenuLabel Int
maxLength =
  (Text -> Text) -> TaffyIO Text -> TaffyIO Text
forall a b.
(a -> b) -> ReaderT Context IO a -> ReaderT Context IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Text -> Text
truncateText Int
maxLength) (TaffyIO Text -> TaffyIO Text)
-> (X11Window -> TaffyIO Text) -> X11Window -> TaffyIO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X11Window -> TaffyIO Text
defaultGetMenuLabel

defaultWindowsConfig :: WindowsConfig
defaultWindowsConfig :: WindowsConfig
defaultWindowsConfig =
  WindowsConfig
  { getMenuLabel :: X11Window -> TaffyIO Text
getMenuLabel = Int -> X11Window -> TaffyIO Text
truncatedGetMenuLabel Int
35
  , getActiveLabel :: TaffyIO Text
getActiveLabel = Int -> TaffyIO Text
truncatedGetActiveLabel Int
35
  , getActiveWindowIconPixbuf :: Maybe WindowIconPixbufGetter
getActiveWindowIconPixbuf = WindowIconPixbufGetter -> Maybe WindowIconPixbufGetter
forall a. a -> Maybe a
Just WindowIconPixbufGetter
defaultGetWindowIconPixbuf
  }

instance Default WindowsConfig where
  def :: WindowsConfig
def = WindowsConfig
defaultWindowsConfig

-- | Create a new Windows widget that will use the given Pager as
-- its source of events.
windowsNew :: WindowsConfig -> TaffyIO Gtk.Widget
windowsNew :: WindowsConfig -> TaffyIO Widget
windowsNew WindowsConfig
config = do
  hbox <- IO Box -> ReaderT Context IO Box
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 Box -> ReaderT Context IO Box)
-> IO Box -> ReaderT Context IO Box
forall a b. (a -> b) -> a -> b
$ Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal Int32
0

  refreshIcon <- case getActiveWindowIconPixbuf config of
    Just WindowIconPixbufGetter
getIcon -> do
      (rf, icon) <- WindowIconPixbufGetter -> TaffyIO (IO (), Widget)
buildWindowsIcon WindowIconPixbufGetter
getIcon
      Gtk.boxPackStart hbox icon True True 0
      pure rf
    Maybe WindowIconPixbufGetter
Nothing -> IO () -> ReaderT Context IO (IO ())
forall a. a -> ReaderT Context IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

  (setLabelTitle, label) <- buildWindowsLabel
  Gtk.boxPackStart hbox label True True 0
  let refreshLabel = WindowsConfig -> TaffyIO Text
getActiveLabel WindowsConfig
config TaffyIO Text
-> (Text -> ReaderT Context IO ()) -> ReaderT Context IO ()
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
>>= IO () -> ReaderT Context IO ()
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 () -> ReaderT Context IO ())
-> (Text -> IO ()) -> Text -> ReaderT Context IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
setLabelTitle

  subscription <- subscribeToPropertyEvents
    [ewmhActiveWindow, ewmhWMName, ewmhWMClass]
    (const $ refreshLabel >> lift refreshIcon)

  void $ mapReaderT (Gtk.onWidgetUnrealize hbox) (unsubscribe subscription)

  Gtk.widgetShowAll hbox
  boxWidget <- Gtk.toWidget hbox

  runTaffy <- asks (flip runReaderT)
  menu <- dynamicMenuNew
    DynamicMenuConfig { dmClickWidget = boxWidget
                      , dmPopulateMenu = runTaffy . fillMenu config
                      }

  widgetSetClassGI menu "windows"

buildWindowsLabel :: TaffyIO (T.Text -> IO (), Gtk.Widget)
buildWindowsLabel :: TaffyIO (Text -> IO (), Widget)
buildWindowsLabel = do
  label <- IO Label -> ReaderT Context IO Label
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 Label -> ReaderT Context IO Label)
-> IO Label -> ReaderT Context IO Label
forall a b. (a -> b) -> a -> b
$ Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
Gtk.labelNew Maybe Text
forall a. Maybe a
Nothing
  let setLabelTitle Text
title = IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
Gtk.labelSetMarkup Label
label Text
title
  (setLabelTitle,) <$> Gtk.toWidget label

buildWindowsIcon :: WindowIconPixbufGetter -> TaffyIO (IO (), Gtk.Widget)
buildWindowsIcon :: WindowIconPixbufGetter -> TaffyIO (IO (), Widget)
buildWindowsIcon WindowIconPixbufGetter
windowIconPixbufGetter = do
  icon <- IO Image -> ReaderT Context IO Image
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 Image
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Image
Gtk.imageNew

  runTaffy <- asks (flip runReaderT)
  let getActiveWindowPixbuf Int32
size = ReaderT Context IO (Maybe Pixbuf) -> IO (Maybe Pixbuf)
runTaffy (ReaderT Context IO (Maybe Pixbuf) -> IO (Maybe Pixbuf))
-> (MaybeT (ReaderT Context IO) Pixbuf
    -> ReaderT Context IO (Maybe Pixbuf))
-> MaybeT (ReaderT Context IO) Pixbuf
-> IO (Maybe Pixbuf)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT (ReaderT Context IO) Pixbuf
-> ReaderT Context IO (Maybe Pixbuf)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT Context IO) Pixbuf -> IO (Maybe Pixbuf))
-> MaybeT (ReaderT Context IO) Pixbuf -> IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ do
        wd <- ReaderT Context IO (Maybe WindowData)
-> MaybeT (ReaderT Context IO) WindowData
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (ReaderT Context IO (Maybe WindowData)
 -> MaybeT (ReaderT Context IO) WindowData)
-> ReaderT Context IO (Maybe WindowData)
-> MaybeT (ReaderT Context IO) WindowData
forall a b. (a -> b) -> a -> b
$ Maybe WindowData
-> X11Property (Maybe WindowData)
-> ReaderT Context IO (Maybe WindowData)
forall a. a -> X11Property a -> TaffyIO a
runX11Def Maybe WindowData
forall a. Maybe a
Nothing (X11Property (Maybe WindowData)
 -> ReaderT Context IO (Maybe WindowData))
-> X11Property (Maybe WindowData)
-> ReaderT Context IO (Maybe WindowData)
forall a b. (a -> b) -> a -> b
$
          (X11Window -> ReaderT X11Context IO WindowData)
-> Maybe X11Window -> X11Property (Maybe WindowData)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Maybe X11Window
-> [X11Window] -> X11Window -> ReaderT X11Context IO WindowData
getWindowData Maybe X11Window
forall a. Maybe a
Nothing []) (Maybe X11Window -> X11Property (Maybe WindowData))
-> X11Property (Maybe X11Window) -> X11Property (Maybe WindowData)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X11Property (Maybe X11Window)
getActiveWindow
        MaybeT $ windowIconPixbufGetter size wd

  updateImage <- autoSizeImage icon getActiveWindowPixbuf Gtk.OrientationHorizontal
  (postGUIASync updateImage,) <$> Gtk.toWidget icon

-- | Populate the given menu widget with the list of all currently open windows.
fillMenu :: Gtk.IsMenuShell a => WindowsConfig -> a -> ReaderT Context IO ()
fillMenu :: forall a.
IsMenuShell a =>
WindowsConfig -> a -> ReaderT Context IO ()
fillMenu WindowsConfig
config a
menu = ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT Context IO Context
-> (Context -> ReaderT Context IO ()) -> ReaderT Context IO ()
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
context ->
  () -> X11Property () -> ReaderT Context IO ()
forall a. a -> X11Property a -> TaffyIO a
runX11Def () (X11Property () -> ReaderT Context IO ())
-> X11Property () -> ReaderT Context IO ()
forall a b. (a -> b) -> a -> b
$ do
    windowIds <- X11Property [X11Window]
getWindows
    forM_ windowIds $ \X11Window
windowId ->
      IO () -> X11Property ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT X11Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> X11Property ()) -> IO () -> X11Property ()
forall a b. (a -> b) -> a -> b
$ do
        labelText <- TaffyIO Text -> Context -> IO Text
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (WindowsConfig -> X11Window -> TaffyIO Text
getMenuLabel WindowsConfig
config X11Window
windowId) Context
context
        let focusCallback = ReaderT Context IO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (X11Property () -> ReaderT Context IO ()
forall a. X11Property a -> TaffyIO a
runX11 (X11Property () -> ReaderT Context IO ())
-> X11Property () -> ReaderT Context IO ()
forall a b. (a -> b) -> a -> b
$ X11Window -> X11Property ()
focusWindow X11Window
windowId) Context
context IO () -> 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
        item <- Gtk.menuItemNewWithLabel labelText
        _ <- Gtk.onWidgetButtonPressEvent item $ const focusCallback
        Gtk.menuShellAppend menu item
        Gtk.widgetShow item