mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-05-19 03:20:21 -07:00
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>
This commit is contained in:
Ilya V. Portnov
GitHub
parent
09e37131ca
commit
a5fb7e021a
@ -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`
|
||||
|
||||
106
XMonad/Layout/DecorationEx.hs
Normal file
106
XMonad/Layout/DecorationEx.hs
Normal file
@ -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.
|
||||
|
||||
272
XMonad/Layout/DecorationEx/Common.hs
Normal file
272
XMonad/Layout/DecorationEx/Common.hs
Normal file
@ -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
|
||||
|
||||
106
XMonad/Layout/DecorationEx/DwmGeometry.hs
Normal file
106
XMonad/Layout/DecorationEx/DwmGeometry.hs
Normal file
@ -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
|
||||
|
||||
511
XMonad/Layout/DecorationEx/Engine.hs
Normal file
511
XMonad/Layout/DecorationEx/Engine.hs
Normal file
@ -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
|
||||
|
||||
87
XMonad/Layout/DecorationEx/Geometry.hs
Normal file
87
XMonad/Layout/DecorationEx/Geometry.hs
Normal file
@ -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
|
||||
|
||||
322
XMonad/Layout/DecorationEx/LayoutModifier.hs
Normal file
322
XMonad/Layout/DecorationEx/LayoutModifier.hs
Normal file
@ -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)
|
||||
|
||||
169
XMonad/Layout/DecorationEx/TabbedGeometry.hs
Normal file
169
XMonad/Layout/DecorationEx/TabbedGeometry.hs
Normal file
@ -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
|
||||
|
||||
116
XMonad/Layout/DecorationEx/TextEngine.hs
Normal file
116
XMonad/Layout/DecorationEx/TextEngine.hs
Normal file
@ -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
|
||||
|
||||
208
XMonad/Layout/DecorationEx/Widgets.hs
Normal file
208
XMonad/Layout/DecorationEx/Widgets.hs
Normal file
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user