mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-08-13 03:05:57 -07:00
XMonad
Actions
Config
Doc
Hooks
Layout
Accordion.hs
Circle.hs
Combo.hs
Decoration.hs
DecorationMadness.hs
Dishes.hs
DragPane.hs
DwmStyle.hs
Grid.hs
HintedTile.hs
IM.hs
LayoutCombinators.hs
LayoutHints.hs
LayoutModifier.hs
LayoutScreens.hs
MagicFocus.hs
Magnifier.hs
Maximize.hs
Mosaic.hs
MosaicAlt.hs
MultiToggle.hs
Named.hs
NoBorders.hs
PerWorkspace.hs
Reflect.hs
ResizableTile.hs
ResizeScreen.hs
Roledex.hs
ScratchWorkspace.hs
ShowWName.hs
SimpleDecoration.hs
SimpleFloat.hs
Simplest.hs
Spiral.hs
Square.hs
TabBarDecoration.hs
Tabbed.hs
ThreeColumns.hs
ToggleLayouts.hs
TwoPane.hs
WindowArranger.hs
WindowNavigation.hs
WorkspaceDir.hs
Prompt
Util
Doc.hs
Prompt.hs
scripts
tests
LICENSE
README
Setup.lhs
xmonad-contrib.cabal
431 lines
20 KiB
Haskell
431 lines
20 KiB
Haskell
{-# OPTIONS_GHC -fglasgow-exts #-} -- for deriving Typeable
|
|
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
|
|
-----------------------------------------------------------------------------
|
|
-- |
|
|
-- Module : XMonad.Layout.Decoration
|
|
-- Copyright : (c) 2007 Andrea Rossato
|
|
-- License : BSD-style (see xmonad/LICENSE)
|
|
--
|
|
-- Maintainer : andrea.rossato@unibz.it
|
|
-- Stability : unstable
|
|
-- Portability : unportable
|
|
--
|
|
-- A layout modifier and a class for easily creating decorated
|
|
-- layouts.
|
|
-----------------------------------------------------------------------------
|
|
|
|
module XMonad.Layout.Decoration
|
|
( -- * Usage:
|
|
-- $usage
|
|
decoration
|
|
, Theme (..), defaultTheme
|
|
, Decoration
|
|
, DecorationMsg (..)
|
|
, DecorationStyle (..)
|
|
, DefaultDecoration (..)
|
|
, Shrinker (..), DefaultShrinker
|
|
, shrinkText, CustomShrink ( CustomShrink )
|
|
, isInStack, isVisible, isInvisible, isWithin, fi
|
|
, module XMonad.Layout.LayoutModifier
|
|
) where
|
|
|
|
import Control.Monad (when)
|
|
import Data.Maybe
|
|
import Data.List
|
|
|
|
import XMonad
|
|
import qualified XMonad.StackSet as W
|
|
import XMonad.Hooks.UrgencyHook
|
|
import XMonad.Layout.LayoutModifier
|
|
import XMonad.Layout.WindowArranger (WindowArrangerMsg (..), diff, listFromList)
|
|
import XMonad.Util.NamedWindows (getName)
|
|
import XMonad.Util.Invisible
|
|
import XMonad.Util.XUtils
|
|
import XMonad.Util.Font
|
|
|
|
-- $usage
|
|
-- This module is intended for layout developers, who want to decorate
|
|
-- their layouts. End users will not find here very much for them.
|
|
--
|
|
-- For examples of 'DecorationStyle' instances you can have a look at
|
|
-- "XMonad.Layout.SimpleDecoration", "XMonad.Layout.Tabbed",
|
|
-- "XMonad.Layout.DwmStyle", or "XMonad.Layout.TabBarDecoration".
|
|
|
|
-- | A layout modifier that, with a 'Shrinker', a 'Theme', a
|
|
-- 'DecorationStyle', and a layout, will decorate this layout
|
|
-- according to the decoration style provided.
|
|
--
|
|
-- For some usage examples see "XMonad.Layout.DecorationMadness".
|
|
decoration :: (DecorationStyle ds a, Shrinker s) => s -> Theme -> ds a
|
|
-> l a -> ModifiedLayout (Decoration ds s) l a
|
|
decoration s t ds = ModifiedLayout (Decoration (I Nothing) s t ds)
|
|
|
|
-- | A 'Theme' is a record of colors, font etc., to customize a
|
|
-- 'DecorationStyle'.
|
|
--
|
|
-- For a collection of 'Theme's see "XMonad.Util.Themes"
|
|
data Theme =
|
|
Theme { activeColor :: String -- ^ Color of the active window
|
|
, inactiveColor :: String -- ^ Color of the inactive window
|
|
, urgentColor :: String -- ^ Color of the urgent window
|
|
, activeBorderColor :: String -- ^ Color of the border of the active window
|
|
, inactiveBorderColor :: String -- ^ Color of the border of the inactive window
|
|
, urgentBorderColor :: String -- ^ Color of the border of the urgent window
|
|
, activeTextColor :: String -- ^ Color of the text of the active window
|
|
, inactiveTextColor :: String -- ^ Color of the text of the inactive window
|
|
, urgentTextColor :: String -- ^ Color of the text of the urgent window
|
|
, fontName :: String -- ^ Font name
|
|
, decoWidth :: Dimension -- ^ Maximum width of the decorations (if supported by the 'DecorationStyle')
|
|
, decoHeight :: Dimension -- ^ Height of the decorations
|
|
} deriving (Show, Read)
|
|
|
|
-- | The default xmonad 'Theme'.
|
|
defaultTheme :: Theme
|
|
defaultTheme =
|
|
Theme { activeColor = "#999999"
|
|
, inactiveColor = "#666666"
|
|
, urgentColor = "#FFFF00"
|
|
, activeBorderColor = "#FFFFFF"
|
|
, inactiveBorderColor = "#BBBBBB"
|
|
, urgentBorderColor = "##00FF00"
|
|
, activeTextColor = "#FFFFFF"
|
|
, inactiveTextColor = "#BFBFBF"
|
|
, urgentTextColor = "#FF0000"
|
|
, fontName = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
|
|
, decoWidth = 200
|
|
, decoHeight = 20
|
|
}
|
|
|
|
-- | A 'Decoration' layout modifier will handle 'SetTheme', a message
|
|
-- to dynamically change the decoration 'Theme'.
|
|
data DecorationMsg = SetTheme Theme deriving ( Typeable )
|
|
instance Message DecorationMsg
|
|
|
|
-- | The 'Decoration' state component, where the list of decorated
|
|
-- window's is zipped with a list of decoration. A list of decoration
|
|
-- is a list of tuples, a 'Maybe' 'Window' and a 'Maybe Rectangle'.
|
|
-- The 'Window' will be displayed only if the rectangle is of type
|
|
-- 'Just'.
|
|
data DecorationState =
|
|
DS { decos :: [(OrigWin,DecoWin)]
|
|
, font :: XMonadFont
|
|
}
|
|
type DecoWin = (Maybe Window, Maybe Rectangle)
|
|
type OrigWin = (Window,Rectangle)
|
|
|
|
-- | The 'Decoration' '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
|
|
-- 'DecorationStyle'.
|
|
data Decoration ds s a =
|
|
Decoration (Invisible Maybe DecorationState) s Theme (ds a)
|
|
deriving (Show, Read)
|
|
|
|
-- | The 'DecorationStyle' class, defines methods used in the
|
|
-- implementation of the 'Decoration' 'LayoutModifier' instance. A
|
|
-- type instance of this class is passed to the 'Decoration' type in
|
|
-- order to decorate a layout, by using these methods.
|
|
class (Read (ds a), Show (ds a), Eq a) => DecorationStyle ds a where
|
|
|
|
-- | The description that the 'Decoration' modifier will display.
|
|
describeDeco :: ds a -> String
|
|
describeDeco ds = show ds
|
|
|
|
-- | Shrink the window's rectangle when applying a decoration.
|
|
shrink :: ds a -> Rectangle -> Rectangle -> Rectangle
|
|
shrink _ (Rectangle _ _ _ dh) (Rectangle x y w h) = Rectangle x (y + fi dh) w (h - dh)
|
|
|
|
-- | The decoration event hook, where the
|
|
-- 'decorationMouseFocusHook' and 'decorationMouseDragHook' are
|
|
-- called. If you reimplement it those methods will not be
|
|
-- called.
|
|
decorationEventHook :: ds a -> DecorationState -> Event -> X ()
|
|
decorationEventHook ds s e = do decorationMouseFocusHook ds s e
|
|
decorationMouseDragHook ds s e
|
|
|
|
-- | This method is called when the user clicks the pointer over
|
|
-- the decoration.
|
|
decorationMouseFocusHook :: ds a -> DecorationState -> Event -> X ()
|
|
decorationMouseFocusHook _ s e = handleMouseFocusDrag False s e
|
|
|
|
-- | This method is called when the user starts grabbing the
|
|
-- decoration.
|
|
decorationMouseDragHook :: ds a -> DecorationState -> Event -> X ()
|
|
decorationMouseDragHook _ s e = handleMouseFocusDrag True s e
|
|
|
|
-- | The pure version of the main method, 'decorate'.
|
|
pureDecoration :: ds a -> Dimension -> Dimension -> Rectangle
|
|
-> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> Maybe Rectangle
|
|
pureDecoration _ _ ht _ s _ (w,Rectangle x y wh _) = if isInStack s w
|
|
then Just $ Rectangle x y wh ht
|
|
else Nothing
|
|
|
|
-- | Given the theme's decoration width and height, the screen
|
|
-- rectangle, the windows stack, the list of windows and
|
|
-- rectangles returned by the underlying layout and window to be
|
|
-- decorated, tupled with its rectangle, produce a 'Just'
|
|
-- 'Rectangle' or 'Nothing' if the window is not to be decorated.
|
|
decorate :: ds a -> Dimension -> Dimension -> Rectangle
|
|
-> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> X (Maybe Rectangle)
|
|
decorate ds w h r s wrs wr = return $ pureDecoration ds w h r s wrs wr
|
|
|
|
-- | The default 'DecorationStyle', with just the default methods'
|
|
-- implementations.
|
|
data DefaultDecoration a = DefaultDecoration deriving ( Read, Show )
|
|
instance Eq a => DecorationStyle DefaultDecoration a
|
|
|
|
-- | The long 'LayoutModifier' instance for the 'Decoration' 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 'Decoration' 'LayoutModifier'. Otherwise we call
|
|
-- 'handleEvent', which will call the appropriate 'DecorationStyle'
|
|
-- methods to perform its tasks.
|
|
instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration ds s) Window where
|
|
redoLayout (Decoration st sh t ds) sc stack wrs
|
|
| I Nothing <- st = initState t ds sc stack wrs >>= processState
|
|
| I (Just s) <- st = do let dwrs = decos s
|
|
(d,a) = curry diff (get_ws dwrs) ws
|
|
toDel = todel d dwrs
|
|
toAdd = toadd a wrs
|
|
deleteDecos (map snd toDel)
|
|
let ndwrs = zip toAdd $ repeat (Nothing,Nothing)
|
|
ndecos <- resync (ndwrs ++ del_dwrs d dwrs) wrs
|
|
processState (s {decos = ndecos })
|
|
| otherwise = return (wrs, Nothing)
|
|
|
|
where
|
|
ws = map fst wrs
|
|
get_w = fst . fst
|
|
get_ws = map get_w
|
|
del_dwrs = listFromList get_w notElem
|
|
find_dw i = fst . snd . flip (!!) i
|
|
todel d = filter (flip elem d . get_w)
|
|
toadd a = filter (flip elem a . fst )
|
|
|
|
check_dwr dwr = case dwr of
|
|
(Nothing, Just dr) -> do dw <- createDecoWindow t dr
|
|
return (Just dw, Just dr)
|
|
_ -> return dwr
|
|
|
|
resync _ [] = return []
|
|
resync d ((w,r):xs) = case w `elemIndex` get_ws d of
|
|
Just i -> do dr <- decorate ds (decoWidth t) (decoHeight t) sc stack wrs (w,r)
|
|
dwr <- check_dwr (find_dw i d, dr)
|
|
dwrs <- resync d xs
|
|
return $ ((w,r),dwr) : dwrs
|
|
Nothing -> resync d xs
|
|
|
|
-- We drop any windows that are *precisely* stacked underneath
|
|
-- another window: these must be intended to be tabbed!
|
|
remove_stacked rs ((w,r):xs)
|
|
| r `elem` rs = remove_stacked rs xs
|
|
| otherwise = (w,r) : remove_stacked (r:rs) xs
|
|
remove_stacked _ [] = []
|
|
|
|
insert_dwr ((w,r),(Just dw,Just dr)) xs = (dw,dr):(w, shrink ds dr r):xs
|
|
insert_dwr (x ,( _ , _ )) xs = x:xs
|
|
|
|
dwrs_to_wrs = remove_stacked [] . foldr insert_dwr []
|
|
|
|
processState s = do let ndwrs = decos s
|
|
showDecos (map snd ndwrs)
|
|
updateDecos sh t (font s) ndwrs
|
|
return (dwrs_to_wrs ndwrs, Just (Decoration (I (Just (s {decos = ndwrs}))) sh t ds))
|
|
|
|
handleMess (Decoration (I (Just s@(DS {decos = dwrs}))) sh t ds) m
|
|
| Just e <- fromMessage m :: Maybe Event = do decorationEventHook ds s e
|
|
handleEvent sh t s e
|
|
return Nothing
|
|
| Just Hide <- fromMessage m = do hideDecos (map snd dwrs)
|
|
return Nothing
|
|
| Just (SetTheme nt) <- fromMessage m = do releaseResources s
|
|
return $ Just $ Decoration (I Nothing) sh nt ds
|
|
| Just ReleaseResources <- fromMessage m = do releaseResources s
|
|
return $ Just $ Decoration (I Nothing) sh t ds
|
|
handleMess _ _ = return Nothing
|
|
|
|
emptyLayoutMod (Decoration (I (Just s)) sh t ds) _ _ = do
|
|
releaseResources s
|
|
return ([], Just $ Decoration (I Nothing) sh t ds)
|
|
emptyLayoutMod _ _ _ = return ([], Nothing)
|
|
|
|
modifierDescription (Decoration _ _ _ ds) = describeDeco ds
|
|
|
|
-- | By default 'Decoration' handles 'PropertyEvent' and 'ExposeEvent'
|
|
-- only.
|
|
handleEvent :: Shrinker s => s -> Theme -> DecorationState -> Event -> X ()
|
|
handleEvent sh t (DS dwrs fs) e
|
|
| PropertyEvent {ev_window = w} <- e
|
|
, w `elem` (map (fst . fst) dwrs) = updateDecos sh t fs dwrs
|
|
| ExposeEvent {ev_window = w} <- e
|
|
, w `elem` (catMaybes $ map (fst . snd) dwrs) = updateDecos sh t fs dwrs
|
|
handleEvent _ _ _ _ = return ()
|
|
|
|
-- | Mouse focus and mouse drag are handled by the same function, this
|
|
-- way we can start dragging unfocused windows too.
|
|
handleMouseFocusDrag :: Bool -> DecorationState -> Event -> X ()
|
|
handleMouseFocusDrag b (DS dwrs _) ButtonEvent { ev_window = ew
|
|
, ev_event_type = et
|
|
, ev_x_root = ex
|
|
, ev_y_root = ey }
|
|
| et == buttonPress
|
|
, Just ((mainw,r),_) <- lookFor ew dwrs = do
|
|
focus mainw
|
|
when b $ mouseDrag (\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 (SetGeometry rect)) (return ())
|
|
handleMouseFocusDrag _ _ _ = return ()
|
|
|
|
-- | Given a window and the state, if a matching decoration is in the
|
|
-- state return it with its ('Maybe') 'Rectangle'.
|
|
lookFor :: Window -> [(OrigWin,DecoWin)] -> Maybe (OrigWin,(Window,Maybe Rectangle))
|
|
lookFor w ((wr,(Just dw,dr)):dwrs) | w == dw = Just (wr,(dw,dr))
|
|
| otherwise = lookFor w dwrs
|
|
lookFor w ((_, (Nothing, _)):dwrs) = lookFor w dwrs
|
|
lookFor _ [] = Nothing
|
|
|
|
-- | Initialize the 'DecorationState' by initializing the font
|
|
-- structure and by creating the needed decorations.
|
|
initState :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle
|
|
-> W.Stack Window -> [(Window,Rectangle)] -> X DecorationState
|
|
initState t ds sc s wrs = do
|
|
fs <- initXMF (fontName t)
|
|
dwrs <- createDecos t ds sc s wrs wrs
|
|
return $ DS dwrs fs
|
|
|
|
-- | Delete windows stored in the state and release the font structure.
|
|
releaseResources :: DecorationState -> X ()
|
|
releaseResources s = do
|
|
deleteDecos (map snd $ decos s)
|
|
releaseXMF (font s)
|
|
|
|
-- | Create the decoration windows of a list of windows and their
|
|
-- rectangles, by calling the 'decorate' method of the
|
|
-- 'DecorationStyle' received.
|
|
createDecos :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle -> W.Stack Window
|
|
-> [(Window,Rectangle)] -> [(Window,Rectangle)] -> X [(OrigWin,DecoWin)]
|
|
createDecos t ds sc s wrs ((w,r):xs) = do
|
|
deco <- decorate ds (decoWidth t) (decoHeight t) sc s wrs (w,r)
|
|
case deco of
|
|
Just dr -> do dw <- createDecoWindow t dr
|
|
dwrs <- createDecos t ds sc s wrs xs
|
|
return $ ((w,r), (Just dw, Just dr)) : dwrs
|
|
Nothing -> do dwrs <- createDecos t ds sc s wrs xs
|
|
return $ ((w,r), (Nothing, Nothing)) : dwrs
|
|
createDecos _ _ _ _ _ [] = return []
|
|
|
|
createDecoWindow :: Theme -> Rectangle -> X Window
|
|
createDecoWindow t r = let mask = Just (exposureMask .|. buttonPressMask) in
|
|
createNewWindow r mask (inactiveColor t) True
|
|
|
|
showDecos :: [DecoWin] -> X ()
|
|
showDecos = showWindows . catMaybes . map fst
|
|
|
|
hideDecos :: [DecoWin] -> X ()
|
|
hideDecos = hideWindows . catMaybes . map fst
|
|
|
|
deleteDecos :: [DecoWin] -> X ()
|
|
deleteDecos = deleteWindows . catMaybes . map fst
|
|
|
|
updateDecos :: Shrinker s => s -> Theme -> XMonadFont -> [(OrigWin,DecoWin)] -> X ()
|
|
updateDecos s t f = mapM_ $ updateDeco s t f
|
|
|
|
-- | Update a decoration window given a shrinker, a theme, the font
|
|
-- structure and the needed 'Rectangle's
|
|
updateDeco :: Shrinker s => s -> Theme -> XMonadFont -> (OrigWin,DecoWin) -> X ()
|
|
updateDeco sh t fs ((w,_),(Just dw,Just (Rectangle _ _ wh ht))) = do
|
|
nw <- getName w
|
|
ur <- readUrgents
|
|
dpy <- asks display
|
|
let focusColor win ic ac uc = (maybe ic (\focusw -> case () of
|
|
_ | focusw == win -> ac
|
|
| win `elem` ur -> uc
|
|
| otherwise -> ic) . W.peek)
|
|
`fmap` gets windowset
|
|
(bc,borderc,tc) <- focusColor w (inactiveColor t, inactiveBorderColor t, inactiveTextColor t)
|
|
(activeColor t, activeBorderColor t, activeTextColor t)
|
|
(urgentColor t, urgentBorderColor t, urgentTextColor t)
|
|
let s = shrinkIt sh
|
|
name <- shrinkWhile s (\n -> do size <- io $ textWidthXMF dpy fs n
|
|
return $ size > fromIntegral wh - fromIntegral (ht `div` 2)) (show nw)
|
|
paintAndWrite dw fs wh ht 1 bc borderc tc bc AlignCenter name
|
|
updateDeco _ _ _ (_,(Just w,Nothing)) = hideWindow w
|
|
updateDeco _ _ _ _ = return ()
|
|
|
|
-- | True if the window is in the 'Stack'. The 'Window' comes second
|
|
-- to facilitate list processing, even though @w \`isInStack\` s@ won't
|
|
-- work...;)
|
|
isInStack :: Eq a => W.Stack a -> a -> Bool
|
|
isInStack s = flip elem (W.integrate s)
|
|
|
|
-- | Given a 'Rectangle' and a list of 'Rectangle's is True if the
|
|
-- 'Rectangle' is not completely contained by any 'Rectangle' of the
|
|
-- list.
|
|
isVisible :: Rectangle -> [Rectangle] -> Bool
|
|
isVisible r = and . foldr f []
|
|
where f x xs = if r `isWithin` x then False : xs else True : xs
|
|
|
|
-- | The contrary of 'isVisible'.
|
|
isInvisible :: Rectangle -> [Rectangle] -> Bool
|
|
isInvisible r = not . isVisible r
|
|
|
|
-- | True is the first 'Rectangle' is totally within the second
|
|
-- 'Rectangle'.
|
|
isWithin :: Rectangle -> Rectangle -> Bool
|
|
isWithin (Rectangle x y w h) (Rectangle rx ry rw rh)
|
|
| x >= rx, x <= rx + fi rw
|
|
, y >= ry, y <= ry + fi rh
|
|
, x + fi w <= rx + fi rw
|
|
, y + fi h <= ry + fi rh = True
|
|
| otherwise = False
|
|
|
|
shrinkWhile :: (String -> [String]) -> (String -> X Bool) -> String -> X String
|
|
shrinkWhile sh p x = sw $ sh x
|
|
where sw [n] = return n
|
|
sw [] = return ""
|
|
sw (n:ns) = do
|
|
cond <- p n
|
|
if cond
|
|
then sw ns
|
|
else return n
|
|
|
|
data CustomShrink = CustomShrink
|
|
instance Show CustomShrink where show _ = ""
|
|
instance Read CustomShrink where readsPrec _ s = [(CustomShrink,s)]
|
|
|
|
class (Read s, Show s) => Shrinker s where
|
|
shrinkIt :: s -> String -> [String]
|
|
|
|
data DefaultShrinker = DefaultShrinker
|
|
instance Show DefaultShrinker where show _ = ""
|
|
instance Read DefaultShrinker where readsPrec _ s = [(DefaultShrinker,s)]
|
|
instance Shrinker DefaultShrinker where
|
|
shrinkIt _ "" = [""]
|
|
shrinkIt s cs = cs : shrinkIt s (init cs)
|
|
|
|
shrinkText :: DefaultShrinker
|
|
shrinkText = DefaultShrinker
|