mirror of
https://github.com/elkowar/dots-of-war.git
synced 2024-12-26 14:12:23 +00:00
88 lines
2.9 KiB
Haskell
88 lines
2.9 KiB
Haskell
|
{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, ScopedTypeVariables #-}
|
||
|
|
module FancyBorders
|
||
|
|
( FancyBordersTheme(..)
|
||
|
|
, FancyBorders
|
||
|
|
, fancyBorders
|
||
|
|
, defaultFancyBorders
|
||
|
|
, defaultFancyTheme
|
||
|
|
)
|
||
|
|
where
|
||
|
|
|
||
|
|
import XMonad
|
||
|
|
import XMonad.Layout.LayoutModifier
|
||
|
|
|
||
|
|
defaultFancyTheme :: FancyBordersTheme
|
||
|
|
defaultFancyTheme = FancyBordersTheme "#303030" 1
|
||
|
|
|
||
|
|
data FancyBordersTheme = FancyBordersTheme {
|
||
|
|
outerColor :: String,
|
||
|
|
intBorderWidth:: Integer
|
||
|
|
} deriving (Show, Read)
|
||
|
|
|
||
|
|
newtype FancyBorders a = FancyBorders FancyBordersTheme
|
||
|
|
deriving (Show, Read)
|
||
|
|
|
||
|
|
instance LayoutModifier FancyBorders Window where
|
||
|
|
handleMess (FancyBorders cfg) m
|
||
|
|
| Just (_ :: Event) <- fromMessage m = withFocused (drawFocusedWindow cfg)
|
||
|
|
>> return Nothing
|
||
|
|
| otherwise = return Nothing
|
||
|
|
|
||
|
|
redoLayout (FancyBorders cfg) _ _ wrs = do
|
||
|
|
mapM_ (flip (drawFancyBorder cfg) False) wrs
|
||
|
|
return (wrs, Nothing)
|
||
|
|
|
||
|
|
defaultFancyBorders :: l a -> ModifiedLayout FancyBorders l a
|
||
|
|
defaultFancyBorders = ModifiedLayout (FancyBorders defaultFancyTheme)
|
||
|
|
|
||
|
|
fancyBorders :: FancyBordersTheme -> l a -> ModifiedLayout FancyBorders l a
|
||
|
|
fancyBorders t = ModifiedLayout (FancyBorders t)
|
||
|
|
|
||
|
|
drawFocusedWindow :: FancyBordersTheme -> Window -> X ()
|
||
|
|
drawFocusedWindow cfg win = do
|
||
|
|
dpy <- asks display
|
||
|
|
bw <- asks (borderWidth . config)
|
||
|
|
(_, x, y, w, h, _, _) <- io $ getGeometry dpy win
|
||
|
|
drawFancyBorder cfg (win, Rectangle x y (w + 2 * bw) (h + 2 * bw)) True
|
||
|
|
|
||
|
|
drawFancyBorder :: FancyBordersTheme -> (Window, Rectangle) -> Bool -> X ()
|
||
|
|
drawFancyBorder cfg (win, rect) active = do
|
||
|
|
bw <- asks (borderWidth . config)
|
||
|
|
dpy <- asks display
|
||
|
|
nbc <- asks normalBorder
|
||
|
|
fbc <- asks focusedBorder
|
||
|
|
let w = rect_width rect - 2 * bw
|
||
|
|
h = rect_height rect - 2 * bw
|
||
|
|
fw = rect_width rect
|
||
|
|
fh = rect_height rect
|
||
|
|
ibw' = fromIntegral $ intBorderWidth cfg
|
||
|
|
ibw = if ibw' >= bw then 1 else ibw'
|
||
|
|
rects =
|
||
|
|
[ Rectangle (fromIntegral w) 0 ibw (h + ibw)
|
||
|
|
, Rectangle (fromIntegral fw - fromIntegral ibw) 0 ibw (h + ibw)
|
||
|
|
, Rectangle 0 (fromIntegral h) (w + ibw) ibw
|
||
|
|
, Rectangle 0 (fromIntegral fh - fromIntegral ibw) (w + ibw) ibw
|
||
|
|
, Rectangle (fromIntegral fw - fromIntegral ibw)
|
||
|
|
(fromIntegral fh - fromIntegral ibw)
|
||
|
|
ibw
|
||
|
|
ibw
|
||
|
|
]
|
||
|
|
|
||
|
|
io $ do
|
||
|
|
pix <- createPixmap dpy win fw fh 24
|
||
|
|
gc <- createGC dpy win
|
||
|
|
(Just outerPixel) <- io $ initColor dpy $ outerColor cfg
|
||
|
|
|
||
|
|
-- outer border
|
||
|
|
setForeground dpy gc outerPixel
|
||
|
|
fillRectangle dpy pix gc 0 0 fw fh
|
||
|
|
|
||
|
|
-- inner border
|
||
|
|
setForeground dpy gc $ if active then fbc else nbc
|
||
|
|
io $ fillRectangles dpy pix gc rects
|
||
|
|
|
||
|
|
setWindowBorderPixmap dpy win pix
|
||
|
|
freeGC dpy gc
|
||
|
|
freePixmap dpy pix
|
||
|
|
|