mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-07-31 04:01:51 -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
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)
|
||||
|
||||
Reference in New Issue
Block a user