    {-# 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.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 window :: X11Window
    window = do
      String
    windowString <- String -> X11Property String -> TaffyIO String
    forall a. a -> X11Property a -> TaffyIO a
    runX11Def "(nameless window)" (X11Window -> X11Property String
    getWindowTitle X11Window
    window)
      Text -> TaffyIO Text
    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 "" (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 (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)
    traverse X11Window -> TaffyIO Text
    defaultGetMenuLabel)
      Text -> Int64 -> TaffyIO Text
    forall (m :: * -> *).
    (HasCallStack, MonadIO m) =>
    Text -> Int64 -> m Text
    markupEscapeText Text
    label (-1)

    truncatedGetActiveLabel :: Int -> TaffyIO T.Text
    truncatedGetActiveLabel :: Int -> TaffyIO Text
    truncatedGetActiveLabel maxLength :: 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 maxLength :: Int
    maxLength =
      (Text -> Text) -> TaffyIO Text -> TaffyIO Text
    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 :: (X11Window -> TaffyIO Text) -> TaffyIO Text -> WindowsConfig
    WindowsConfig
      { getMenuLabel :: X11Window -> TaffyIO Text
    getMenuLabel = Int -> X11Window -> TaffyIO Text
    truncatedGetMenuLabel 35
      , getActiveLabel :: TaffyIO Text
    getActiveLabel = Int -> TaffyIO Text
    truncatedGetActiveLabel 35
      }

    -- | 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 config :: WindowsConfig
    config = do
      Label
    label <- IO Label -> ReaderT Context IO Label
    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 title :: Text
    title = IO () -> ReaderT Context IO ()
    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 _ = WindowsConfig -> TaffyIO Text
    getActiveLabel WindowsConfig
    config TaffyIO Text
    -> (Text -> ReaderT Context IO ()) -> ReaderT Context IO ()
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Text -> ReaderT Context IO ()
    setLabelTitle

      Unique
    subscription <-
        [String] -> Listener -> Taffy IO Unique
    subscribeToPropertyEvents [String
    ewmhActiveWindow, String
    ewmhWMName, String
    ewmhWMClass]
                          Event -> ReaderT Context IO ()
    Listener
    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 (Label -> IO () -> IO SignalHandlerId
    forall a (m :: * -> *).
    (IsWidget a, MonadIO m) =>
    a -> IO () -> m SignalHandlerId
    Gtk.onWidgetUnrealize Label
    label) (Unique -> Taffy 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 :: Widget -> (Menu -> IO ()) -> DynamicMenuConfig
    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 "windows"

    -- | Populate the given menu widget with the list of all currently open windows.
    fillMenu :: Gtk.IsMenuShell a => WindowsConfig -> a -> ReaderT Context IO ()
    fillMenu :: WindowsConfig -> a -> ReaderT Context IO ()
    fillMenu config :: WindowsConfig
    config menu :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \context :: 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
    $ \windowId :: X11Window
    windowId ->
          IO () -> X11Property ()
    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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Bool -> IO Bool
    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 -> WidgetButtonPressEventCallback -> IO SignalHandlerId
    forall a (m :: * -> *).
    (IsWidget a, MonadIO m) =>
    a -> WidgetButtonPressEventCallback -> m SignalHandlerId
    Gtk.onWidgetButtonPressEvent MenuItem
    item (WidgetButtonPressEventCallback -> IO SignalHandlerId)
    -> 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