X.L.DecorationEx: extensible mechanism for window decorations (#857)

* First version of DecorationEx.

* Fixed most warnings.

* Fix build error with ghc-9.8.1.

* Fix title shrinking with text decoration.

* Add convinience re-exports.

* Get rid of orphan instances.

* Fix a couple of warnings.

* Rename X.L.DecorationEx.Types -> X.L.DecorationEx.Common

* Add instance Default StandardCommand.

* Fix some typos and formatting

thanks to @geekosaur

Co-authored-by: brandon s allbery kf8nh <allbery.b@gmail.com>

* Fix reference to xmonad.hs

See also #859

Co-authored-by: brandon s allbery kf8nh <allbery.b@gmail.com>

* Fix reference to xmonad.hs

Co-authored-by: brandon s allbery kf8nh <allbery.b@gmail.com>

* Fix formatting

Co-authored-by: brandon s allbery kf8nh <allbery.b@gmail.com>

* Fix some typos and formatting

thanks to @geekosaur

Co-authored-by: brandon s allbery kf8nh <allbery.b@gmail.com>

* Remove commented code.

* Update CHANGES.md.

* calcWidgetPlace is now allowed to return rectangle with any X,

but that will be ignored.

* More generic instance for DecorationWidget GenericWidget.

* Replace explicit definition of `fi` with import from X.Prelude.

thanks to @slotThe.

* Move fetch-all pattern to the end of definition.

thanks to @slotThe.

* X.L.DecorationEx: Add screenshot

---------

Co-authored-by: brandon s allbery kf8nh <allbery.b@gmail.com>
Co-authored-by: Tony Zorman <soliditsallgood@mailbox.org>

CHANGES.md

@@ -145,6 +145,12 @@
     - A new window layout, similar to X.L.Circle, but with more
       possibilities for customisation.
 
+  * `XMonad.Layout.DecorationEx`:
+
+    - A new, more extensible, mechanism for window decorations, and some
+      standard types of decorations, including usual bar on top of window,
+      tabbed decorations and dwm-like decorations.
+
 ### Bug Fixes and Minor Changes
 
   * `XMonad.Layout.Magnifier`

XMonad/Layout/DecorationEx.hs

@@ -0,0 +1,106 @@
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.DecorationEx
+-- Description :  Advanced window decorations module for XMonad
+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  portnov84@rambler.ru
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- This set of modules contains a set of type classes and their implementations
+-- which define a flexible and extensible mechanism of window decorations.
+--
+-- <<https://github.com/xmonad/xmonad-contrib/assets/50166980/ccc20e1b-6762-48d9-8195-579f77a98396>>
+-- Click <https://github.com/xmonad/xmonad-contrib/assets/50166980/64847a85-33c4-4b5f-8ec8-df73d3e4d58d here>
+-- for a larger version.
+--
+-- Within this mechanism, there are the following entities which define
+-- how decorations will look and work:
+--
+-- * Main object is @DecorationEx@ layout modifier. It is from where everything
+--   starts. It creates, shows and hides decoration windows (rectangles) when
+--   needed. It is parameterized with decoration geometry, decoration engine and
+--   theme. It calls these components to do their parts of the work.
+-- * @DecorationGeometry@ defines where decoration rectangles should be placed.
+--   For example, standard horizontal bar above each window; or tab bar.
+-- * @DecorationEngine@ defines how decorations look and how they react on clicks.
+--   Different implementations of the decoration engine can use different APIs
+--   to draw decorations. Within this package, there is one implementation 
+--   (@TextDecoration@), which uses plain Xlib calls, and displays decoration
+--   widgets with text fragments, like @[X]@ or @[_]@. Other engines can, for
+--   example, use the Cairo library to draw nice gradients and image-based widgets.
+-- * A Decoration widget is an element placed on a window decoration. It defines how
+--   it looks and how it responds to clicks. Examples include usual window 
+--   buttons (minimize, maximize, close), window icon, window title.
+-- * A Decoration theme defines colors and fonts for the decoration engine. It also
+--   contains a list of decoration widgets and says where to place them (at the
+--   left, at the right or in the center).
+-- 
+-- This mechanism makes major use of parameterized data types and type families,
+-- in order to make it possible to define different types of decorations, and
+-- easily combine different aspects of decorations. For example, each decoration
+-- engine can be combined with each decoration geometry.
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.DecorationEx (
+  -- * Usage:
+  -- $usage
+
+  -- * Standard decoration settings
+  decorationEx,
+  textDecoration, textTabbed, dwmStyleDeco,
+  -- * Decoration-related types
+  TextDecoration (..), DefaultGeometry (..),
+  TabbedGeometry (..), DwmGeometry (..),
+  DecorationEx,
+  -- * Theme types
+  BoxBorders (..), BorderColors,
+  SimpleStyle (..), GenericTheme (..),
+  ThemeEx,
+  -- * Widget types
+  StandardCommand (..), GenericWidget (..),
+  StandardWidget,
+  -- * Utility functions for themes
+  themeEx, borderColor, shadowBorder,
+  -- * Convinience re-exports
+  Shrinker (..), shrinkText,
+  -- * Standard widgets
+  titleW, toggleStickyW, minimizeW,
+  maximizeW, closeW, dwmpromoteW,
+  moveToNextGroupW, moveToPrevGroupW
+  ) where
+
+import XMonad.Layout.Decoration
+import XMonad.Layout.DecorationEx.Common
+import XMonad.Layout.DecorationEx.Widgets
+import XMonad.Layout.DecorationEx.Geometry
+import XMonad.Layout.DecorationEx.LayoutModifier
+import XMonad.Layout.DecorationEx.TextEngine
+import XMonad.Layout.DecorationEx.TabbedGeometry
+import XMonad.Layout.DecorationEx.DwmGeometry
+
+-- $usage
+--
+-- You can use this module with the following in your
+-- @xmonad.hs@:
+--
+-- > import XMonad.Layout.DecorationEx
+-- Then edit your @layoutHook@ by adding the DwmStyle decoration to
+-- your layout:
+--
+-- > myTheme = ThemeEx {...}
+-- > myL = textDecoration shrinkText myTheme (layoutHook def)
+-- > main = xmonad def { layoutHook = myL }
+--
+-- For more detailed instructions on editing the layoutHook see:
+--
+-- "XMonad.Doc.Extending#Editing_the_layout_hook"
+--
+-- This module exports only some definitions from it's submodules,
+-- most likely to be used from user configurations. To define
+-- your own decoration types you will likely have to import specific
+-- submodules.
+

XMonad/Layout/DecorationEx/Common.hs

@@ -0,0 +1,272 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.DecorationEx.Common
+-- Description :  Declaration of types used by DecorationEx module,
+--                and commonly used utility functions.
+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  portnov84@rambler.ru
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- This module exposes a number of types which are used by other sub-modules
+-- of "XMonad.Layout.DecorationEx" module.
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.DecorationEx.Common (
+    -- * Common types
+    WindowDecoration (..)
+  , WindowCommand (..)
+  , DecorationWidget (..)
+  , WidgetPlace (..)
+  , WidgetLayout (..)
+  , HasWidgets (..)
+  , ClickHandler (..)
+  , ThemeAttributes (..)
+  , XPaintingContext
+  , BoxBorders (..)
+  , BorderColors
+  , ThemeStyleType (..)
+  , SimpleStyle (..)
+  , GenericTheme (..)
+  , ThemeEx 
+  -- * Utilities
+  , widgetLayout
+  , windowStyleType
+  , genericWindowStyle
+  , themeEx
+  , borderColor
+  , shadowBorder
+  ) where
+
+import qualified Data.Map as M
+import Data.Bits (testBit)
+
+import XMonad
+import qualified XMonad.StackSet as W
+import XMonad.Hooks.UrgencyHook
+import qualified XMonad.Layout.Decoration as D
+
+-- | Information about decoration of one window
+data WindowDecoration = WindowDecoration {
+    wdOrigWindow :: !Window         -- ^ Original window (one being decorated)
+  , wdOrigWinRect :: !Rectangle     -- ^ Rectangle of original window
+  , wdDecoWindow :: !(Maybe Window) -- ^ Decoration window, or Nothing if this window should not be decorated
+  , wdDecoRect :: !(Maybe Rectangle) -- ^ Rectangle for decoration window
+  , wdWidgets :: ![WidgetPlace]      -- ^ Places for widgets
+  }
+
+-- | Type class for window commands (such as maximize or close window)
+class (Read cmd, Show cmd) => WindowCommand cmd where
+  -- | Execute the command
+  executeWindowCommand :: cmd -> Window -> X Bool
+
+  -- | Is the command currently in `checked' state. 
+  -- For example, for 'sticky' command, check if the
+  -- window is currently sticky.
+  isCommandChecked :: cmd -> Window -> X Bool
+
+-- | Type class for decoration widgets
+class (WindowCommand (WidgetCommand widget), Read widget, Show widget)
+  => DecorationWidget widget where
+  -- | Type of window commands which this type of widgets can execute
+  type WidgetCommand widget
+
+  -- | Get window command which is associated with this widget.
+  widgetCommand :: widget -> Int -> WidgetCommand widget
+
+  -- | Check if the widget is shrinkable, i.e. if it's width
+  -- can be reduced if there is not enough place in the decoration.
+  isShrinkable :: widget -> Bool
+
+-- | Layout of widgets
+data WidgetLayout a = WidgetLayout {
+    wlLeft :: ![a]     -- ^ Widgets that should be aligned to the left side of decoration
+  , wlCenter :: ![a]   -- ^ Widgets that should be in the center of decoration
+  , wlRight :: ![a]    -- ^ Widgets taht should be aligned to the right side of decoration
+  }
+
+-- | Data type describing where the decoration widget (e.g. window button)
+-- should be placed.
+-- All coordinates are relative to decoration rectangle.
+data WidgetPlace = WidgetPlace {
+    wpTextYPosition :: !Position -- ^ Y position of text base line
+                                 -- (for widgets like window title or text-based buttons)
+  , wpRectangle :: !Rectangle    -- ^ Rectangle where to place the widget
+  }
+  deriving (Show)
+
+-- | Generic data type which is used to
+-- describe characteristics of rectangle borders.
+data BoxBorders a = BoxBorders {
+    bxTop :: !a
+  , bxRight :: !a
+  , bxBottom :: !a
+  , bxLeft :: !a
+  } deriving (Eq, Read, Show)
+
+-- | Convinience data type describing colors of decoration rectangle borders.
+type BorderColors = BoxBorders String
+
+-- | Data type describing look of window decoration
+-- in particular state (active or inactive)
+data SimpleStyle = SimpleStyle {
+    sBgColor :: !String                 -- ^ Decoration background color
+  , sTextColor :: !String               -- ^ Text (foreground) color
+  , sTextBgColor :: !String             -- ^ Text background color
+  , sDecoBorderWidth :: !Dimension      -- ^ Width of border of decoration rectangle. Set to 0 to disable the border.
+  , sDecorationBorders :: !BorderColors -- ^ Colors of borders of decoration rectangle.
+  }
+  deriving (Show, Read)
+
+-- | Type class for themes, which claims that
+-- the theme contains the list of widgets and their alignments.
+class HasWidgets theme widget where
+  themeWidgets :: theme widget -> WidgetLayout widget
+
+-- | Type class for themes, which claims that
+-- the theme can describe how the decoration should respond
+-- to clicks on decoration itself (between widgets).
+class ClickHandler theme widget where
+  -- | This is called when the user clicks on the decoration rectangle
+  -- (not on one of widgets).
+  onDecorationClick :: theme widget
+                    -> Int                          -- ^ Mouse button number
+                    -> Maybe (WidgetCommand widget)
+
+  -- | Determine if it is possible to drag window by it's decoration
+  -- with mouse button.
+  isDraggingEnabled :: theme widget
+                    -> Int          -- ^ Mouse button number
+                    -> Bool
+
+-- | Type class for themes, which claims that the theme
+-- is responsible for determining looks of decoration.
+class (Read theme, Show theme) => ThemeAttributes theme where
+  -- | Type which describes looks of decoration in one
+  -- of window states (active, inactive, urgent, etc).
+  type Style theme
+
+  -- | Select style based on window state.
+  selectWindowStyle :: theme -> Window -> X (Style theme)
+
+  -- | Define padding between decoration rectangle and widgets.
+  widgetsPadding :: theme -> BoxBorders Dimension
+  
+  -- | Initial background color of decoration rectangle.
+  -- When decoration widget is created, it is initially filled
+  -- with this color.
+  defaultBgColor :: theme -> String
+
+  -- | Font name defined in the theme.
+  themeFontName :: theme -> String
+
+-- | Generic Theme data type. This is used
+-- by @TextEngine@ and can be used by other relatively
+-- simple decoration engines.
+data GenericTheme style widget = GenericTheme {
+    exActive :: !style                                  -- ^ Decoration style for active (focused) windows
+  , exInactive :: !style                                -- ^ Decoration style for inactive (unfocused) windows
+  , exUrgent :: !style                                  -- ^ Decoration style for urgent windows
+  , exPadding :: !(BoxBorders Dimension)                -- ^ Padding between decoration rectangle and widgets
+  , exFontName :: !String                               -- ^ Font name
+  , exOnDecoClick :: !(M.Map Int (WidgetCommand widget)) -- ^ Correspondence between mouse button number and window command.
+  , exDragWindowButtons :: ![Int]                       -- ^ For which mouse buttons dragging is enabled
+  , exWidgetsLeft :: ![widget]                          -- ^ Widgets that should appear at the left of decoration rectangle (listed left to right)
+  , exWidgetsCenter :: ![widget]                        -- ^ Widgets that should appear in the center of decoration rectangle (listed left to right)
+  , exWidgetsRight :: ![widget]                         -- ^ Widgets that should appear at the right of decoration rectangle (listed left to right)
+  }
+
+deriving instance (Show widget, Show (WidgetCommand widget), Show style) => Show (GenericTheme style widget)
+deriving instance (Read widget, Read (WidgetCommand widget), Read style) => Read (GenericTheme style widget)
+
+-- | Convience type for themes used by @TextDecoration@.
+type ThemeEx widget = GenericTheme SimpleStyle widget
+
+instance HasWidgets (GenericTheme style) widget where
+  themeWidgets theme = WidgetLayout (exWidgetsLeft theme) (exWidgetsCenter theme) (exWidgetsRight theme)
+
+-- | Supported states of windows (on which looks of decorations can depend).
+data ThemeStyleType = ActiveWindow | UrgentWindow | InactiveWindow
+  deriving (Eq, Show, Read)
+
+-- | Utility function to convert WidgetLayout to plain list of widgets.
+widgetLayout :: WidgetLayout widget -> [widget]
+widgetLayout ws = wlLeft ws ++ wlCenter ws ++ wlRight ws
+
+-- | Painting context for decoration engines based on plain X11 calls.
+type XPaintingContext = (Display, Pixmap, GC)
+
+instance (Show widget, Read widget, Read (WidgetCommand widget), Show (WidgetCommand widget))
+        => ThemeAttributes (ThemeEx widget) where
+  type Style (ThemeEx widget) = SimpleStyle
+  selectWindowStyle theme w = genericWindowStyle w theme
+  defaultBgColor t = sBgColor $ exInactive t
+  widgetsPadding = exPadding
+  themeFontName = exFontName
+
+instance ClickHandler (GenericTheme SimpleStyle) widget where
+  onDecorationClick theme button = M.lookup button (exOnDecoClick theme)
+  isDraggingEnabled theme button = button `elem` exDragWindowButtons theme
+
+-- | Generic utility function to select style from @GenericTheme@
+-- based on current state of the window.
+genericWindowStyle :: Window -> GenericTheme style widget -> X style
+genericWindowStyle win theme = do
+  styleType <- windowStyleType win
+  return $ case styleType of
+             ActiveWindow -> exActive theme
+             InactiveWindow -> exInactive theme
+             UrgentWindow -> exUrgent theme
+
+-- | Detect type of style to be used from current state of the window.
+windowStyleType :: Window -> X ThemeStyleType
+windowStyleType win = do
+  mbFocused <- W.peek <$> gets windowset
+  isWmStateUrgent <- (win `elem`) <$> readUrgents
+  isUrgencyBitSet <- withDisplay $ \dpy -> do
+                       hints <- io $ getWMHints dpy win
+                       return $ wmh_flags hints `testBit` urgencyHintBit
+  if isWmStateUrgent || isUrgencyBitSet
+    then return UrgentWindow
+    else return $
+      case mbFocused of
+        Nothing -> InactiveWindow
+        Just focused
+          | focused == win -> ActiveWindow
+          | otherwise -> InactiveWindow
+
+-- | Convert Theme type from "XMonad.Layout.Decoration" to 
+-- theme type used by "XMonad.Layout.DecorationEx.TextEngine".
+themeEx :: Default (WidgetCommand widget) => D.Theme -> ThemeEx widget
+themeEx t =
+    GenericTheme {
+          exActive = SimpleStyle (D.activeColor t) (D.activeTextColor t) (D.activeColor t) (D.activeBorderWidth t) (borderColor $ D.activeColor t)
+        , exInactive = SimpleStyle (D.inactiveColor t) (D.inactiveTextColor t) (D.inactiveColor t) (D.inactiveBorderWidth t) (borderColor $ D.inactiveColor t)
+        , exUrgent = SimpleStyle (D.urgentColor t) (D.urgentTextColor t) (D.urgentColor t) (D.urgentBorderWidth t) (borderColor $ D.urgentColor t)
+        , exPadding = BoxBorders 0 4 0 4
+        , exFontName = D.fontName t
+        , exOnDecoClick = M.fromList [(1, def)]
+        , exDragWindowButtons = [1]
+        , exWidgetsLeft = []
+        , exWidgetsCenter = []
+        , exWidgetsRight = []
+      }
+
+instance Default (WidgetCommand widget) => Default (ThemeEx widget) where
+  def = themeEx (def :: D.Theme)
+
+borderColor :: String -> BorderColors
+borderColor c = BoxBorders c c c c
+
+shadowBorder :: String -> String -> BorderColors
+shadowBorder highlight shadow = BoxBorders highlight shadow shadow highlight
+

XMonad/Layout/DecorationEx/DwmGeometry.hs

@@ -0,0 +1,106 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.DecorationEx.DwmGeometry
+-- Description :  DWM-style window decoration geometry
+-- Copyright   :  (c) 2007 Andrea Rossato, 2023 Ilya Portnov
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  portnov84@rambler.ru
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- This defines window decorations which are shown as a bar of fixed width
+-- on top of window.
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.DecorationEx.DwmGeometry (
+    -- * Usage:
+    -- $usage
+    DwmGeometry (..),
+    dwmStyleDeco, dwmStyleDecoEx
+  ) where 
+
+import XMonad
+import XMonad.Prelude
+import qualified XMonad.StackSet as W
+import XMonad.Layout.LayoutModifier
+import qualified XMonad.Layout.Decoration as D
+
+import XMonad.Layout.DecorationEx.LayoutModifier
+import XMonad.Layout.DecorationEx.Common
+import XMonad.Layout.DecorationEx.Geometry
+import XMonad.Layout.DecorationEx.Widgets
+import XMonad.Layout.DecorationEx.TextEngine
+
+-- $usage
+-- You can use this module with the following in your
+-- @xmonad.hs@:
+--
+-- > import XMonad.Layout.DecorationEx.DwmStyle
+-- Then edit your @layoutHook@ by adding the DwmStyle decoration to
+-- your layout:
+--
+-- > myL = dwmStyleDeco shrinkText (layoutHook def)
+-- > main = xmonad def { layoutHook = myL }
+--
+-- For more detailed instructions on editing the layoutHook see:
+--
+-- "XMonad.Doc.Extending#Editing_the_layout_hook"
+
+-- | Decoration geometry data type
+data DwmGeometry a = DwmGeometry {
+      dwmShowForFocused :: !Bool         -- ^ Whether to show decorations on focused windows
+    , dwmHorizontalPosition :: !Rational -- ^ Horizontal position of decoration rectangle.
+                                         -- 0 means place it at left corner, 1 - place it at
+                                         -- right corner, @1%2@ - place it at center.
+    , dwmDecoHeight :: !Dimension        -- ^ Height of decoration rectangle
+    , dwmDecoWidth :: !Dimension         -- ^ Width of decoration rectangle
+  }
+  deriving (Show, Read)
+
+instance Default (DwmGeometry a) where
+  def = DwmGeometry False 1 20 200
+
+instance DecorationGeometry DwmGeometry Window where
+  describeGeometry _ = "DwmStyle"
+
+  pureDecoration (DwmGeometry {..}) _ stack _ (w, Rectangle x y windowWidth _) =
+    let width = min windowWidth dwmDecoWidth
+        halfWidth = width `div` 2
+        minCenterX = x + fi halfWidth
+        maxCenterX = x + fi windowWidth - fromIntegral halfWidth
+        centerX = round ((1 - dwmHorizontalPosition)*fi minCenterX + dwmHorizontalPosition*fi maxCenterX) :: Position
+        decoX = centerX - fi halfWidth
+        focusedWindow = W.focus stack
+        isFocused = focusedWindow == w
+    in  if (not dwmShowForFocused && isFocused) || not (D.isInStack stack w)
+          then Nothing
+          else Just $ Rectangle decoX y width dwmDecoHeight
+
+  shrinkWindow _ _ windowRect = windowRect
+
+-- | Add a decoration to window layout. Widgets are indicated with text fragments using TextDecoration;
+-- decoration placement can be adjusted.
+dwmStyleDecoEx :: D.Shrinker shrinker    
+             => shrinker               -- ^ Strings shrinker, for example @shrinkText@
+             -> DwmGeometry Window
+             -> ThemeEx StandardWidget -- ^ Decoration theme (font, colors, widgets, etc)
+             -> l Window               -- ^ Layout to be decorated
+             -> ModifiedLayout (DecorationEx TextDecoration StandardWidget DwmGeometry shrinker) l Window
+dwmStyleDecoEx shrinker geom theme = decorationEx shrinker theme TextDecoration geom
+
+-- | Add a decoration to window layout. Widgets are indicated with text fragments using TextDecoration;
+-- decoration placement is similar to DWM.
+dwmStyleDeco :: D.Shrinker shrinker    
+             => shrinker               -- ^ Strings shrinker, for example @shrinkText@
+             -> ThemeEx StandardWidget -- ^ Decoration theme (font, colors, widgets, etc)
+             -> l Window               -- ^ Layout to be decorated
+             -> ModifiedLayout (DecorationEx TextDecoration StandardWidget DwmGeometry shrinker) l Window
+dwmStyleDeco shrinker = dwmStyleDecoEx shrinker def
+

XMonad/Layout/DecorationEx/Engine.hs

@@ -0,0 +1,511 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DefaultSignatures #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.DecorationEx.Engine
+-- Description :  Type class and its default implementation for window decoration engines.
+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  portnov84@rambler.ru
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- This module defines @DecorationEngine@ type class, and default implementation for it.
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.DecorationEx.Engine (
+    -- * DecorationEngine class
+    DecorationEngine (..),
+    -- * Auxiliary data types
+    DrawData (..), 
+    DecorationLayoutState (..),
+    -- * Re-exports from X.L.Decoration
+    Shrinker (..), shrinkText,
+    -- * Utility functions
+    mkDrawData,
+    paintDecorationSimple
+  ) where
+
+import Control.Monad
+import Data.Kind
+import Foreign.C.Types (CInt)
+
+import XMonad
+import XMonad.Prelude
+import qualified XMonad.StackSet as W
+import XMonad.Layout.Decoration (Shrinker (..), shrinkWhile, shrinkText)
+import XMonad.Layout.DraggingVisualizer (DraggingVisualizerMsg (..))
+import XMonad.Layout.DecorationAddons (handleScreenCrossing)
+import XMonad.Util.Font
+import XMonad.Util.NamedWindows (getName)
+
+import XMonad.Layout.DecorationEx.Common
+
+-- | Auxiliary type for data which are passed from
+-- decoration layout modifier to decoration engine.
+data DrawData engine widget = DrawData {
+    ddEngineState :: !(DecorationEngineState engine)     -- ^ Decoration engine state
+  , ddStyle :: !(Style (Theme engine widget))  -- ^ Graphics style of the decoration. This defines colors, fonts etc
+                                                        -- which are to be used for this particular window in it's current state.
+  , ddOrigWindow :: !Window                             -- ^ Original window to be decorated
+  , ddWindowTitle :: !String                            -- ^ Original window title (not shrinked yet)
+  , ddDecoRect :: !Rectangle                            -- ^ Decoration rectangle
+  , ddWidgets :: !(WidgetLayout widget)         -- ^ Widgets to be placed on decoration
+  , ddWidgetPlaces :: !(WidgetLayout WidgetPlace)       -- ^ Places where widgets must be shown
+  }
+
+-- | State of decoration engine
+data DecorationLayoutState engine = DecorationLayoutState {
+    dsStyleState :: !(DecorationEngineState engine) -- ^ Engine-specific state
+  , dsDecorations :: ![WindowDecoration]            -- ^ Mapping between decoration windows and original windows
+  }
+
+-- | Decoration engines type class.
+-- Decoration engine is responsible for drawing something inside decoration rectangle.
+-- It is also responsible for handling X11 events (such as clicks) which happen
+-- within decoration rectangle.
+-- Decoration rectangles are defined by DecorationGeometry implementation.
+class (Read (engine widget a), Show (engine widget a),
+       Eq a,
+       DecorationWidget widget,
+       HasWidgets (Theme engine) widget,
+       ClickHandler (Theme engine) widget,
+       ThemeAttributes (Theme engine widget))
+    => DecorationEngine engine widget a where
+
+    -- | Type of themes used by decoration engine.
+    -- This type must be parameterized over a widget type,
+    -- because a theme will contain a list of widgets.
+    type Theme engine :: Type -> Type           
+                                          
+    -- | Type of data used by engine as a context during painting;
+    -- for plain X11-based implementation this is Display, Pixmap
+    -- and GC.
+    type DecorationPaintingContext engine 
+ 
+    -- | Type of state used by the decoration engine.
+    -- This can contain some resources that should be initialized
+    -- and released at time, such as X11 fonts.
+    type DecorationEngineState engine     
+
+    -- | Give a name to decoration engine.
+    describeEngine :: engine widget a -> String
+
+    -- | Initialize state of the engine.
+    initializeState :: engine widget a       -- ^ Decoration engine instance
+                    -> geom a                -- ^ Decoration geometry instance
+                    -> Theme engine widget   -- ^ Theme to be used
+                    -> X (DecorationEngineState engine)
+
+    -- | Release resources held in engine state.
+    releaseStateResources :: engine widget a              -- ^ Decoration engine instance
+                          -> DecorationEngineState engine -- ^ Engine state
+                          -> X ()
+
+    -- | Calculate place which will be occupied by one widget.
+    -- NB: X coordinate of the returned rectangle will be ignored, because
+    -- the rectangle will be moved to the right or to the left for proper alignment
+    -- of widgets.
+    calcWidgetPlace :: engine widget a         -- ^ Decoration engine instance
+                    -> DrawData engine widget  -- ^ Information about window and decoration
+                    -> widget                  -- ^ Widget to be placed
+                    -> X WidgetPlace
+
+    -- | Place widgets along the decoration bar.
+    placeWidgets :: Shrinker shrinker
+                 => engine widget a              -- ^ Decoration engine instance
+                 -> Theme engine widget          -- ^ Theme to be used
+                 -> shrinker                     -- ^ Strings shrinker
+                 -> DecorationEngineState engine -- ^ Current state of the engine
+                 -> Rectangle                    -- ^ Decoration rectangle
+                 -> Window                       -- ^ Original window to be decorated
+                 -> WidgetLayout widget          -- ^ Widgets layout
+                 -> X (WidgetLayout WidgetPlace)
+    placeWidgets engine theme _ decoStyle decoRect window wlayout = do
+        let leftWidgets = wlLeft wlayout
+            rightWidgets = wlRight wlayout
+            centerWidgets = wlCenter wlayout
+
+        dd <- mkDrawData engine theme decoStyle window decoRect
+        let paddedDecoRect = pad (widgetsPadding theme) (ddDecoRect dd)
+            paddedDd = dd {ddDecoRect = paddedDecoRect}
+        rightRects <- alignRight engine paddedDd rightWidgets
+        leftRects <- alignLeft engine paddedDd leftWidgets
+        let wantedLeftWidgetsWidth = sum $ map (rect_width . wpRectangle) leftRects
+            wantedRightWidgetsWidth = sum $ map (rect_width . wpRectangle) rightRects
+            hasShrinkableOnLeft = any isShrinkable leftWidgets
+            hasShrinkableOnRight = any isShrinkable rightWidgets
+            decoWidth = rect_width decoRect
+            (leftWidgetsWidth, rightWidgetsWidth)
+              | hasShrinkableOnLeft = 
+                  (min (decoWidth - wantedRightWidgetsWidth) wantedLeftWidgetsWidth,
+                      wantedRightWidgetsWidth)
+              | hasShrinkableOnRight =
+                  (wantedLeftWidgetsWidth,
+                      min (decoWidth - wantedLeftWidgetsWidth) wantedRightWidgetsWidth)
+              | otherwise = (wantedLeftWidgetsWidth, wantedRightWidgetsWidth)
+            ddForCenter = paddedDd {ddDecoRect = padCenter leftWidgetsWidth rightWidgetsWidth paddedDecoRect}
+        centerRects <- alignCenter engine ddForCenter centerWidgets
+        let shrinkedLeftRects = packLeft (rect_x paddedDecoRect) $ shrinkPlaces leftWidgetsWidth $ zip leftRects (map isShrinkable leftWidgets)
+            shrinkedRightRects = packRight (rect_width paddedDecoRect) $ shrinkPlaces rightWidgetsWidth $ zip rightRects (map isShrinkable rightWidgets)
+        return $ WidgetLayout shrinkedLeftRects centerRects shrinkedRightRects
+      where
+        shrinkPlaces targetWidth ps =
+          let nShrinkable = length (filter snd ps)
+              totalUnshrinkedWidth = sum $ map (rect_width . wpRectangle . fst) $ filter (not . snd) ps
+              shrinkedWidth = (targetWidth - totalUnshrinkedWidth) `div` fi nShrinkable
+
+              resetX place = place {wpRectangle = (wpRectangle place) {rect_x = 0}}
+
+              adjust (place, True) = resetX $ place {wpRectangle = (wpRectangle place) {rect_width = shrinkedWidth}}
+              adjust (place, False) = resetX place
+          in  map adjust ps
+
+        pad p (Rectangle _ _ w h) =
+          Rectangle (fi (bxLeft p)) (fi (bxTop p))
+                    (w - bxLeft p - bxRight p)
+                    (h - bxTop p - bxBottom p)
+      
+        padCenter left right (Rectangle x y w h) =
+          Rectangle (x + fi left) y
+                    (w - left - right) h
+
+    -- | Shrink window title so that it would fit in decoration.
+    getShrinkedWindowName :: Shrinker shrinker
+                          => engine widget a              -- ^ Decoration engine instance
+                          -> shrinker                     -- ^ Strings shrinker
+                          -> DecorationEngineState engine -- ^ State of decoration engine
+                          -> String                       -- ^ Original window title
+                          -> Dimension                    -- ^ Width of rectangle in which the title should fit
+                          -> Dimension                    -- ^ Height of rectangle in which the title should fit
+                          -> X String
+
+    default getShrinkedWindowName :: (Shrinker shrinker, DecorationEngineState engine ~ XMonadFont)
+                                  => engine widget a -> shrinker -> DecorationEngineState engine -> String -> Dimension -> Dimension -> X String
+    getShrinkedWindowName _ shrinker font name wh _ = do
+      let s = shrinkIt shrinker
+      dpy <- asks display
+      shrinkWhile s (\n -> do size <- io $ textWidthXMF dpy font n
+                              return $ size > fromIntegral wh) name
+
+    -- | Mask of X11 events on which the decoration engine should do something.
+    -- @exposureMask@ should be included here so that decoration engine could
+    -- repaint decorations when they are shown on screen.
+    -- @buttonPressMask@ should be included so that decoration engine could
+    -- response to mouse clicks.
+    -- Other events can be added to custom implementations of DecorationEngine.
+    decorationXEventMask :: engine widget a -> EventMask
+    decorationXEventMask _ = exposureMask .|. buttonPressMask
+
+    -- | List of X11 window property atoms of original (client) windows,
+    -- change of which should trigger repainting of decoration.
+    -- For example, if @WM_NAME@ changes it means that we have to redraw
+    -- window title.
+    propsToRepaintDecoration :: engine widget a -> X [Atom]
+    propsToRepaintDecoration _ =
+      mapM getAtom ["WM_NAME", "_NET_WM_NAME", "WM_STATE", "WM_HINTS"]
+
+    -- | Generic event handler, which recieves X11 events on decoration
+    -- window.
+    -- Default implementation handles mouse clicks and drags.
+    decorationEventHookEx :: Shrinker shrinker
+                          => engine widget a
+                          -> Theme engine widget
+                          -> DecorationLayoutState engine
+                          -> shrinker
+                          -> Event
+                          -> X ()
+    decorationEventHookEx = handleMouseFocusDrag
+
+    -- | Event handler for clicks on decoration window.
+    -- This is called from default implementation of "decorationEventHookEx".
+    -- This should return True, if the click was handled (something happened
+    -- because of that click). If this returns False, the click can be considered
+    -- as a beginning of mouse drag.
+    handleDecorationClick :: engine widget a      -- ^ Decoration engine instance
+                          -> Theme engine widget  -- ^ Decoration theme
+                          -> Rectangle            -- ^ Decoration rectangle
+                          -> [Rectangle]          -- ^ Rectangles where widgets are placed
+                          -> Window               -- ^ Original (client) window
+                          -> Int                  -- ^ Mouse click X coordinate
+                          -> Int                  -- ^ Mouse click Y coordinate
+                          -> Int                  -- ^ Mouse button number
+                          -> X Bool
+    handleDecorationClick = decorationHandler
+
+    -- | Event handler which is called during mouse dragging.
+    -- This is called from default implementation of "decorationEventHookEx".
+    decorationWhileDraggingHook :: engine widget a      -- ^ Decoration engine instance
+                                -> CInt                 -- ^ Event X coordinate
+                                -> CInt                 -- ^ Event Y coordinate
+                                -> (Window, Rectangle)  -- ^ Original window and it's rectangle
+                                -> Position             -- ^ X coordinate of new pointer position during dragging
+                                -> Position             -- ^ Y coordinate of new pointer position during dragging
+                                -> X ()
+    decorationWhileDraggingHook _ = handleDraggingInProgress
+
+    -- | This hoook is called after a window has been dragged using the decoration.
+    -- This is called from default implementation of "decorationEventHookEx".
+    decorationAfterDraggingHook :: engine widget a     -- ^ Decoration engine instance
+                                -> (Window, Rectangle) -- ^ Original window and its rectangle
+                                -> Window              -- ^ Decoration window
+                                -> X ()
+    decorationAfterDraggingHook _ds (w, _r) decoWin = do
+      focus w
+      hasCrossed <- handleScreenCrossing w decoWin
+      unless hasCrossed $ do
+        sendMessage DraggingStopped
+        performWindowSwitching w
+
+    -- | Draw everything required on the decoration window.
+    -- This method should draw background (flat or gradient or whatever),
+    -- borders, and call @paintWidget@ method to draw window widgets
+    -- (buttons and title).
+    paintDecoration :: Shrinker shrinker
+                    => engine widget a         -- ^ Decoration engine instance
+                    -> a                       -- ^ Decoration window
+                    -> Dimension               -- ^ Decoration window width
+                    -> Dimension               -- ^ Decoration window height
+                    -> shrinker                -- ^ Strings shrinker instance
+                    -> DrawData engine widget  -- ^ Details about what to draw
+                    -> Bool                    -- ^ True when this method is called during Expose event
+                    -> X ()
+
+    -- | Paint one widget on the decoration window.
+    paintWidget :: Shrinker shrinker
+                => engine widget a                  -- ^ Decoration engine instance
+                -> DecorationPaintingContext engine -- ^ Decoration painting context
+                -> WidgetPlace                      -- ^ Place (rectangle) where the widget should be drawn
+                -> shrinker                         -- ^ Strings shrinker instance
+                -> DrawData engine widget           -- ^ Details about window decoration
+                -> widget                           -- ^ Widget to be drawn
+                -> Bool                             -- ^ True when this method is called during Expose event
+                -> X ()
+
+handleDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()
+handleDraggingInProgress ex ey (mainw, r) x y = do
+    let rect = Rectangle (x - (fi ex - rect_x r))
+                         (y - (fi ey - rect_y r))
+                         (rect_width  r)
+                         (rect_height r)
+    sendMessage $ DraggingWindow mainw rect
+
+performWindowSwitching :: Window -> X ()
+performWindowSwitching win =
+    withDisplay $ \d -> do
+       root <- asks theRoot
+       (_, _, selWin, _, _, _, _, _) <- io $ queryPointer d root
+       ws <- gets windowset
+       let allWindows = W.index ws
+       -- do a little double check to be sure
+       when ((win `elem` allWindows) && (selWin `elem` allWindows)) $ do
+                let allWindowsSwitched = map (switchEntries win selWin) allWindows
+                let (ls, notEmpty -> t :| rs) = break (win ==) allWindowsSwitched
+                let newStack = W.Stack t (reverse ls) rs
+                windows $ W.modify' $ const newStack
+    where
+        switchEntries a b x
+            | x == a    = b
+            | x == b    = a
+            | otherwise = x
+
+ignoreX :: WidgetPlace -> WidgetPlace
+ignoreX place = place {wpRectangle = (wpRectangle place) {rect_x = 0}}
+
+alignLeft :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]
+alignLeft engine dd widgets = do
+    places <- mapM (calcWidgetPlace engine dd) widgets
+    return $ packLeft (rect_x $ ddDecoRect dd) $ map ignoreX places
+
+packLeft :: Position -> [WidgetPlace] -> [WidgetPlace]
+packLeft _ [] = []
+packLeft x0 (place : places) =
+  let rect = wpRectangle place
+      x' = x0 + rect_x rect
+      rect' = rect {rect_x = x'}
+      place' = place {wpRectangle = rect'}
+  in  place' : packLeft (x' + fi (rect_width rect)) places
+
+alignRight :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]
+alignRight engine dd widgets = do
+    places <- mapM (calcWidgetPlace engine dd) widgets
+    return $ packRight (rect_width $ ddDecoRect dd) $ map ignoreX places
+
+packRight :: Dimension -> [WidgetPlace] -> [WidgetPlace]
+packRight x0 places = reverse $ go x0 places
+  where
+    go _ [] = []
+    go x (place : rest) = 
+      let rect = wpRectangle place
+          x' = x - rect_width rect
+          rect' = rect {rect_x = fi x'}
+          place' = place {wpRectangle = rect'}
+      in  place' : go x' rest
+
+alignCenter :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]
+alignCenter engine dd widgets = do
+    places <- alignLeft engine dd widgets
+    let totalWidth = sum $ map (rect_width . wpRectangle) places
+        availableWidth = fi (rect_width (ddDecoRect dd)) :: Position
+        x0 = max 0 $ (availableWidth - fi totalWidth) `div` 2
+        places' = map (shift x0) places
+    return $ pack (fi availableWidth) places'
+  where
+    shift x0 place =
+      let rect = wpRectangle place
+          rect' = rect {rect_x = rect_x rect + fi x0}
+      in  place {wpRectangle = rect'}
+    
+    pack _ [] = []
+    pack available (place : places) =
+      let rect = wpRectangle place
+          placeWidth = rect_width rect
+          widthToUse = min available placeWidth
+          remaining = available - widthToUse
+          rect' = rect {rect_width = widthToUse}
+          place' = place {wpRectangle = rect'}
+      in  place' : pack remaining places
+
+-- | Build an instance of 'DrawData' type.
+mkDrawData :: (DecorationEngine engine widget a, ThemeAttributes (Theme engine widget), HasWidgets (Theme engine) widget)
+           => engine widget a
+           -> Theme engine widget            -- ^ Decoration theme
+           -> DecorationEngineState engine   -- ^ State of decoration engine
+           -> Window                         -- ^ Original window (to be decorated)
+           -> Rectangle                      -- ^ Decoration rectangle
+           -> X (DrawData engine widget)
+mkDrawData _ theme decoState origWindow decoRect = do
+    -- xmonad-contrib #809
+    -- qutebrowser will happily shovel a 389K multiline string into @_NET_WM_NAME@
+    -- and the 'defaultShrinker' (a) doesn't handle multiline strings well (b) is
+    -- quadratic due to using 'init'
+    name  <- fmap (take 2048 . takeWhile (/= '\n') . show) (getName origWindow)
+    style <- selectWindowStyle theme origWindow
+    return $ DrawData {
+                   ddEngineState = decoState,
+                   ddStyle = style,
+                   ddOrigWindow = origWindow,
+                   ddWindowTitle = name,
+                   ddDecoRect = decoRect,
+                   ddWidgets = themeWidgets theme,
+                   ddWidgetPlaces = WidgetLayout [] [] []
+                  }
+
+-- | Mouse focus and mouse drag are handled by the same function, this
+-- way we can start dragging unfocused windows too.
+handleMouseFocusDrag :: (DecorationEngine engine widget a, Shrinker shrinker) => engine widget a -> Theme engine widget -> DecorationLayoutState engine -> shrinker -> Event -> X ()
+handleMouseFocusDrag ds theme (DecorationLayoutState {dsDecorations}) _ (ButtonEvent {ev_window, ev_x_root, ev_y_root, ev_event_type, ev_button})
+    | ev_event_type == buttonPress
+    , Just (WindowDecoration {..}) <- findDecoDataByDecoWindow ev_window dsDecorations = do
+        let decoRect@(Rectangle dx dy _ _) = fromJust wdDecoRect
+            x = fi $ ev_x_root - fi dx
+            y = fi $ ev_y_root - fi dy
+            button = fi ev_button
+        dealtWith <- handleDecorationClick ds theme decoRect (map wpRectangle wdWidgets) wdOrigWindow x y button
+        unless dealtWith $ when (isDraggingEnabled theme button) $
+            mouseDrag (\dragX dragY -> focus wdOrigWindow >> decorationWhileDraggingHook ds ev_x_root ev_y_root (wdOrigWindow, wdOrigWinRect) dragX dragY)
+                      (decorationAfterDraggingHook ds (wdOrigWindow, wdOrigWinRect) ev_window)
+handleMouseFocusDrag _ _ _ _ _ = return ()
+
+-- | Given a window and the state, if a matching decoration is in the
+-- state return it with its ('Maybe') 'Rectangle'.
+findDecoDataByDecoWindow :: Window -> [WindowDecoration] -> Maybe WindowDecoration
+findDecoDataByDecoWindow decoWin = find (\dd -> wdDecoWindow dd == Just decoWin)
+
+decorationHandler :: forall engine widget a.
+                     (DecorationEngine engine widget a,
+                      ClickHandler (Theme engine) widget)
+                  => engine widget a
+                  -> Theme engine widget
+                  -> Rectangle
+                  -> [Rectangle]
+                  -> Window
+                  -> Int
+                  -> Int
+                  -> Int
+                  -> X Bool
+decorationHandler _ theme _ widgetPlaces window x y button = do
+    widgetDone <- go $ zip (widgetLayout $ themeWidgets theme) widgetPlaces
+    if widgetDone
+      then return True
+      else case onDecorationClick theme button of
+             Just cmd -> do
+               executeWindowCommand cmd window
+             Nothing -> return False
+  where
+    go :: [(widget, Rectangle)] -> X Bool
+    go [] = return False
+    go ((w, rect) : rest) = do
+      if pointWithin (fi x) (fi y) rect
+        then do
+          executeWindowCommand (widgetCommand w button) window
+        else go rest
+
+-- | Simple implementation of @paintDecoration@ method.
+-- This is used by @TextEngine@ and can be re-used by other decoration
+-- engines.
+paintDecorationSimple :: forall engine shrinker widget.
+                          (DecorationEngine engine widget Window,
+                           DecorationPaintingContext engine ~ XPaintingContext,
+                           Shrinker shrinker,
+                           Style (Theme engine widget) ~ SimpleStyle)
+                       => engine widget Window
+                       -> Window
+                       -> Dimension
+                       -> Dimension
+                       -> shrinker
+                       -> DrawData engine widget
+                       -> Bool
+                       -> X ()
+paintDecorationSimple deco win windowWidth windowHeight shrinker dd isExpose = do
+    dpy <- asks display
+    let widgets = widgetLayout $ ddWidgets dd
+        style = ddStyle dd
+    pixmap  <- io $ createPixmap dpy win windowWidth windowHeight (defaultDepthOfScreen $ defaultScreenOfDisplay dpy)
+    gc <- io $ createGC dpy pixmap
+    -- draw
+    io $ setGraphicsExposures dpy gc False
+    bgColor <- stringToPixel dpy (sBgColor style)
+    -- we start with the border
+    let borderWidth = sDecoBorderWidth style
+        borderColors = sDecorationBorders style
+    when (borderWidth > 0) $ do
+      drawLineWith dpy pixmap gc 0 0 windowWidth borderWidth (bxTop borderColors)
+      drawLineWith dpy pixmap gc 0 0 borderWidth windowHeight (bxLeft borderColors)
+      drawLineWith dpy pixmap gc 0 (fi (windowHeight - borderWidth)) windowWidth borderWidth (bxBottom borderColors)
+      drawLineWith dpy pixmap gc (fi (windowWidth - borderWidth)) 0 borderWidth windowHeight (bxRight borderColors)
+
+    -- and now again
+    io $ setForeground dpy gc bgColor
+    io $ fillRectangle dpy pixmap gc (fi borderWidth) (fi borderWidth) (windowWidth - (borderWidth * 2)) (windowHeight - (borderWidth * 2))
+
+    -- paint strings
+    forM_ (zip widgets $ widgetLayout $ ddWidgetPlaces dd) $ \(widget, place) ->
+        paintWidget deco (dpy, pixmap, gc) place shrinker dd widget isExpose
+
+    -- debug
+    -- black <- stringToPixel dpy "black"
+    -- io $ setForeground dpy gc black
+    -- forM_ (ddWidgetPlaces dd) $ \(WidgetPlace {wpRectangle = Rectangle x y w h}) ->
+    --   io $ drawRectangle dpy pixmap gc x y w h
+
+    -- copy the pixmap over the window
+    io $ copyArea      dpy pixmap win gc 0 0 windowWidth windowHeight 0 0
+    -- free the pixmap and GC
+    io $ freePixmap    dpy pixmap
+    io $ freeGC        dpy gc
+  where
+    drawLineWith dpy pixmap gc x y w h colorName = do
+      color <- stringToPixel dpy colorName
+      io $ setForeground dpy gc color
+      io $ fillRectangle dpy pixmap gc x y w h
+

XMonad/Layout/DecorationEx/Geometry.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.DecorationEx.Geometry
+-- Description :  Type class which is responsible for defining the placement
+--                of window decorations
+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  portnov84@rambler.ru
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- This module defines @DecorationGeometry@ type class, and default implementation for it.
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.DecorationEx.Geometry (
+    DecorationGeometry (..),
+    DefaultGeometry (..)
+  ) where
+
+import XMonad
+import XMonad.Prelude
+import qualified XMonad.StackSet as W
+import qualified XMonad.Layout.Decoration as D
+
+-- | Decoration geometry class.
+-- Decoration geometry is responsible for placement of window decorations: whether
+-- they should be on the top of the window or on the bottom, should they go for 
+-- full window width or only be of certain width, etc.
+-- This does not know what will be drawn inside decorations.
+class (Read (geom a), Show (geom a),
+       Eq a)
+    => DecorationGeometry geom a where
+
+    -- | Give a name to decoration geometry implementation.
+    describeGeometry :: geom a -> String
+
+    -- | Reduce original window size to make space for decoration, if necessary.
+    shrinkWindow :: geom a -> Rectangle -> Rectangle -> Rectangle
+    shrinkWindow _ (Rectangle _ _ _ dh) (Rectangle x y w h) = Rectangle x (y + fi dh) w (h - dh)
+
+    -- | The pure version of the main method, 'decorate'.
+    -- The method should return a rectangle where to place window decoration,
+    -- or 'Nothing' if this window is not to be decorated.
+    pureDecoration :: geom a          -- ^ Decoration geometry instance
+                   -> Rectangle       -- ^ Screen rectangle
+                   -> W.Stack a       -- ^ Current stack of windows being displayed
+                   -> [(a,Rectangle)] -- ^ Set of all windows with their corresponding rectangle
+                   -> (a,Rectangle)   -- ^ Window being decorated and its rectangle
+                   -> Maybe Rectangle
+
+    -- | The method should return a rectangle where to place window decoration,
+    -- or 'Nothing' if this window is not to be decorated.
+    decorateWindow :: geom a           -- ^ Decoration geometry instance
+                   -> Rectangle        -- ^ Screen rectangle
+                   -> W.Stack a        -- ^ Current stack of windows being displayed
+                   -> [(a, Rectangle)] -- ^ Set of all windows with their corresponding rectangle
+                   -> (a, Rectangle)   -- ^ Window being decorated and its rectangle
+                   -> X (Maybe Rectangle)
+    decorateWindow geom r s wrs wr = return $ pureDecoration geom r s wrs wr
+
+-- | Data type for default implementation of 'DecorationGeometry'.
+-- This defines simple decorations: a horizontal bar at the top of each window,
+-- running for full width of the window.
+newtype DefaultGeometry a = DefaultGeometry {
+    gDecorationHeight :: Dimension
+  }
+  deriving (Read, Show)
+
+instance Eq a => DecorationGeometry DefaultGeometry a where
+  describeGeometry _ = "Default"
+
+  pureDecoration (DefaultGeometry {..}) _ s _ (w, Rectangle x y windowWidth windowHeight) =
+      if D.isInStack s w && (gDecorationHeight < windowHeight)
+        then Just $ Rectangle x y windowWidth gDecorationHeight
+        else Nothing
+
+instance Default (DefaultGeometry a) where
+  def = DefaultGeometry 20
+

XMonad/Layout/DecorationEx/LayoutModifier.hs

@@ -0,0 +1,322 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.DecorationEx.LayoutModifier
+-- Description :  Layout modifier which adds decorations to windows.
+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  portnov84@rambler.ru
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Layout modifier, which is responsible for creation of decoration rectangles
+-- (windows), updating and removing them when needed. It is parameterized by
+-- @DecorationGeometry@, which says where decorations should be placed, and by
+-- @DecorationEngine@, which says how decorations should look.
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.DecorationEx.LayoutModifier (
+    -- * Usage
+    --
+    -- $usage
+    decorationEx,
+    DecorationEx
+  ) where
+
+import XMonad
+import XMonad.Prelude
+import qualified XMonad.StackSet as W
+import XMonad.Layout.LayoutModifier
+import XMonad.Layout.WindowArranger (diff, listFromList)
+import XMonad.Util.Invisible
+import XMonad.Util.XUtils hiding (paintTextAndIcons)
+
+import XMonad.Layout.DecorationEx.Common
+import XMonad.Layout.DecorationEx.Engine
+import XMonad.Layout.DecorationEx.Geometry
+
+-- $usage
+--
+-- This module exports @decorationEx@ function, which is a generic function for
+-- adding decorations to your layouts. It can be used to use different
+-- decoration geometries and engines in any combination.
+-- For most used combinations, there are convenience functions in
+-- "XMonad.Layout.DecorationEx.TextEngine", "XMonad.Layout.DecorationEx.TabbedGeometry",
+-- and "XMonad.Layout.DecorationEx.DwmGeometry".
+--
+-- You can use this module with the following in your
+-- @xmonad.hs@:
+--
+-- > import XMonad.Layout.DecorationEx.LayoutModifier
+-- Then edit your @layoutHook@ by adding the DwmStyle decoration to
+-- your layout:
+--
+-- > myL = decorationEx shrinkText myTheme myEngine myGeometry (layoutHook def)
+-- >         where
+-- >           myGeometry = DefaultGeometry -- or another geometry type
+-- >           myEngine = TextDecoration    -- or another decoration engine
+-- >           myTheme = GenericTheme {...} -- theme type should correspond to selected engine type
+-- >
+-- > main = xmonad def { layoutHook = myL }
+--
+-- For more detailed instructions on editing the layoutHook see:
+--
+-- "XMonad.Doc.Extending#Editing_the_layout_hook"
+
+
+-- | The 'DecorationEx' 'LayoutModifier'. This data type is an instance
+-- of the 'LayoutModifier' class. This data type will be passed,
+-- together with a layout, to the 'ModifiedLayout' type constructor
+-- to modify the layout by adding decorations according to a
+-- 'DecorationEngine'.
+data DecorationEx engine widget geom shrinker a =
+    DecorationEx (Invisible Maybe (DecorationLayoutState engine)) shrinker (Theme engine widget) (engine widget a) (geom a)
+
+deriving instance (Show (Theme engine widget), Show shrinker, Show (engine widget a), Show (geom a)) => Show (DecorationEx engine widget geom shrinker a)
+deriving instance (Read (Theme engine widget), Read shrinker, Read (engine widget a), Read (geom a)) => Read (DecorationEx engine widget geom shrinker a)
+
+-- | The long 'LayoutModifier' instance for the 'DecorationEx' type.
+--
+-- In 'redoLayout' we check the state: if there is no state we
+-- initialize it.
+--
+-- The state is @diff@ed against the list of windows produced by the
+-- underlying layout: removed windows get deleted and new ones
+-- decorated by 'createDecos', which will call 'decorate' to decide if
+-- a window must be given a 'Rectangle', in which case a decoration
+-- window will be created.
+--
+-- After that we resync the updated state with the windows' list and
+-- then we process the resynced stated (as we do with a new state).
+--
+-- First we map the decoration windows, we update each decoration to
+-- reflect any decorated window's change, and we insert, in the list
+-- of windows and rectangles returned by the underlying layout, the
+-- decoration for each window. This way xmonad will restack the
+-- decorations and their windows accordingly. At the end we remove
+-- invisible\/stacked windows.
+--
+-- Message handling is quite simple: when needed we release the state
+-- component of the 'DecorationEx' 'LayoutModifier'. Otherwise we call
+-- 'handleEvent', which will call the appropriate 'DecorationEngine'
+-- methods to perform its tasks.
+instance (DecorationEngine engine widget Window, DecorationGeometry geom Window, Shrinker shrinker) => LayoutModifier (DecorationEx engine widget geom shrinker) Window where
+    redoLayout (DecorationEx (I (Just decoState)) shrinker theme engine geom) _ Nothing _ = do
+        releaseResources engine decoState
+        return ([], Just $ DecorationEx (I Nothing) shrinker theme engine geom)
+    redoLayout _ _ Nothing _  = return ([], Nothing)
+
+    redoLayout (DecorationEx invState shrinker theme engine geom) screenRect (Just stack) srcPairs
+        | I Nothing  <- invState = initState theme engine geom shrinker screenRect stack srcPairs >>= processState
+        | I (Just s) <- invState = do
+            let decorations  = dsDecorations s
+                (d,a) = curry diff (getOrigWindows decorations) srcWindows
+                toDel = todel d decorations
+                toAdd = toadd a srcPairs
+            deleteDecos toDel
+            let decosToBeAdded = [WindowDecoration win rect Nothing Nothing [] | (win, rect) <- toAdd]
+            newDecorations <- resync (dsStyleState s) (decosToBeAdded ++ del_dwrs d decorations) srcPairs
+            processState (s {dsDecorations = newDecorations})
+
+        where
+          srcWindows = map fst srcPairs
+
+          getOrigWindows :: [WindowDecoration] -> [Window]
+          getOrigWindows = map wdOrigWindow
+
+          del_dwrs :: [Window] -> [WindowDecoration] -> [WindowDecoration]
+          del_dwrs = listFromList wdOrigWindow notElem
+
+          findDecoWindow :: Int -> [WindowDecoration] -> Maybe Window
+          findDecoWindow i d = wdDecoWindow $ d !! i
+
+          todel :: [Window] -> [WindowDecoration] -> [WindowDecoration]
+          todel d = filter (\dd -> wdOrigWindow dd `elem` d)
+
+          toadd :: [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
+          toadd a = filter (\p -> fst p `elem` a)
+
+          createDecoWindowIfNeeded :: Maybe Window -> Maybe Rectangle -> X (Maybe Window)
+          createDecoWindowIfNeeded mbDecoWindow mbDecoRect =
+            case (mbDecoWindow, mbDecoRect) of
+              (Nothing, Just decoRect) -> do
+                decoWindow <- createDecoWindow engine theme decoRect
+                return $ Just decoWindow
+              _ -> return mbDecoWindow
+
+          resync :: DecorationEngineState engine -> [WindowDecoration] -> [(Window,Rectangle)] -> X [WindowDecoration]
+          resync _ _ [] = return []
+          resync decoState dd ((window,rect):xs) =
+            case  window `elemIndex` getOrigWindows dd of
+              Just i  -> do
+                mbDecoRect <- decorateWindow geom screenRect stack srcPairs (window,rect)
+                widgetPlaces <- case mbDecoRect of
+                                  Nothing -> return $ WidgetLayout [] [] []
+                                  Just decoRect -> placeWidgets engine theme shrinker decoState decoRect window (themeWidgets theme)
+                mbDecoWindow  <- createDecoWindowIfNeeded (findDecoWindow i dd) mbDecoRect
+                let newDd = WindowDecoration window rect mbDecoWindow mbDecoRect (widgetLayout widgetPlaces)
+                restDd <- resync decoState dd xs
+                return $ newDd : restDd
+              Nothing -> resync decoState dd xs
+
+          -- We drop any windows that are *precisely* stacked underneath
+          -- another window: these must be intended to be tabbed!
+          removeTabbed :: [Rectangle] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
+          removeTabbed _ [] = []
+          removeTabbed rs ((w,r):xs)
+              | r `elem` rs = removeTabbed rs xs
+              | otherwise   = (w,r) : removeTabbed (r:rs) xs
+
+          insertDwr :: WindowDecoration -> [(Window, Rectangle)] -> [(Window, Rectangle)]
+          insertDwr dd wrs =
+            case (wdDecoWindow dd, wdDecoRect dd) of
+              (Just decoWindow, Just decoRect) -> (decoWindow, decoRect) : (wdOrigWindow dd, shrinkWindow geom decoRect (wdOrigWinRect dd)) : wrs
+              _ -> (wdOrigWindow dd, wdOrigWinRect dd) : wrs
+
+          dwrs_to_wrs :: [WindowDecoration] -> [(Window, Rectangle)]
+          dwrs_to_wrs = removeTabbed [] . foldr insertDwr []
+
+          processState :: DecorationLayoutState engine -> X ([(Window, Rectangle)], Maybe (DecorationEx engine widget geom shrinker Window))
+          processState st = do
+            let decorations = dsDecorations st
+            showDecos decorations
+            updateDecos engine shrinker theme (dsStyleState st) decorations
+            return (dwrs_to_wrs decorations, Just (DecorationEx (I (Just (st {dsDecorations = decorations}))) shrinker theme engine geom))
+
+    handleMess (DecorationEx (I (Just st)) shrinker theme engine geom) m
+        | Just Hide <- fromMessage m = do
+            hideDecos $ dsDecorations st
+            return Nothing
+--         | Just (SetTheme nt) <- fromMessage m = do
+--             releaseResources engine st
+--             let t' = themeEx nt
+--             return $ Just $ DecorationEx (I Nothing) shrinker t' engine
+        | Just ReleaseResources <- fromMessage m = do
+            releaseResources engine st
+            return $ Just $ DecorationEx (I Nothing) shrinker theme  engine geom
+        | Just e <- fromMessage m = do
+            decorationEventHookEx engine theme st shrinker e
+            handleEvent engine shrinker theme st e
+            return Nothing
+    handleMess _ _ = return Nothing
+
+    modifierDescription (DecorationEx _ _ _ engine geom) = describeEngine engine ++ describeGeometry geom
+
+-- | By default 'DecorationEx' handles 'PropertyEvent' and 'ExposeEvent'
+-- only.
+handleEvent :: (Shrinker shrinker, DecorationEngine engine widget Window) => engine widget Window -> shrinker -> Theme engine widget -> DecorationLayoutState engine -> Event -> X ()
+handleEvent engine shrinker theme (DecorationLayoutState {..}) e
+    | PropertyEvent {ev_window = w, ev_atom = atom} <- e
+    , Just i <- w `elemIndex` map wdOrigWindow dsDecorations = do
+        supportedAtoms <- propsToRepaintDecoration engine
+        when (atom `elem` supportedAtoms) $ do
+          -- io $ putStrLn $ "property event on " ++ show w -- ++ ": " ++ fromMaybe "<?>" atomName
+          updateDeco engine shrinker theme dsStyleState (dsDecorations !! i) False
+    | ExposeEvent   {ev_window = w} <- e
+    , Just i <- w `elemIndex` mapMaybe wdDecoWindow dsDecorations = do
+        -- io $ putStrLn $ "expose event on " ++ show w
+        updateDeco engine shrinker theme dsStyleState (dsDecorations !! i) True
+handleEvent _ _ _ _ _ = return ()
+
+-- | Initialize the 'DecorationState' by initializing the font
+-- structure and by creating the needed decorations.
+initState :: (DecorationEngine engine widget Window, DecorationGeometry geom Window, Shrinker shrinker)
+          => Theme engine widget
+          -> engine widget Window
+          -> geom Window
+          -> shrinker
+          -> Rectangle
+          -> W.Stack Window
+          -> [(Window,Rectangle)] -> X (DecorationLayoutState engine)
+initState theme engine geom shrinker screenRect stack wrs = do
+  styleState <- initializeState engine geom theme
+  decorations <- createDecos theme engine geom shrinker styleState screenRect stack wrs wrs
+  return $ DecorationLayoutState styleState decorations
+
+-- | Delete windows stored in the state and release the font structure.
+releaseResources :: DecorationEngine engine widget Window => engine widget Window -> DecorationLayoutState engine -> X ()
+releaseResources engine st = do
+  deleteDecos (dsDecorations st)
+  releaseStateResources engine (dsStyleState st)
+
+-- | Create the decoration windows of a list of windows and their
+-- rectangles, by calling the 'decorate' method of the
+-- 'DecorationStyle' received.
+createDecos :: (DecorationEngine engine widget Window, DecorationGeometry geom Window, Shrinker shrinker)
+            => Theme engine widget
+            -> engine widget Window
+            -> geom Window
+            -> shrinker
+            -> DecorationEngineState engine
+            -> Rectangle
+            -> W.Stack Window
+            -> [(Window,Rectangle)] -> [(Window,Rectangle)] -> X [WindowDecoration]
+createDecos theme engine geom shrinker decoState screenRect stack wrs ((w,r):xs) = do
+  mbDecoRect <- decorateWindow geom screenRect stack wrs (w,r)
+  case mbDecoRect of
+    Just decoRect -> do
+      decoWindow <- createDecoWindow engine theme decoRect
+      widgetPlaces <- placeWidgets engine theme shrinker decoState decoRect w (themeWidgets theme)
+      restDd <- createDecos theme engine geom shrinker decoState screenRect stack wrs xs
+      let newDd = WindowDecoration w r (Just decoWindow) (Just decoRect) $ widgetLayout widgetPlaces
+      return $ newDd : restDd
+    Nothing -> do
+      restDd <- createDecos theme engine geom shrinker decoState screenRect stack wrs xs
+      let newDd = WindowDecoration w r Nothing Nothing []
+      return $ newDd : restDd
+createDecos _ _ _ _ _ _ _ _ [] = return []
+
+createDecoWindow :: (DecorationEngine engine widget Window) => engine widget Window -> Theme engine widget -> Rectangle -> X Window
+createDecoWindow engine theme rect = do
+  let mask = Just $ decorationXEventMask engine
+  w <- createNewWindow rect mask (defaultBgColor theme) True
+  d <- asks display
+  io $ setClassHint d w (ClassHint "xmonad-decoration" "xmonad")
+  return w
+
+showDecos :: [WindowDecoration] -> X ()
+showDecos dd =
+  showWindows $ mapMaybe wdDecoWindow $ filter (isJust . wdDecoRect) dd
+
+hideDecos :: [WindowDecoration] -> X ()
+hideDecos = hideWindows . mapMaybe wdDecoWindow
+
+deleteDecos :: [WindowDecoration] -> X ()
+deleteDecos = deleteWindows . mapMaybe wdDecoWindow
+
+updateDecos :: (Shrinker shrinker, DecorationEngine engine widget Window)
+            => engine widget Window -> shrinker -> Theme engine widget -> DecorationEngineState engine -> [WindowDecoration] -> X ()
+updateDecos engine shrinker theme decoState = mapM_ (\wd -> updateDeco engine shrinker theme decoState wd False)
+
+-- | Update a decoration window given a shrinker, a theme, the font
+-- structure and the needed 'Rectangle's
+updateDeco :: (Shrinker shrinker, DecorationEngine engine widget Window) => engine widget Window -> shrinker -> Theme engine widget -> DecorationEngineState engine -> WindowDecoration -> Bool -> X ()
+updateDeco engine shrinker theme decoState wd isExpose =
+  case (wdDecoWindow wd, wdDecoRect wd) of
+    (Just decoWindow, Just decoRect@(Rectangle _ _ wh ht)) -> do
+      let origWin = wdOrigWindow wd
+      drawData <- mkDrawData engine theme decoState origWin decoRect
+      widgetPlaces <- placeWidgets engine theme shrinker decoState decoRect (wdOrigWindow wd) (themeWidgets theme)
+      -- io $ print widgetPlaces
+      paintDecoration engine decoWindow wh ht shrinker (drawData {ddWidgetPlaces = widgetPlaces}) isExpose
+    (Just decoWindow, Nothing) -> hideWindow decoWindow
+    _ -> return ()
+
+-- | Apply a DecorationEx modifier to an underlying layout
+decorationEx :: (DecorationEngine engine widget a, DecorationGeometry geom a, Shrinker shrinker)
+             => shrinker             -- ^ Strings shrinker, for example @shrinkText@
+             -> Theme engine widget  -- ^ Decoration theme
+             -> engine widget a      -- ^ Decoration engine instance
+             -> geom a               -- ^ Decoration geometry instance
+             -> l a                  -- ^ Underlying layout to be decorated
+             -> ModifiedLayout (DecorationEx engine widget geom shrinker) l a
+decorationEx shrinker theme engine geom = ModifiedLayout (DecorationEx (I Nothing) shrinker theme engine geom)
+

XMonad/Layout/DecorationEx/TabbedGeometry.hs

@@ -0,0 +1,169 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.DecorationEx.TabbedGeometry
+-- Description :  Tab-based window decoration geometry
+-- Copyright   :  (c) 2007 Andrea Rossato, 2023 Ilya Portnov
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  portnov84@rambler.ru
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- This module defines window decoration geometry based on tabs.
+-- The tabs can follow horizontally and be placed above or below windows;
+-- in such case, tabs can occupy full width of the window or be aligned to
+-- left or right. Or tabs can go vertically near left or right side of
+-- the window.
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.DecorationEx.TabbedGeometry (
+    textTabbed,
+    TabbedGeometry (..),
+    HorizontalTabPlacement (..),
+    VerticalTabPlacement (..),
+    HorizontalTabWidth (..),
+    HorizontalTabsAlignment (..),
+    SingleTabMode (..)
+  ) where 
+
+import XMonad
+import qualified XMonad.StackSet as W
+import XMonad.Prelude
+import XMonad.Layout.Decoration (ModifiedLayout, Shrinker (..))
+
+import XMonad.Layout.DecorationEx.LayoutModifier
+import XMonad.Layout.DecorationEx.Common
+import XMonad.Layout.DecorationEx.Geometry
+import XMonad.Layout.DecorationEx.Widgets
+import XMonad.Layout.DecorationEx.TextEngine
+
+-- | Placement of tabs when they go horizontally:
+-- should they be placed above or below the window.
+data HorizontalTabPlacement = Top | Bottom
+  deriving (Eq, Read, Show)
+
+-- | Placement of tabs when they go vertically:
+-- should they appear at left or at right side of the window.
+data VerticalTabPlacement = TabsAtLeft | TabsAtRight
+  deriving (Eq, Read, Show)
+
+-- | Width of tabs when they go horizontally.
+data HorizontalTabWidth =
+      AutoWidth             -- ^ Define the width automatically by evenly dividing windows' width
+    | FixedWidth !Dimension -- ^ Use fixed width of the tab
+  deriving (Eq, Read, Show)
+
+-- | Alignment of tabs when they go horizontally.
+data HorizontalTabsAlignment = AlignTabsLeft | AlignTabsCenter | AlignTabsRight
+  deriving (Eq, Read, Show)
+
+-- | What to do if there is only one tab.
+data SingleTabMode = ShowTab | HideTab
+  deriving (Eq, Read, Show)
+
+data TabbedGeometry a =
+      HorizontalTabs {
+          showIfSingleWindow :: !SingleTabMode      -- ^ What to do if there is only one tab
+        , hTabPlacement :: !HorizontalTabPlacement  -- ^ Where to place horizontal tabs
+        , hTabAlignment :: !HorizontalTabsAlignment -- ^ How to align horizontal tabs (makes sense with fixed width of tabs).
+        , hTabWidth :: !HorizontalTabWidth          -- ^ Width of horizontal tabs
+        , hTabHeight :: !Dimension                  -- ^ Height of horizontal tabs
+      }
+    | VerticalTabs {
+          showIfSingleWindow :: !SingleTabMode      -- ^ What to do if there is only one tab
+        , vTabPlacement :: !VerticalTabPlacement    -- ^ Where to place vertical tabs
+        , vTabWidth :: !Dimension                   -- ^ Width of vertical tabs
+        , vTabHeight :: !Dimension                  -- ^ Height of vertical tabs
+      }
+  deriving (Show, Read)
+
+instance Default (TabbedGeometry a) where
+  def = HorizontalTabs ShowTab Top AlignTabsLeft AutoWidth 20 
+
+instance DecorationGeometry TabbedGeometry Window where
+
+  describeGeometry _ = "Tabbed"
+
+  pureDecoration tabs _ stack wrs (window, windowRect) =
+    let Rectangle windowX windowY windowWidth windowHeight = windowRect
+        -- windows that are mapped onto the same rectangle as current one are considered to
+        -- be in one tabs group
+        tabbedWindows = filter (`elem` map fst (filter ((==windowRect) . snd) wrs)) (W.integrate stack)
+        mbWindowIndex = window `elemIndex` tabbedWindows
+        numWindows = length tabbedWindows
+    in  if numWindows > 1 || (showIfSingleWindow tabs == ShowTab && numWindows > 0)
+          then
+            case tabs of
+              HorizontalTabs {..} ->
+                  Just $ case hTabPlacement of
+                            Top    -> Rectangle decoX windowY effectiveTabWidth hTabHeight
+                            Bottom -> Rectangle decoX (windowY + fi (windowHeight - hTabHeight)) effectiveTabWidth hTabHeight
+                where
+                  decoX = maybe windowX tabX mbWindowIndex
+
+                  -- If there are too many windows or configured tab width
+                  -- is too big, then we have to switch to 'auto' mode.
+                  hTabWidth' =
+                    case hTabWidth of
+                      AutoWidth -> AutoWidth
+                      FixedWidth tabWidth
+                        | tabWidth * fi numWindows > windowWidth -> AutoWidth
+                        | otherwise -> FixedWidth tabWidth
+
+                  effectiveTabWidth =
+                    case hTabWidth' of
+                      AutoWidth -> fi $ maybe windowX (\i -> tabX (i+1) - tabX i) mbWindowIndex
+                      FixedWidth tabWidth -> tabWidth
+
+                  allTabsWidth =
+                    case hTabWidth' of
+                      AutoWidth -> fi windowWidth
+                      FixedWidth _ -> fi $ min windowWidth $ effectiveTabWidth * max 1 (fi numWindows)
+
+                  tabsStartX =
+                    case hTabAlignment of
+                      AlignTabsLeft -> windowX
+                      AlignTabsRight -> windowX + fi windowWidth - allTabsWidth
+                      AlignTabsCenter -> windowX + (fi windowWidth - allTabsWidth) `div` 2
+
+                  -- X coordinate of i'th window in horizontal tabs layout
+                  tabX i = tabsStartX +
+                        case hTabWidth' of
+                          AutoWidth -> fi ((windowWidth * fi i) `div` max 1 (fi numWindows))
+                          FixedWidth _ -> fi effectiveTabWidth * fi i
+
+              VerticalTabs {..} ->
+                  Just $ case vTabPlacement of
+                            TabsAtLeft  -> fixHeightTab windowX
+                            TabsAtRight -> fixHeightTab (windowX + fi (windowWidth - vTabWidth))
+                where
+                  fixHeightLoc i = windowY + fi vTabHeight * fi i
+                  fixHeightTab x = Rectangle x
+                        (maybe windowY fixHeightLoc mbWindowIndex) vTabWidth vTabHeight
+          else Nothing
+
+  shrinkWindow tabs (Rectangle _ _ dw dh) (Rectangle x y w h) =
+    case tabs of
+      HorizontalTabs {..} ->
+        case hTabPlacement of
+            Top -> Rectangle x (y + fi dh) w (h - dh)
+            Bottom -> Rectangle x y w (h - dh)
+      VerticalTabs {..} ->
+        case vTabPlacement of
+            TabsAtLeft  -> Rectangle (x + fi dw) y (w - dw) h
+            TabsAtRight -> Rectangle x y (w - dw) h
+
+-- | Add tabbed decorations (with default settings) with text-based widgets to a layout.
+textTabbed :: (Shrinker shrinker)
+           => shrinker               -- ^ Strings shrinker, e.g. @shrinkText@
+           -> ThemeEx StandardWidget -- ^ Decoration theme
+           -> l Window               -- ^ Layout to be decorated
+           -> ModifiedLayout (DecorationEx TextDecoration StandardWidget TabbedGeometry shrinker) l Window
+textTabbed shrinker theme = decorationEx shrinker theme TextDecoration def
+

XMonad/Layout/DecorationEx/TextEngine.hs

@@ -0,0 +1,116 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.DecorationEx.TextEngine
+-- Description :  Text-based window decoration engine
+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  portnov84@rambler.ru
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Window decoration engine, that uses text fragments (like @"[X]"@) to indicate
+-- widgets (window buttons).
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.DecorationEx.TextEngine (
+    textDecoration,
+    TextDecoration (..)
+  ) where 
+
+import XMonad
+import XMonad.Prelude
+import XMonad.Layout.LayoutModifier
+import XMonad.Util.Font
+
+import XMonad.Layout.DecorationEx.LayoutModifier
+import XMonad.Layout.DecorationEx.Common
+import XMonad.Layout.DecorationEx.Engine
+import XMonad.Layout.DecorationEx.Geometry
+import XMonad.Layout.DecorationEx.Widgets
+
+-- | Decoration engine data type
+data TextDecoration widget a = TextDecoration
+  deriving (Show, Read)
+
+instance (TextWidget widget, ClickHandler (GenericTheme SimpleStyle) widget)
+  => DecorationEngine TextDecoration widget Window where
+  type Theme TextDecoration = GenericTheme SimpleStyle
+  type DecorationPaintingContext TextDecoration = XPaintingContext
+  type DecorationEngineState TextDecoration = XMonadFont
+
+  describeEngine _ = "TextDecoration"
+
+  calcWidgetPlace = calcTextWidgetPlace
+
+  paintWidget = paintTextWidget
+
+  paintDecoration = paintDecorationSimple
+
+  initializeState _ _ theme = initXMF (themeFontName theme)
+  releaseStateResources _ = releaseXMF
+
+-- | Implementation of @paintWidget@ for decoration engines based on @TextDecoration@.
+paintTextWidget :: (TextWidget widget,
+                    Style (Theme engine widget) ~ SimpleStyle,
+                    DecorationPaintingContext engine ~ XPaintingContext,
+                    DecorationEngineState engine ~ XMonadFont,
+                    Shrinker shrinker,
+                    DecorationEngine engine widget Window)
+                => engine widget Window
+                -> DecorationPaintingContext engine
+                -> WidgetPlace
+                -> shrinker
+                -> DrawData engine widget
+                -> widget
+                -> Bool
+                -> X ()
+paintTextWidget engine (dpy, pixmap, gc) place shrinker dd widget _ = do
+    let style = ddStyle dd
+        rect = wpRectangle place
+        x = rect_x rect
+        y = wpTextYPosition place
+    str <- widgetString dd widget
+    str' <- if isShrinkable widget
+              then getShrinkedWindowName engine shrinker (ddEngineState dd) str (rect_width rect) (rect_height rect)
+              else return str
+    printStringXMF dpy pixmap (ddEngineState dd) gc (sTextColor style) (sTextBgColor style) x y str'
+
+-- | Implementation of @calcWidgetPlace@ for decoration engines based on @TextDecoration@.
+calcTextWidgetPlace :: (TextWidget widget,
+                        DecorationEngineState engine ~ XMonadFont,
+                        DecorationEngine engine widget Window)
+                    => engine widget Window
+                    -> DrawData engine widget
+                    -> widget
+                    -> X WidgetPlace
+calcTextWidgetPlace _ dd widget = do
+    str <- widgetString dd widget
+    let h = rect_height (ddDecoRect dd)
+        font = ddEngineState dd
+    withDisplay $ \dpy -> do
+      width <- fi <$> textWidthXMF dpy (ddEngineState dd) str
+      (a, d) <- textExtentsXMF font str
+      let height = a + d
+          y = fi $ (h - fi height) `div` 2
+          y0 = y + fi a
+          rect = Rectangle 0 y width (fi height)
+      return $ WidgetPlace y0 rect
+
+-- | Add decoration to existing layout. Widgets are indicated by text fragments, like @"[+]"@.
+-- Geometry is simple: a horizontal panel at the top of each window, going for the full width
+-- of the window.
+textDecoration :: (Shrinker shrinker)
+               => shrinker                -- ^ String shrinker, for example @shrinkText@
+               -> Theme TextDecoration StandardWidget  -- ^ Decoration theme (font, colors, widgets, etc)
+               -> l Window                -- ^ Layout to be decorated
+             -> ModifiedLayout (DecorationEx TextDecoration StandardWidget DefaultGeometry shrinker) l Window
+textDecoration shrinker theme = decorationEx shrinker theme TextDecoration def
+

XMonad/Layout/DecorationEx/Widgets.hs

@@ -0,0 +1,208 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.DecorationEx.Widgets
+-- Description :  Definitions for decoration widgets (window buttons etc)
+-- Copyright   :  2023 Ilya Portnov
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  portnov84@rambler.ru
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- This module contains data types and utilities to deal with decoration
+-- widgets. A widget is anything that is displayed on window decoration,
+-- and, optionally, can react on clicks. Examples of widgets are usual
+-- window buttons (minimize, maximize, close), window icon and window title.
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.DecorationEx.Widgets (
+    -- * Data types
+    StandardCommand (..),
+    TextWidget (..),
+    GenericWidget (..),
+    StandardWidget,
+    -- * Utility functions
+    isWidgetChecked,
+    -- * Presets for standard widgets
+    titleW, toggleStickyW, minimizeW,
+    maximizeW, closeW, dwmpromoteW,
+    moveToNextGroupW,moveToPrevGroupW
+  ) where 
+
+import XMonad
+import qualified XMonad.StackSet as W
+import XMonad.Actions.DwmPromote
+import qualified XMonad.Actions.CopyWindow as CW
+import qualified XMonad.Layout.Groups.Examples as Ex
+import XMonad.Layout.Maximize
+import XMonad.Actions.Minimize
+import XMonad.Actions.WindowMenu
+
+import XMonad.Layout.DecorationEx.Common
+import XMonad.Layout.DecorationEx.Engine
+
+-- | Standard window commands.
+--
+-- One can extend this list by simply doing
+--
+-- > data MyWindowCommand =
+-- >     Std StandardCommand
+-- >   | SomeFancyCommand
+--
+-- > instance WindowCommand MyWindowCommand where ...
+--
+-- > type MyWidget = GenericWidget MyWindowCommand
+--
+data StandardCommand =
+      FocusWindow      -- ^ Focus the window
+    | FocusUp          -- ^ Move focus to previous window
+    | FocusDown        -- ^ Move focus to following window
+    | MoveToNextGroup  -- ^ Move the window to the next group (see "XMonad.Layout.Groups")
+    | MoveToPrevGroup  -- ^ Move the window to the previous group
+    | DwmPromote       -- ^ Execute @dwmpromote@ (see "XMonad.Actions.DwmPromote")
+    | ToggleSticky     -- ^ Make window sticky or unstick it (see "XMonad.Actions.CopyWindow")
+    | ToggleMaximize   -- ^ Maximize or restore window (see "XMonad.Layout.Maximize")
+    | Minimize         -- ^ Minimize window (see "XMonad.Actions.Minimize")
+    | CloseWindow      -- ^ Close the window
+    | GridWindowMenu   -- ^ Show window menu via "XMonad.Actions.GridSelect" (see "XMonad.Actions.WindowMenu")
+  deriving (Eq, Show, Read)
+
+instance Default StandardCommand where
+  def = FocusWindow
+
+instance WindowCommand StandardCommand where
+  executeWindowCommand FocusWindow w = do
+    focus w
+    return False
+  executeWindowCommand FocusUp _ = do
+    windows W.focusUp
+    withFocused maximizeWindowAndFocus
+    return True
+  executeWindowCommand FocusDown _ = do
+    windows W.focusDown
+    withFocused maximizeWindowAndFocus
+    return True
+  executeWindowCommand MoveToNextGroup w = do
+    focus w
+    Ex.moveToGroupDown False
+    return True
+  executeWindowCommand MoveToPrevGroup w = do
+    focus w
+    Ex.moveToGroupUp False
+    return True
+  executeWindowCommand CloseWindow w = do
+    killWindow w
+    return True
+  executeWindowCommand DwmPromote w = do
+    focus w
+    dwmpromote
+    return True
+  executeWindowCommand ToggleSticky w = do
+    focus w
+    copies <- CW.wsContainingCopies
+    if null copies
+      then windows CW.copyToAll
+      else CW.killAllOtherCopies
+    return True
+  executeWindowCommand ToggleMaximize w = do
+    sendMessage $ maximizeRestore w
+    focus w
+    return True
+  executeWindowCommand Minimize w = do
+    minimizeWindow w
+    return True
+  executeWindowCommand GridWindowMenu w = do
+    focus w
+    windowMenu
+    return True
+
+  isCommandChecked FocusWindow _ = return False
+  isCommandChecked DwmPromote w = do
+      withWindowSet $ \ws -> return $ Just w == master ws
+    where
+      master ws =
+        case W.integrate' $ W.stack $ W.workspace $ W.current ws of
+          [] -> Nothing
+          (x:_) -> Just x
+  isCommandChecked ToggleSticky w = do
+    ws <- gets windowset
+    let copies = CW.copiesOfOn (Just w) (CW.taggedWindows $ W.hidden ws)
+    return $ not $ null copies
+  isCommandChecked _ _ = return False
+
+-- | Generic data type for decoration widgets.
+data GenericWidget cmd =
+      TitleWidget                      -- ^ Window title (just text label)
+    | WindowIcon { swCommand :: !cmd } -- ^ Window icon with some associated command
+    -- | Other widgets
+    | GenericWidget {
+        swCheckedText :: !String       -- ^ Text for checked widget state
+      , swUncheckedText :: !String     -- ^ Text for unchecked widget state
+      , swCommand :: !cmd              -- ^ Window command
+    }
+    deriving (Show, Read)
+
+-- | Generic widget type specialized for 'StandardCommand'
+type StandardWidget = GenericWidget StandardCommand
+
+instance (Default cmd, Read cmd, Show cmd, WindowCommand cmd) => DecorationWidget (GenericWidget cmd) where
+
+  type WidgetCommand (GenericWidget cmd) = cmd
+
+  widgetCommand TitleWidget _ = def
+  widgetCommand w 1 = swCommand w
+  widgetCommand _ _ = def
+
+  isShrinkable TitleWidget = True
+  isShrinkable _ = False
+
+-- | Check if the widget should be displayed in `checked' state.
+isWidgetChecked :: DecorationWidget widget => widget -> Window -> X Bool
+isWidgetChecked wdt = isCommandChecked (widgetCommand wdt 1)
+
+-- | Type class for widgets that can be displayed as
+-- text fragments by 'TextDecoration' engine.
+class DecorationWidget widget => TextWidget widget where
+  widgetString :: DrawData engine widget -> widget -> X String
+
+instance TextWidget StandardWidget where
+    widgetString dd TitleWidget = return $ ddWindowTitle dd
+    widgetString _ (WindowIcon {}) = return "[*]"
+    widgetString dd w = do
+      checked <- isWidgetChecked w (ddOrigWindow dd)
+      if checked
+        then return $ swCheckedText w
+        else return $ swUncheckedText w
+
+-- | Widget for window title
+titleW :: StandardWidget
+titleW = TitleWidget
+
+-- | Widget for ToggleSticky command.
+toggleStickyW :: StandardWidget
+toggleStickyW = GenericWidget "[S]" "[s]" ToggleSticky
+
+-- | Widget for Minimize command
+minimizeW :: StandardWidget
+minimizeW = GenericWidget "" "[_]" Minimize
+
+-- | Widget for ToggleMaximize command
+maximizeW :: StandardWidget
+maximizeW = GenericWidget "" "[O]" ToggleMaximize
+
+-- | Widget for CloseWindow command
+closeW :: StandardWidget
+closeW = GenericWidget "" "[X]" CloseWindow
+
+dwmpromoteW :: StandardWidget
+dwmpromoteW = GenericWidget "[M]" "[m]" DwmPromote
+
+moveToNextGroupW :: StandardWidget
+moveToNextGroupW = GenericWidget "" "[>]" MoveToNextGroup
+
+moveToPrevGroupW :: StandardWidget
+moveToPrevGroupW = GenericWidget "" "[<]" MoveToPrevGroup
+

xmonad-contrib.cabal

@@ -238,6 +238,15 @@ library
                         XMonad.Layout.ComboP
                         XMonad.Layout.Cross
                         XMonad.Layout.Decoration
+                        XMonad.Layout.DecorationEx
+                        XMonad.Layout.DecorationEx.Common
+                        XMonad.Layout.DecorationEx.Engine
+                        XMonad.Layout.DecorationEx.Geometry
+                        XMonad.Layout.DecorationEx.Widgets
+                        XMonad.Layout.DecorationEx.LayoutModifier
+                        XMonad.Layout.DecorationEx.TextEngine
+                        XMonad.Layout.DecorationEx.DwmGeometry
+                        XMonad.Layout.DecorationEx.TabbedGeometry
                         XMonad.Layout.DecorationAddons
                         XMonad.Layout.DecorationMadness
                         XMonad.Layout.Dishes