85 lines
2.7 KiB
Haskell
85 lines
2.7 KiB
Haskell
|
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts, PatternGuards, DeriveDataTypeable #-}
|
||
|
|
|
||
|
|
module ConfigurableBorders ( configureBorders
|
||
|
|
, configBorderWidth
|
||
|
|
, resetBorderWidth
|
||
|
|
, doConfigBorderWidth
|
||
|
|
, doConfigBorderOff
|
||
|
|
) where
|
||
|
|
|
||
|
|
|
||
|
|
import qualified XMonad.Core as XM
|
||
|
|
import XMonad.Operations (sendMessage)
|
||
|
|
import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..))
|
||
|
|
import Graphics.X11.Types (Window)
|
||
|
|
import Graphics.X11.Xlib.Types (Dimension)
|
||
|
|
import Graphics.X11.Xlib.Window (setWindowBorderWidth)
|
||
|
|
|
||
|
|
import Control.Monad.Reader
|
||
|
|
|
||
|
|
import Data.Monoid
|
||
|
|
import Data.Typeable
|
||
|
|
import qualified Data.Map as M
|
||
|
|
import qualified Data.Set as S
|
||
|
|
|
||
|
|
|
||
|
|
defaultBorderWidth :: XM.X Dimension
|
||
|
|
defaultBorderWidth = asks (XM.borderWidth . XM.config)
|
||
|
|
|
||
|
|
|
||
|
|
data BorderWidth = BorderWidth Window Dimension deriving Typeable
|
||
|
|
|
||
|
|
instance XM.Message BorderWidth
|
||
|
|
|
||
|
|
|
||
|
|
configBorderWidth :: Dimension -> Window -> XM.X ()
|
||
|
|
configBorderWidth w win = sendMessage $ BorderWidth win w
|
||
|
|
|
||
|
|
resetBorderWidth :: Window -> XM.X ()
|
||
|
|
resetBorderWidth win = do
|
||
|
|
defBW <- defaultBorderWidth
|
||
|
|
configBorderWidth defBW win
|
||
|
|
|
||
|
|
doConfigBorderWidth :: Dimension -> XM.ManageHook
|
||
|
|
doConfigBorderWidth w = XM.Query $ do
|
||
|
|
win <- ask
|
||
|
|
lift $ configBorderWidth w win
|
||
|
|
return $ Endo id
|
||
|
|
|
||
|
|
doConfigBorderOff :: XM.ManageHook
|
||
|
|
doConfigBorderOff = doConfigBorderWidth 0
|
||
|
|
|
||
|
|
|
||
|
|
data ConfigureBorders a = ConfigureBorders (M.Map a Dimension) (M.Map a Dimension)
|
||
|
|
deriving (Show, Read)
|
||
|
|
|
||
|
|
configureBorders :: (XM.LayoutClass l a) =>
|
||
|
|
l a
|
||
|
|
-> ModifiedLayout ConfigureBorders l a
|
||
|
|
configureBorders = ModifiedLayout $ ConfigureBorders M.empty M.empty
|
||
|
|
|
||
|
|
|
||
|
|
instance LayoutModifier ConfigureBorders Window where
|
||
|
|
modifierDescription _ = "ConfigureBorders"
|
||
|
|
|
||
|
|
pureMess (ConfigureBorders wm wmlast) m
|
||
|
|
| Just (BorderWidth win width) <- XM.fromMessage m = do
|
||
|
|
let wmnew = M.insert win width wm
|
||
|
|
return $ ConfigureBorders wmnew wmlast
|
||
|
|
|
||
|
|
pureMess _ _ = Nothing
|
||
|
|
|
||
|
|
redoLayout (ConfigureBorders wm wmlast) _ _ wrs = do
|
||
|
|
setBorders wmlast
|
||
|
|
return (wrs, Just $ ConfigureBorders M.empty wm)
|
||
|
|
where
|
||
|
|
ws = S.fromList $ map fst wrs
|
||
|
|
|
||
|
|
|
||
|
|
setBorders :: (M.Map Window Dimension) -> XM.X ()
|
||
|
|
setBorders wm = forM_ (M.toList wm) $ \(win,width) -> setBorder win width
|
||
|
|
|
||
|
|
|
||
|
|
setBorder :: Window -> Dimension -> XM.X ()
|
||
|
|
setBorder w width = XM.withDisplay $ \dpy -> XM.io $ setWindowBorderWidth dpy w width
|