{-# 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
-- Description :  Type class and its default implementation for window decoration engines.
-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov
-- License     :  BSD-style (see xmonad/LICENSE)
--
-- Maintainer  :  portnov84@rambler.ru
-- Stability   :  unstable
-- Portability :  unportable
--
-- This module defines @DecorationEngine@ type class, and default implementation for it.
-----------------------------------------------------------------------------

module XMonad.Layout.DecorationEx.Engine (
    -- * DecorationEngine class
    DecorationEngine (..),
    -- * Auxiliary data types
    DrawData (..), 
    DecorationLayoutState (..),
    -- * Re-exports from X.L.Decoration
    Shrinker (..), shrinkText,
    -- * Utility functions
    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

-- | Auxiliary type for data which are passed from
-- decoration layout modifier to decoration engine.
data DrawData engine widget = DrawData {
    forall (engine :: * -> * -> *) widget.
DrawData engine widget -> DecorationEngineState engine
ddEngineState :: !(DecorationEngineState engine)     -- ^ Decoration engine state
  , forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Style (Theme engine widget)
ddStyle :: !(Style (Theme engine widget))  -- ^ Graphics style of the decoration. This defines colors, fonts etc
                                                        -- which are to be used for this particular window in it's current state.
  , forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Window
ddOrigWindow :: !Window                             -- ^ Original window to be decorated
  , forall (engine :: * -> * -> *) widget.
DrawData engine widget -> String
ddWindowTitle :: !String                            -- ^ Original window title (not shrinked yet)
  , forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect :: !Rectangle                            -- ^ Decoration rectangle
  , forall (engine :: * -> * -> *) widget.
DrawData engine widget -> WidgetLayout widget
ddWidgets :: !(WidgetLayout widget)         -- ^ Widgets to be placed on decoration
  , forall (engine :: * -> * -> *) widget.
DrawData engine widget -> WidgetLayout WidgetPlace
ddWidgetPlaces :: !(WidgetLayout WidgetPlace)       -- ^ Places where widgets must be shown
  }

-- | State of decoration engine
data DecorationLayoutState engine = DecorationLayoutState {
    forall (engine :: * -> * -> *).
DecorationLayoutState engine -> DecorationEngineState engine
dsStyleState :: !(DecorationEngineState engine) -- ^ Engine-specific state
  , forall (engine :: * -> * -> *).
DecorationLayoutState engine -> [WindowDecoration]
dsDecorations :: ![WindowDecoration]            -- ^ Mapping between decoration windows and original windows
  }

-- | Decoration engines type class.
-- Decoration engine is responsible for drawing something inside decoration rectangle.
-- It is also responsible for handling X11 events (such as clicks) which happen
-- within decoration rectangle.
-- Decoration rectangles are defined by DecorationGeometry implementation.
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 of themes used by decoration engine.
    -- This type must be parameterized over a widget type,
    -- because a theme will contain a list of widgets.
    type Theme engine :: Type -> Type           
                                          
    -- | Type of data used by engine as a context during painting;
    -- for plain X11-based implementation this is Display, Pixmap
    -- and GC.
    type DecorationPaintingContext engine 
 
    -- | Type of state used by the decoration engine.
    -- This can contain some resources that should be initialized
    -- and released at time, such as X11 fonts.
    type DecorationEngineState engine     

    -- | Give a name to decoration engine.
    describeEngine :: engine widget a -> String

    -- | Initialize state of the engine.
    initializeState :: engine widget a       -- ^ Decoration engine instance
                    -> geom a                -- ^ Decoration geometry instance
                    -> Theme engine widget   -- ^ Theme to be used
                    -> X (DecorationEngineState engine)

    -- | Release resources held in engine state.
    releaseStateResources :: engine widget a              -- ^ Decoration engine instance
                          -> DecorationEngineState engine -- ^ Engine state
                          -> X ()

    -- | Calculate place which will be occupied by one widget.
    -- NB: X coordinate of the returned rectangle will be ignored, because
    -- the rectangle will be moved to the right or to the left for proper alignment
    -- of widgets.
    calcWidgetPlace :: engine widget a         -- ^ Decoration engine instance
                    -> DrawData engine widget  -- ^ Information about window and decoration
                    -> widget                  -- ^ Widget to be placed
                    -> X WidgetPlace

    -- | Place widgets along the decoration bar.
    placeWidgets :: Shrinker shrinker
                 => engine widget a              -- ^ Decoration engine instance
                 -> Theme engine widget          -- ^ Theme to be used
                 -> shrinker                     -- ^ Strings shrinker
                 -> DecorationEngineState engine -- ^ Current state of the engine
                 -> Rectangle                    -- ^ Decoration rectangle
                 -> Window                       -- ^ Original window to be decorated
                 -> WidgetLayout widget          -- ^ Widgets layout
                 -> 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

        DrawData engine widget
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 :: Rectangle
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
paddedDd = DrawData engine widget
dd {ddDecoRect = paddedDecoRect}
        [WidgetPlace]
rightRects <- 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]
alignRight engine widget a
engine DrawData engine widget
paddedDd [widget]
rightWidgets
        [WidgetPlace]
leftRects <- 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
paddedDd [widget]
leftWidgets
        let wantedLeftWidgetsWidth :: Dimension
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
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 :: Bool
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 :: Bool
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 :: Dimension
decoWidth = Rectangle -> Dimension
rect_width Rectangle
decoRect
            (Dimension
leftWidgetsWidth, Dimension
rightWidgetsWidth)
              | Bool
hasShrinkableOnLeft = 
                  (Dimension -> Dimension -> Dimension
forall a. Ord a => a -> a -> a
min (Dimension
decoWidth Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
wantedRightWidgetsWidth) Dimension
wantedLeftWidgetsWidth,
                      Dimension
wantedRightWidgetsWidth)
              | Bool
hasShrinkableOnRight =
                  (Dimension
wantedLeftWidgetsWidth,
                      Dimension -> Dimension -> Dimension
forall a. Ord a => a -> a -> a
min (Dimension
decoWidth Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
wantedLeftWidgetsWidth) Dimension
wantedRightWidgetsWidth)
              | Bool
otherwise = (Dimension
wantedLeftWidgetsWidth, Dimension
wantedRightWidgetsWidth)
            ddForCenter :: DrawData engine widget
ddForCenter = DrawData engine widget
paddedDd {ddDecoRect = padCenter leftWidgetsWidth rightWidgetsWidth paddedDecoRect}
        [WidgetPlace]
centerRects <- 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]
alignCenter engine widget a
engine DrawData engine widget
ddForCenter [widget]
centerWidgets
        let shrinkedLeftRects :: [WidgetPlace]
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 :: [WidgetPlace]
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)
        WidgetLayout WidgetPlace -> X (WidgetLayout WidgetPlace)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetLayout WidgetPlace -> X (WidgetLayout WidgetPlace))
-> WidgetLayout WidgetPlace -> X (WidgetLayout WidgetPlace)
forall a b. (a -> b) -> a -> b
$ [WidgetPlace]
-> [WidgetPlace] -> [WidgetPlace] -> WidgetLayout WidgetPlace
forall a. [a] -> [a] -> [a] -> WidgetLayout a
WidgetLayout [WidgetPlace]
shrinkedLeftRects [WidgetPlace]
centerRects [WidgetPlace]
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

    -- | Shrink window title so that it would fit in decoration.
    getShrinkedWindowName :: Shrinker shrinker
                          => engine widget a              -- ^ Decoration engine instance
                          -> shrinker                     -- ^ Strings shrinker
                          -> DecorationEngineState engine -- ^ State of decoration engine
                          -> String                       -- ^ Original window title
                          -> Dimension                    -- ^ Width of rectangle in which the title should fit
                          -> Dimension                    -- ^ Height of rectangle in which the title should fit
                          -> 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
      Display
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
      (String -> [String]) -> (String -> X Bool) -> String -> X String
shrinkWhile String -> [String]
s (\String
n -> do Int
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
                              Bool -> X Bool
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> X Bool) -> Bool -> X Bool
forall a b. (a -> b) -> a -> b
$ Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
wh) String
name

    -- | Mask of X11 events on which the decoration engine should do something.
    -- @exposureMask@ should be included here so that decoration engine could
    -- repaint decorations when they are shown on screen.
    -- @buttonPressMask@ should be included so that decoration engine could
    -- response to mouse clicks.
    -- Other events can be added to custom implementations of DecorationEngine.
    decorationXEventMask :: engine widget a -> EventMask
    decorationXEventMask engine widget a
_ = Window
exposureMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
buttonPressMask

    -- | List of X11 window property atoms of original (client) windows,
    -- change of which should trigger repainting of decoration.
    -- For example, if @WM_NAME@ changes it means that we have to redraw
    -- window title.
    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"]

    -- | Generic event handler, which recieves X11 events on decoration
    -- window.
    -- Default implementation handles mouse clicks and drags.
    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

    -- | Event handler for clicks on decoration window.
    -- This is called from default implementation of "decorationEventHookEx".
    -- This should return True, if the click was handled (something happened
    -- because of that click). If this returns False, the click can be considered
    -- as a beginning of mouse drag.
    handleDecorationClick :: engine widget a      -- ^ Decoration engine instance
                          -> Theme engine widget  -- ^ Decoration theme
                          -> Rectangle            -- ^ Decoration rectangle
                          -> [Rectangle]          -- ^ Rectangles where widgets are placed
                          -> Window               -- ^ Original (client) window
                          -> Int                  -- ^ Mouse click X coordinate
                          -> Int                  -- ^ Mouse click Y coordinate
                          -> Int                  -- ^ Mouse button number
                          -> 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

    -- | Event handler which is called during mouse dragging.
    -- This is called from default implementation of "decorationEventHookEx".
    decorationWhileDraggingHook :: engine widget a      -- ^ Decoration engine instance
                                -> CInt                 -- ^ Event X coordinate
                                -> CInt                 -- ^ Event Y coordinate
                                -> (Window, Rectangle)  -- ^ Original window and it's rectangle
                                -> Position             -- ^ X coordinate of new pointer position during dragging
                                -> Position             -- ^ Y coordinate of new pointer position during dragging
                                -> X ()
    decorationWhileDraggingHook engine widget a
_ = CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()
handleDraggingInProgress

    -- | This hoook is called after a window has been dragged using the decoration.
    -- This is called from default implementation of "decorationEventHookEx".
    decorationAfterDraggingHook :: engine widget a     -- ^ Decoration engine instance
                                -> (Window, Rectangle) -- ^ Original window and its rectangle
                                -> Window              -- ^ Decoration window
                                -> X ()
    decorationAfterDraggingHook engine widget a
_ds (Window
w, Rectangle
_r) Window
decoWin = do
      Window -> X ()
focus Window
w
      Bool
hasCrossed <- Window -> Window -> X Bool
handleScreenCrossing Window
w Window
decoWin
      Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasCrossed (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
        DraggingVisualizerMsg -> X ()
forall a. Message a => a -> X ()
sendMessage DraggingVisualizerMsg
DraggingStopped
        Window -> X ()
performWindowSwitching Window
w

    -- | Draw everything required on the decoration window.
    -- This method should draw background (flat or gradient or whatever),
    -- borders, and call @paintWidget@ method to draw window widgets
    -- (buttons and title).
    paintDecoration :: Shrinker shrinker
                    => engine widget a         -- ^ Decoration engine instance
                    -> a                       -- ^ Decoration window
                    -> Dimension               -- ^ Decoration window width
                    -> Dimension               -- ^ Decoration window height
                    -> shrinker                -- ^ Strings shrinker instance
                    -> DrawData engine widget  -- ^ Details about what to draw
                    -> Bool                    -- ^ True when this method is called during Expose event
                    -> X ()

    -- | Paint one widget on the decoration window.
    paintWidget :: Shrinker shrinker
                => engine widget a                  -- ^ Decoration engine instance
                -> DecorationPaintingContext engine -- ^ Decoration painting context
                -> WidgetPlace                      -- ^ Place (rectangle) where the widget should be drawn
                -> shrinker                         -- ^ Strings shrinker instance
                -> DrawData engine widget           -- ^ Details about window decoration
                -> widget                           -- ^ Widget to be drawn
                -> Bool                             -- ^ True when this method is called during Expose event
                -> 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
       Window
root <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
       (Bool
_, Window
_, Window
selWin, CInt
_, CInt
_, CInt
_, CInt
_, Modifier
_) <- IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
-> X (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
 -> X (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier))
-> IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
-> X (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
queryPointer Display
d Window
root
       WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
       let allWindows :: [Window]
allWindows = WindowSet -> [Window]
forall i l a s sd. StackSet i l a s sd -> [a]
W.index WindowSet
ws
       -- do a little double check to be sure
       Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Window
win Window -> [Window] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window]
allWindows) Bool -> Bool -> Bool
&& (Window
selWin Window -> [Window] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window]
allWindows)) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
                let allWindowsSwitched :: [Window]
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 ([Window]
ls, [Window] -> NonEmpty Window
forall a. HasCallStack => [a] -> NonEmpty a
notEmpty -> Window
t :| [Window]
rs) = (Window -> Bool) -> [Window] -> ([Window], [Window])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Window
win Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
==) [Window]
allWindowsSwitched
                let newStack :: Stack Window
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
                (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ (Stack Window -> Stack Window) -> WindowSet -> WindowSet
forall a i l s sd.
(Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd
W.modify' ((Stack Window -> Stack Window) -> WindowSet -> WindowSet)
-> (Stack Window -> Stack Window) -> WindowSet -> WindowSet
forall a b. (a -> b) -> a -> b
$ Stack Window -> Stack Window -> Stack Window
forall a b. a -> b -> a
const Stack Window
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
    [WidgetPlace]
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
    [WidgetPlace] -> X [WidgetPlace]
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ([WidgetPlace] -> X [WidgetPlace])
-> [WidgetPlace] -> X [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ Position -> [WidgetPlace] -> [WidgetPlace]
packLeft (Rectangle -> Position
rect_x (Rectangle -> Position) -> Rectangle -> Position
forall a b. (a -> b) -> a -> b
$ DrawData engine widget -> Rectangle
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd) ([WidgetPlace] -> [WidgetPlace]) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ (WidgetPlace -> WidgetPlace) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> [a] -> [b]
map WidgetPlace -> WidgetPlace
ignoreX [WidgetPlace]
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
    [WidgetPlace]
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
    [WidgetPlace] -> X [WidgetPlace]
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ([WidgetPlace] -> X [WidgetPlace])
-> [WidgetPlace] -> X [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ Dimension -> [WidgetPlace] -> [WidgetPlace]
packRight (Rectangle -> Dimension
rect_width (Rectangle -> Dimension) -> Rectangle -> Dimension
forall a b. (a -> b) -> a -> b
$ DrawData engine widget -> Rectangle
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd) ([WidgetPlace] -> [WidgetPlace]) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ (WidgetPlace -> WidgetPlace) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> [a] -> [b]
map WidgetPlace -> WidgetPlace
ignoreX [WidgetPlace]
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
    [WidgetPlace]
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
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 :: Position
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
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]
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
    [WidgetPlace] -> X [WidgetPlace]
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ([WidgetPlace] -> X [WidgetPlace])
-> [WidgetPlace] -> X [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ Dimension -> [WidgetPlace] -> [WidgetPlace]
pack (Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Position
availableWidth) [WidgetPlace]
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

-- | Build an instance of 'DrawData' type.
mkDrawData :: (DecorationEngine engine widget a, ThemeAttributes (Theme engine widget), HasWidgets (Theme engine) widget)
           => engine widget a
           -> Theme engine widget            -- ^ Decoration theme
           -> DecorationEngineState engine   -- ^ State of decoration engine
           -> Window                         -- ^ Original window (to be decorated)
           -> Rectangle                      -- ^ Decoration 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
    -- xmonad-contrib #809
    -- qutebrowser will happily shovel a 389K multiline string into @_NET_WM_NAME@
    -- and the 'defaultShrinker' (a) doesn't handle multiline strings well (b) is
    -- quadratic due to using 'init'
    String
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 (Theme engine widget)
style <- Theme engine widget -> Window -> X (Style (Theme engine widget))
forall theme.
ThemeAttributes theme =>
theme -> Window -> X (Style theme)
selectWindowStyle Theme engine widget
theme Window
origWindow
    DrawData engine widget -> X (DrawData engine widget)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (DrawData engine widget -> X (DrawData engine widget))
-> DrawData engine widget -> X (DrawData engine widget)
forall a b. (a -> b) -> a -> b
$ DrawData {
                   ddEngineState :: DecorationEngineState engine
ddEngineState = DecorationEngineState engine
decoState,
                   ddStyle :: Style (Theme engine widget)
ddStyle = Style (Theme engine widget)
style,
                   ddOrigWindow :: Window
ddOrigWindow = Window
origWindow,
                   ddWindowTitle :: String
ddWindowTitle = String
name,
                   ddDecoRect :: Rectangle
ddDecoRect = Rectangle
decoRect,
                   ddWidgets :: WidgetLayout widget
ddWidgets = Theme engine widget -> WidgetLayout widget
forall (theme :: * -> *) widget.
HasWidgets theme widget =>
theme widget -> WidgetLayout widget
themeWidgets Theme engine widget
theme,
                   ddWidgetPlaces :: WidgetLayout WidgetPlace
ddWidgetPlaces = [WidgetPlace]
-> [WidgetPlace] -> [WidgetPlace] -> WidgetLayout WidgetPlace
forall a. [a] -> [a] -> [a] -> WidgetLayout a
WidgetLayout [] [] []
                  }

-- | Mouse focus and mouse drag are handled by the same function, this
-- way we can start dragging unfocused windows too.
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
        Bool
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
        Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dealtWith (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Theme engine widget -> Int -> Bool
forall (theme :: * -> *) widget.
ClickHandler theme widget =>
theme widget -> Int -> Bool
isDraggingEnabled Theme engine widget
theme Int
button) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
            (Position -> Position -> X ()) -> X () -> X ()
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)
                      (engine widget a -> (Window, Rectangle) -> Window -> X ()
forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a -> (Window, Rectangle) -> Window -> X ()
decorationAfterDraggingHook engine widget a
ds (Window
wdOrigWindow, Rectangle
wdOrigWinRect) Window
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 ()

-- | Given a window and the state, if a matching decoration is in the
-- state return it with its ('Maybe') 'Rectangle'.
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
    Bool
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 Bool
widgetDone
      then Bool -> X Bool
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else case Theme engine widget -> Int -> Maybe (WidgetCommand widget)
forall (theme :: * -> *) widget.
ClickHandler theme widget =>
theme widget -> Int -> Maybe (WidgetCommand widget)
onDecorationClick Theme engine widget
theme Int
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

-- | Simple implementation of @paintDecoration@ method.
-- This is used by @TextEngine@ and can be re-used by other decoration
-- engines.
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
    Display
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    let widgets :: [widget]
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 :: Style (Theme engine widget)
style = DrawData engine widget -> Style (Theme engine widget)
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Style (Theme engine widget)
ddStyle DrawData engine widget
dd
    Window
pixmap  <- IO Window -> X Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Window -> X Window) -> IO Window -> X Window
forall a b. (a -> b) -> a -> b
$ Display -> Window -> Dimension -> Dimension -> CInt -> IO Window
createPixmap Display
dpy Window
win Dimension
windowWidth Dimension
windowHeight (Screen -> CInt
defaultDepthOfScreen (Screen -> CInt) -> Screen -> CInt
forall a b. (a -> b) -> a -> b
$ Display -> Screen
defaultScreenOfDisplay Display
dpy)
    GC
gc <- IO GC -> X GC
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO GC -> X GC) -> IO GC -> X GC
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO GC
createGC Display
dpy Window
pixmap
    -- draw
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> GC -> Bool -> IO ()
setGraphicsExposures Display
dpy GC
gc Bool
False
    Window
bgColor <- Display -> String -> X Window
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display -> String -> m Window
stringToPixel Display
dpy (SimpleStyle -> String
sBgColor Style (Theme engine widget)
SimpleStyle
style)
    -- we start with the border
    let borderWidth :: Dimension
borderWidth = SimpleStyle -> Dimension
sDecoBorderWidth Style (Theme engine widget)
SimpleStyle
style
        borderColors :: BorderColors
borderColors = SimpleStyle -> BorderColors
sDecorationBorders Style (Theme engine widget)
SimpleStyle
style
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dimension
borderWidth Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
> Dimension
0) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
      Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> String
-> X ()
forall {m :: * -> *}.
MonadIO m =>
Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> String
-> m ()
drawLineWith Display
dpy Window
pixmap GC
gc Position
0 Position
0 Dimension
windowWidth Dimension
borderWidth (BorderColors -> String
forall a. BoxBorders a -> a
bxTop BorderColors
borderColors)
      Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> String
-> X ()
forall {m :: * -> *}.
MonadIO m =>
Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> String
-> m ()
drawLineWith Display
dpy Window
pixmap GC
gc Position
0 Position
0 Dimension
borderWidth Dimension
windowHeight (BorderColors -> String
forall a. BoxBorders a -> a
bxLeft BorderColors
borderColors)
      Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> String
-> X ()
forall {m :: * -> *}.
MonadIO m =>
Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> String
-> m ()
drawLineWith Display
dpy Window
pixmap GC
gc Position
0 (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Dimension
windowHeight Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
borderWidth)) Dimension
windowWidth Dimension
borderWidth (BorderColors -> String
forall a. BoxBorders a -> a
bxBottom BorderColors
borderColors)
      Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> String
-> X ()
forall {m :: * -> *}.
MonadIO m =>
Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> String
-> m ()
drawLineWith Display
dpy Window
pixmap GC
gc (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Dimension
windowWidth Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
borderWidth)) Position
0 Dimension
borderWidth Dimension
windowHeight (BorderColors -> String
forall a. BoxBorders a -> a
bxRight BorderColors
borderColors)

    -- and now again
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> GC -> Window -> IO ()
setForeground Display
dpy GC
gc Window
bgColor
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle Display
dpy Window
pixmap GC
gc (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
borderWidth) (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
borderWidth) (Dimension
windowWidth Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- (Dimension
borderWidth Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
2)) (Dimension
windowHeight Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- (Dimension
borderWidth Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
2))

    -- paint strings
    [(widget, WidgetPlace)] -> ((widget, WidgetPlace) -> X ()) -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([widget] -> [WidgetPlace] -> [(widget, WidgetPlace)]
forall a b. [a] -> [b] -> [(a, b)]
zip [widget]
widgets ([WidgetPlace] -> [(widget, WidgetPlace)])
-> [WidgetPlace] -> [(widget, WidgetPlace)]
forall a b. (a -> b) -> a -> b
$ WidgetLayout WidgetPlace -> [WidgetPlace]
forall a. WidgetLayout a -> [a]
widgetLayout (WidgetLayout WidgetPlace -> [WidgetPlace])
-> WidgetLayout WidgetPlace -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ DrawData engine widget -> WidgetLayout WidgetPlace
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> WidgetLayout WidgetPlace
ddWidgetPlaces DrawData engine widget
dd) (((widget, WidgetPlace) -> X ()) -> X ())
-> ((widget, WidgetPlace) -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \(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

    -- debug
    -- black <- stringToPixel dpy "black"
    -- io $ setForeground dpy gc black
    -- forM_ (ddWidgetPlaces dd) $ \(WidgetPlace {wpRectangle = Rectangle x y w h}) ->
    --   io $ drawRectangle dpy pixmap gc x y w h

    -- copy the pixmap over the window
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> Position
-> Position
-> IO ()
copyArea      Display
dpy Window
pixmap Window
win GC
gc Position
0 Position
0 Dimension
windowWidth Dimension
windowHeight Position
0 Position
0
    -- free the pixmap and GC
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO ()
freePixmap    Display
dpy Window
pixmap
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> GC -> IO ()
freeGC        Display
dpy GC
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
      Window
color <- Display -> String -> m Window
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display -> String -> m Window
stringToPixel Display
dpy String
colorName
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display -> GC -> Window -> IO ()
setForeground Display
dpy GC
gc Window
color
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle Display
dpy Window
pixmap GC
gc Position
x Position
y Dimension
w Dimension
h