{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Widget.Layout
-- Copyright   : (c) Ivan Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan Malison <IvanMalison@gmail.com>
-- Stability   : unstable
-- Portability : unportable
--
-- Simple text widget that shows the XMonad layout used in the currently active
-- workspace, and that allows to change it by clicking with the mouse:
-- left-click to switch to the next layout in the list, right-click to switch to
-- the first one (as configured in @xmonad.hs@)
-----------------------------------------------------------------------------

module System.Taffybar.Widget.Layout
  (
  -- * Usage
  -- $usage
    LayoutConfig(..)
  , defaultLayoutConfig
  , layoutNew
  ) where

import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Reader
import qualified Data.Text as T
import qualified GI.Gtk as Gtk
import           GI.Gdk
import           System.Taffybar.Context
import           System.Taffybar.Information.X11DesktopInfo
import           System.Taffybar.Util
import           System.Taffybar.Widget.Util

-- $usage
--
-- This widget requires that the "System.Taffybar.Support.PagerHints" hook be
-- installed in your @xmonad.hs@:
--
-- > import System.Taffybar.Support.PagerHints (pagerHints)
-- > main = do
-- >   xmonad $ ewmh $ pagerHints $ defaultConfig
-- > ...
--
-- Once you've properly configured @xmonad.hs@, you can use the widget in
-- your @taffybar.hs@ file:
--
-- > import System.Taffybar.Widget.Layout
-- > main = do
-- >   let los = layoutSwitcherNew defaultLayoutConfig
--
-- now you can use @los@ as any other Taffybar widget.

newtype LayoutConfig = LayoutConfig
  { LayoutConfig -> Text -> TaffyIO Text
formatLayout :: T.Text -> TaffyIO T.Text
  }

defaultLayoutConfig :: LayoutConfig
defaultLayoutConfig :: LayoutConfig
defaultLayoutConfig = (Text -> TaffyIO Text) -> LayoutConfig
LayoutConfig Text -> TaffyIO Text
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Name of the X11 events to subscribe, and of the hint to look for for
-- the name of the current layout.
xLayoutProp :: String
xLayoutProp :: String
xLayoutProp = String
"_XMONAD_CURRENT_LAYOUT"

-- | Create a new Layout widget that will use the given Pager as
-- its source of events.
layoutNew :: LayoutConfig -> TaffyIO Gtk.Widget
layoutNew :: LayoutConfig -> TaffyIO Widget
layoutNew LayoutConfig
config = do
  Context
ctx <- ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  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 :: Maybe T.Text)
  Label
_ <- Label -> Text -> ReaderT Context IO Label
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Label
label Text
"layout-label"

  -- This callback is run in a separate thread and needs to use
  -- postGUIASync
  let callback :: Event -> ReaderT Context IO ()
callback Event
_ = (IO () -> IO ()) -> ReaderT Context IO () -> ReaderT Context IO ()
forall (m :: * -> *) (m1 :: * -> *) a b r.
Monad m =>
(m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b
liftReader IO () -> IO ()
postGUIASync (ReaderT Context IO () -> ReaderT Context IO ())
-> ReaderT Context IO () -> ReaderT Context IO ()
forall a b. (a -> b) -> a -> b
$ do
        String
layout <- String -> X11Property String -> TaffyIO String
forall a. a -> X11Property a -> TaffyIO a
runX11Def String
"" (X11Property String -> TaffyIO String)
-> X11Property String -> TaffyIO String
forall a b. (a -> b) -> a -> b
$ Maybe X11Window -> String -> X11Property String
readAsString Maybe X11Window
forall a. Maybe a
Nothing String
xLayoutProp
        Text
markup <- LayoutConfig -> Text -> TaffyIO Text
formatLayout LayoutConfig
config (String -> Text
T.pack String
layout)
        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
$ Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
Gtk.labelSetMarkup Label
label Text
markup

  Unique
subscription <- [String] -> Listener -> Taffy IO Unique
subscribeToPropertyEvents [String
xLayoutProp] Event -> ReaderT Context IO ()
Listener
callback

  do
    EventBox
ebox <- ReaderT Context IO EventBox
forall (m :: * -> *). (HasCallStack, MonadIO m) => m EventBox
Gtk.eventBoxNew
    EventBox -> Label -> ReaderT Context IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd EventBox
ebox Label
label
    SignalHandlerId
_ <- EventBox
-> WidgetButtonPressEventCallback
-> ReaderT Context IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> WidgetButtonPressEventCallback -> m SignalHandlerId
Gtk.onWidgetButtonPressEvent EventBox
ebox (WidgetButtonPressEventCallback
 -> ReaderT Context IO SignalHandlerId)
-> WidgetButtonPressEventCallback
-> ReaderT Context IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ Context -> WidgetButtonPressEventCallback
dispatchButtonEvent Context
ctx
    EventBox -> ReaderT Context IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShowAll EventBox
ebox
    SignalHandlerId
_ <- EventBox -> IO () -> ReaderT Context IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> IO () -> m SignalHandlerId
Gtk.onWidgetUnrealize EventBox
ebox (IO () -> ReaderT Context IO SignalHandlerId)
-> IO () -> ReaderT Context IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ (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
ctx (ReaderT Context IO () -> IO ()) -> ReaderT Context IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Unique -> Taffy IO ()
unsubscribe Unique
subscription
    EventBox -> TaffyIO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget EventBox
ebox

-- | Call 'switch' with the appropriate argument (1 for left click, -1 for
-- right click), depending on the click event received.
dispatchButtonEvent :: Context -> EventButton -> IO Bool
dispatchButtonEvent :: Context -> WidgetButtonPressEventCallback
dispatchButtonEvent Context
context EventButton
btn = do
  EventType
pressType <- EventButton -> IO EventType
forall (m :: * -> *). MonadIO m => EventButton -> m EventType
getEventButtonType EventButton
btn
  Word32
buttonNumber <- EventButton -> IO Word32
forall (m :: * -> *). MonadIO m => EventButton -> m Word32
getEventButtonButton EventButton
btn
  case EventType
pressType of
    EventType
EventTypeButtonPress ->
        case Word32
buttonNumber of
          Word32
1 -> ReaderT Context IO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (() -> X11Property () -> ReaderT Context IO ()
forall a. a -> X11Property a -> TaffyIO a
runX11Def () (Int -> X11Property ()
switch Int
1)) 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
          Word32
2 -> ReaderT Context IO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (() -> X11Property () -> ReaderT Context IO ()
forall a. a -> X11Property a -> TaffyIO a
runX11Def () (Int -> X11Property ()
switch (-Int
1))) 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
          Word32
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    EventType
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Emit a new custom event of type _XMONAD_CURRENT_LAYOUT, that can be
-- intercepted by the PagerHints hook, which in turn can instruct XMonad to
-- switch to a different layout.
switch :: Int -> X11Property ()
switch :: Int -> X11Property ()
switch Int
n = do
  X11Window
cmd <- String -> X11Property X11Window
getAtom String
xLayoutProp
  X11Window -> X11Window -> X11Property ()
sendCommandEvent X11Window
cmd (Int -> X11Window
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)