    {-# 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 = "_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 config :: 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 "layout-label"

      -- This callback is run in a separate thread and needs to use
      -- postGUIASync
      let callback :: Event -> ReaderT Context IO ()
    callback _ = (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 "" (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
    context btn :: 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
        EventTypeButtonPress ->
            case Word32
    buttonNumber of
              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 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
              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 (-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
              _ -> Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
        _ -> 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 n :: 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)