    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Hooks.TaffybarPagerHints
    -- Description :  Export additional X properties for [taffybar](https://github.com/taffybar/taffybar).
    -- Copyright   :  (c) 2020 Ivan Malison
    -- License     :  BSD3-style (see LICENSE)
    --
    -- Maintainer  :  Ivan Malison <ivanmalison@gmail.com>
    -- Stability   :  unstable
    -- Portability :  unportable
    --
    -- This module exports additional X properties that allow
    -- [taffybar](https://github.com/taffybar/taffybar) to understand the state of
    -- XMonad.
    --
    -----------------------------------------------------------------------------

    module XMonad.Hooks.TaffybarPagerHints (
        -- $usage
        pagerHints,
        pagerHintsLogHook,
        pagerHintsEventHook,

        setCurrentLayoutProp,
        setVisibleWorkspacesProp,
        ) where

    import Codec.Binary.UTF8.String (encode)
    import Foreign.C.Types (CInt)

    import XMonad
    import XMonad.Prelude
    import qualified XMonad.StackSet as W

    -- $usage
    --
    -- You can use this module with the following in your @xmonad.hs@ file:
    --
    -- > import XMonad.Hooks.TaffybarPagerHints (pagerHints)
    -- >
    -- > main = xmonad $ ewmh $ pagerHints $ def
    -- > ...

    -- | The \"Current Layout\" custom hint.
    xLayoutProp :: X Atom
    xLayoutProp :: X Window
    xLayoutProp = String -> X Window
    getAtom String
    "_XMONAD_CURRENT_LAYOUT"

    -- | The \"Visible Workspaces\" custom hint.
    xVisibleProp :: X Atom
    xVisibleProp :: X Window
    xVisibleProp = String -> X Window
    getAtom String
    "_XMONAD_VISIBLE_WORKSPACES"

    -- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom
    -- hints to the given config.
    pagerHints :: XConfig a -> XConfig a
    pagerHints :: forall (a :: * -> *). XConfig a -> XConfig a
    pagerHints XConfig a
    c =
      XConfig a
    c { handleEventHook = handleEventHook c <> pagerHintsEventHook
        , logHook = logHook c <> pagerHintsLogHook
        }

    -- | Update the current values of both custom hints.
    pagerHintsLogHook :: X ()
    pagerHintsLogHook :: X ()
    pagerHintsLogHook = do
      (WindowSet -> X ()) -> X ()
    forall a. (WindowSet -> X a) -> X a
    withWindowSet
        (String -> X ()
    setCurrentLayoutProp (String -> X ()) -> (WindowSet -> String) -> WindowSet -> X ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Layout Window -> String
    forall (layout :: * -> *) a.
    LayoutClass layout a =>
    layout a -> String
    description (Layout Window -> String)
    -> (WindowSet -> Layout Window) -> WindowSet -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Workspace String (Layout Window) Window -> Layout Window
    forall i l a. Workspace i l a -> l
    W.layout (Workspace String (Layout Window) Window -> Layout Window)
    -> (WindowSet -> Workspace String (Layout Window) Window)
    -> WindowSet
    -> Layout Window
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Screen String (Layout Window) Window ScreenId ScreenDetail
    -> Workspace String (Layout Window) Window
    forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
    W.workspace (Screen String (Layout Window) Window ScreenId ScreenDetail
     -> Workspace String (Layout Window) Window)
    -> (WindowSet
        -> Screen String (Layout Window) Window ScreenId ScreenDetail)
    -> WindowSet
    -> Workspace String (Layout Window) Window
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . WindowSet
    -> Screen String (Layout Window) Window ScreenId ScreenDetail
    forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
    W.current)
      (WindowSet -> X ()) -> X ()
    forall a. (WindowSet -> X a) -> X a
    withWindowSet
        ([String] -> X ()
    setVisibleWorkspacesProp ([String] -> X ()) -> (WindowSet -> [String]) -> WindowSet -> X ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Screen String (Layout Window) Window ScreenId ScreenDetail
     -> String)
    -> [Screen String (Layout Window) Window ScreenId ScreenDetail]
    -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Workspace String (Layout Window) Window -> String
    forall i l a. Workspace i l a -> i
    W.tag (Workspace String (Layout Window) Window -> String)
    -> (Screen String (Layout Window) Window ScreenId ScreenDetail
        -> Workspace String (Layout Window) Window)
    -> Screen String (Layout Window) Window ScreenId ScreenDetail
    -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Screen String (Layout Window) Window ScreenId ScreenDetail
    -> Workspace String (Layout Window) Window
    forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
    W.workspace) ([Screen String (Layout Window) Window ScreenId ScreenDetail]
     -> [String])
    -> (WindowSet
        -> [Screen String (Layout Window) Window ScreenId ScreenDetail])
    -> WindowSet
    -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . WindowSet
    -> [Screen String (Layout Window) Window ScreenId ScreenDetail]
    forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
    W.visible)

    -- | Set the value of the \"Current Layout\" custom hint to the one given.
    setCurrentLayoutProp :: String -> X ()
    setCurrentLayoutProp :: String -> X ()
    setCurrentLayoutProp String
    l = (Display -> X ()) -> X ()
    forall a. (Display -> X a) -> X a
    withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
    forall a b. (a -> b) -> a -> b
    $ \Display
    dpy -> do
      Window
    r <- (XConf -> Window) -> X Window
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> Window
    theRoot
      Window
    a <- X Window
    xLayoutProp
      Window
    c <- String -> X Window
    getAtom String
    "UTF8_STRING"
      let l' :: [CChar]
    l' = (Word8 -> CChar) -> [Word8] -> [CChar]
    forall a b. (a -> b) -> [a] -> [b]
    map Word8 -> CChar
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (String -> [Word8]
    encode String
    l)
      IO () -> X ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    io (IO () -> X ()) -> IO () -> X ()
    forall a b. (a -> b) -> a -> b
    $ Display -> Window -> Window -> Window -> CInt -> [CChar] -> IO ()
    changeProperty8 Display
    dpy Window
    r Window
    a Window
    c CInt
    propModeReplace [CChar]
    l'

    -- | Set the value of the \"Visible Workspaces\" hint to the one given.
    setVisibleWorkspacesProp :: [String] -> X ()
    setVisibleWorkspacesProp :: [String] -> X ()
    setVisibleWorkspacesProp [String]
    vis = (Display -> X ()) -> X ()
    forall a. (Display -> X a) -> X a
    withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
    forall a b. (a -> b) -> a -> b
    $ \Display
    dpy -> do
      Window
    r  <- (XConf -> Window) -> X Window
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> Window
    theRoot
      Window
    a  <- X Window
    xVisibleProp
      Window
    c  <- String -> X Window
    getAtom String
    "UTF8_STRING"
      let vis' :: [CChar]
    vis' = (Word8 -> CChar) -> [Word8] -> [CChar]
    forall a b. (a -> b) -> [a] -> [b]
    map Word8 -> CChar
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral ([Word8] -> [CChar]) -> [Word8] -> [CChar]
    forall a b. (a -> b) -> a -> b
    $ (String -> [Word8]) -> [String] -> [Word8]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (([Word8] -> [Word8] -> [Word8]
    forall a. [a] -> [a] -> [a]
    ++[Word8
    0]) ([Word8] -> [Word8]) -> (String -> [Word8]) -> String -> [Word8]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [Word8]
    encode) [String]
    vis
      IO () -> X ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    io (IO () -> X ()) -> IO () -> X ()
    forall a b. (a -> b) -> a -> b
    $ Display -> Window -> Window -> Window -> CInt -> [CChar] -> IO ()
    changeProperty8 Display
    dpy Window
    r Window
    a Window
    c CInt
    propModeReplace [CChar]
    vis'

    -- | Handle all \"Current Layout\" events received from pager widgets, and
    -- set the current layout accordingly.
    pagerHintsEventHook :: Event -> X All
    pagerHintsEventHook :: Event -> X All
    pagerHintsEventHook ClientMessageEvent
                          { ev_message_type :: Event -> Window
    ev_message_type = Window
    mt
                          , ev_data :: Event -> [CInt]
    ev_data = [CInt]
    d
                          } = (WindowSet -> X All) -> X All
    forall a. (WindowSet -> X a) -> X a
    withWindowSet ((WindowSet -> X All) -> X All) -> (WindowSet -> X All) -> X All
    forall a b. (a -> b) -> a -> b
    $ \WindowSet
    _ -> do
      Window
    a <- X Window
    xLayoutProp
      Bool -> X () -> X ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Window
    mt Window -> Window -> Bool
    forall a. Eq a => a -> a -> Bool
    == Window
    a) (X () -> X ()) -> X () -> X ()
    forall a b. (a -> b) -> a -> b
    $ [CInt] -> X ()
    sendLayoutMessage [CInt]
    d
      All -> X All
    forall a. a -> X a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> All
    All Bool
    True)
    pagerHintsEventHook Event
    _ = All -> X All
    forall a. a -> X a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> All
    All Bool
    True)

    -- | Request a change in the current layout by sending an internal message
    -- to XMonad.
    sendLayoutMessage :: [CInt] -> X ()
    sendLayoutMessage :: [CInt] -> X ()
    sendLayoutMessage (CInt
    x:[CInt]
    _) | CInt
    x CInt -> CInt -> Bool
    forall a. Ord a => a -> a -> Bool
    < CInt
    0     = ChangeLayout -> X ()
    forall a. Message a => a -> X ()
    sendMessage ChangeLayout
    FirstLayout
                            | Bool
    otherwise = ChangeLayout -> X ()
    forall a. Message a => a -> X ()
    sendMessage ChangeLayout
    NextLayout
    sendLayoutMessage [] = () -> X ()
    forall a. a -> X a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()