From a5fb7e021a6fda38c9539a8da7bd757ac957eeca Mon Sep 17 00:00:00 2001 From: "Ilya V. Portnov" Date: Sun, 21 Jan 2024 22:02:08 +0500 Subject: [PATCH] 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 * Fix reference to xmonad.hs See also #859 Co-authored-by: brandon s allbery kf8nh * Fix reference to xmonad.hs Co-authored-by: brandon s allbery kf8nh * Fix formatting Co-authored-by: brandon s allbery kf8nh * Fix some typos and formatting thanks to @geekosaur Co-authored-by: brandon s allbery kf8nh * 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 Co-authored-by: Tony Zorman --- CHANGES.md | 6 + XMonad/Layout/DecorationEx.hs | 106 ++++ XMonad/Layout/DecorationEx/Common.hs | 272 ++++++++++ XMonad/Layout/DecorationEx/DwmGeometry.hs | 106 ++++ XMonad/Layout/DecorationEx/Engine.hs | 511 +++++++++++++++++++ XMonad/Layout/DecorationEx/Geometry.hs | 87 ++++ XMonad/Layout/DecorationEx/LayoutModifier.hs | 322 ++++++++++++ XMonad/Layout/DecorationEx/TabbedGeometry.hs | 169 ++++++ XMonad/Layout/DecorationEx/TextEngine.hs | 116 +++++ XMonad/Layout/DecorationEx/Widgets.hs | 208 ++++++++ xmonad-contrib.cabal | 9 + 11 files changed, 1912 insertions(+) create mode 100644 XMonad/Layout/DecorationEx.hs create mode 100644 XMonad/Layout/DecorationEx/Common.hs create mode 100644 XMonad/Layout/DecorationEx/DwmGeometry.hs create mode 100644 XMonad/Layout/DecorationEx/Engine.hs create mode 100644 XMonad/Layout/DecorationEx/Geometry.hs create mode 100644 XMonad/Layout/DecorationEx/LayoutModifier.hs create mode 100644 XMonad/Layout/DecorationEx/TabbedGeometry.hs create mode 100644 XMonad/Layout/DecorationEx/TextEngine.hs create mode 100644 XMonad/Layout/DecorationEx/Widgets.hs diff --git a/CHANGES.md b/CHANGES.md index 438a6d6b..38e13a39 100644 --- a/CHANGES.md +++ b/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` diff --git a/XMonad/Layout/DecorationEx.hs b/XMonad/Layout/DecorationEx.hs new file mode 100644 index 00000000..9db42667 --- /dev/null +++ b/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. +-- +-- <> +-- Click +-- 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. + diff --git a/XMonad/Layout/DecorationEx/Common.hs b/XMonad/Layout/DecorationEx/Common.hs new file mode 100644 index 00000000..ba472c64 --- /dev/null +++ b/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 + diff --git a/XMonad/Layout/DecorationEx/DwmGeometry.hs b/XMonad/Layout/DecorationEx/DwmGeometry.hs new file mode 100644 index 00000000..eedd968f --- /dev/null +++ b/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 + diff --git a/XMonad/Layout/DecorationEx/Engine.hs b/XMonad/Layout/DecorationEx/Engine.hs new file mode 100644 index 00000000..9810d45a --- /dev/null +++ b/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 + diff --git a/XMonad/Layout/DecorationEx/Geometry.hs b/XMonad/Layout/DecorationEx/Geometry.hs new file mode 100644 index 00000000..ea057036 --- /dev/null +++ b/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 + diff --git a/XMonad/Layout/DecorationEx/LayoutModifier.hs b/XMonad/Layout/DecorationEx/LayoutModifier.hs new file mode 100644 index 00000000..b603b8ca --- /dev/null +++ b/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) + diff --git a/XMonad/Layout/DecorationEx/TabbedGeometry.hs b/XMonad/Layout/DecorationEx/TabbedGeometry.hs new file mode 100644 index 00000000..83e640d3 --- /dev/null +++ b/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 + diff --git a/XMonad/Layout/DecorationEx/TextEngine.hs b/XMonad/Layout/DecorationEx/TextEngine.hs new file mode 100644 index 00000000..a0ddd439 --- /dev/null +++ b/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 + diff --git a/XMonad/Layout/DecorationEx/Widgets.hs b/XMonad/Layout/DecorationEx/Widgets.hs new file mode 100644 index 00000000..5bd7a53c --- /dev/null +++ b/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 + diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index fca6af66..bad3ba71 100644 --- a/xmonad-contrib.cabal +++ b/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