{-# 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           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.Util
import           System.Taffybar.Widget.Generic.DynamicMenu
import           System.Taffybar.Widget.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.
  }

defaultGetMenuLabel :: X11Window -> TaffyIO T.Text
defaultGetMenuLabel :: X11Window -> TaffyIO Text
defaultGetMenuLabel X11Window
window = do
  String
windowString <- String -> X11Property String -> TaffyIO String
forall a. a -> X11Property a -> TaffyIO a
runX11Def String
"(nameless window)" (X11Window -> X11Property String
getWindowTitle X11Window
window)
  Text -> TaffyIO Text
forall a. a -> ReaderT Context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> TaffyIO Text) -> Text -> TaffyIO Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
windowString

defaultGetActiveLabel :: TaffyIO T.Text
defaultGetActiveLabel :: TaffyIO Text
defaultGetActiveLabel = do
  Text
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)
  Text -> Int64 -> TaffyIO Text
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> m Text
markupEscapeText Text
label (-Int64
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
  }

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
  Label
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 -> ReaderT Context IO ()
setLabelTitle Text
title = 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 ()) -> IO () -> ReaderT Context IO ()
forall a b. (a -> b) -> a -> b
$ 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
      activeWindowUpdatedCallback :: Event -> ReaderT Context IO ()
activeWindowUpdatedCallback Event
_ = 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
>>= Text -> ReaderT Context IO ()
setLabelTitle

  Unique
subscription <-
    [String] -> (Event -> ReaderT Context IO ()) -> Taffy IO Unique
subscribeToPropertyEvents [String
ewmhActiveWindow, String
ewmhWMName, String
ewmhWMClass]
                      Event -> ReaderT Context IO ()
activeWindowUpdatedCallback
  SignalHandlerId
_ <- (IO () -> IO SignalHandlerId)
-> ReaderT Context IO () -> ReaderT Context IO SignalHandlerId
forall (m :: * -> *) (m1 :: * -> *) a b r.
Monad m =>
(m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b
liftReader (\IO ()
x -> Label -> ((?self::Label) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
Gtk.onWidgetUnrealize Label
label IO ()
(?self::Label) => IO ()
x) (Unique -> ReaderT Context IO ()
unsubscribe Unique
subscription)

  Context
context <- ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

  Widget
labelWidget <- Label -> TaffyIO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget Label
label
  Widget
menu <- DynamicMenuConfig -> TaffyIO Widget
forall (m :: * -> *). MonadIO m => DynamicMenuConfig -> m Widget
dynamicMenuNew
    DynamicMenuConfig { dmClickWidget :: Widget
dmClickWidget = Widget
labelWidget
                      , dmPopulateMenu :: Menu -> IO ()
dmPopulateMenu = (ReaderT Context IO () -> Context -> IO ())
-> Context -> ReaderT Context IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Context IO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
context (ReaderT Context IO () -> IO ())
-> (Menu -> ReaderT Context IO ()) -> Menu -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowsConfig -> Menu -> ReaderT Context IO ()
forall a.
IsMenuShell a =>
WindowsConfig -> a -> ReaderT Context IO ()
fillMenu WindowsConfig
config
                      }

  Widget -> Text -> TaffyIO Widget
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Widget
menu Text
"windows"

-- | 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
    [X11Window]
windowIds <- X11Property [X11Window]
getWindows
    [X11Window] -> (X11Window -> X11Property ()) -> X11Property ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [X11Window]
windowIds ((X11Window -> X11Property ()) -> X11Property ())
-> (X11Window -> X11Property ()) -> X11Property ()
forall a b. (a -> b) -> a -> b
$ \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
        Text
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 :: IO Bool
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
        MenuItem
item <- Text -> IO MenuItem
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> m MenuItem
Gtk.menuItemNewWithLabel Text
labelText
        SignalHandlerId
_ <- MenuItem
-> ((?self::MenuItem) => WidgetButtonPressEventCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a
-> ((?self::a) => WidgetButtonPressEventCallback)
-> m SignalHandlerId
Gtk.onWidgetButtonPressEvent MenuItem
item (((?self::MenuItem) => WidgetButtonPressEventCallback)
 -> IO SignalHandlerId)
-> ((?self::MenuItem) => WidgetButtonPressEventCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ IO Bool -> WidgetButtonPressEventCallback
forall a b. a -> b -> a
const IO Bool
focusCallback
        a -> MenuItem -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsMenuShell a, IsMenuItem b) =>
a -> b -> m ()
Gtk.menuShellAppend a
menu MenuItem
item
        MenuItem -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow MenuItem
item