{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DefaultSignatures #-}
module XMonad.Layout.DecorationEx.Engine (
DecorationEngine (..),
DrawData (..),
DecorationLayoutState (..),
Shrinker (..), shrinkText,
mkDrawData,
paintDecorationSimple
) where
import Control.Monad
import Data.Kind
import Foreign.C.Types (CInt)
import XMonad
import XMonad.Prelude
import qualified XMonad.StackSet as W
import XMonad.Layout.Decoration (Shrinker (..), shrinkWhile, shrinkText)
import XMonad.Layout.DraggingVisualizer (DraggingVisualizerMsg (..))
import XMonad.Layout.DecorationAddons (handleScreenCrossing)
import XMonad.Util.Font
import XMonad.Util.NamedWindows (getName)
import XMonad.Layout.DecorationEx.Common
data DrawData engine widget = DrawData {
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> DecorationEngineState engine
ddEngineState :: !(DecorationEngineState engine)
, forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Style (Theme engine widget)
ddStyle :: !(Style (Theme engine widget))
, forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Window
ddOrigWindow :: !Window
, forall (engine :: * -> * -> *) widget.
DrawData engine widget -> String
ddWindowTitle :: !String
, forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect :: !Rectangle
, forall (engine :: * -> * -> *) widget.
DrawData engine widget -> WidgetLayout widget
ddWidgets :: !(WidgetLayout widget)
, forall (engine :: * -> * -> *) widget.
DrawData engine widget -> WidgetLayout WidgetPlace
ddWidgetPlaces :: !(WidgetLayout WidgetPlace)
}
data DecorationLayoutState engine = DecorationLayoutState {
forall (engine :: * -> * -> *).
DecorationLayoutState engine -> DecorationEngineState engine
dsStyleState :: !(DecorationEngineState engine)
, forall (engine :: * -> * -> *).
DecorationLayoutState engine -> [WindowDecoration]
dsDecorations :: ![WindowDecoration]
}
class (Read (engine widget a), Show (engine widget a),
Eq a,
DecorationWidget widget,
HasWidgets (Theme engine) widget,
ClickHandler (Theme engine) widget,
ThemeAttributes (Theme engine widget))
=> DecorationEngine engine widget a where
type Theme engine :: Type -> Type
type DecorationPaintingContext engine
type DecorationEngineState engine
describeEngine :: engine widget a -> String
initializeState :: engine widget a
-> geom a
-> Theme engine widget
-> X (DecorationEngineState engine)
releaseStateResources :: engine widget a
-> DecorationEngineState engine
-> X ()
calcWidgetPlace :: engine widget a
-> DrawData engine widget
-> widget
-> X WidgetPlace
placeWidgets :: Shrinker shrinker
=> engine widget a
-> Theme engine widget
-> shrinker
-> DecorationEngineState engine
-> Rectangle
-> Window
-> WidgetLayout widget
-> X (WidgetLayout WidgetPlace)
placeWidgets engine widget a
engine Theme engine widget
theme shrinker
_ DecorationEngineState engine
decoStyle Rectangle
decoRect Window
window WidgetLayout widget
wlayout = do
let leftWidgets :: [widget]
leftWidgets = WidgetLayout widget -> [widget]
forall a. WidgetLayout a -> [a]
wlLeft WidgetLayout widget
wlayout
rightWidgets :: [widget]
rightWidgets = WidgetLayout widget -> [widget]
forall a. WidgetLayout a -> [a]
wlRight WidgetLayout widget
wlayout
centerWidgets :: [widget]
centerWidgets = WidgetLayout widget -> [widget]
forall a. WidgetLayout a -> [a]
wlCenter WidgetLayout widget
wlayout
dd <- engine widget a
-> Theme engine widget
-> DecorationEngineState engine
-> Window
-> Rectangle
-> X (DrawData engine widget)
forall (engine :: * -> * -> *) widget a.
(DecorationEngine engine widget a,
ThemeAttributes (Theme engine widget),
HasWidgets (Theme engine) widget) =>
engine widget a
-> Theme engine widget
-> DecorationEngineState engine
-> Window
-> Rectangle
-> X (DrawData engine widget)
mkDrawData engine widget a
engine Theme engine widget
theme DecorationEngineState engine
decoStyle Window
window Rectangle
decoRect
let paddedDecoRect = BoxBorders Dimension -> Rectangle -> Rectangle
pad (Theme engine widget -> BoxBorders Dimension
forall theme.
ThemeAttributes theme =>
theme -> BoxBorders Dimension
widgetsPadding Theme engine widget
theme) (DrawData engine widget -> Rectangle
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd)
paddedDd = DrawData engine widget
dd {ddDecoRect = paddedDecoRect}
rightRects <- alignRight engine paddedDd rightWidgets
leftRects <- alignLeft engine paddedDd leftWidgets
let wantedLeftWidgetsWidth = [Dimension] -> Dimension
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Dimension] -> Dimension) -> [Dimension] -> Dimension
forall a b. (a -> b) -> a -> b
$ (WidgetPlace -> Dimension) -> [WidgetPlace] -> [Dimension]
forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width (Rectangle -> Dimension)
-> (WidgetPlace -> Rectangle) -> WidgetPlace -> Dimension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle) [WidgetPlace]
leftRects
wantedRightWidgetsWidth = [Dimension] -> Dimension
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Dimension] -> Dimension) -> [Dimension] -> Dimension
forall a b. (a -> b) -> a -> b
$ (WidgetPlace -> Dimension) -> [WidgetPlace] -> [Dimension]
forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width (Rectangle -> Dimension)
-> (WidgetPlace -> Rectangle) -> WidgetPlace -> Dimension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle) [WidgetPlace]
rightRects
hasShrinkableOnLeft = (widget -> Bool) -> [widget] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any widget -> Bool
forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
leftWidgets
hasShrinkableOnRight = (widget -> Bool) -> [widget] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any widget -> Bool
forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
rightWidgets
decoWidth = Rectangle -> Dimension
rect_width Rectangle
decoRect
(leftWidgetsWidth, rightWidgetsWidth)
| hasShrinkableOnLeft =
(min (decoWidth - wantedRightWidgetsWidth) wantedLeftWidgetsWidth,
wantedRightWidgetsWidth)
| hasShrinkableOnRight =
(wantedLeftWidgetsWidth,
min (decoWidth - wantedLeftWidgetsWidth) wantedRightWidgetsWidth)
| otherwise = (wantedLeftWidgetsWidth, wantedRightWidgetsWidth)
ddForCenter = DrawData engine widget
paddedDd {ddDecoRect = padCenter leftWidgetsWidth rightWidgetsWidth paddedDecoRect}
centerRects <- alignCenter engine ddForCenter centerWidgets
let shrinkedLeftRects = Position -> [WidgetPlace] -> [WidgetPlace]
packLeft (Rectangle -> Position
rect_x Rectangle
paddedDecoRect) ([WidgetPlace] -> [WidgetPlace]) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ Dimension -> [(WidgetPlace, Bool)] -> [WidgetPlace]
shrinkPlaces Dimension
leftWidgetsWidth ([(WidgetPlace, Bool)] -> [WidgetPlace])
-> [(WidgetPlace, Bool)] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ [WidgetPlace] -> [Bool] -> [(WidgetPlace, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WidgetPlace]
leftRects ((widget -> Bool) -> [widget] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map widget -> Bool
forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
leftWidgets)
shrinkedRightRects = Dimension -> [WidgetPlace] -> [WidgetPlace]
packRight (Rectangle -> Dimension
rect_width Rectangle
paddedDecoRect) ([WidgetPlace] -> [WidgetPlace]) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ Dimension -> [(WidgetPlace, Bool)] -> [WidgetPlace]
shrinkPlaces Dimension
rightWidgetsWidth ([(WidgetPlace, Bool)] -> [WidgetPlace])
-> [(WidgetPlace, Bool)] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ [WidgetPlace] -> [Bool] -> [(WidgetPlace, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WidgetPlace]
rightRects ((widget -> Bool) -> [widget] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map widget -> Bool
forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
rightWidgets)
return $ WidgetLayout shrinkedLeftRects centerRects shrinkedRightRects
where
shrinkPlaces :: Dimension -> [(WidgetPlace, Bool)] -> [WidgetPlace]
shrinkPlaces Dimension
targetWidth [(WidgetPlace, Bool)]
ps =
let nShrinkable :: Int
nShrinkable = [(WidgetPlace, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (((WidgetPlace, Bool) -> Bool)
-> [(WidgetPlace, Bool)] -> [(WidgetPlace, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (WidgetPlace, Bool) -> Bool
forall a b. (a, b) -> b
snd [(WidgetPlace, Bool)]
ps)
totalUnshrinkedWidth :: Dimension
totalUnshrinkedWidth = [Dimension] -> Dimension
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Dimension] -> Dimension) -> [Dimension] -> Dimension
forall a b. (a -> b) -> a -> b
$ ((WidgetPlace, Bool) -> Dimension)
-> [(WidgetPlace, Bool)] -> [Dimension]
forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width (Rectangle -> Dimension)
-> ((WidgetPlace, Bool) -> Rectangle)
-> (WidgetPlace, Bool)
-> Dimension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle (WidgetPlace -> Rectangle)
-> ((WidgetPlace, Bool) -> WidgetPlace)
-> (WidgetPlace, Bool)
-> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetPlace, Bool) -> WidgetPlace
forall a b. (a, b) -> a
fst) ([(WidgetPlace, Bool)] -> [Dimension])
-> [(WidgetPlace, Bool)] -> [Dimension]
forall a b. (a -> b) -> a -> b
$ ((WidgetPlace, Bool) -> Bool)
-> [(WidgetPlace, Bool)] -> [(WidgetPlace, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((WidgetPlace, Bool) -> Bool) -> (WidgetPlace, Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetPlace, Bool) -> Bool
forall a b. (a, b) -> b
snd) [(WidgetPlace, Bool)]
ps
shrinkedWidth :: Dimension
shrinkedWidth = (Dimension
targetWidth Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
totalUnshrinkedWidth) Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Int
nShrinkable
resetX :: WidgetPlace -> WidgetPlace
resetX WidgetPlace
place = WidgetPlace
place {wpRectangle = (wpRectangle place) {rect_x = 0}}
adjust :: (WidgetPlace, Bool) -> WidgetPlace
adjust (WidgetPlace
place, Bool
True) = WidgetPlace -> WidgetPlace
resetX (WidgetPlace -> WidgetPlace) -> WidgetPlace -> WidgetPlace
forall a b. (a -> b) -> a -> b
$ WidgetPlace
place {wpRectangle = (wpRectangle place) {rect_width = shrinkedWidth}}
adjust (WidgetPlace
place, Bool
False) = WidgetPlace -> WidgetPlace
resetX WidgetPlace
place
in ((WidgetPlace, Bool) -> WidgetPlace)
-> [(WidgetPlace, Bool)] -> [WidgetPlace]
forall a b. (a -> b) -> [a] -> [b]
map (WidgetPlace, Bool) -> WidgetPlace
adjust [(WidgetPlace, Bool)]
ps
pad :: BoxBorders Dimension -> Rectangle -> Rectangle
pad BoxBorders Dimension
p (Rectangle Position
_ Position
_ Dimension
w Dimension
h) =
Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxLeft BoxBorders Dimension
p)) (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxTop BoxBorders Dimension
p))
(Dimension
w Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxLeft BoxBorders Dimension
p Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxRight BoxBorders Dimension
p)
(Dimension
h Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxTop BoxBorders Dimension
p Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxBottom BoxBorders Dimension
p)
padCenter :: Dimension -> Dimension -> Rectangle -> Rectangle
padCenter Dimension
left Dimension
right (Rectangle Position
x Position
y Dimension
w Dimension
h) =
Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Position
x Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
left) Position
y
(Dimension
w Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
left Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
right) Dimension
h
getShrinkedWindowName :: Shrinker shrinker
=> engine widget a
-> shrinker
-> DecorationEngineState engine
-> String
-> Dimension
-> Dimension
-> X String
default getShrinkedWindowName :: (Shrinker shrinker, DecorationEngineState engine ~ XMonadFont)
=> engine widget a -> shrinker -> DecorationEngineState engine -> String -> Dimension -> Dimension -> X String
getShrinkedWindowName engine widget a
_ shrinker
shrinker DecorationEngineState engine
font String
name Dimension
wh Dimension
_ = do
let s :: String -> [String]
s = shrinker -> String -> [String]
forall s. Shrinker s => s -> String -> [String]
shrinkIt shrinker
shrinker
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
shrinkWhile s (\String
n -> do size <- IO Int -> X Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Int -> X Int) -> IO Int -> X Int
forall a b. (a -> b) -> a -> b
$ Display -> XMonadFont -> String -> IO Int
forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
DecorationEngineState engine
font String
n
return $ size > fromIntegral wh) name
decorationXEventMask :: engine widget a -> EventMask
decorationXEventMask engine widget a
_ = Window
exposureMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
buttonPressMask
propsToRepaintDecoration :: engine widget a -> X [Atom]
propsToRepaintDecoration engine widget a
_ =
(String -> X Window) -> [String] -> X [Window]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> X Window
getAtom [String
"WM_NAME", String
"_NET_WM_NAME", String
"WM_STATE", String
"WM_HINTS"]
decorationEventHookEx :: Shrinker shrinker
=> engine widget a
-> Theme engine widget
-> DecorationLayoutState engine
-> shrinker
-> Event
-> X ()
decorationEventHookEx = engine widget a
-> Theme engine widget
-> DecorationLayoutState engine
-> shrinker
-> Event
-> X ()
forall (engine :: * -> * -> *) widget a shrinker.
(DecorationEngine engine widget a, Shrinker shrinker) =>
engine widget a
-> Theme engine widget
-> DecorationLayoutState engine
-> shrinker
-> Event
-> X ()
handleMouseFocusDrag
handleDecorationClick :: engine widget a
-> Theme engine widget
-> Rectangle
-> [Rectangle]
-> Window
-> Int
-> Int
-> Int
-> X Bool
handleDecorationClick = engine widget a
-> Theme engine widget
-> Rectangle
-> [Rectangle]
-> Window
-> Int
-> Int
-> Int
-> X Bool
forall (engine :: * -> * -> *) widget a.
(DecorationEngine engine widget a,
ClickHandler (Theme engine) widget) =>
engine widget a
-> Theme engine widget
-> Rectangle
-> [Rectangle]
-> Window
-> Int
-> Int
-> Int
-> X Bool
decorationHandler
decorationWhileDraggingHook :: engine widget a
-> CInt
-> CInt
-> (Window, Rectangle)
-> Position
-> Position
-> X ()
decorationWhileDraggingHook engine widget a
_ = CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()
handleDraggingInProgress
decorationAfterDraggingHook :: engine widget a
-> (Window, Rectangle)
-> Window
-> X ()
decorationAfterDraggingHook engine widget a
_ds (Window
w, Rectangle
_r) Window
decoWin = do
Window -> X ()
focus Window
w
hasCrossed <- Window -> Window -> X Bool
handleScreenCrossing Window
w Window
decoWin
unless hasCrossed $ do
sendMessage DraggingStopped
performWindowSwitching w
paintDecoration :: Shrinker shrinker
=> engine widget a
-> a
-> Dimension
-> Dimension
-> shrinker
-> DrawData engine widget
-> Bool
-> X ()
paintWidget :: Shrinker shrinker
=> engine widget a
-> DecorationPaintingContext engine
-> WidgetPlace
-> shrinker
-> DrawData engine widget
-> widget
-> Bool
-> X ()
handleDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()
handleDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()
handleDraggingInProgress CInt
ex CInt
ey (Window
mainw, Rectangle
r) Position
x Position
y = do
let rect :: Rectangle
rect = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Position
x Position -> Position -> Position
forall a. Num a => a -> a -> a
- (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi CInt
ex Position -> Position -> Position
forall a. Num a => a -> a -> a
- Rectangle -> Position
rect_x Rectangle
r))
(Position
y Position -> Position -> Position
forall a. Num a => a -> a -> a
- (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi CInt
ey Position -> Position -> Position
forall a. Num a => a -> a -> a
- Rectangle -> Position
rect_y Rectangle
r))
(Rectangle -> Dimension
rect_width Rectangle
r)
(Rectangle -> Dimension
rect_height Rectangle
r)
DraggingVisualizerMsg -> X ()
forall a. Message a => a -> X ()
sendMessage (DraggingVisualizerMsg -> X ()) -> DraggingVisualizerMsg -> X ()
forall a b. (a -> b) -> a -> b
$ Window -> Rectangle -> DraggingVisualizerMsg
DraggingWindow Window
mainw Rectangle
rect
performWindowSwitching :: Window -> X ()
performWindowSwitching :: Window -> X ()
performWindowSwitching Window
win =
(Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
root <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
(_, _, selWin, _, _, _, _, _) <- io $ queryPointer d root
ws <- gets windowset
let allWindows = WindowSet -> [Window]
forall i l a s sd. StackSet i l a s sd -> [a]
W.index WindowSet
ws
when ((win `elem` allWindows) && (selWin `elem` allWindows)) $ do
let allWindowsSwitched = (Window -> Window) -> [Window] -> [Window]
forall a b. (a -> b) -> [a] -> [b]
map (Window -> Window -> Window -> Window
forall {a}. Eq a => a -> a -> a -> a
switchEntries Window
win Window
selWin) [Window]
allWindows
let (ls, notEmpty -> t :| rs) = break (win ==) allWindowsSwitched
let newStack = Window -> [Window] -> [Window] -> Stack Window
forall a. a -> [a] -> [a] -> Stack a
W.Stack Window
t ([Window] -> [Window]
forall a. [a] -> [a]
reverse [Window]
ls) [Window]
rs
windows $ W.modify' $ const newStack
where
switchEntries :: a -> a -> a -> a
switchEntries a
a a
b a
x
| a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a = a
b
| a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b = a
a
| Bool
otherwise = a
x
ignoreX :: WidgetPlace -> WidgetPlace
ignoreX :: WidgetPlace -> WidgetPlace
ignoreX WidgetPlace
place = WidgetPlace
place {wpRectangle = (wpRectangle place) {rect_x = 0}}
alignLeft :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignLeft :: forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignLeft engine widget a
engine DrawData engine widget
dd [widget]
widgets = do
places <- (widget -> X WidgetPlace) -> [widget] -> X [WidgetPlace]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (engine widget a
-> DrawData engine widget -> widget -> X WidgetPlace
forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> widget -> X WidgetPlace
calcWidgetPlace engine widget a
engine DrawData engine widget
dd) [widget]
widgets
return $ packLeft (rect_x $ ddDecoRect dd) $ map ignoreX places
packLeft :: Position -> [WidgetPlace] -> [WidgetPlace]
packLeft :: Position -> [WidgetPlace] -> [WidgetPlace]
packLeft Position
_ [] = []
packLeft Position
x0 (WidgetPlace
place : [WidgetPlace]
places) =
let rect :: Rectangle
rect = WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place
x' :: Position
x' = Position
x0 Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Rectangle -> Position
rect_x Rectangle
rect
rect' :: Rectangle
rect' = Rectangle
rect {rect_x = x'}
place' :: WidgetPlace
place' = WidgetPlace
place {wpRectangle = rect'}
in WidgetPlace
place' WidgetPlace -> [WidgetPlace] -> [WidgetPlace]
forall a. a -> [a] -> [a]
: Position -> [WidgetPlace] -> [WidgetPlace]
packLeft (Position
x' Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
rect)) [WidgetPlace]
places
alignRight :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignRight :: forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignRight engine widget a
engine DrawData engine widget
dd [widget]
widgets = do
places <- (widget -> X WidgetPlace) -> [widget] -> X [WidgetPlace]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (engine widget a
-> DrawData engine widget -> widget -> X WidgetPlace
forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> widget -> X WidgetPlace
calcWidgetPlace engine widget a
engine DrawData engine widget
dd) [widget]
widgets
return $ packRight (rect_width $ ddDecoRect dd) $ map ignoreX places
packRight :: Dimension -> [WidgetPlace] -> [WidgetPlace]
packRight :: Dimension -> [WidgetPlace] -> [WidgetPlace]
packRight Dimension
x0 [WidgetPlace]
places = [WidgetPlace] -> [WidgetPlace]
forall a. [a] -> [a]
reverse ([WidgetPlace] -> [WidgetPlace]) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ Dimension -> [WidgetPlace] -> [WidgetPlace]
go Dimension
x0 [WidgetPlace]
places
where
go :: Dimension -> [WidgetPlace] -> [WidgetPlace]
go Dimension
_ [] = []
go Dimension
x (WidgetPlace
place : [WidgetPlace]
rest) =
let rect :: Rectangle
rect = WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place
x' :: Dimension
x' = Dimension
x Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Rectangle -> Dimension
rect_width Rectangle
rect
rect' :: Rectangle
rect' = Rectangle
rect {rect_x = fi x'}
place' :: WidgetPlace
place' = WidgetPlace
place {wpRectangle = rect'}
in WidgetPlace
place' WidgetPlace -> [WidgetPlace] -> [WidgetPlace]
forall a. a -> [a] -> [a]
: Dimension -> [WidgetPlace] -> [WidgetPlace]
go Dimension
x' [WidgetPlace]
rest
alignCenter :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignCenter :: forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignCenter engine widget a
engine DrawData engine widget
dd [widget]
widgets = do
places <- engine widget a
-> DrawData engine widget -> [widget] -> X [WidgetPlace]
forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignLeft engine widget a
engine DrawData engine widget
dd [widget]
widgets
let totalWidth = [Dimension] -> Dimension
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Dimension] -> Dimension) -> [Dimension] -> Dimension
forall a b. (a -> b) -> a -> b
$ (WidgetPlace -> Dimension) -> [WidgetPlace] -> [Dimension]
forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width (Rectangle -> Dimension)
-> (WidgetPlace -> Rectangle) -> WidgetPlace -> Dimension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle) [WidgetPlace]
places
availableWidth = Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width (DrawData engine widget -> Rectangle
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd)) :: Position
x0 = Position -> Position -> Position
forall a. Ord a => a -> a -> a
max Position
0 (Position -> Position) -> Position -> Position
forall a b. (a -> b) -> a -> b
$ (Position
availableWidth Position -> Position -> Position
forall a. Num a => a -> a -> a
- Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
totalWidth) Position -> Position -> Position
forall a. Integral a => a -> a -> a
`div` Position
2
places' = (WidgetPlace -> WidgetPlace) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> WidgetPlace -> WidgetPlace
forall {a}. Integral a => a -> WidgetPlace -> WidgetPlace
shift Position
x0) [WidgetPlace]
places
return $ pack (fi availableWidth) places'
where
shift :: a -> WidgetPlace -> WidgetPlace
shift a
x0 WidgetPlace
place =
let rect :: Rectangle
rect = WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place
rect' :: Rectangle
rect' = Rectangle
rect {rect_x = rect_x rect + fi x0}
in WidgetPlace
place {wpRectangle = rect'}
pack :: Dimension -> [WidgetPlace] -> [WidgetPlace]
pack Dimension
_ [] = []
pack Dimension
available (WidgetPlace
place : [WidgetPlace]
places) =
let rect :: Rectangle
rect = WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place
placeWidth :: Dimension
placeWidth = Rectangle -> Dimension
rect_width Rectangle
rect
widthToUse :: Dimension
widthToUse = Dimension -> Dimension -> Dimension
forall a. Ord a => a -> a -> a
min Dimension
available Dimension
placeWidth
remaining :: Dimension
remaining = Dimension
available Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
widthToUse
rect' :: Rectangle
rect' = Rectangle
rect {rect_width = widthToUse}
place' :: WidgetPlace
place' = WidgetPlace
place {wpRectangle = rect'}
in WidgetPlace
place' WidgetPlace -> [WidgetPlace] -> [WidgetPlace]
forall a. a -> [a] -> [a]
: Dimension -> [WidgetPlace] -> [WidgetPlace]
pack Dimension
remaining [WidgetPlace]
places
mkDrawData :: (DecorationEngine engine widget a, ThemeAttributes (Theme engine widget), HasWidgets (Theme engine) widget)
=> engine widget a
-> Theme engine widget
-> DecorationEngineState engine
-> Window
-> Rectangle
-> X (DrawData engine widget)
mkDrawData :: forall (engine :: * -> * -> *) widget a.
(DecorationEngine engine widget a,
ThemeAttributes (Theme engine widget),
HasWidgets (Theme engine) widget) =>
engine widget a
-> Theme engine widget
-> DecorationEngineState engine
-> Window
-> Rectangle
-> X (DrawData engine widget)
mkDrawData engine widget a
_ Theme engine widget
theme DecorationEngineState engine
decoState Window
origWindow Rectangle
decoRect = do
name <- (NamedWindow -> String) -> X NamedWindow -> X String
forall a b. (a -> b) -> X a -> X b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
2048 (String -> String)
-> (NamedWindow -> String) -> NamedWindow -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (String -> String)
-> (NamedWindow -> String) -> NamedWindow -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedWindow -> String
forall a. Show a => a -> String
show) (Window -> X NamedWindow
getName Window
origWindow)
style <- selectWindowStyle theme origWindow
return $ DrawData {
ddEngineState = decoState,
ddStyle = style,
ddOrigWindow = origWindow,
ddWindowTitle = name,
ddDecoRect = decoRect,
ddWidgets = themeWidgets theme,
ddWidgetPlaces = WidgetLayout [] [] []
}
handleMouseFocusDrag :: (DecorationEngine engine widget a, Shrinker shrinker) => engine widget a -> Theme engine widget -> DecorationLayoutState engine -> shrinker -> Event -> X ()
handleMouseFocusDrag :: forall (engine :: * -> * -> *) widget a shrinker.
(DecorationEngine engine widget a, Shrinker shrinker) =>
engine widget a
-> Theme engine widget
-> DecorationLayoutState engine
-> shrinker
-> Event
-> X ()
handleMouseFocusDrag engine widget a
ds Theme engine widget
theme (DecorationLayoutState {[WindowDecoration]
dsDecorations :: forall (engine :: * -> * -> *).
DecorationLayoutState engine -> [WindowDecoration]
dsDecorations :: [WindowDecoration]
dsDecorations}) shrinker
_ (ButtonEvent {Window
ev_window :: Window
ev_window :: Event -> Window
ev_window, CInt
ev_x_root :: CInt
ev_x_root :: Event -> CInt
ev_x_root, CInt
ev_y_root :: CInt
ev_y_root :: Event -> CInt
ev_y_root, Dimension
ev_event_type :: Dimension
ev_event_type :: Event -> Dimension
ev_event_type, Dimension
ev_button :: Dimension
ev_button :: Event -> Dimension
ev_button})
| Dimension
ev_event_type Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
buttonPress
, Just (WindowDecoration {[WidgetPlace]
Maybe Window
Maybe Rectangle
Window
Rectangle
wdOrigWindow :: Window
wdOrigWinRect :: Rectangle
wdDecoWindow :: Maybe Window
wdDecoRect :: Maybe Rectangle
wdWidgets :: [WidgetPlace]
wdWidgets :: WindowDecoration -> [WidgetPlace]
wdDecoRect :: WindowDecoration -> Maybe Rectangle
wdDecoWindow :: WindowDecoration -> Maybe Window
wdOrigWinRect :: WindowDecoration -> Rectangle
wdOrigWindow :: WindowDecoration -> Window
..}) <- Window -> [WindowDecoration] -> Maybe WindowDecoration
findDecoDataByDecoWindow Window
ev_window [WindowDecoration]
dsDecorations = do
let decoRect :: Rectangle
decoRect@(Rectangle Position
dx Position
dy Dimension
_ Dimension
_) = Maybe Rectangle -> Rectangle
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Rectangle
wdDecoRect
x :: Int
x = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ CInt
ev_x_root CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
- Position -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Position
dx
y :: Int
y = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ CInt
ev_y_root CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
- Position -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Position
dy
button :: Int
button = Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi Dimension
ev_button
dealtWith <- engine widget a
-> Theme engine widget
-> Rectangle
-> [Rectangle]
-> Window
-> Int
-> Int
-> Int
-> X Bool
forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> Theme engine widget
-> Rectangle
-> [Rectangle]
-> Window
-> Int
-> Int
-> Int
-> X Bool
handleDecorationClick engine widget a
ds Theme engine widget
theme Rectangle
decoRect ((WidgetPlace -> Rectangle) -> [WidgetPlace] -> [Rectangle]
forall a b. (a -> b) -> [a] -> [b]
map WidgetPlace -> Rectangle
wpRectangle [WidgetPlace]
wdWidgets) Window
wdOrigWindow Int
x Int
y Int
button
unless dealtWith $ when (isDraggingEnabled theme button) $
mouseDrag (\Position
dragX Position
dragY -> Window -> X ()
focus Window
wdOrigWindow X () -> X () -> X ()
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> engine widget a
-> CInt
-> CInt
-> (Window, Rectangle)
-> Position
-> Position
-> X ()
forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> CInt
-> CInt
-> (Window, Rectangle)
-> Position
-> Position
-> X ()
decorationWhileDraggingHook engine widget a
ds CInt
ev_x_root CInt
ev_y_root (Window
wdOrigWindow, Rectangle
wdOrigWinRect) Position
dragX Position
dragY)
(decorationAfterDraggingHook ds (wdOrigWindow, wdOrigWinRect) ev_window)
handleMouseFocusDrag engine widget a
_ Theme engine widget
_ DecorationLayoutState engine
_ shrinker
_ Event
_ = () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
findDecoDataByDecoWindow :: Window -> [WindowDecoration] -> Maybe WindowDecoration
findDecoDataByDecoWindow :: Window -> [WindowDecoration] -> Maybe WindowDecoration
findDecoDataByDecoWindow Window
decoWin = (WindowDecoration -> Bool)
-> [WindowDecoration] -> Maybe WindowDecoration
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\WindowDecoration
dd -> WindowDecoration -> Maybe Window
wdDecoWindow WindowDecoration
dd Maybe Window -> Maybe Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window -> Maybe Window
forall a. a -> Maybe a
Just Window
decoWin)
decorationHandler :: forall engine widget a.
(DecorationEngine engine widget a,
ClickHandler (Theme engine) widget)
=> engine widget a
-> Theme engine widget
-> Rectangle
-> [Rectangle]
-> Window
-> Int
-> Int
-> Int
-> X Bool
decorationHandler :: forall (engine :: * -> * -> *) widget a.
(DecorationEngine engine widget a,
ClickHandler (Theme engine) widget) =>
engine widget a
-> Theme engine widget
-> Rectangle
-> [Rectangle]
-> Window
-> Int
-> Int
-> Int
-> X Bool
decorationHandler engine widget a
_ Theme engine widget
theme Rectangle
_ [Rectangle]
widgetPlaces Window
window Int
x Int
y Int
button = do
widgetDone <- [(widget, Rectangle)] -> X Bool
go ([(widget, Rectangle)] -> X Bool)
-> [(widget, Rectangle)] -> X Bool
forall a b. (a -> b) -> a -> b
$ [widget] -> [Rectangle] -> [(widget, Rectangle)]
forall a b. [a] -> [b] -> [(a, b)]
zip (WidgetLayout widget -> [widget]
forall a. WidgetLayout a -> [a]
widgetLayout (WidgetLayout widget -> [widget])
-> WidgetLayout widget -> [widget]
forall a b. (a -> b) -> a -> b
$ Theme engine widget -> WidgetLayout widget
forall (theme :: * -> *) widget.
HasWidgets theme widget =>
theme widget -> WidgetLayout widget
themeWidgets Theme engine widget
theme) [Rectangle]
widgetPlaces
if widgetDone
then return True
else case onDecorationClick theme button of
Just WidgetCommand widget
cmd -> do
WidgetCommand widget -> Window -> X Bool
forall cmd. WindowCommand cmd => cmd -> Window -> X Bool
executeWindowCommand WidgetCommand widget
cmd Window
window
Maybe (WidgetCommand widget)
Nothing -> Bool -> X Bool
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where
go :: [(widget, Rectangle)] -> X Bool
go :: [(widget, Rectangle)] -> X Bool
go [] = Bool -> X Bool
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
go ((widget
w, Rectangle
rect) : [(widget, Rectangle)]
rest) = do
if Position -> Position -> Rectangle -> Bool
pointWithin (Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
x) (Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
y) Rectangle
rect
then do
WidgetCommand widget -> Window -> X Bool
forall cmd. WindowCommand cmd => cmd -> Window -> X Bool
executeWindowCommand (widget -> Int -> WidgetCommand widget
forall widget.
DecorationWidget widget =>
widget -> Int -> WidgetCommand widget
widgetCommand widget
w Int
button) Window
window
else [(widget, Rectangle)] -> X Bool
go [(widget, Rectangle)]
rest
paintDecorationSimple :: forall engine shrinker widget.
(DecorationEngine engine widget Window,
DecorationPaintingContext engine ~ XPaintingContext,
Shrinker shrinker,
Style (Theme engine widget) ~ SimpleStyle)
=> engine widget Window
-> Window
-> Dimension
-> Dimension
-> shrinker
-> DrawData engine widget
-> Bool
-> X ()
paintDecorationSimple :: forall (engine :: * -> * -> *) shrinker widget.
(DecorationEngine engine widget Window,
DecorationPaintingContext engine ~ XPaintingContext,
Shrinker shrinker, Style (Theme engine widget) ~ SimpleStyle) =>
engine widget Window
-> Window
-> Dimension
-> Dimension
-> shrinker
-> DrawData engine widget
-> Bool
-> X ()
paintDecorationSimple engine widget Window
deco Window
win Dimension
windowWidth Dimension
windowHeight shrinker
shrinker DrawData engine widget
dd Bool
isExpose = do
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
let widgets = WidgetLayout widget -> [widget]
forall a. WidgetLayout a -> [a]
widgetLayout (WidgetLayout widget -> [widget])
-> WidgetLayout widget -> [widget]
forall a b. (a -> b) -> a -> b
$ DrawData engine widget -> WidgetLayout widget
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> WidgetLayout widget
ddWidgets DrawData engine widget
dd
style = DrawData engine widget -> Style (Theme engine widget)
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Style (Theme engine widget)
ddStyle DrawData engine widget
dd
pixmap <- io $ createPixmap dpy win windowWidth windowHeight (defaultDepthOfScreen $ defaultScreenOfDisplay dpy)
gc <- io $ createGC dpy pixmap
io $ setGraphicsExposures dpy gc False
bgColor <- stringToPixel dpy (sBgColor style)
let borderWidth = SimpleStyle -> Dimension
sDecoBorderWidth Style (Theme engine widget)
SimpleStyle
style
borderColors = SimpleStyle -> BorderColors
sDecorationBorders Style (Theme engine widget)
SimpleStyle
style
when (borderWidth > 0) $ do
drawLineWith dpy pixmap gc 0 0 windowWidth borderWidth (bxTop borderColors)
drawLineWith dpy pixmap gc 0 0 borderWidth windowHeight (bxLeft borderColors)
drawLineWith dpy pixmap gc 0 (fi (windowHeight - borderWidth)) windowWidth borderWidth (bxBottom borderColors)
drawLineWith dpy pixmap gc (fi (windowWidth - borderWidth)) 0 borderWidth windowHeight (bxRight borderColors)
io $ setForeground dpy gc bgColor
io $ fillRectangle dpy pixmap gc (fi borderWidth) (fi borderWidth) (windowWidth - (borderWidth * 2)) (windowHeight - (borderWidth * 2))
forM_ (zip widgets $ widgetLayout $ ddWidgetPlaces dd) $ \(widget
widget, WidgetPlace
place) ->
engine widget Window
-> DecorationPaintingContext engine
-> WidgetPlace
-> shrinker
-> DrawData engine widget
-> widget
-> Bool
-> X ()
forall shrinker.
Shrinker shrinker =>
engine widget Window
-> DecorationPaintingContext engine
-> WidgetPlace
-> shrinker
-> DrawData engine widget
-> widget
-> Bool
-> X ()
forall (engine :: * -> * -> *) widget a shrinker.
(DecorationEngine engine widget a, Shrinker shrinker) =>
engine widget a
-> DecorationPaintingContext engine
-> WidgetPlace
-> shrinker
-> DrawData engine widget
-> widget
-> Bool
-> X ()
paintWidget engine widget Window
deco (Display
dpy, Window
pixmap, GC
gc) WidgetPlace
place shrinker
shrinker DrawData engine widget
dd widget
widget Bool
isExpose
io $ copyArea dpy pixmap win gc 0 0 windowWidth windowHeight 0 0
io $ freePixmap dpy pixmap
io $ freeGC dpy gc
where
drawLineWith :: Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> String
-> m ()
drawLineWith Display
dpy Window
pixmap GC
gc Position
x Position
y Dimension
w Dimension
h String
colorName = do
color <- Display -> String -> m Window
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display -> String -> m Window
stringToPixel Display
dpy String
colorName
io $ setForeground dpy gc color
io $ fillRectangle dpy pixmap gc x y w h