{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}
module XMonad.Util.XUtils
(
withSimpleWindow
, showSimpleWindow
, WindowConfig(..)
, WindowRect(..)
, averagePixels
, createNewWindow
, showWindow
, showWindows
, hideWindow
, hideWindows
, deleteWindow
, deleteWindows
, paintWindow
, paintAndWrite
, paintTextAndIcons
, stringToPixel
, pixelToString
, fi
) where
import XMonad.Prelude
import XMonad
import XMonad.Util.Font
import XMonad.Util.Image
import qualified XMonad.StackSet as W
import Data.Bits ((.&.))
averagePixels :: Pixel -> Pixel -> Double -> X Pixel
averagePixels :: Atom -> Atom -> Double -> X Atom
averagePixels Atom
p1' Atom
p2' Double
f =
do d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
let cm = Display -> Dimension -> Atom
defaultColormap Display
d (Display -> Dimension
defaultScreen Display
d)
mask a
p = a
p a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x00FFFFFF
p1 = Atom -> Atom
forall {a}. (Bits a, Num a) => a -> a
mask Atom
p1'
p2 = Atom -> Atom
forall {a}. (Bits a, Num a) => a -> a
mask Atom
p2'
[Color _ r1 g1 b1 _,Color _ r2 g2 b2 _] <- io $ queryColors d cm [Color p1 0 0 0 0,Color p2 0 0 0 0]
let mn a
x1 a
x2 = Double -> b
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
f Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
f))
Color p _ _ _ _ <- io $ allocColor d cm (Color 0 (mn r1 r2) (mn g1 g2) (mn b1 b2) 0)
return p
createNewWindow :: Rectangle -> Maybe EventMask -> String -> Bool -> X Window
createNewWindow :: Rectangle -> Maybe Atom -> String -> Bool -> X Atom
createNewWindow (Rectangle Position
x Position
y Dimension
w Dimension
h) Maybe Atom
m String
col Bool
o = do
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
rw <- asks theRoot
c <- stringToPixel d col
win <- io $ mkWindow d (defaultScreenOfDisplay d) rw x y w h c o
case m of
Just Atom
em -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Atom -> Atom -> IO ()
selectInput Display
d Atom
win Atom
em
Maybe Atom
Nothing -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Atom -> Atom -> IO ()
selectInput Display
d Atom
win Atom
exposureMask
whenX (return $ isJust m) $ flip catchX (return ()) $ do
wINDOW_TYPE <- getAtom "_NET_WM_WINDOW_TYPE"
dESKTOP <- getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"
io $ changeProperty32 d win wINDOW_TYPE aTOM propModeReplace [fi dESKTOP]
return win
showWindow :: Window -> X ()
showWindow :: Atom -> X ()
showWindow Atom
w = do
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
io $ mapWindow d w
showWindows :: [Window] -> X ()
showWindows :: [Atom] -> X ()
showWindows = (Atom -> X ()) -> [Atom] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Atom -> X ()
showWindow
hideWindow :: Window -> X ()
hideWindow :: Atom -> X ()
hideWindow Atom
w = do
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
io $ unmapWindow d w
hideWindows :: [Window] -> X ()
hideWindows :: [Atom] -> X ()
hideWindows = (Atom -> X ()) -> [Atom] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Atom -> X ()
hideWindow
deleteWindow :: Window -> X ()
deleteWindow :: Atom -> X ()
deleteWindow Atom
w = do
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
io $ destroyWindow d w
deleteWindows :: [Window] -> X ()
deleteWindows :: [Atom] -> X ()
deleteWindows = (Atom -> X ()) -> [Atom] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Atom -> X ()
deleteWindow
paintWindow :: Window
-> Dimension
-> Dimension
-> Dimension
-> String
-> String
-> X ()
paintWindow :: Atom
-> Dimension -> Dimension -> Dimension -> String -> String -> X ()
paintWindow Atom
w Dimension
wh Dimension
ht Dimension
bw String
c String
bc =
Atom
-> Rectangle
-> Dimension
-> String
-> String
-> Maybe
(XMonadFont, String, String, [(String, (Position, Position))])
-> Maybe (String, String, [((Position, Position), [[Bool]])])
-> X ()
paintWindow' Atom
w (Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
0 Position
0 Dimension
wh Dimension
ht) Dimension
bw String
c String
bc Maybe
(XMonadFont, String, String, [(String, (Position, Position))])
forall a. Maybe a
Nothing Maybe (String, String, [((Position, Position), [[Bool]])])
forall a. Maybe a
Nothing
paintAndWrite :: Window
-> XMonadFont
-> Dimension
-> Dimension
-> Dimension
-> String
-> String
-> String
-> String
-> [Align]
-> [String]
-> X ()
paintAndWrite :: Atom
-> XMonadFont
-> Dimension
-> Dimension
-> Dimension
-> String
-> String
-> String
-> String
-> [Align]
-> [String]
-> X ()
paintAndWrite Atom
w XMonadFont
fs Dimension
wh Dimension
ht Dimension
bw String
bc String
borc String
ffc String
fbc [Align]
als [String]
strs = do
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
strPositions <- forM (zip als strs) $
uncurry (stringPosition d fs (Rectangle 0 0 wh ht))
let ms = (XMonadFont, String, String, [(String, (Position, Position))])
-> Maybe
(XMonadFont, String, String, [(String, (Position, Position))])
forall a. a -> Maybe a
Just (XMonadFont
fs,String
ffc,String
fbc, [String]
-> [(Position, Position)] -> [(String, (Position, Position))]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
strs [(Position, Position)]
strPositions)
paintWindow' w (Rectangle 0 0 wh ht) bw bc borc ms Nothing
paintTextAndIcons :: Window
-> XMonadFont
-> Dimension
-> Dimension
-> Dimension
-> String
-> String
-> String
-> String
-> [Align]
-> [String]
-> [Placement]
-> [[[Bool]]]
-> X ()
paintTextAndIcons :: Atom
-> XMonadFont
-> Dimension
-> Dimension
-> Dimension
-> String
-> String
-> String
-> String
-> [Align]
-> [String]
-> [Placement]
-> [[[Bool]]]
-> X ()
paintTextAndIcons Atom
w XMonadFont
fs Dimension
wh Dimension
ht Dimension
bw String
bc String
borc String
ffc String
fbc [Align]
als [String]
strs [Placement]
i_als [[[Bool]]]
icons = do
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
strPositions <- forM (zip als strs) $ uncurry (stringPosition d fs (Rectangle 0 0 wh ht))
let iconPositions = (Placement -> [[Bool]] -> (Position, Position))
-> [Placement] -> [[[Bool]]] -> [(Position, Position)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Rectangle -> Placement -> [[Bool]] -> (Position, Position)
iconPosition (Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
0 Position
0 Dimension
wh Dimension
ht)) [Placement]
i_als [[[Bool]]]
icons
ms = (XMonadFont, String, String, [(String, (Position, Position))])
-> Maybe
(XMonadFont, String, String, [(String, (Position, Position))])
forall a. a -> Maybe a
Just (XMonadFont
fs,String
ffc,String
fbc, [String]
-> [(Position, Position)] -> [(String, (Position, Position))]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
strs [(Position, Position)]
strPositions)
is = (String, String, [((Position, Position), [[Bool]])])
-> Maybe (String, String, [((Position, Position), [[Bool]])])
forall a. a -> Maybe a
Just (String
ffc, String
fbc, [(Position, Position)]
-> [[[Bool]]] -> [((Position, Position), [[Bool]])]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Position, Position)]
iconPositions [[[Bool]]]
icons)
paintWindow' w (Rectangle 0 0 wh ht) bw bc borc ms is
data WindowConfig = WindowConfig
{ WindowConfig -> String
winFont :: !String
, WindowConfig -> String
winBg :: !String
, WindowConfig -> String
winFg :: !String
, WindowConfig -> WindowRect
winRect :: !WindowRect
}
instance Default WindowConfig where
def :: WindowConfig
def = WindowConfig
{
#ifdef XFT
winFont :: String
winFont = String
"xft:monospace-20"
#else
winFont = "-misc-fixed-*-*-*-*-20-*-*-*-*-*-*-*"
#endif
, winBg :: String
winBg = String
"black"
, winFg :: String
winFg = String
"white"
, winRect :: WindowRect
winRect = WindowRect
CenterWindow
}
data WindowRect
= CenterWindow
| CustomRect Rectangle
showSimpleWindow :: WindowConfig
-> [String]
-> X Window
showSimpleWindow :: WindowConfig -> [String] -> X Atom
showSimpleWindow WindowConfig{String
WindowRect
winFont :: WindowConfig -> String
winBg :: WindowConfig -> String
winFg :: WindowConfig -> String
winRect :: WindowConfig -> WindowRect
winFont :: String
winBg :: String
winFg :: String
winRect :: WindowRect
..} [String]
strs = do
let pad :: Position
pad = Position
20
font <- String -> X XMonadFont
initXMF String
winFont
dpy <- asks display
Rectangle sx sy sw sh <- getRectangle winRect
extends <- maximum . map (uncurry (+)) <$> traverse (textExtentsXMF font) strs
height <- pure . fi $ (1 + length strs) * fi extends
width <- (+ pad) . fi . maximum <$> traverse (textWidthXMF dpy font) strs
let
x = Position
sx Position -> Position -> Position
forall a. Num a => a -> a -> a
+ (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
sw Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
width Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
2) Position -> Position -> Position
forall a. Integral a => a -> a -> a
`div` Position
2
y = Position
sy Position -> Position -> Position
forall a. Num a => a -> a -> a
+ (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
sh Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
height Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
2) Position -> Position -> Position
forall a. Integral a => a -> a -> a
`div` Position
2
yFirst = (Position
height Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
2 Position -> Position -> Position
forall a. Num a => a -> a -> a
* Position
extends) Position -> Position -> Position
forall a. Integral a => a -> a -> a
`div` Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
strs)
strPositions = (Position -> (Position, Position))
-> [Position] -> [(Position, Position)]
forall a b. (a -> b) -> [a] -> [b]
map (Position
pad Position -> Position -> Position
forall a. Integral a => a -> a -> a
`div` Position
2, ) [Position
yFirst, Position
yFirst Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
extends ..]
w <- createNewWindow (Rectangle x y (fi width) (fi height)) Nothing "" True
let ms = (XMonadFont, String, String, [(String, (Position, Position))])
-> Maybe
(XMonadFont, String, String, [(String, (Position, Position))])
forall a. a -> Maybe a
Just (XMonadFont
font, String
winFg, String
winBg, [String]
-> [(Position, Position)] -> [(String, (Position, Position))]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
strs [(Position, Position)]
strPositions)
showWindow w
paintWindow' w (Rectangle 0 0 (fi width) (fi height)) 0 winBg "" ms Nothing
releaseXMF font
pure w
where
getRectangle :: WindowRect -> X Rectangle
getRectangle :: WindowRect -> X Rectangle
getRectangle = \case
WindowRect
CenterWindow -> (XState -> Rectangle) -> X Rectangle
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> Rectangle) -> X Rectangle)
-> (XState -> Rectangle) -> X Rectangle
forall a b. (a -> b) -> a -> b
$ ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle)
-> (XState -> ScreenDetail) -> XState -> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Atom) Atom ScreenId ScreenDetail
-> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail (Screen String (Layout Atom) Atom ScreenId ScreenDetail
-> ScreenDetail)
-> (XState
-> Screen String (Layout Atom) Atom ScreenId ScreenDetail)
-> XState
-> ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet String (Layout Atom) Atom ScreenId ScreenDetail
-> Screen String (Layout Atom) Atom ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (StackSet String (Layout Atom) Atom ScreenId ScreenDetail
-> Screen String (Layout Atom) Atom ScreenId ScreenDetail)
-> (XState
-> StackSet String (Layout Atom) Atom ScreenId ScreenDetail)
-> XState
-> Screen String (Layout Atom) Atom ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> StackSet String (Layout Atom) Atom ScreenId ScreenDetail
windowset
CustomRect Rectangle
r -> Rectangle -> X Rectangle
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rectangle
r
withSimpleWindow :: WindowConfig -> [String] -> X a -> X a
withSimpleWindow :: forall a. WindowConfig -> [String] -> X a -> X a
withSimpleWindow WindowConfig
wc [String]
strs X a
doStuff = do
w <- WindowConfig -> [String] -> X Atom
showSimpleWindow WindowConfig
wc [String]
strs
doStuff <* withDisplay (io . (`destroyWindow` w))
paintWindow' :: Window -> Rectangle -> Dimension -> String -> String
-> Maybe (XMonadFont,String,String,[(String, (Position, Position))])
-> Maybe (String, String, [((Position, Position), [[Bool]])]) -> X ()
paintWindow' :: Atom
-> Rectangle
-> Dimension
-> String
-> String
-> Maybe
(XMonadFont, String, String, [(String, (Position, Position))])
-> Maybe (String, String, [((Position, Position), [[Bool]])])
-> X ()
paintWindow' Atom
win (Rectangle Position
_ Position
_ Dimension
wh Dimension
ht) Dimension
bw String
color String
b_color Maybe
(XMonadFont, String, String, [(String, (Position, Position))])
strStuff Maybe (String, String, [((Position, Position), [[Bool]])])
iconStuff = do
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
p <- io $ createPixmap d win wh ht (defaultDepthOfScreen $ defaultScreenOfDisplay d)
gc <- io $ createGC d p
io $ setGraphicsExposures d gc False
[color',b_color'] <- mapM (stringToPixel d) [color,b_color]
io $ setForeground d gc b_color'
io $ fillRectangle d p gc 0 0 wh ht
io $ setForeground d gc color'
io $ fillRectangle d p gc (fi bw) (fi bw) (wh - (bw * 2)) (ht - (bw * 2))
when (isJust strStuff) $ do
let (xmf,fc,bc,strAndPos) = fromJust strStuff
forM_ strAndPos $ \(String
s, (Position
x, Position
y)) ->
Display
-> Atom
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> X ()
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display
-> Atom
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> m ()
printStringXMF Display
d Atom
p XMonadFont
xmf GC
gc String
fc String
bc Position
x Position
y String
s
when (isJust iconStuff) $ do
let (fc, bc, iconAndPos) = fromJust iconStuff
forM_ iconAndPos $ \((Position
x, Position
y), [[Bool]]
icon) ->
Display
-> Atom
-> GC
-> String
-> String
-> Position
-> Position
-> [[Bool]]
-> X ()
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display
-> Atom
-> GC
-> String
-> String
-> Position
-> Position
-> [[Bool]]
-> m ()
drawIcon Display
d Atom
p GC
gc String
fc String
bc Position
x Position
y [[Bool]]
icon
io $ copyArea d p win gc 0 0 wh ht 0 0
io $ freePixmap d p
io $ freeGC d gc
mkWindow :: Display -> Screen -> Window -> Position
-> Position -> Dimension -> Dimension -> Pixel -> Bool -> IO Window
mkWindow :: Display
-> Screen
-> Atom
-> Position
-> Position
-> Dimension
-> Dimension
-> Atom
-> Bool
-> IO Atom
mkWindow Display
d Screen
s Atom
rw Position
x Position
y Dimension
w Dimension
h Atom
p Bool
o = do
let visual :: Visual
visual = Screen -> Visual
defaultVisualOfScreen Screen
s
attrmask :: Atom
attrmask = Atom
cWOverrideRedirect Atom -> Atom -> Atom
forall a. Bits a => a -> a -> a
.|. Atom
cWBackPixel Atom -> Atom -> Atom
forall a. Bits a => a -> a -> a
.|. Atom
cWBorderPixel
(Ptr SetWindowAttributes -> IO Atom) -> IO Atom
forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO Atom) -> IO Atom)
-> (Ptr SetWindowAttributes -> IO Atom) -> IO Atom
forall a b. (a -> b) -> a -> b
$
\Ptr SetWindowAttributes
attributes -> do
Ptr SetWindowAttributes -> Bool -> IO ()
set_override_redirect Ptr SetWindowAttributes
attributes Bool
o
Ptr SetWindowAttributes -> Atom -> IO ()
set_border_pixel Ptr SetWindowAttributes
attributes Atom
p
Ptr SetWindowAttributes -> Atom -> IO ()
set_background_pixel Ptr SetWindowAttributes
attributes Atom
p
Display
-> Atom
-> Position
-> Position
-> Dimension
-> Dimension
-> CInt
-> CInt
-> CInt
-> Visual
-> Atom
-> Ptr SetWindowAttributes
-> IO Atom
createWindow Display
d Atom
rw Position
x Position
y Dimension
w Dimension
h CInt
0 (Screen -> CInt
defaultDepthOfScreen Screen
s)
CInt
inputOutput Visual
visual Atom
attrmask Ptr SetWindowAttributes
attributes