{-# 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

        dd <- engine widget a
-> Theme engine widget
-> DecorationEngineState engine
-> Window
-> Rectangle
-> X (DrawData engine widget)
forall (engine :: * -> * -> *) widget a.
(DecorationEngine engine widget a,
 ThemeAttributes (Theme engine widget),
 HasWidgets (Theme engine) widget) =>
engine widget a
-> Theme engine widget
-> DecorationEngineState engine
-> Window
-> Rectangle
-> X (DrawData engine widget)
mkDrawData engine widget a
engine Theme engine widget
theme DecorationEngineState engine
decoStyle Window
window Rectangle
decoRect
        let paddedDecoRect = BoxBorders Dimension -> Rectangle -> Rectangle
pad (Theme engine widget -> BoxBorders Dimension
forall theme.
ThemeAttributes theme =>
theme -> BoxBorders Dimension
widgetsPadding Theme engine widget
theme) (DrawData engine widget -> Rectangle
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd)
            paddedDd = DrawData engine widget
dd {ddDecoRect = paddedDecoRect}
        rightRects <- alignRight engine paddedDd rightWidgets
        leftRects <- alignLeft engine paddedDd leftWidgets
        let wantedLeftWidgetsWidth = [Dimension] -> Dimension
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Dimension] -> Dimension) -> [Dimension] -> Dimension
forall a b. (a -> b) -> a -> b
$ (WidgetPlace -> Dimension) -> [WidgetPlace] -> [Dimension]
forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width (Rectangle -> Dimension)
-> (WidgetPlace -> Rectangle) -> WidgetPlace -> Dimension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle) [WidgetPlace]
leftRects
            wantedRightWidgetsWidth = [Dimension] -> Dimension
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Dimension] -> Dimension) -> [Dimension] -> Dimension
forall a b. (a -> b) -> a -> b
$ (WidgetPlace -> Dimension) -> [WidgetPlace] -> [Dimension]
forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width (Rectangle -> Dimension)
-> (WidgetPlace -> Rectangle) -> WidgetPlace -> Dimension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle) [WidgetPlace]
rightRects
            hasShrinkableOnLeft = (widget -> Bool) -> [widget] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any widget -> Bool
forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
leftWidgets
            hasShrinkableOnRight = (widget -> Bool) -> [widget] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any widget -> Bool
forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
rightWidgets
            decoWidth = Rectangle -> Dimension
rect_width Rectangle
decoRect
            (leftWidgetsWidth, rightWidgetsWidth)
              | hasShrinkableOnLeft = 
                  (min (decoWidth - wantedRightWidgetsWidth) wantedLeftWidgetsWidth,
                      wantedRightWidgetsWidth)
              | hasShrinkableOnRight =
                  (wantedLeftWidgetsWidth,
                      min (decoWidth - wantedLeftWidgetsWidth) wantedRightWidgetsWidth)
              | otherwise = (wantedLeftWidgetsWidth, wantedRightWidgetsWidth)
            ddForCenter = DrawData engine widget
paddedDd {ddDecoRect = padCenter leftWidgetsWidth rightWidgetsWidth paddedDecoRect}
        centerRects <- alignCenter engine ddForCenter centerWidgets
        let shrinkedLeftRects = Position -> [WidgetPlace] -> [WidgetPlace]
packLeft (Rectangle -> Position
rect_x Rectangle
paddedDecoRect) ([WidgetPlace] -> [WidgetPlace]) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ Dimension -> [(WidgetPlace, Bool)] -> [WidgetPlace]
shrinkPlaces Dimension
leftWidgetsWidth ([(WidgetPlace, Bool)] -> [WidgetPlace])
-> [(WidgetPlace, Bool)] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ [WidgetPlace] -> [Bool] -> [(WidgetPlace, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WidgetPlace]
leftRects ((widget -> Bool) -> [widget] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map widget -> Bool
forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
leftWidgets)
            shrinkedRightRects = Dimension -> [WidgetPlace] -> [WidgetPlace]
packRight (Rectangle -> Dimension
rect_width Rectangle
paddedDecoRect) ([WidgetPlace] -> [WidgetPlace]) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ Dimension -> [(WidgetPlace, Bool)] -> [WidgetPlace]
shrinkPlaces Dimension
rightWidgetsWidth ([(WidgetPlace, Bool)] -> [WidgetPlace])
-> [(WidgetPlace, Bool)] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ [WidgetPlace] -> [Bool] -> [(WidgetPlace, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WidgetPlace]
rightRects ((widget -> Bool) -> [widget] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map widget -> Bool
forall widget. DecorationWidget widget => widget -> Bool
isShrinkable [widget]
rightWidgets)
        return $ WidgetLayout shrinkedLeftRects centerRects shrinkedRightRects
      where
        shrinkPlaces :: Dimension -> [(WidgetPlace, Bool)] -> [WidgetPlace]
shrinkPlaces Dimension
targetWidth [(WidgetPlace, Bool)]
ps =
          let nShrinkable :: Int
nShrinkable = [(WidgetPlace, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (((WidgetPlace, Bool) -> Bool)
-> [(WidgetPlace, Bool)] -> [(WidgetPlace, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (WidgetPlace, Bool) -> Bool
forall a b. (a, b) -> b
snd [(WidgetPlace, Bool)]
ps)
              totalUnshrinkedWidth :: Dimension
totalUnshrinkedWidth = [Dimension] -> Dimension
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Dimension] -> Dimension) -> [Dimension] -> Dimension
forall a b. (a -> b) -> a -> b
$ ((WidgetPlace, Bool) -> Dimension)
-> [(WidgetPlace, Bool)] -> [Dimension]
forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width (Rectangle -> Dimension)
-> ((WidgetPlace, Bool) -> Rectangle)
-> (WidgetPlace, Bool)
-> Dimension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle (WidgetPlace -> Rectangle)
-> ((WidgetPlace, Bool) -> WidgetPlace)
-> (WidgetPlace, Bool)
-> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetPlace, Bool) -> WidgetPlace
forall a b. (a, b) -> a
fst) ([(WidgetPlace, Bool)] -> [Dimension])
-> [(WidgetPlace, Bool)] -> [Dimension]
forall a b. (a -> b) -> a -> b
$ ((WidgetPlace, Bool) -> Bool)
-> [(WidgetPlace, Bool)] -> [(WidgetPlace, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((WidgetPlace, Bool) -> Bool) -> (WidgetPlace, Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetPlace, Bool) -> Bool
forall a b. (a, b) -> b
snd) [(WidgetPlace, Bool)]
ps
              shrinkedWidth :: Dimension
shrinkedWidth = (Dimension
targetWidth Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
totalUnshrinkedWidth) Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Int
nShrinkable

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

              adjust :: (WidgetPlace, Bool) -> WidgetPlace
adjust (WidgetPlace
place, Bool
True) = WidgetPlace -> WidgetPlace
resetX (WidgetPlace -> WidgetPlace) -> WidgetPlace -> WidgetPlace
forall a b. (a -> b) -> a -> b
$ WidgetPlace
place {wpRectangle = (wpRectangle place) {rect_width = shrinkedWidth}}
              adjust (WidgetPlace
place, Bool
False) = WidgetPlace -> WidgetPlace
resetX WidgetPlace
place
          in  ((WidgetPlace, Bool) -> WidgetPlace)
-> [(WidgetPlace, Bool)] -> [WidgetPlace]
forall a b. (a -> b) -> [a] -> [b]
map (WidgetPlace, Bool) -> WidgetPlace
adjust [(WidgetPlace, Bool)]
ps

        pad :: BoxBorders Dimension -> Rectangle -> Rectangle
pad BoxBorders Dimension
p (Rectangle Position
_ Position
_ Dimension
w Dimension
h) =
          Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxLeft BoxBorders Dimension
p)) (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxTop BoxBorders Dimension
p))
                    (Dimension
w Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxLeft BoxBorders Dimension
p Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxRight BoxBorders Dimension
p)
                    (Dimension
h Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxTop BoxBorders Dimension
p Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- BoxBorders Dimension -> Dimension
forall a. BoxBorders a -> a
bxBottom BoxBorders Dimension
p)
      
        padCenter :: Dimension -> Dimension -> Rectangle -> Rectangle
padCenter Dimension
left Dimension
right (Rectangle Position
x Position
y Dimension
w Dimension
h) =
          Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Position
x Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
left) Position
y
                    (Dimension
w Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
left Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
right) Dimension
h

    -- | 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
      dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
      shrinkWhile s (\String
n -> do size <- IO Int -> X Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Int -> X Int) -> IO Int -> X Int
forall a b. (a -> b) -> a -> b
$ Display -> XMonadFont -> String -> IO Int
forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
DecorationEngineState engine
font String
n
                              return $ size > fromIntegral wh) name

    -- | 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
      hasCrossed <- Window -> Window -> X Bool
handleScreenCrossing Window
w Window
decoWin
      unless hasCrossed $ do
        sendMessage DraggingStopped
        performWindowSwitching 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
       root <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
       (_, _, selWin, _, _, _, _, _) <- io $ queryPointer d root
       ws <- gets windowset
       let allWindows = WindowSet -> [Window]
forall i l a s sd. StackSet i l a s sd -> [a]
W.index WindowSet
ws
       -- do a little double check to be sure
       when ((win `elem` allWindows) && (selWin `elem` allWindows)) $ do
                let allWindowsSwitched = (Window -> Window) -> [Window] -> [Window]
forall a b. (a -> b) -> [a] -> [b]
map (Window -> Window -> Window -> Window
forall {a}. Eq a => a -> a -> a -> a
switchEntries Window
win Window
selWin) [Window]
allWindows
                let (ls, notEmpty -> t :| rs) = break (win ==) allWindowsSwitched
                let newStack = Window -> [Window] -> [Window] -> Stack Window
forall a. a -> [a] -> [a] -> Stack a
W.Stack Window
t ([Window] -> [Window]
forall a. [a] -> [a]
reverse [Window]
ls) [Window]
rs
                windows $ W.modify' $ const newStack
    where
        switchEntries :: a -> a -> a -> a
switchEntries a
a a
b a
x
            | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a    = a
b
            | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b    = a
a
            | Bool
otherwise = a
x

ignoreX :: WidgetPlace -> WidgetPlace
ignoreX :: WidgetPlace -> WidgetPlace
ignoreX WidgetPlace
place = WidgetPlace
place {wpRectangle = (wpRectangle place) {rect_x = 0}}

alignLeft :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignLeft :: forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignLeft engine widget a
engine DrawData engine widget
dd [widget]
widgets = do
    places <- (widget -> X WidgetPlace) -> [widget] -> X [WidgetPlace]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (engine widget a
-> DrawData engine widget -> widget -> X WidgetPlace
forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> widget -> X WidgetPlace
calcWidgetPlace engine widget a
engine DrawData engine widget
dd) [widget]
widgets
    return $ packLeft (rect_x $ ddDecoRect dd) $ map ignoreX places

packLeft :: Position -> [WidgetPlace] -> [WidgetPlace]
packLeft :: Position -> [WidgetPlace] -> [WidgetPlace]
packLeft Position
_ [] = []
packLeft Position
x0 (WidgetPlace
place : [WidgetPlace]
places) =
  let rect :: Rectangle
rect = WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place
      x' :: Position
x' = Position
x0 Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Rectangle -> Position
rect_x Rectangle
rect
      rect' :: Rectangle
rect' = Rectangle
rect {rect_x = x'}
      place' :: WidgetPlace
place' = WidgetPlace
place {wpRectangle = rect'}
  in  WidgetPlace
place' WidgetPlace -> [WidgetPlace] -> [WidgetPlace]
forall a. a -> [a] -> [a]
: Position -> [WidgetPlace] -> [WidgetPlace]
packLeft (Position
x' Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
rect)) [WidgetPlace]
places

alignRight :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignRight :: forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignRight engine widget a
engine DrawData engine widget
dd [widget]
widgets = do
    places <- (widget -> X WidgetPlace) -> [widget] -> X [WidgetPlace]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (engine widget a
-> DrawData engine widget -> widget -> X WidgetPlace
forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> widget -> X WidgetPlace
calcWidgetPlace engine widget a
engine DrawData engine widget
dd) [widget]
widgets
    return $ packRight (rect_width $ ddDecoRect dd) $ map ignoreX places

packRight :: Dimension -> [WidgetPlace] -> [WidgetPlace]
packRight :: Dimension -> [WidgetPlace] -> [WidgetPlace]
packRight Dimension
x0 [WidgetPlace]
places = [WidgetPlace] -> [WidgetPlace]
forall a. [a] -> [a]
reverse ([WidgetPlace] -> [WidgetPlace]) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> a -> b
$ Dimension -> [WidgetPlace] -> [WidgetPlace]
go Dimension
x0 [WidgetPlace]
places
  where
    go :: Dimension -> [WidgetPlace] -> [WidgetPlace]
go Dimension
_ [] = []
    go Dimension
x (WidgetPlace
place : [WidgetPlace]
rest) = 
      let rect :: Rectangle
rect = WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place
          x' :: Dimension
x' = Dimension
x Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Rectangle -> Dimension
rect_width Rectangle
rect
          rect' :: Rectangle
rect' = Rectangle
rect {rect_x = fi x'}
          place' :: WidgetPlace
place' = WidgetPlace
place {wpRectangle = rect'}
      in  WidgetPlace
place' WidgetPlace -> [WidgetPlace] -> [WidgetPlace]
forall a. a -> [a] -> [a]
: Dimension -> [WidgetPlace] -> [WidgetPlace]
go Dimension
x' [WidgetPlace]
rest

alignCenter :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignCenter :: forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignCenter engine widget a
engine DrawData engine widget
dd [widget]
widgets = do
    places <- engine widget a
-> DrawData engine widget -> [widget] -> X [WidgetPlace]
forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> DrawData engine widget -> [widget] -> X [WidgetPlace]
alignLeft engine widget a
engine DrawData engine widget
dd [widget]
widgets
    let totalWidth = [Dimension] -> Dimension
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Dimension] -> Dimension) -> [Dimension] -> Dimension
forall a b. (a -> b) -> a -> b
$ (WidgetPlace -> Dimension) -> [WidgetPlace] -> [Dimension]
forall a b. (a -> b) -> [a] -> [b]
map (Rectangle -> Dimension
rect_width (Rectangle -> Dimension)
-> (WidgetPlace -> Rectangle) -> WidgetPlace -> Dimension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetPlace -> Rectangle
wpRectangle) [WidgetPlace]
places
        availableWidth = Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width (DrawData engine widget -> Rectangle
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd)) :: Position
        x0 = Position -> Position -> Position
forall a. Ord a => a -> a -> a
max Position
0 (Position -> Position) -> Position -> Position
forall a b. (a -> b) -> a -> b
$ (Position
availableWidth Position -> Position -> Position
forall a. Num a => a -> a -> a
- Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
totalWidth) Position -> Position -> Position
forall a. Integral a => a -> a -> a
`div` Position
2
        places' = (WidgetPlace -> WidgetPlace) -> [WidgetPlace] -> [WidgetPlace]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> WidgetPlace -> WidgetPlace
forall {a}. Integral a => a -> WidgetPlace -> WidgetPlace
shift Position
x0) [WidgetPlace]
places
    return $ pack (fi availableWidth) places'
  where
    shift :: a -> WidgetPlace -> WidgetPlace
shift a
x0 WidgetPlace
place =
      let rect :: Rectangle
rect = WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place
          rect' :: Rectangle
rect' = Rectangle
rect {rect_x = rect_x rect + fi x0}
      in  WidgetPlace
place {wpRectangle = rect'}
    
    pack :: Dimension -> [WidgetPlace] -> [WidgetPlace]
pack Dimension
_ [] = []
    pack Dimension
available (WidgetPlace
place : [WidgetPlace]
places) =
      let rect :: Rectangle
rect = WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place
          placeWidth :: Dimension
placeWidth = Rectangle -> Dimension
rect_width Rectangle
rect
          widthToUse :: Dimension
widthToUse = Dimension -> Dimension -> Dimension
forall a. Ord a => a -> a -> a
min Dimension
available Dimension
placeWidth
          remaining :: Dimension
remaining = Dimension
available Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
widthToUse
          rect' :: Rectangle
rect' = Rectangle
rect {rect_width = widthToUse}
          place' :: WidgetPlace
place' = WidgetPlace
place {wpRectangle = rect'}
      in  WidgetPlace
place' WidgetPlace -> [WidgetPlace] -> [WidgetPlace]
forall a. a -> [a] -> [a]
: Dimension -> [WidgetPlace] -> [WidgetPlace]
pack Dimension
remaining [WidgetPlace]
places

-- | 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'
    name  <- (NamedWindow -> String) -> X NamedWindow -> X String
forall a b. (a -> b) -> X a -> X b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
2048 (String -> String)
-> (NamedWindow -> String) -> NamedWindow -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (String -> String)
-> (NamedWindow -> String) -> NamedWindow -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedWindow -> String
forall a. Show a => a -> String
show) (Window -> X NamedWindow
getName Window
origWindow)
    style <- selectWindowStyle theme origWindow
    return $ DrawData {
                   ddEngineState = decoState,
                   ddStyle = style,
                   ddOrigWindow = origWindow,
                   ddWindowTitle = name,
                   ddDecoRect = decoRect,
                   ddWidgets = themeWidgets theme,
                   ddWidgetPlaces = WidgetLayout [] [] []
                  }

-- | 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
        dealtWith <- engine widget a
-> Theme engine widget
-> Rectangle
-> [Rectangle]
-> Window
-> Int
-> Int
-> Int
-> X Bool
forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> Theme engine widget
-> Rectangle
-> [Rectangle]
-> Window
-> Int
-> Int
-> Int
-> X Bool
handleDecorationClick engine widget a
ds Theme engine widget
theme Rectangle
decoRect ((WidgetPlace -> Rectangle) -> [WidgetPlace] -> [Rectangle]
forall a b. (a -> b) -> [a] -> [b]
map WidgetPlace -> Rectangle
wpRectangle [WidgetPlace]
wdWidgets) Window
wdOrigWindow Int
x Int
y Int
button
        unless dealtWith $ when (isDraggingEnabled theme button) $
            mouseDrag (\Position
dragX Position
dragY -> Window -> X ()
focus Window
wdOrigWindow X () -> X () -> X ()
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> engine widget a
-> CInt
-> CInt
-> (Window, Rectangle)
-> Position
-> Position
-> X ()
forall (engine :: * -> * -> *) widget a.
DecorationEngine engine widget a =>
engine widget a
-> CInt
-> CInt
-> (Window, Rectangle)
-> Position
-> Position
-> X ()
decorationWhileDraggingHook engine widget a
ds CInt
ev_x_root CInt
ev_y_root (Window
wdOrigWindow, Rectangle
wdOrigWinRect) Position
dragX Position
dragY)
                      (decorationAfterDraggingHook ds (wdOrigWindow, wdOrigWinRect) ev_window)
handleMouseFocusDrag engine widget a
_ Theme engine widget
_ DecorationLayoutState engine
_ shrinker
_ Event
_ = () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | 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
    widgetDone <- [(widget, Rectangle)] -> X Bool
go ([(widget, Rectangle)] -> X Bool)
-> [(widget, Rectangle)] -> X Bool
forall a b. (a -> b) -> a -> b
$ [widget] -> [Rectangle] -> [(widget, Rectangle)]
forall a b. [a] -> [b] -> [(a, b)]
zip (WidgetLayout widget -> [widget]
forall a. WidgetLayout a -> [a]
widgetLayout (WidgetLayout widget -> [widget])
-> WidgetLayout widget -> [widget]
forall a b. (a -> b) -> a -> b
$ Theme engine widget -> WidgetLayout widget
forall (theme :: * -> *) widget.
HasWidgets theme widget =>
theme widget -> WidgetLayout widget
themeWidgets Theme engine widget
theme) [Rectangle]
widgetPlaces
    if widgetDone
      then return True
      else case onDecorationClick theme button of
             Just WidgetCommand widget
cmd -> do
               WidgetCommand widget -> Window -> X Bool
forall cmd. WindowCommand cmd => cmd -> Window -> X Bool
executeWindowCommand WidgetCommand widget
cmd Window
window
             Maybe (WidgetCommand widget)
Nothing -> Bool -> X Bool
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    go :: [(widget, Rectangle)] -> X Bool
    go :: [(widget, Rectangle)] -> X Bool
go [] = Bool -> X Bool
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    go ((widget
w, Rectangle
rect) : [(widget, Rectangle)]
rest) = do
      if Position -> Position -> Rectangle -> Bool
pointWithin (Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
x) (Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
y) Rectangle
rect
        then do
          WidgetCommand widget -> Window -> X Bool
forall cmd. WindowCommand cmd => cmd -> Window -> X Bool
executeWindowCommand (widget -> Int -> WidgetCommand widget
forall widget.
DecorationWidget widget =>
widget -> Int -> WidgetCommand widget
widgetCommand widget
w Int
button) Window
window
        else [(widget, Rectangle)] -> X Bool
go [(widget, Rectangle)]
rest

-- | 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
    dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    let widgets = WidgetLayout widget -> [widget]
forall a. WidgetLayout a -> [a]
widgetLayout (WidgetLayout widget -> [widget])
-> WidgetLayout widget -> [widget]
forall a b. (a -> b) -> a -> b
$ DrawData engine widget -> WidgetLayout widget
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> WidgetLayout widget
ddWidgets DrawData engine widget
dd
        style = DrawData engine widget -> Style (Theme engine widget)
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Style (Theme engine widget)
ddStyle DrawData engine widget
dd
    pixmap  <- io $ createPixmap dpy win windowWidth windowHeight (defaultDepthOfScreen $ defaultScreenOfDisplay dpy)
    gc <- io $ createGC dpy pixmap
    -- draw
    io $ setGraphicsExposures dpy gc False
    bgColor <- stringToPixel dpy (sBgColor style)
    -- we start with the border
    let borderWidth = SimpleStyle -> Dimension
sDecoBorderWidth Style (Theme engine widget)
SimpleStyle
style
        borderColors = SimpleStyle -> BorderColors
sDecorationBorders Style (Theme engine widget)
SimpleStyle
style
    when (borderWidth > 0) $ do
      drawLineWith dpy pixmap gc 0 0 windowWidth borderWidth (bxTop borderColors)
      drawLineWith dpy pixmap gc 0 0 borderWidth windowHeight (bxLeft borderColors)
      drawLineWith dpy pixmap gc 0 (fi (windowHeight - borderWidth)) windowWidth borderWidth (bxBottom borderColors)
      drawLineWith dpy pixmap gc (fi (windowWidth - borderWidth)) 0 borderWidth windowHeight (bxRight borderColors)

    -- and now again
    io $ setForeground dpy gc bgColor
    io $ fillRectangle dpy pixmap gc (fi borderWidth) (fi borderWidth) (windowWidth - (borderWidth * 2)) (windowHeight - (borderWidth * 2))

    -- paint strings
    forM_ (zip widgets $ widgetLayout $ ddWidgetPlaces dd) $ \(widget
widget, WidgetPlace
place) ->
        engine widget Window
-> DecorationPaintingContext engine
-> WidgetPlace
-> shrinker
-> DrawData engine widget
-> widget
-> Bool
-> X ()
forall shrinker.
Shrinker shrinker =>
engine widget Window
-> DecorationPaintingContext engine
-> WidgetPlace
-> shrinker
-> DrawData engine widget
-> widget
-> Bool
-> X ()
forall (engine :: * -> * -> *) widget a shrinker.
(DecorationEngine engine widget a, Shrinker shrinker) =>
engine widget a
-> DecorationPaintingContext engine
-> WidgetPlace
-> shrinker
-> DrawData engine widget
-> widget
-> Bool
-> X ()
paintWidget engine widget Window
deco (Display
dpy, Window
pixmap, GC
gc) WidgetPlace
place shrinker
shrinker DrawData engine widget
dd widget
widget Bool
isExpose

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