{-# 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 = forall a. WidgetLayout a -> [a]
wlLeft WidgetLayout widget
wlayout
            rightWidgets :: [widget]
rightWidgets = forall a. WidgetLayout a -> [a]
wlRight WidgetLayout widget
wlayout
            centerWidgets :: [widget]
centerWidgets = forall a. WidgetLayout a -> [a]
wlCenter WidgetLayout widget
wlayout

        DrawData engine widget
dd <- 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 (forall theme.
ThemeAttributes theme =>
theme -> BoxBorders Dimension
widgetsPadding Theme engine widget
theme) (forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd)
            paddedDd :: DrawData engine widget
paddedDd = DrawData engine widget
dd {ddDecoRect :: Rectangle
ddDecoRect = Rectangle
paddedDecoRect}
        [WidgetPlace]
rightRects <- 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 <- 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 = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle) [WidgetPlace]
leftRects
            wantedRightWidgetsWidth :: Dimension
wantedRightWidgetsWidth = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle) [WidgetPlace]
rightRects
            hasShrinkableOnLeft :: Bool
hasShrinkableOnLeft = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
leftWidgets
            hasShrinkableOnRight :: Bool
hasShrinkableOnRight = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
rightWidgets
            decoWidth :: Dimension
decoWidth = Rectangle -> Dimension
rect_width Rectangle
decoRect
            (Dimension
leftWidgetsWidth, Dimension
rightWidgetsWidth)
              | Bool
hasShrinkableOnLeft = 
                  (forall a. Ord a => a -> a -> a
min (Dimension
decoWidth forall a. Num a => a -> a -> a
- Dimension
wantedRightWidgetsWidth) Dimension
wantedLeftWidgetsWidth,
                      Dimension
wantedRightWidgetsWidth)
              | Bool
hasShrinkableOnRight =
                  (Dimension
wantedLeftWidgetsWidth,
                      forall a. Ord a => a -> a -> a
min (Dimension
decoWidth 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 :: Rectangle
ddDecoRect = Dimension -> Dimension -> Rectangle -> Rectangle
padCenter Dimension
leftWidgetsWidth Dimension
rightWidgetsWidth Rectangle
paddedDecoRect}
        [WidgetPlace]
centerRects <- 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) forall a b. (a -> b) -> a -> b
$ Dimension -> [(WidgetPlace, Bool)] -> [WidgetPlace]
shrinkPlaces Dimension
leftWidgetsWidth forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [WidgetPlace]
leftRects (forall a b. (a -> b) -> [a] -> [b]
map forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
leftWidgets)
            shrinkedRightRects :: [WidgetPlace]
shrinkedRightRects = Dimension -> [WidgetPlace] -> [WidgetPlace]
packRight (Rectangle -> Dimension
rect_width Rectangle
paddedDecoRect) forall a b. (a -> b) -> a -> b
$ Dimension -> [(WidgetPlace, Bool)] -> [WidgetPlace]
shrinkPlaces Dimension
rightWidgetsWidth forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [WidgetPlace]
rightRects (forall a b. (a -> b) -> [a] -> [b]
map forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
rightWidgets)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> b
snd [(WidgetPlace, Bool)]
ps)
              totalUnshrinkedWidth :: Dimension
totalUnshrinkedWidth = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(WidgetPlace, Bool)]
ps
              shrinkedWidth :: Dimension
shrinkedWidth = (Dimension
targetWidth forall a. Num a => a -> a -> a
- Dimension
totalUnshrinkedWidth) forall a. Integral a => a -> a -> a
`div` forall a b. (Integral a, Num b) => a -> b
fi Int
nShrinkable

              resetX :: WidgetPlace -> WidgetPlace
resetX WidgetPlace
place = WidgetPlace
place {wpRectangle :: Rectangle
wpRectangle = (WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place) {rect_x :: Position
rect_x = Position
0}}

              adjust :: (WidgetPlace, Bool) -> WidgetPlace
adjust (WidgetPlace
place, Bool
True) = WidgetPlace -> WidgetPlace
resetX forall a b. (a -> b) -> a -> b
$ WidgetPlace
place {wpRectangle :: Rectangle
wpRectangle = (WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place) {rect_width :: Dimension
rect_width = Dimension
shrinkedWidth}}
              adjust (WidgetPlace
place, Bool
False) = WidgetPlace -> WidgetPlace
resetX WidgetPlace
place
          in  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 (forall a b. (Integral a, Num b) => a -> b
fi (forall a. BoxBorders a -> a
bxLeft BoxBorders Dimension
p)) (forall a b. (Integral a, Num b) => a -> b
fi (forall a. BoxBorders a -> a
bxTop BoxBorders Dimension
p))
                    (Dimension
w forall a. Num a => a -> a -> a
- forall a. BoxBorders a -> a
bxLeft BoxBorders Dimension
p forall a. Num a => a -> a -> a
- forall a. BoxBorders a -> a
bxRight BoxBorders Dimension
p)
                    (Dimension
h forall a. Num a => a -> a -> a
- forall a. BoxBorders a -> a
bxTop BoxBorders Dimension
p forall a. Num a => a -> a -> a
- 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 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
left) Position
y
                    (Dimension
w forall a. Num a => a -> a -> a
- Dimension
left 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 = forall s. Shrinker s => s -> String -> [String]
shrinkIt shrinker
shrinker
      Display
dpy <- 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy DecorationEngineState engine
font String
n
                              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
size forall a. Ord a => a -> a -> Bool
> 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 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
_ =
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 = 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 = 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
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasCrossed forall a b. (a -> b) -> a -> b
$ do
        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 forall a. Num a => a -> a -> a
- (forall a b. (Integral a, Num b) => a -> b
fi CInt
ex forall a. Num a => a -> a -> a
- Rectangle -> Position
rect_x Rectangle
r))
                         (Position
y forall a. Num a => a -> a -> a
- (forall a b. (Integral a, Num b) => a -> b
fi CInt
ey 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)
    forall a. Message a => a -> X ()
sendMessage forall a b. (a -> b) -> a -> b
$ Window -> Rectangle -> DraggingVisualizerMsg
DraggingWindow Window
mainw Rectangle
rect

performWindowSwitching :: Window -> X ()
performWindowSwitching :: Window -> X ()
performWindowSwitching Window
win =
    forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> do
       Window
root <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
       (Bool
_, Window
_, Window
selWin, CInt
_, CInt
_, CInt
_, CInt
_, Modifier
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
       let allWindows :: [Window]
allWindows = 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
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Window
win forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window]
allWindows) Bool -> Bool -> Bool
&& (Window
selWin forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Window]
allWindows)) forall a b. (a -> b) -> a -> b
$ do
                let allWindowsSwitched :: [Window]
allWindowsSwitched = forall a b. (a -> b) -> [a] -> [b]
map (forall {a}. Eq a => a -> a -> a -> a
switchEntries Window
win Window
selWin) [Window]
allWindows
                let ([Window]
ls, forall a. HasCallStack => [a] -> NonEmpty a
notEmpty -> Window
t :| [Window]
rs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Window
win forall a. Eq a => a -> a -> Bool
==) [Window]
allWindowsSwitched
                let newStack :: Stack Window
newStack = forall a. a -> [a] -> [a] -> Stack a
W.Stack Window
t (forall a. [a] -> [a]
reverse [Window]
ls) [Window]
rs
                (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ forall a i l s sd.
(Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd
W.modify' forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
== a
a    = a
b
            | a
x 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 :: Rectangle
wpRectangle = (WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place) {rect_x :: Position
rect_x = Position
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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Position -> [WidgetPlace] -> [WidgetPlace]
packLeft (Rectangle -> Position
rect_x forall a b. (a -> b) -> a -> b
$ forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd) forall a b. (a -> b) -> a -> b
$ 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 forall a. Num a => a -> a -> a
+ Rectangle -> Position
rect_x Rectangle
rect
      rect' :: Rectangle
rect' = Rectangle
rect {rect_x :: Position
rect_x = Position
x'}
      place' :: WidgetPlace
place' = WidgetPlace
place {wpRectangle :: Rectangle
wpRectangle = Rectangle
rect'}
  in  WidgetPlace
place' forall a. a -> [a] -> [a]
: Position -> [WidgetPlace] -> [WidgetPlace]
packLeft (Position
x' forall a. Num a => a -> a -> a
+ 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dimension -> [WidgetPlace] -> [WidgetPlace]
packRight (Rectangle -> Dimension
rect_width forall a b. (a -> b) -> a -> b
$ forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd) forall a b. (a -> b) -> a -> b
$ 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 = forall a. [a] -> [a]
reverse 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 forall a. Num a => a -> a -> a
- Rectangle -> Dimension
rect_width Rectangle
rect
          rect' :: Rectangle
rect' = Rectangle
rect {rect_x :: Position
rect_x = forall a b. (Integral a, Num b) => a -> b
fi Dimension
x'}
          place' :: WidgetPlace
place' = WidgetPlace
place {wpRectangle :: Rectangle
wpRectangle = Rectangle
rect'}
      in  WidgetPlace
place' 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 <- 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 = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle) [WidgetPlace]
places
        availableWidth :: Position
availableWidth = forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width (forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd)) :: Position
        x0 :: Position
x0 = forall a. Ord a => a -> a -> a
max Position
0 forall a b. (a -> b) -> a -> b
$ (Position
availableWidth forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fi Dimension
totalWidth) forall a. Integral a => a -> a -> a
`div` Position
2
        places' :: [WidgetPlace]
places' = forall a b. (a -> b) -> [a] -> [b]
map (forall {a}. Integral a => a -> WidgetPlace -> WidgetPlace
shift Position
x0) [WidgetPlace]
places
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dimension -> [WidgetPlace] -> [WidgetPlace]
pack (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 :: Position
rect_x = Rectangle -> Position
rect_x Rectangle
rect forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi a
x0}
      in  WidgetPlace
place {wpRectangle :: Rectangle
wpRectangle = Rectangle
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 = forall a. Ord a => a -> a -> a
min Dimension
available Dimension
placeWidth
          remaining :: Dimension
remaining = Dimension
available forall a. Num a => a -> a -> a
- Dimension
widthToUse
          rect' :: Rectangle
rect' = Rectangle
rect {rect_width :: Dimension
rect_width = Dimension
widthToUse}
          place' :: WidgetPlace
place' = WidgetPlace
place {wpRectangle :: Rectangle
wpRectangle = Rectangle
rect'}
      in  WidgetPlace
place' 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  <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Int -> [a] -> [a]
take Int
2048 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (Window -> X NamedWindow
getName Window
origWindow)
    Style (Theme engine widget)
style <- forall theme.
ThemeAttributes theme =>
theme -> Window -> X (Style theme)
selectWindowStyle Theme engine widget
theme Window
origWindow
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (theme :: * -> *) widget.
HasWidgets theme widget =>
theme widget -> WidgetLayout widget
themeWidgets Theme engine widget
theme,
                   ddWidgetPlaces :: WidgetLayout WidgetPlace
ddWidgetPlaces = 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 :: [WindowDecoration]
dsDecorations :: forall (engine :: * -> * -> *).
DecorationLayoutState engine -> [WindowDecoration]
dsDecorations}) shrinker
_ (ButtonEvent {Window
ev_window :: Event -> Window
ev_window :: Window
ev_window, CInt
ev_x_root :: Event -> CInt
ev_x_root :: CInt
ev_x_root, CInt
ev_y_root :: Event -> CInt
ev_y_root :: CInt
ev_y_root, Dimension
ev_event_type :: Event -> Dimension
ev_event_type :: Dimension
ev_event_type, Dimension
ev_button :: Event -> Dimension
ev_button :: Dimension
ev_button})
    | Dimension
ev_event_type forall a. Eq a => a -> a -> Bool
== Dimension
buttonPress
    , Just (WindowDecoration {[WidgetPlace]
Maybe Window
Maybe Rectangle
Window
Rectangle
wdWidgets :: WindowDecoration -> [WidgetPlace]
wdDecoRect :: WindowDecoration -> Maybe Rectangle
wdDecoWindow :: WindowDecoration -> Maybe Window
wdOrigWinRect :: WindowDecoration -> Rectangle
wdOrigWindow :: WindowDecoration -> Window
wdWidgets :: [WidgetPlace]
wdDecoRect :: Maybe Rectangle
wdDecoWindow :: Maybe Window
wdOrigWinRect :: Rectangle
wdOrigWindow :: Window
..}) <- Window -> [WindowDecoration] -> Maybe WindowDecoration
findDecoDataByDecoWindow Window
ev_window [WindowDecoration]
dsDecorations = do
        let decoRect :: Rectangle
decoRect@(Rectangle Position
dx Position
dy Dimension
_ Dimension
_) = forall a. HasCallStack => Maybe a -> a
fromJust Maybe Rectangle
wdDecoRect
            x :: Int
x = forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ CInt
ev_x_root forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fi Position
dx
            y :: Int
y = forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ CInt
ev_y_root forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fi Position
dy
            button :: Int
button = forall a b. (Integral a, Num b) => a -> b
fi Dimension
ev_button
        Bool
dealtWith <- 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 (forall a b. (a -> b) -> [a] -> [b]
map WidgetPlace -> Rectangle
wpRectangle [WidgetPlace]
wdWidgets) Window
wdOrigWindow Int
x Int
y Int
button
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dealtWith forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (theme :: * -> *) widget.
ClickHandler theme widget =>
theme widget -> Int -> Bool
isDraggingEnabled Theme engine widget
theme Int
button) forall a b. (a -> b) -> a -> b
$
            (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
dragX Position
dragY -> Window -> X ()
focus Window
wdOrigWindow forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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)
                      (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
_ = 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\WindowDecoration
dd -> WindowDecoration -> Maybe Window
wdDecoWindow WindowDecoration
dd forall a. Eq a => a -> a -> Bool
== 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 forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. WidgetLayout a -> [a]
widgetLayout forall a b. (a -> b) -> a -> b
$ forall (theme :: * -> *) widget.
HasWidgets theme widget =>
theme widget -> WidgetLayout widget
themeWidgets Theme engine widget
theme) [Rectangle]
widgetPlaces
    if Bool
widgetDone
      then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else case 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
               forall cmd. WindowCommand cmd => cmd -> Window -> X Bool
executeWindowCommand WidgetCommand widget
cmd Window
window
             Maybe (WidgetCommand widget)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    go :: [(widget, Rectangle)] -> X Bool
    go :: [(widget, Rectangle)] -> X Bool
go [] = 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 (forall a b. (Integral a, Num b) => a -> b
fi Int
x) (forall a b. (Integral a, Num b) => a -> b
fi Int
y) Rectangle
rect
        then do
          forall cmd. WindowCommand cmd => cmd -> Window -> X Bool
executeWindowCommand (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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    let widgets :: [widget]
widgets = forall a. WidgetLayout a -> [a]
widgetLayout forall a b. (a -> b) -> a -> b
$ forall (engine :: * -> * -> *) widget.
DrawData engine widget -> WidgetLayout widget
ddWidgets DrawData engine widget
dd
        style :: Style (Theme engine widget)
style = forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Style (Theme engine widget)
ddStyle DrawData engine widget
dd
    Window
pixmap  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io 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 forall a b. (a -> b) -> a -> b
$ Display -> Screen
defaultScreenOfDisplay Display
dpy)
    GC
gc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO GC
createGC Display
dpy Window
pixmap
    -- draw
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> GC -> Bool -> IO ()
setGraphicsExposures Display
dpy GC
gc Bool
False
    Window
bgColor <- forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display -> String -> m Window
stringToPixel Display
dpy (SimpleStyle -> String
sBgColor Style (Theme engine widget)
style)
    -- we start with the border
    let borderWidth :: Dimension
borderWidth = SimpleStyle -> Dimension
sDecoBorderWidth Style (Theme engine widget)
style
        borderColors :: BorderColors
borderColors = SimpleStyle -> BorderColors
sDecorationBorders Style (Theme engine widget)
style
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dimension
borderWidth forall a. Ord a => a -> a -> Bool
> Dimension
0) forall a b. (a -> b) -> a -> b
$ do
      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 (forall a. BoxBorders a -> a
bxTop BorderColors
borderColors)
      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 (forall a. BoxBorders a -> a
bxLeft BorderColors
borderColors)
      forall {m :: * -> *}.
MonadIO m =>
Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> String
-> m ()
drawLineWith Display
dpy Window
pixmap GC
gc Position
0 (forall a b. (Integral a, Num b) => a -> b
fi (Dimension
windowHeight forall a. Num a => a -> a -> a
- Dimension
borderWidth)) Dimension
windowWidth Dimension
borderWidth (forall a. BoxBorders a -> a
bxBottom BorderColors
borderColors)
      forall {m :: * -> *}.
MonadIO m =>
Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> String
-> m ()
drawLineWith Display
dpy Window
pixmap GC
gc (forall a b. (Integral a, Num b) => a -> b
fi (Dimension
windowWidth forall a. Num a => a -> a -> a
- Dimension
borderWidth)) Position
0 Dimension
borderWidth Dimension
windowHeight (forall a. BoxBorders a -> a
bxRight BorderColors
borderColors)

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

    -- paint strings
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [widget]
widgets forall a b. (a -> b) -> a -> b
$ forall a. WidgetLayout a -> [a]
widgetLayout forall a b. (a -> b) -> a -> b
$ forall (engine :: * -> * -> *) widget.
DrawData engine widget -> WidgetLayout WidgetPlace
ddWidgetPlaces DrawData engine widget
dd) forall a b. (a -> b) -> a -> b
$ \(widget
widget, WidgetPlace
place) ->
        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
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io 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
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO ()
freePixmap    Display
dpy Window
pixmap
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io 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 <- forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display -> String -> m Window
stringToPixel Display
dpy String
colorName
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> GC -> Window -> IO ()
setForeground Display
dpy GC
gc Window
color
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
io 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